diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..ba3acfa8 --- /dev/null +++ b/.gitignore @@ -0,0 +1,39 @@ +# Delphi compiler-generated binaries (safe to delete) +*.exe +*.dll +*.bpl +*.bpi +*.dcp +*.so +*.apk +*.drc +*.map +*.dres +*.rsm +*.tds +*.dcu +*.lib +*.a +*.o +*.ocx + +# Delphi autogenerated files (duplicated info) +*.cfg +*.hpp +*Resource.rc + + +# Delphi local files (user-specific info) +*.local +*.identcache +*.projdata +*.tvsconfig +*.dsk + +# Delphi history and backups +__history/ +__recovery/ +*.~* + +# Castalia statistics file (since XE7 Castalia is distributed with Delphi) +*.stat \ No newline at end of file diff --git a/Bold.dpk b/Bold.dpk index fe592107..62ec2e30 100644 --- a/Bold.dpk +++ b/Bold.dpk @@ -1,43 +1,82 @@ package Bold; -{.$R *.res} +{$R *.res} {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} -{ ALIGN 8} -{ ASSERTIONS ON} -{ BOOLEVAL OFF} -{ DEBUGINFO ON} -{ EXTENDEDSYNTAX ON} -{ IMPORTEDDATA ON} -{ IOCHECKS ON} -{ LOCALSYMBOLS ON} -{ LONGSTRINGS ON} -{ OPENSTRINGS ON} -{ OPTIMIZATION OFF} -{ OVERFLOWCHECKS ON} -{ RANGECHECKS ON} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS ON} +{$RANGECHECKS ON} {$REFERENCEINFO ON} -{ SAFEDIVIDE OFF} -{ STACKFRAMES ON} -{ TYPEDADDRESS OFF} -{ VARSTRINGCHECKS ON} -{ WRITEABLECONST ON} -{ MINENUMSIZE 1} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} {$IMAGEBASE $400000} -{$DEFINE BOLD_DELPHI} {$DEFINE DEBUG} {$ENDIF IMPLICITBUILDING} -{$DESCRIPTION 'Bold 4.0 for Delphi'} -{$LIBSUFFIX '90'} -{$DESIGNONLY} -{$IMPLICITBUILD ON} +{$DESCRIPTION 'Bold for Delphi - Runtime'} +{$LIBVERSION '27'} +{$RUNONLY} +{$IMPLICITBUILD OFF} requires vcl, vcldb, - VclX, - DesignIDE; + vclx, + vclimg, + FireDac, + FireDACCommonDriver, + FireDACCommon, + FireDACPgDriver, + IndySystem, + IndyCore; contains + BoldModel in 'Source\UMLModel\Handles\BoldModel.pas', + BoldUMLModelSupport in 'Source\UMLModel\Core\BoldUMLModelSupport.pas', + BoldUMLModel in 'Source\UMLModel\Core\BoldUMLModel.pas', + BoldUMLModelConverter in 'Source\UMLModel\Core\BoldUMLModelConverter.pas', + BoldUMLModelDataModule in 'Source\UMLModel\Core\BoldUMLModelDataModule.pas', + BoldUMLAttributes in 'Source\UMLModel\Core\BoldUMLAttributes.pas', + BoldUMLBldLink in 'Source\UMLModel\ModelLinks\Bld\BoldUMLBldLink.pas', + BoldUMLAbstractModelValidator in 'Source\UMLModel\Core\BoldUMLAbstractModelValidator.pas', + BoldUMLModelValidator in 'Source\UMLModel\Core\BoldUMLModelValidator.pas', + BoldUMLModelValidationForm in 'Source\UMLModel\Editor\BoldUMLModelValidationForm.pas', + BoldDerivationExpressionsEditor in 'Source\UMLModel\Editor\BoldDerivationExpressionsEditor.pas', + BoldDragObject in 'Source\UMLModel\Editor\BoldDragObject.pas', + BoldModelOCLValidatorPlugIn in 'Source\UMLModel\Plugins\BoldModelOCLValidatorPlugIn.pas', + BoldUMLAddTV in 'Source\UMLModel\Editor\BoldUMLAddTV.pas', + BoldUMLConstraintEditor in 'Source\UMLModel\Editor\BoldUMLConstraintEditor.pas', + BoldUMLModelEdit in 'Source\UMLModel\Editor\BoldUMLModelEdit.pas', + BoldUMLModelEditForm in 'Source\UMLModel\Editor\BoldUMLModelEditForm.pas', + BoldUMLModelEditPlugIn in 'Source\UMLModel\Plugins\BoldUMLModelEditPlugIn.pas', + BoldUMLModelLink in 'Source\UMLModel\ModelLinks\Core\BoldUMLModelLink.pas', + BoldUMLModelLinkSupport in 'Source\UMLModel\ModelLinks\Core\BoldUMLModelLinkSupport.pas', + BoldUMLModelStreamer in 'Source\UMLModel\Handles\BoldUMLModelStreamer.pas', + BoldUMLModelUpdater in 'Source\UMLModel\Core\BoldUMLModelUpdater.pas', + BoldUMLOCLEditor in 'Source\UMLModel\Editor\BoldUMLOCLEditor.pas', + BoldUMLOCLValidator in 'Source\UMLModel\Core\BoldUMLOCLValidator.pas', + BoldUMLPluginCallBacks in 'Source\UMLModel\Plugins\BoldUMLPluginCallBacks.pas', + BoldUMLPlugins in 'Source\UMLModel\Plugins\BoldUMLPlugins.pas', + BoldUMLTaggedValuesEditor in 'Source\UMLModel\Editor\BoldUMLTaggedValuesEditor.pas', + BoldUMLUsesEditorForm in 'Source\UMLModel\Editor\BoldUMLUsesEditorForm.pas', + BoldUMLRose98Link in 'Source\UMLModel\ModelLinks\Rose98\BoldUMLRose98Link.pas', + BoldUMLRose98MappingUtils in 'Source\UMLModel\ModelLinks\Rose98\BoldUMLRose98MappingUtils.pas', + BoldUMLRose98Support in 'Source\UMLModel\ModelLinks\Rose98\BoldUMLRose98Support.pas', + RationalRose2000_TLB in 'Source\Common\Rose2000\RationalRose2000_TLB.pas', + RationalRose98_TLB in 'Source\Common\Rose98\RationalRose98_TLB.pas', + BoldUMLUtils in 'Source\UMLModel\Core\BoldUMLUtils.pas', BoldSystem in 'Source\ObjectSpace\BORepresentation\BoldSystem.pas', BoldAttributes in 'Source\ObjectSpace\BORepresentation\BoldAttributes.pas', BoldDerivedValueSet in 'Source\ObjectSpace\BORepresentation\BoldDerivedValueSet.pas', @@ -55,28 +94,6 @@ contains BoldCoreConsts in 'Source\ObjectSpace\Core\BoldCoreConsts.pas', BoldElements in 'Source\ObjectSpace\Core\BoldElements.pas', BoldMetaElementList in 'Source\ObjectSpace\Core\BoldMetaElementList.pas', - BoldComponentValidatorIDE in 'Source\ObjectSpace\IDE\BoldComponentValidatorIDE.pas', - BoldExternalObjectSpaceEventHandlerReg in 'Source\ObjectSpace\IDE\BoldExternalObjectSpaceEventHandlerReg.pas', - BoldWSimpleMenuWizard in 'Source\ObjectSpace\IDE\BoldWSimpleMenuWizard.pas', - BoldAttributeWizard in 'Source\ObjectSpace\IDE\AttributeWizard\BoldAttributeWizard.pas', - BoldOTACodeGen in 'Source\ObjectSpace\IDE\AttributeWizard\BoldOTACodeGen.pas', - BoldWAClassInfo in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWAClassInfo.pas', - BoldWACustomAttr in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWACustomAttr.pas', - BoldWACustomAttrForm1 in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWACustomAttrForm1.pas', - BoldWAdatamodule in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWAdatamodule.pas', - BoldWAdmTemplates in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWAdmTemplates.pas', - BoldWAInputFormUnit in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWAInputFormUnit.pas', - BoldWAInterfaces in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWAInterfaces.pas', - BoldWAMainForm in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWAMainForm.pas', - BoldWAMethodInfo in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWAMethodInfo.pas', - BoldWAStringGridManager in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWAStringGridManager.pas', - BoldWASubClassForm1 in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWASubClassForm1.pas', - BoldWAValueSetDlg in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWAValueSetDlg.pas', - BoldWAValueSetForm1 in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWAValueSetForm1.pas', - BoldVclUtils in 'Source\ObjectSpace\IDE\AttributeWizard\BoldVclUtils.pas', - BoldWCodeInformer in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWCodeInformer.pas', - BoldWProjectWizard in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWProjectWizard.pas', - BoldWScanner in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWScanner.pas', BoldUndoInterfaces in 'Source\ObjectSpace\Interfaces\BoldUndoInterfaces.pas', BoldOcl in 'Source\ObjectSpace\Ocl\BoldOcl.pas', BoldOclClasses in 'Source\ObjectSpace\Ocl\BoldOclClasses.pas', @@ -88,7 +105,6 @@ contains BoldOclSemantics in 'Source\ObjectSpace\Ocl\BoldOclSemantics.pas', BoldOclSymbolImplementations in 'Source\ObjectSpace\Ocl\BoldOclSymbolImplementations.pas', BoldORed in 'Source\ObjectSpace\Ocl\BoldORed.pas', - BoldRegularExpression in 'Source\ObjectSpace\Ocl\BoldRegularExpression.pas', BoldSSExcept in 'Source\ObjectSpace\Ocl\BoldSSExcept.pas', BoldSSLexU in 'Source\ObjectSpace\Ocl\BoldSSLexU.pas', BoldSSYaccU in 'Source\ObjectSpace\Ocl\BoldSSYaccU.pas', @@ -118,28 +134,9 @@ contains BoldStreams in 'Source\Common\Core\BoldStreams.pas', BoldThreadSafeQueue in 'Source\Common\Core\BoldThreadSafeQueue.pas', BoldEnvironment in 'Source\Common\Environment\BoldEnvironment.pas', - BoldEnvironmentIDE in 'Source\Common\Environment\BoldEnvironmentIDE.pas', BoldEnvironmentVCL in 'Source\Common\Environment\BoldEnvironmentVCL.pas', BoldHandle in 'Source\Common\Handles\BoldHandle.pas', BoldDataBlock in 'Source\Common\HTTP\BoldDataBlock.pas', - BoldWebConnection in 'Source\Common\HTTP\BoldWebConnection.pas', - BoldAbout in 'Source\Common\IDE\BoldAbout.pas', - BoldAbstractPropertyEditors in 'Source\Common\IDE\BoldAbstractPropertyEditors.pas', - BoldDefsDT in 'Source\Common\IDE\BoldDefsDT.pas', - BoldExpert in 'Source\Common\IDE\BoldExpert.pas', - BoldExpertMenus in 'Source\Common\IDE\BoldExpertMenus.pas', - BoldGettingStartedExpert in 'Source\Common\IDE\BoldGettingStartedExpert.pas', - BoldGettingStartedForm in 'Source\Common\IDE\BoldGettingStartedForm.pas', - BoldIDEConsts in 'Source\Common\IDE\BoldIDEConsts.pas', - BoldIDEMenus in 'Source\Common\IDE\BoldIDEMenus.pas', - BoldIDESupport in 'Source\Common\IDE\BoldIDESupport.pas', - BoldModelAwareComponentEditor in 'Source\Common\IDE\BoldModelAwareComponentEditor.pas', - BoldOTAFileHandler in 'Source\Common\IDE\BoldOTAFileHandler.pas', - BoldOTASupport in 'Source\Common\IDE\BoldOTASupport.pas', - BoldPropertyEditors in 'Source\Common\IDE\BoldPropertyEditors.pas', - BoldReg in 'Source\Common\IDE\BoldReg.pas', - BoldTextStream in 'Source\Common\IDE\BoldTextStream.pas', - BoldWebConnectionReg in 'Source\Common\IDE\BoldWebConnectionReg.pas', BoldLogForm in 'Source\Common\Logging\BoldLogForm.pas', BoldLogHandler in 'Source\Common\Logging\BoldLogHandler.pas', BoldLogHandlerForm in 'Source\Common\Logging\BoldLogHandlerForm.pas', @@ -147,14 +144,10 @@ contains BoldLogReceiverInterface in 'Source\Common\Logging\BoldLogReceiverInterface.pas', BoldSmallLogFrame in 'Source\Common\Logging\BoldSmallLogFrame.pas', BoldThreadSafeLog in 'Source\Common\Logging\BoldThreadSafeLog.pas', - MSXML_TLB in 'Source\Common\MsXml\MSXML_TLB.pas', + Bold_MSXML_TLB in 'Source\Common\MsXml\Bold_MSXML_TLB.pas', BoldAbstractDequeuer in 'Source\Common\Queue\BoldAbstractDequeuer.pas', BoldEventQueue in 'Source\Common\Queue\BoldEventQueue.pas', BoldQueue in 'Source\Common\Queue\BoldQueue.pas', - BoldRose2000Support in 'Source\Common\Rose2000\BoldRose2000Support.pas', - RationalRose2000_TLB in 'Source\Common\Rose2000\RationalRose2000_TLB.pas', - BoldRose98Support in 'Source\Common\Rose98\BoldRose98Support.pas', - RationalRose98_TLB in 'Source\Common\Rose98\RationalRose98_TLB.pas', BoldSOAP_TLB in 'Source\Common\SOAP\BoldSOAP_TLB.pas', BoldSOAP2_TLB in 'Source\Common\SOAP\BoldSOAP2_TLB.pas', BoldXMLRequests in 'Source\Common\SOAP\BoldXMLRequests.pas', @@ -163,6 +156,7 @@ contains BoldSubscription in 'Source\Common\Subscription\BoldSubscription.pas', BoldBase64 in 'Source\Common\Support\BoldBase64.pas', BoldCollections in 'Source\Common\Support\BoldCollections.pas', + BoldIndexCollection in 'Source\Common\Support\BoldIndexCollection.pas', BoldCommonBitmaps in 'Source\Common\Support\BoldCommonBitmaps.pas', BoldControlPackDefs in 'Source\Common\Support\BoldControlPackDefs.pas', BoldControlsDefs in 'Source\Common\Support\BoldControlsDefs.pas', @@ -209,8 +203,12 @@ contains BoldFreeStandingValueFactories in 'Source\FreestandingValueSpace\Core\BoldFreeStandingValueFactories.pas', BoldFreeStandingValues in 'Source\FreestandingValueSpace\Core\BoldFreeStandingValues.pas', FreeStandingValuesConst in 'Source\FreestandingValueSpace\Core\FreeStandingValuesConst.pas', + BoldDbPlugins in 'Source\UMLModel\Plugins\BoldDbPlugins.pas', BoldActionDefs in 'Source\Handles\Actions\BoldActionDefs.pas', BoldActions in 'Source\Handles\Actions\BoldActions.pas', + BoldAction in 'Source\BoldAwareGUI\Actions\BoldAction.pas', + BoldDebugActions in 'Source\Samples\Actions\BoldDebugActions.pas', + BoldEditOCLAction in 'Source\Samples\Actions\BoldEditOCLAction.pas', BoldHandleAction in 'Source\Handles\Actions\BoldHandleAction.pas', BoldListActions in 'Source\Handles\Actions\BoldListActions.pas', BoldUndoActions in 'Source\Handles\Actions\BoldUndoActions.pas', @@ -223,37 +221,28 @@ contains BoldListHandle in 'Source\Handles\Core\BoldListHandle.pas', BoldOclRepository in 'Source\Handles\Core\BoldOclRepository.pas', BoldOclVariables in 'Source\Handles\Core\BoldOclVariables.pas', + BoldOSSMessage in 'Source\ObjectSpace\BORepresentation\BoldOSSMessage.pas', BoldPlaceableSubscriber in 'Source\Handles\Core\BoldPlaceableSubscriber.pas', BoldReferenceHandle in 'Source\Handles\Core\BoldReferenceHandle.pas', BoldRootedHandles in 'Source\Handles\Core\BoldRootedHandles.pas', BoldSortedHandle in 'Source\Handles\Core\BoldSortedHandle.pas', BoldSQLHandle in 'Source\Handles\Core\BoldSQLHandle.pas', + BoldRawSQLHandle in 'Source\Handles\Core\BoldRawSQLHandle.pas', BoldSystemHandle in 'Source\Handles\Core\BoldSystemHandle.pas', BoldVariableDefinition in 'Source\Handles\Core\BoldVariableDefinition.pas', BoldVariableHandle in 'Source\Handles\Core\BoldVariableHandle.pas', HandlesConst in 'Source\Handles\Core\HandlesConst.pas', - BoldHandlePropEditor in 'Source\Handles\IDE\BoldHandlePropEditor.pas', - BoldHandleReg in 'Source\Handles\IDE\BoldHandleReg.pas', - BoldLockingReg in 'Source\Handles\IDE\BoldLockingReg.pas', - BoldManipulatorReg in 'Source\Handles\IDE\BoldManipulatorReg.pas', - BoldXMLReg in 'Source\Handles\IDE\BoldXMLReg.pas', BoldManipulators in 'Source\Handles\Manipulators\BoldManipulators.pas', BoldLockingHandles in 'Source\Handles\PessimisticLocking\BoldLockingHandles.pas', BoldUnloaderHandle in 'Source\Handles\UnLoader\BoldUnloaderHandle.pas', BoldXMLProducers in 'Source\Handles\XML\BoldXMLProducers.pas', BoldBld in 'Source\MoldModel\Bld\BoldBld.pas', - BoldGen in 'Source\MoldModel\CodeGenerator\BoldGen.pas', - BoldGeneratorTemplates in 'Source\MoldModel\CodeGenerator\BoldGeneratorTemplates.pas', - BoldGeneratorTemplatesCPP in 'Source\MoldModel\CodeGenerator\BoldGeneratorTemplatesCPP.pas', - BoldGeneratorTemplatesDelphi in 'Source\MoldModel\CodeGenerator\BoldGeneratorTemplatesDelphi.pas', BoldMeta in 'Source\MoldModel\Core\BoldMeta.pas', BoldMetaSupport in 'Source\MoldModel\Core\BoldMetaSupport.pas', BoldMoldConsts in 'Source\MoldModel\Core\BoldMoldConsts.pas', BoldNameExpander in 'Source\MoldModel\Core\BoldNameExpander.pas', BoldAbstractModel in 'Source\MoldModel\Handles\BoldAbstractModel.pas', BoldTypeNameHandle in 'Source\MoldModel\Handles\BoldTypeNameHandle.pas', - BoldModelReg in 'Source\MoldModel\IDE\BoldModelReg.pas', - BoldTypeNameHandleReg in 'Source\MoldModel\IDE\BoldTypeNameHandleReg.pas', BoldTypeNameDictionary in 'Source\MoldModel\TypeNameDictionary\BoldTypeNameDictionary.pas', BoldTypeNameEditor in 'Source\MoldModel\UtilsGUI\BoldTypeNameEditor.pas', BoldAbstractSnooper in 'Source\Persistence\Core\BoldAbstractSnooper.pas', @@ -269,17 +258,9 @@ contains BoldDBActions in 'Source\Persistence\DB\BoldDBActions.pas', BoldDBInterfaces in 'Source\Persistence\DB\BoldDBInterfaces.pas', BoldPersistenceControllerDefault in 'Source\Persistence\DB\BoldPersistenceControllerDefault.pas', - BoldPersistenceHandleDB_deprecated in 'Source\Persistence\DB\BoldPersistenceHandleDB_deprecated.pas', BoldPersistenceHandleDB in 'Source\Persistence\DB\BoldPersistenceHandleDB.pas', - BoldPersistenceHandleDBreg in 'Source\Persistence\DB\BoldPersistenceHandleDBreg.pas', BoldPersistenceHandleFile in 'Source\Persistence\File\BoldPersistenceHandleFile.pas', BoldPersistenceHandleFileXML in 'Source\Persistence\File\BoldPersistenceHandleFileXML.pas', - BoldHandlesPropagationReg in 'Source\Persistence\IDE\BoldHandlesPropagationReg.pas', - BoldObjectUpgraderHandleReg in 'Source\Persistence\IDE\BoldObjectUpgraderHandleReg.pas', - BoldPersistenceHandleFileReg in 'Source\Persistence\IDE\BoldPersistenceHandleFileReg.pas', - BoldPersistenceHandleReg in 'Source\Persistence\IDE\BoldPersistenceHandleReg.pas', - BoldPersistenceHandleSystemReg in 'Source\Persistence\IDE\BoldPersistenceHandleSystemReg.pas', - BoldPersistenceNotifierReg in 'Source\Persistence\IDE\BoldPersistenceNotifierReg.pas', BoldAbstractObjectUpgraderHandle in 'Source\Persistence\ObjectUpgrading\BoldAbstractObjectUpgraderHandle.pas', BoldBatchUpgrader in 'Source\Persistence\ObjectUpgrading\BoldBatchUpgrader.pas', BoldObjectUpgrader in 'Source\Persistence\ObjectUpgrading\BoldObjectUpgrader.pas', @@ -327,10 +308,10 @@ contains BoldDbValidator in 'Source\PMapper\Validator\BoldDbValidator.pas', BoldAbstractPropagatorHandle in 'Source\Propagator\Common\BoldAbstractPropagatorHandle.pas', BoldLockingSupportInterfaces_TLB in 'Source\Propagator\Common\BoldLockingSupportInterfaces_TLB.pas', + BoldPropagatorInterfaces_TLB in 'Source\Propagator\Common\BoldPropagatorInterfaces_TLB.pas', BoldObjectMarshaler in 'Source\Propagator\Common\BoldObjectMarshaler.pas', BoldPropagatorConstants in 'Source\Propagator\Common\BoldPropagatorConstants.pas', BoldPropagatorGUIDs in 'Source\Propagator\Common\BoldPropagatorGUIDs.pas', - BoldPropagatorInterfaces_TLB in 'Source\Propagator\Common\BoldPropagatorInterfaces_TLB.pas', PropagatorConsts in 'Source\Propagator\Common\PropagatorConsts.pas', BoldCondition in 'Source\ValueSpace\Condition\BoldCondition.pas', BoldObjectSpaceExternalEvents in 'Source\ValueSpace\ExternalEvents\BoldObjectSpaceExternalEvents.pas', @@ -339,9 +320,135 @@ contains BoldId in 'Source\ValueSpace\Id\BoldId.pas', BoldStringId in 'Source\ValueSpace\Id\BoldStringId.pas', ValueSpaceConst in 'Source\ValueSpace\Id\ValueSpaceConst.pas', + BoldPropertiesController in 'Source\BoldAwareGUI\BoldControls\BoldPropertiesController.pas', BoldValueInterfaces in 'Source\ValueSpace\Interfaces\BoldValueInterfaces.pas', BoldValueSpaceInterfaces in 'Source\ValueSpace\Interfaces\BoldValueSpaceInterfaces.pas', BoldDefaultStreamNames in 'Source\ValueSpace\XMLStreaming\BoldDefaultStreamNames.pas', - BoldDefaultXMLStreaming in 'Source\ValueSpace\XMLStreaming\BoldDefaultXMLStreaming.pas'; + BoldElementHandleFollower in 'Source\BoldAwareGUI\ControlPacks\BoldElementHandleFollower.pas', + BoldDefaultXMLStreaming in 'Source\ValueSpace\XMLStreaming\BoldDefaultXMLStreaming.pas', + BoldAbstractComClientPersistenceHandles in 'Source\Persistence\COM\BoldAbstractComClientPersistenceHandles.pas', + BoldAbstractComPersistenceControllerProxy in 'Source\Persistence\COM\BoldAbstractComPersistenceControllerProxy.pas', + BoldAFP in 'Source\BoldAwareGUI\FormGen\BoldAFP.pas', + BoldAFPDefault in 'Source\BoldAwareGUI\FormGen\BoldAFPDefault.pas', + BoldAFPPluggable in 'Source\BoldAwareGUI\FormGen\BoldAFPPluggable.pas', + BoldAFPUser in 'Source\BoldAwareGUI\FormGen\BoldAFPUser.pas', + BoldApartmentThread in 'Source\Common\COM\BoldApartmentThread.pas', + BoldCaptionController in 'Source\BoldAwareGUI\BoldControls\BoldCaptionController.pas', + BoldCheckBox in 'Source\BoldAwareGUI\BoldControls\BoldCheckBox.pas', + BoldCheckboxStateControlPack in 'Source\BoldAwareGUI\ControlPacks\BoldCheckboxStateControlPack.pas', + BoldCheckListBox in 'Source\Samples\BoldCheckListBox\BoldCheckListBox.pas', + BoldComAdapter in 'Source\Common\COM\BoldComAdapter.pas', + BoldComboBox in 'Source\BoldAwareGUI\BoldControls\BoldComboBox.pas', + BoldComClient in 'Source\Common\ConnectionCOM\BoldComClient.pas', + BoldComClientElementHandles in 'Source\Handles\COM\BoldComClientElementHandles.pas', + BoldComClientHandles in 'Source\Common\ConnectionHandlesCOM\BoldComClientHandles.pas', + BoldComConnection in 'Source\Common\ConnectionCOM\BoldComConnection.pas', + BoldComConst in 'Source\Common\COM\BoldComConst.pas', + BoldComEventQueue in 'Source\Common\COM\BoldComEventQueue.pas', + BoldComObj in 'Source\Common\COM\BoldComObj.pas', + BoldComObjectSpace in 'Source\ObjectSpace\COM\BoldComObjectSpace.pas', + BoldComObjectSpace_TLB in 'Source\ObjectSpace\COM\BoldComObjectSpace_TLB.pas', + BoldComObjectSpaceAdapters in 'Source\ObjectSpace\COM\BoldComObjectSpaceAdapters.pas', + BoldComponentValidatorCom in 'Source\ObjectSpace\COM\BoldComponentValidatorCom.pas', + BoldComServer in 'Source\Common\ConnectionCOM\BoldComServer.pas', + BoldComServerElementHandleFactory in 'Source\Handles\COM\BoldComServerElementHandleFactory.pas', + BoldComServerElementHandles in 'Source\Handles\COM\BoldComServerElementHandles.pas', + BoldComServerHandles in 'Source\Common\ConnectionHandlesCOM\BoldComServerHandles.pas', + BoldComThreads in 'Source\Common\COM\BoldComThreads.pas', + BoldComUtils in 'Source\Common\COM\BoldComUtils.pas', + BoldConstraintValidator in 'Source\Samples\ConstraintValidator\BoldConstraintValidator.pas', + BoldControllerListControlPack in 'Source\BoldAwareGUI\ControlPacks\BoldControllerListControlPack.pas', + BoldControlPack in 'Source\BoldAwareGUI\ControlPacks\BoldControlPack.pas', + BoldCustomCheckListBox in 'Source\Samples\BoldCheckListBox\BoldCustomCheckListBox.pas', + BoldDatabaseAdapterFireDAC in 'Source\Persistence\FireDAC\BoldDatabaseAdapterFireDAC.pas', + BoldDateTimeControlPack in 'Source\BoldAwareGUI\ControlPacks\BoldDateTimeControlPack.pas', + BoldDragDropTarget in 'Source\BoldAwareGUI\BoldControls\BoldDragDropTarget.pas', + BoldEdit in 'Source\BoldAwareGUI\BoldControls\BoldEdit.pas', + BoldExceptionHandlers in 'Source\BoldAwareGUI\Core\BoldExceptionHandlers.pas', + BoldFireDACConsts in 'Source\Persistence\FireDAC\BoldFireDACConsts.pas', + BoldFireDACInterfaces in 'Source\Persistence\FireDAC\BoldFireDACInterfaces.pas', + BoldFloatControlPack in 'Source\BoldAwareGUI\ControlPacks\BoldFloatControlPack.pas', + BoldFormSaver in 'Source\Samples\FormSaver\BoldFormSaver.pas', + BoldFormSaverActions in 'Source\Samples\FormSaver\BoldFormSaverActions.pas', + BoldGen in 'Source\MoldModel\CodeGenerator\BoldGen.pas', + BoldGeneratorTemplates in 'Source\MoldModel\CodeGenerator\BoldGeneratorTemplates.pas', + BoldGeneratorTemplatesCPP in 'Source\MoldModel\CodeGenerator\BoldGeneratorTemplatesCPP.pas', + BoldGeneratorTemplatesDelphi in 'Source\MoldModel\CodeGenerator\BoldGeneratorTemplatesDelphi.pas', + BoldGenericListControlPack in 'Source\BoldAwareGUI\ControlPacks\BoldGenericListControlPack.pas', + BoldGrid in 'Source\BoldAwareGUI\BoldControls\BoldGrid.pas', + BoldGridRTColEditor in 'Source\BoldAwareGUI\BoldControls\BoldGridRTColEditor.pas', + BoldGUI in 'Source\BoldAwareGUI\Core\BoldGUI.pas', + BoldGuiResourceStrings in 'Source\BoldAwareGUI\Core\BoldGuiResourceStrings.pas', + BoldHTTPClientPersistenceHandle in 'Source\Persistence\HTTP\BoldHTTPClientPersistenceHandle.pas', + BoldHTTPPersistenceControllerClient in 'Source\Persistence\HTTP\BoldHTTPPersistenceControllerClient.pas', + BoldHTTPServerPersistenceHandlePassthrough in 'Source\Persistence\HTTP\BoldHTTPServerPersistenceHandlePassthrough.pas', + BoldImage in 'Source\BoldAwareGUI\BoldControls\BoldImage.pas', + BoldImageBitmap in 'Source\BoldAwareGUI\BoldControls\BoldImageBitmap.pas', + BoldImageJPEG in 'Source\BoldAwareGUI\BoldControls\BoldImageJPEG.pas', + BoldLabel in 'Source\BoldAwareGUI\BoldControls\BoldLabel.pas', + BoldListBox in 'Source\BoldAwareGUI\BoldControls\BoldListBox.pas', + BoldListControlPack in 'Source\BoldAwareGUI\ControlPacks\BoldListControlPack.pas', + BoldListHandleFollower in 'Source\BoldAwareGUI\ControlPacks\BoldListHandleFollower.pas', + BoldListListControlPack in 'Source\BoldAwareGUI\ControlPacks\BoldListListControlPack.pas', + BoldLockManagerAdminHandleCom in 'Source\ConcurrencyControl\COM\BoldLockManagerAdminHandleCom.pas', + BoldLockManagerHandleCom in 'Source\ConcurrencyControl\COM\BoldLockManagerHandleCom.pas', + BoldLockUtils in 'Source\Samples\Misc\BoldLockUtils.pas', + BoldMemo in 'Source\BoldAwareGUI\BoldControls\BoldMemo.pas', + BoldMLRenderers in 'Source\BoldAwareGUI\ControlPacks\BoldMLRenderers.pas', + BoldModelLoader in 'Source\Samples\ModelLoader\BoldModelLoader.pas', + BoldNavigator in 'Source\BoldAwareGUI\BoldControls\BoldNavigator.pas', + BoldNewObjectInterceptor in 'Source\Samples\NewObjectInterceptor\BoldNewObjectInterceptor.pas', + BoldNodeControlPack in 'Source\BoldAwareGUI\ControlPacks\BoldNodeControlPack.pas', + BoldNumericControlPack in 'Source\BoldAwareGUI\ControlPacks\BoldNumericControlPack.pas', + BoldObjectRetriever in 'Source\Samples\Misc\BoldObjectRetriever.pas', + BoldPageControl in 'Source\BoldAwareGUI\BoldControls\BoldPageControl.pas', + BoldPersistenceControllerSOAPAdapterCore in 'Source\Persistence\SOAP\BoldPersistenceControllerSOAPAdapterCore.pas', + BoldPersistenceOperationXMLStreaming in 'Source\Persistence\SOAP\BoldPersistenceOperationXMLStreaming.pas', + BoldProgressBar in 'Source\BoldAwareGUI\BoldControls\BoldProgressBar.pas', + BoldPropagatorHandleCOM in 'Source\Propagator\COM\BoldPropagatorHandleCOM.pas', + BoldPropagatorUtils in 'Source\Persistence\Propagation\BoldPropagatorUtils.pas', + BoldRichEdit in 'Source\BoldAwareGUI\BoldControls\BoldRichEdit.pas', + BoldRose2000Support in 'Source\Common\Rose2000\BoldRose2000Support.pas', + BoldRose98ptyCreator in 'Source\UMLModel\ModelLinks\Rose98\BoldRose98ptyCreator.pas', + BoldRose98Support in 'Source\Common\Rose98\BoldRose98Support.pas', + BoldRose98TaggedValues in 'Source\UMLModel\ModelLinks\Rose98\BoldRose98TaggedValues.pas', + BoldSelectionListBox in 'Source\Samples\BoldCheckListBox\BoldSelectionListBox.pas', + BoldSOAPClientPersistenceHandles in 'Source\Persistence\SOAP\BoldSOAPClientPersistenceHandles.pas', + BoldSOAPPersistenceControllerProxy in 'Source\Persistence\SOAP\BoldSOAPPersistenceControllerProxy.pas', + BoldSOAPPersistenceControllerStub in 'Source\Persistence\SOAP\BoldSOAPPersistenceControllerStub.pas', + BoldSOAPServerPersistenceHandles in 'Source\Persistence\SOAP\BoldSOAPServerPersistenceHandles.pas', + BoldStringControlPack in 'Source\BoldAwareGUI\ControlPacks\BoldStringControlPack.pas', + BoldStringsPropertyController in 'Source\BoldAwareGUI\BoldControls\BoldStringsPropertyController.pas', + BoldSystemComparer in 'Source\Samples\SystemComparer\BoldSystemComparer.pas', + BoldSystemDebuggerForm in 'Source\Samples\SystemDebugger\BoldSystemDebuggerForm.pas', + BoldThreadedComObjectFactory in 'Source\Common\COM\BoldThreadedComObjectFactory.pas', + BoldTrackBar in 'Source\BoldAwareGUI\BoldControls\BoldTrackBar.pas', + BoldTreeView in 'Source\BoldAwareGUI\BoldControls\BoldTreeView.pas', + BoldTreeViewConfig in 'Source\BoldAwareGUI\BoldControls\BoldTreeViewConfig.pas', + BoldUMLModelToEcoIIIGenerator in 'Source\UMLModel\Plugins\BoldUMLModelToEcoIIIGenerator.pas', + BoldUMLNameTrimmer in 'Source\Samples\UMLPlugins\BoldUMLNameTrimmer.pas', + BoldVariantControlPack in 'Source\BoldAwareGUI\ControlPacks\BoldVariantControlPack.pas', + BoldViewerControlPack in 'Source\BoldAwareGUI\ControlPacks\BoldViewerControlPack.pas', + BoldWebConnection in 'Source\Common\HTTP\BoldWebConnection.pas', + BoldXCVTreeView in 'Source\BoldAwareGUI\BoldControls\BoldXCVTreeView.pas', + BoldXMLDispatcher in 'Source\Common\ConnectionHandlesCOM\BoldXMLDispatcher.pas', + BoldXMLDispatcherVB in 'Source\Common\ConnectionHandlesCOM\BoldXMLDispatcherVB.pas', + UMLConsts in 'Source\UMLModel\Core\UMLConsts.pas', + BoldAbstractExternalPersistenceController in 'Source\Persistence\ExternalPersistence\BoldAbstractExternalPersistenceController.pas', + BoldAbstractExternalPersistenceHandle in 'Source\Persistence\ExternalPersistence\BoldAbstractExternalPersistenceHandle.pas', + BoldAbstractPartiallyExternalPC in 'Source\Persistence\ExternalPersistence\BoldAbstractPartiallyExternalPC.pas', + BoldAbstractPartiallyExternalPH in 'Source\Persistence\ExternalPersistence\BoldAbstractPartiallyExternalPH.pas', + BoldExternalPersistenceConfigItemDataSet in 'Source\Persistence\ExternalPersistence\BoldExternalPersistenceConfigItemDataSet.pas', + BoldExternalPersistenceControllerConfig in 'Source\Persistence\ExternalPersistence\BoldExternalPersistenceControllerConfig.pas', + BoldExternalPersistenceControllerDataSet in 'Source\Persistence\ExternalPersistence\BoldExternalPersistenceControllerDataSet.pas', + BoldExternalPersistenceControllerEventDriven in 'Source\Persistence\ExternalPersistence\BoldExternalPersistenceControllerEventDriven.pas', + BoldExternalPersistenceControllerSQL in 'Source\Persistence\ExternalPersistence\BoldExternalPersistenceControllerSQL.pas', + BoldExternalPersistenceHandleDataSet in 'Source\Persistence\ExternalPersistence\BoldExternalPersistenceHandleDataSet.pas', + BoldExternalPersistenceHandleEventDriven in 'Source\Persistence\ExternalPersistence\BoldExternalPersistenceHandleEventDriven.pas', + BoldExternalPersistenceHandleSQL in 'Source\Persistence\ExternalPersistence\BoldExternalPersistenceHandleSQL.pas', + BoldExternalPersistenceHandleSQLPropEditor in 'Source\Persistence\ExternalPersistence\BoldExternalPersistenceHandleSQLPropEditor.pas', + BoldExternalPersistenceSupport in 'Source\Persistence\ExternalPersistence\BoldExternalPersistenceSupport.pas', + ExPeConsts in 'Source\Persistence\ExternalPersistence\ExPeConsts.pas', + BoldClientElementSupport in 'Source\ClientHandlesCom\Core\BoldClientElementSupport.pas'; end. diff --git a/Bold.dproj b/Bold.dproj index 218c111e..b2954ed9 100644 --- a/Bold.dproj +++ b/Bold.dproj @@ -1,34 +1,46 @@  - {02C80A51-35CA-4FE1-9B68-25EF64BBE566} + {4BC34884-BFF5-402F-81A4-0063B51D2F4F} Bold.dpk + 19.2 + None True Debug - 1 - Package - VCL - 16.1 Win32 + 3 + Package true - - true + + true Base true - - true + + true Base true - + true Base true - + + true + Cfg_1 + true + true + + + true + Cfg_1 + true + true + + true Base true @@ -40,53 +52,64 @@ true - 00400000 + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false false - Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace) - 1 - true - true false - Bold 4.0 for Delphi - false - true - false - 1033 - true + true true - true - false - 90 + System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;Winapi;System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + All Bold - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= - true - false - - - package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar;hardwareAccelerated=true - Debug + $(BoldDelphi)\Source\Common\Include;$(DCC_UnitSearchPath) + 2077 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + Bold For Delphi - Core + true + 27 + true - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= - System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true 1033 + vcl;vcldb;$(DCC_UsePackage) + + + vcl;vcldb;$(DCC_UsePackage) + Debug true + 1033 + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + true + 1033 + + + true + 1033 + + false RELEASE;$(DCC_Define) 0 0 - - true - DEBUG;$(DCC_Define) - false - - BOLD_DELPHI;$(DCC_Define) - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= true + 1033 @@ -94,8 +117,48 @@ - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -113,28 +176,6 @@ - - - - - - - - - - - - - - - - - - - - - - @@ -146,7 +187,6 @@ - @@ -176,28 +216,9 @@ - - - - - - - - - - - - - - - - - - - @@ -205,14 +226,10 @@ - + - - - - @@ -221,6 +238,7 @@ + @@ -267,8 +285,12 @@ + + + + @@ -281,37 +303,28 @@ + + - - - - - - - - - - - @@ -327,17 +340,9 @@ - - - - - - - - @@ -385,10 +390,10 @@ + - @@ -397,18 +402,144 @@ + + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Cfg_2 Base Base - + Cfg_1 Base @@ -422,39 +553,727 @@ Bold.dpk - Embarcadero FireDAC Common Components - Embarcadero FireDAC Infx Driver Components - Embarcadero FireDAC ODBC Driver Components - Embarcadero FireDAC Common Driver Components - Embarcadero FireDAC Db2 Driver Components - Embarcadero FireDAC SQL Server Driver Components - Embarcadero FireDAC Oracle Driver Components - Embarcadero FireDAC Database Components - Embarcadero FireDAC Sqlite Driver Components - Embarcadero FireDAC PostgreSQL Driver Components - Embarcadero FireDAC ASA Driver Components - Embarcadero FireDAC MS Access Driver Components - Embarcadero FireDAC IB Driver Components - Embarcadero FireDAC MySQL Driver Components - Embarcadero FireDAC ADS Driver Components - Embarcadero FireDAC DBX Driver Components - Embarcadero FireDAC DataSnap Driver Components - Embarcadero C++Builder Office 2000 Servers Package - Embarcadero C++Builder Office XP Servers Package - Microsoft Office 2000 Sample Automation Server Wrapper Components - Microsoft Office XP Sample Automation Server Wrapper Components + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + true + + + + + true + + + + + true + + + + + 1 + + + 0 + + + + + classes + 1 + + + classes + 1 + + + + + res\xml + 1 + + + res\xml + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + library\lib\armeabi + 1 + + + library\lib\armeabi + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + library\lib\mips + 1 + + + library\lib\mips + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\values-v21 + 1 + + + res\values-v21 + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-ldpi + 1 + + + res\drawable-ldpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-small + 1 + + + res\drawable-small + 1 + + + + + res\drawable-normal + 1 + + + res\drawable-normal + 1 + + + + + res\drawable-large + 1 + + + res\drawable-large + 1 + + + + + res\drawable-xlarge + 1 + + + res\drawable-xlarge + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + 1 + + + 1 + + + 0 + + + + + 1 + .framework + + + 1 + .framework + + + 0 + + + + + 1 + .dylib + + + 1 + .dylib + + + 0 + .dll;.bpl + + + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 0 + .bpl + + + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + 1 + + + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + + + + 1 + + + 1 + + + 1 + + + + + + + + Contents\Resources + 1 + + + Contents\Resources + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 0 + + + + + library\lib\armeabi-v7a + 1 + + + + + 1 + + + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + + + + + + + + + - False - False - False True - False + True 12 + diff --git a/Bold.res b/Bold.res index a64cea33..348af5e9 100644 Binary files a/Bold.res and b/Bold.res differ diff --git a/Bold.~dsk b/Bold.~dsk new file mode 100644 index 00000000..47778468 --- /dev/null +++ b/Bold.~dsk @@ -0,0 +1,923 @@ +[Closed Files] +File_0=TSourceModule,'D:\Developer\DELPHI\BoldForDelphi\Source\Handles\IDE\BoldHandleReg.pas',0,1,51,73,71,0,0,, +File_1=TSourceModule,'D:\Developer\DELPHI\BoldForDelphi\Source\Propagator\Common\BoldLockingSupportInterfaces_TLB.pas',0,1,28,77,40,0,0,, +File_2=TSourceModule,'D:\Developer\DELPHI\BoldForDelphi\Source\Common\Support\BoldControlsDefs.pas',0,1,1,7,12,0,0,, +File_3=TSourceModule,'D:\Developer\DELPHI\BoldForDelphi\Source\Common\UtilsGUI\BoldQueryUserDlg.pas',0,1,1,7,11,0,0,, +File_4=TSourceModule,'D:\Developer\DELPHI\BoldForDelphi\Source\MoldModel\UtilsGUI\BoldTypeNameEditor.pas',0,1,1,7,10,0,0,, +File_5=TSourceModule,'D:\Developer\DELPHI\BoldForDelphi\Source\Common\SOAP\BoldSOAP2_TLB.pas',0,1,29,37,38,0,0,, +File_6=TSourceModule,'D:\Developer\DELPHI\BoldForDelphi\Source\Common\SOAP\BoldSOAP_TLB.pas',0,1,29,37,38,0,0,, +File_7=TSourceModule,'D:\Developer\DELPHI\BoldForDelphi\Source\Common\Rose98\RationalRose98_TLB.pas',0,1,21,37,30,0,0,, +File_8=TSourceModule,'D:\Developer\DELPHI\BoldForDelphi\Source\Common\Rose2000\RationalRose2000_TLB.pas',0,1,22,37,31,0,0,, +File_9=TSourceModule,'D:\Developer\DELPHI\BoldForDelphi\Source\Common\MsXml\MSXML_TLB.pas',0,1,34,37,43,0,0,, + +[Modules] +Module0=D:\Developer\DELPHI\BoldForDelphi\Bold.dproj +Module1=D:\Developer\DELPHI\BoldForDelphi\Source\Common\IDE\BoldExpert.pas +Module2=D:\Developer\DELPHI\BoldForDelphi\Source\ObjectSpace\IDE\BoldExternalObjectSpaceEventHandlerReg.pas +Module3=D:\Developer\DELPHI\BoldForDelphi\Source\Common\Support\BoldCommonBitmaps.pas +Module4=D:\Developer\DELPHI\BoldForDelphi\Source\Common\IDE\BoldWebConnectionReg.pas +Module5=D:\Developer\DELPHI\BoldForDelphi\Source\Common\IDE\BoldReg.pas +Module6=default.htm +Count=7 +EditWindowCount=1 + +[D:\Developer\DELPHI\BoldForDelphi\Bold.dproj] +ModuleType=TBaseProject + +[D:\Developer\DELPHI\BoldForDelphi\Source\Common\IDE\BoldExpert.pas] +ModuleType=TSourceModule + +[D:\Developer\DELPHI\BoldForDelphi\Source\ObjectSpace\IDE\BoldExternalObjectSpaceEventHandlerReg.pas] +ModuleType=TSourceModule + +[D:\Developer\DELPHI\BoldForDelphi\Source\Common\Support\BoldCommonBitmaps.pas] +ModuleType=TSourceModule + +[D:\Developer\DELPHI\BoldForDelphi\Source\Common\IDE\BoldWebConnectionReg.pas] +ModuleType=TSourceModule + +[D:\Developer\DELPHI\BoldForDelphi\Source\Common\IDE\BoldReg.pas] +ModuleType=TSourceModule + +[default.htm] +ModuleType=TURLModule + +[EditWindow0] +ViewCount=7 +CurrentEditView=D:\Developer\DELPHI\BoldForDelphi\Bold.dpk +View0=0 +View1=1 +View2=2 +View3=3 +View4=4 +View5=5 +View6=6 +PercentageSizes=1 +Create=1 +Visible=1 +Docked=1 +State=0 +Left=0 +Top=0 +Width=9917 +Height=9052 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=9917 +ClientHeight=9052 +DockedToMainForm=1 +BorlandEditorCodeExplorer=BorlandEditorCodeExplorer@EditWindow0 +TopPanelSize=0 +LeftPanelSize=2005 +LeftPanelClients=DockSite2 +LeftPanelData=00000800010100000000F10B00000000000001D50700000000000001000000003B15000009000000446F636B5369746532FFFFFFFF +RightPanelSize=2052 +RightPanelClients=DockSite1 +RightPanelData=00000800010100000000F10B00000000000001040800000000000001000000003B15000009000000446F636B5369746531FFFFFFFF +BottomPanelSize=3157 +BottomPanelClients=DockSite0,MessageView +BottomPanelData=0000080001020100000009000000446F636B5369746530DE4400000000000002550C0000000000000100000000DE4400000F0000004D65737361676556696577466F726DFFFFFFFF +BottomMiddlePanelSize=0 +BottomMiddlePanelClients=GraphDrawingModel +BottomMiddelPanelData=0000080001000100000010000000477261706844726177696E67566965771D2800000000000000B621000000000000FFFFFFFF + +[View0] +CustomEditViewType=TWelcomePageView +WelcomePageURL=bds:/default.htm + +[View1] +CustomEditViewType=TEditView +Module=D:\Developer\DELPHI\BoldForDelphi\Bold.dpk +CursorX=80 +CursorY=25 +TopLine=13 +LeftCol=1 +Elisions= +Bookmarks= +EditViewName=D:\Developer\DELPHI\BoldForDelphi\Bold.dpk + +[View2] +CustomEditViewType=TEditView +Module=D:\Developer\DELPHI\BoldForDelphi\Source\ObjectSpace\IDE\BoldExternalObjectSpaceEventHandlerReg.pas +CursorX=5 +CursorY=12 +TopLine=1 +LeftCol=1 +Elisions= +Bookmarks= +EditViewName=D:\Developer\DELPHI\BoldForDelphi\Source\ObjectSpace\IDE\BoldExternalObjectSpaceEventHandlerReg.pas + +[View3] +CustomEditViewType=TEditView +Module=D:\Developer\DELPHI\BoldForDelphi\Source\Common\IDE\BoldExpert.pas +CursorX=56 +CursorY=55 +TopLine=33 +LeftCol=1 +Elisions= +Bookmarks= +EditViewName=D:\Developer\DELPHI\BoldForDelphi\Source\Common\IDE\BoldExpert.pas + +[View4] +CustomEditViewType=TEditView +Module=D:\Developer\DELPHI\BoldForDelphi\Source\Common\IDE\BoldReg.pas +CursorX=2 +CursorY=19 +TopLine=1 +LeftCol=1 +Elisions= +Bookmarks= +EditViewName=D:\Developer\DELPHI\BoldForDelphi\Source\Common\IDE\BoldReg.pas + +[View5] +CustomEditViewType=TEditView +Module=D:\Developer\DELPHI\BoldForDelphi\Source\Common\IDE\BoldWebConnectionReg.pas +CursorX=2 +CursorY=12 +TopLine=1 +LeftCol=1 +Elisions= +Bookmarks= +EditViewName=D:\Developer\DELPHI\BoldForDelphi\Source\Common\IDE\BoldWebConnectionReg.pas + +[View6] +CustomEditViewType=TEditView +Module=D:\Developer\DELPHI\BoldForDelphi\Source\Common\Support\BoldCommonBitmaps.pas +CursorX=2 +CursorY=30 +TopLine=17 +LeftCol=1 +Elisions= +Bookmarks= +EditViewName=D:\Developer\DELPHI\BoldForDelphi\Source\Common\Support\BoldCommonBitmaps.pas + +[Watches] +Count=0 + +[WatchWindow] +WatchColumnWidth=120 +WatchShowColumnHeaders=1 +PercentageSizes=1 +Create=1 +Visible=1 +Docked=1 +State=0 +Left=0 +Top=0 +Width=3823 +Height=1151 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=3823 +ClientHeight=1151 +TBDockHeight=213 +LRDockWidth=13604 +Dockable=1 +StayOnTop=0 + +[Breakpoints] +Count=0 + +[EmbarcaderoWin32Debugger_AddressBreakpoints] +Count=0 + +[EmbarcaderoWin64Debugger_AddressBreakpoints] +Count=0 + +[EmbarcaderoLinux64Debugger_AddressBreakpoints] +Count=0 + +[EmbarcaderoOSX32Debugger_AddressBreakpoints] +Count=0 + +[EmbarcaderoOSX64Debugger_AddressBreakpoints] +Count=0 + +[EmbarcaderoIOS64DeviceDebugger_AddressBreakpoints] +Count=0 + +[EmbarcaderoAndroid32Debugger_AddressBreakpoints] +Count=0 + +[EmbarcaderoAndroid64Debugger_AddressBreakpoints] +Count=0 + +[Main Window] +PercentageSizes=1 +Create=1 +Visible=1 +Docked=0 +State=2 +Left=11120 +Top=0 +Width=8922 +Height=8491 +MaxLeft=-5 +MaxTop=-10 +MaxWidth=8922 +MaxHeight=8491 +ClientWidth=10000 +ClientHeight=10135 +BottomPanelSize=8667 +BottomPanelClients=EditWindow0 +BottomPanelData=0000080000000000000000000000000000000000000000000000000100000000000000000C0000004564697457696E646F775F30FFFFFFFF + +[ProjectManager] +PercentageSizes=1 +Create=1 +Visible=1 +Docked=1 +State=0 +Left=0 +Top=0 +Width=2052 +Height=5135 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=2052 +ClientHeight=5135 +TBDockHeight=5890 +LRDockWidth=2349 +Dockable=1 +StayOnTop=0 + +[MessageView] +PercentageSizes=1 +Create=1 +Visible=1 +Docked=1 +State=0 +Left=0 +Top=28 +Width=9917 +Height=3027 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=9917 +ClientHeight=3027 +TBDockHeight=3027 +LRDockWidth=2771 +Dockable=1 +StayOnTop=0 + +[ConfigurationManager] +PercentageSizes=1 +Create=1 +Visible=0 +Docked=0 +State=0 +Left=3531 +Top=2930 +Width=2932 +Height=4091 +MaxLeft=-5 +MaxTop=-10 +ClientWidth=2849 +ClientHeight=3714 +TBDockHeight=4091 +LRDockWidth=2932 +Dockable=1 +StayOnTop=0 + +[TConfigMgrDlg] +Column0=120 +Column1=120 +Column2=120 +Column3=100 +Column4=140 + +[ToolForm] +PercentageSizes=1 +Create=1 +Visible=1 +Docked=1 +State=0 +Left=0 +Top=0 +Width=2052 +Height=6557 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=2052 +ClientHeight=6557 +TBDockHeight=7137 +LRDockWidth=2000 +Dockable=1 +StayOnTop=0 + +[PropertyInspector] +PercentageSizes=1 +Create=1 +Visible=1 +Docked=1 +State=0 +Left=0 +Top=0 +Width=2005 +Height=5135 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=2005 +ClientHeight=5135 +TBDockHeight=8985 +LRDockWidth=1682 +Dockable=1 +StayOnTop=0 +SplitPos=178 + +[frmDesignPreview] +PercentageSizes=1 +Create=1 +Visible=1 +Docked=1 +State=0 +Left=0 +Top=0 +Width=2005 +Height=6557 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=2005 +ClientHeight=6557 +TBDockHeight=5948 +LRDockWidth=2510 +Dockable=1 +StayOnTop=0 + +[TemplateView] +PercentageSizes=1 +Create=1 +Visible=0 +Docked=1 +State=0 +Left=0 +Top=0 +Width=276 +Height=368 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=276 +ClientHeight=368 +TBDockHeight=368 +LRDockWidth=276 +Dockable=1 +StayOnTop=0 +Name=120 +Description=334 +filter=1 + +[DebugLogView] +PercentageSizes=1 +Create=1 +Visible=1 +Docked=1 +State=0 +Left=0 +Top=0 +Width=3823 +Height=1151 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=3823 +ClientHeight=1151 +TBDockHeight=416 +LRDockWidth=4953 +Dockable=1 +StayOnTop=0 + +[ThreadStatusWindow] +PercentageSizes=1 +Create=1 +Visible=1 +Docked=1 +State=0 +Left=0 +Top=0 +Width=3823 +Height=1151 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=3823 +ClientHeight=1151 +TBDockHeight=213 +LRDockWidth=7406 +Dockable=1 +StayOnTop=0 +Column0Width=145 +Column1Width=100 +Column2Width=115 +Column3Width=374 +Column4Width=10 + +[LocalVarsWindow] +PercentageSizes=1 +Create=1 +Visible=1 +Docked=1 +State=0 +Left=0 +Top=0 +Width=3823 +Height=1151 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=3823 +ClientHeight=1151 +TBDockHeight=1538 +LRDockWidth=3484 +Dockable=1 +StayOnTop=0 + +[CallStackWindow] +PercentageSizes=1 +Create=1 +Visible=1 +Docked=1 +State=0 +Left=0 +Top=0 +Width=3823 +Height=1151 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=3823 +ClientHeight=1151 +TBDockHeight=2060 +LRDockWidth=3484 +Dockable=1 +StayOnTop=0 + +[FindReferencsForm] +PercentageSizes=1 +Create=1 +Visible=0 +Docked=0 +State=0 +Left=3135 +Top=4265 +Width=2339 +Height=1209 +MaxLeft=-5 +MaxTop=-10 +ClientWidth=2255 +ClientHeight=832 +TBDockHeight=2311 +LRDockWidth=2823 +Dockable=1 +StayOnTop=0 + +[RefactoringForm] +PercentageSizes=1 +Create=1 +Visible=0 +Docked=0 +State=0 +Left=3453 +Top=3501 +Width=2339 +Height=1209 +MaxLeft=-5 +MaxTop=-10 +ClientWidth=2255 +ClientHeight=832 +TBDockHeight=3201 +LRDockWidth=2823 +Dockable=1 +StayOnTop=0 + +[ToDo List] +PercentageSizes=1 +Create=1 +Visible=1 +Docked=1 +State=0 +Left=0 +Top=0 +Width=2005 +Height=6557 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=2005 +ClientHeight=6557 +TBDockHeight=1151 +LRDockWidth=3677 +Dockable=1 +StayOnTop=0 +Column0Width=314 +Column1Width=30 +Column2Width=150 +Column3Width=172 +Column4Width=129 +SortOrder=4 +ShowHints=1 +ShowChecked=1 + +[DataExplorerContainer] +PercentageSizes=1 +Create=1 +Visible=1 +Docked=1 +State=0 +Left=0 +Top=0 +Width=2052 +Height=6557 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=2052 +ClientHeight=6557 +TBDockHeight=4874 +LRDockWidth=7151 +Dockable=1 +StayOnTop=0 + +[GraphDrawingModel] +PercentageSizes=1 +Create=1 +Visible=0 +Docked=1 +State=0 +Left=0 +Top=0 +Width=2854 +Height=3201 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=2854 +ClientHeight=3201 +TBDockHeight=3201 +LRDockWidth=2854 +Dockable=1 +StayOnTop=0 + +[ClassBrowserTool] +PercentageSizes=1 +Create=1 +Visible=0 +Docked=1 +State=0 +Left=-172 +Top=-399 +Width=1849 +Height=3133 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=1849 +ClientHeight=3133 +TBDockHeight=3133 +LRDockWidth=1849 +Dockable=1 +StayOnTop=0 + +[MetricsView] +PercentageSizes=1 +Create=1 +Visible=0 +Docked=0 +State=0 +Left=3594 +Top=4178 +Width=2339 +Height=1209 +MaxLeft=-5 +MaxTop=-10 +ClientWidth=2255 +ClientHeight=832 +TBDockHeight=4826 +LRDockWidth=3562 +Dockable=1 +StayOnTop=0 + +[QAView] +PercentageSizes=1 +Create=1 +Visible=0 +Docked=0 +State=0 +Left=3812 +Top=3694 +Width=2339 +Height=1209 +MaxLeft=-5 +MaxTop=-10 +ClientWidth=2255 +ClientHeight=832 +TBDockHeight=4826 +LRDockWidth=3562 +Dockable=1 +StayOnTop=0 + +[BreakpointWindow] +PercentageSizes=1 +Create=1 +Visible=1 +Docked=1 +State=0 +Left=0 +Top=0 +Width=3823 +Height=1151 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=3823 +ClientHeight=1151 +TBDockHeight=1547 +LRDockWidth=8740 +Dockable=1 +StayOnTop=0 +Column0Width=200 +Column1Width=75 +Column2Width=200 +Column3Width=200 +Column4Width=200 +Column5Width=75 +Column6Width=75 + +[StructureView] +PercentageSizes=1 +Create=1 +Visible=1 +Docked=1 +State=0 +Left=0 +Top=0 +Width=2052 +Height=6557 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=2052 +ClientHeight=6557 +TBDockHeight=3675 +LRDockWidth=1896 +Dockable=1 +StayOnTop=0 + +[ParnassusBookmarksForm] +PercentageSizes=1 +Create=1 +Visible=0 +Docked=1 +State=0 +Left=-172 +Top=-399 +Width=2969 +Height=3153 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=2969 +ClientHeight=3153 +TBDockHeight=3153 +LRDockWidth=2969 +Dockable=1 +StayOnTop=0 + +[MMXCodeExplorer] +PercentageSizes=1 +Create=1 +Visible=1 +Docked=1 +State=0 +Left=0 +Top=0 +Width=2052 +Height=6557 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=2052 +ClientHeight=6557 +TBDockHeight=8288 +LRDockWidth=1464 +Dockable=1 +StayOnTop=0 +Layout=0 +Split=30 +ContentsClosed=0 + +[MMXSourceIndexerView] +PercentageSizes=1 +Create=1 +Visible=0 +Docked=0 +State=0 +Left=3250 +Top=2911 +Width=3495 +Height=4139 +MaxLeft=-5 +MaxTop=-10 +ClientWidth=3411 +ClientHeight=3762 +TBDockHeight=4139 +LRDockWidth=3495 +Dockable=1 +StayOnTop=0 + +[ParnassusThreadListForm] +PercentageSizes=1 +Create=1 +Visible=0 +Docked=0 +State=0 +Left=0 +Top=0 +Width=3797 +Height=3104 +MaxLeft=-5 +MaxTop=-10 +ClientWidth=3714 +ClientHeight=2727 +TBDockHeight=3104 +LRDockWidth=3797 +Dockable=1 +StayOnTop=0 + +[ParnassusProcessForm] +PercentageSizes=1 +Create=1 +Visible=0 +Docked=0 +State=0 +Left=0 +Top=0 +Width=3797 +Height=3104 +MaxLeft=-5 +MaxTop=-10 +ClientWidth=3714 +ClientHeight=2727 +TBDockHeight=3104 +LRDockWidth=3797 +Dockable=1 +StayOnTop=0 + +[fmGrepResults] +PercentageSizes=1 +Create=1 +Visible=0 +Docked=0 +State=0 +Left=0 +Top=0 +Width=2146 +Height=3636 +MaxLeft=-5 +MaxTop=-10 +ClientWidth=2062 +ClientHeight=3259 +TBDockHeight=3607 +LRDockWidth=2146 +Dockable=1 +StayOnTop=0 + +[fmMacroLibrary] +PercentageSizes=1 +Create=1 +Visible=0 +Docked=0 +State=0 +Left=0 +Top=0 +Width=1719 +Height=2485 +MaxLeft=-5 +MaxTop=-10 +ClientWidth=1635 +ClientHeight=2108 +TBDockHeight=2466 +LRDockWidth=1719 +Dockable=1 +StayOnTop=0 + +[TestInsightForm] +PercentageSizes=1 +Create=1 +Visible=0 +Docked=0 +State=0 +Left=0 +Top=0 +Width=2969 +Height=3172 +MaxLeft=-5 +MaxTop=-10 +ClientWidth=2885 +ClientHeight=2795 +TBDockHeight=3172 +LRDockWidth=2969 +Dockable=1 +StayOnTop=0 +TabIndex=0 + +[ModelViewTool] +PercentageSizes=1 +Create=1 +Visible=1 +Docked=1 +State=0 +Left=0 +Top=0 +Width=2005 +Height=6557 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=2005 +ClientHeight=6557 +TBDockHeight=4874 +LRDockWidth=5307 +Dockable=1 +StayOnTop=0 + +[BorlandEditorCodeExplorer@EditWindow0] +PercentageSizes=1 +Create=1 +Visible=0 +Docked=0 +State=0 +Left=0 +Top=0 +Width=1823 +Height=6151 +MaxLeft=-5 +MaxTop=-10 +ClientWidth=1740 +ClientHeight=5774 +TBDockHeight=6151 +LRDockWidth=1823 +Dockable=1 +StayOnTop=0 + +[DockHosts] +DockHostCount=3 + +[DockSite0] +HostDockSite=DockBottomPanel +DockSiteType=1 +PercentageSizes=1 +Create=1 +Visible=0 +Docked=1 +State=0 +Left=8 +Top=8 +Width=3823 +Height=1422 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=3823 +ClientHeight=1422 +TBDockHeight=1422 +LRDockWidth=3823 +Dockable=1 +StayOnTop=0 +TabPosition=1 +ActiveTabID=DebugLogView +TabDockClients=DebugLogView,BreakpointWindow,ThreadStatusWindow,CallStackWindow,WatchWindow,LocalVarsWindow + +[DockSite1] +HostDockSite=DockRightPanel +DockSiteType=1 +PercentageSizes=1 +Create=1 +Visible=1 +Docked=1 +State=0 +Left=0 +Top=28 +Width=2052 +Height=5406 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=2052 +ClientHeight=5406 +TBDockHeight=8985 +LRDockWidth=2052 +Dockable=1 +StayOnTop=0 +TabPosition=0 +ActiveTabID=ProjectManager +TabDockClients=ProjectManager,ToolForm,StructureView,MMXCodeExplorer,DataExplorerContainer,TemplateView + +[DockSite2] +HostDockSite=DockLeftPanel +DockSiteType=1 +PercentageSizes=1 +Create=1 +Visible=1 +Docked=1 +State=0 +Left=0 +Top=28 +Width=2005 +Height=5406 +MaxLeft=-1 +MaxTop=-1 +ClientWidth=2005 +ClientHeight=5406 +TBDockHeight=3627 +LRDockWidth=2005 +Dockable=1 +StayOnTop=0 +TabPosition=0 +ActiveTabID=PropertyInspector +TabDockClients=PropertyInspector,frmDesignPreview,ModelViewTool,ToDo List,ParnassusBookmarksForm,ClassBrowserTool + diff --git a/BoldAdo.dproj b/BoldAdo.dproj new file mode 100644 index 00000000..ab4c41b0 --- /dev/null +++ b/BoldAdo.dproj @@ -0,0 +1,131 @@ + + + {BE726EF9-DAC0-4138-B2C9-AF623827CC4C} + BoldAdo.dpk + True + Debug + 1 + Package + VCL + 19.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + BoldAdo + 1 + false + true + true + true + true + true + Bold 4.0 for Delphi (ADO Support) + 90 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;DUnitX.Loggers.GUI;Data.Win;$(DCC_Namespace) + 2077 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + Source\Common\Include\;$(DCC_UnitSearchPath) + + + Winapi;System.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + DEBUG;$(DCC_Define) + false + true + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + + MainSource + + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + BoldAdo.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + False + + + 12 + + + + diff --git a/BoldAdo.res b/BoldAdo.res new file mode 100644 index 00000000..800ca8b6 Binary files /dev/null and b/BoldAdo.res differ diff --git a/BoldAdvantage.dproj b/BoldAdvantage.dproj new file mode 100644 index 00000000..4df1e012 --- /dev/null +++ b/BoldAdvantage.dproj @@ -0,0 +1,130 @@ + + + {A770C0F0-9130-4024-8968-458A685FA8A3} + BoldAdvantage.dpk + True + Debug + 1 + Package + VCL + 19.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + BoldAdvantage + 1 + false + true + true + true + true + true + Bold 4.0 for Delphi (dvantage Support) + 90 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;DUnitX.Loggers.GUI;System.Win;$(DCC_Namespace) + 2077 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + Source\Common\Include\;$(DCC_UnitSearchPath) + + + Winapi;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + DEBUG;$(DCC_Define) + false + true + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + + MainSource + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + BoldAdvantage.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + False + + + 12 + + + + diff --git a/BoldAdvantage.res b/BoldAdvantage.res new file mode 100644 index 00000000..a59b5069 Binary files /dev/null and b/BoldAdvantage.res differ diff --git a/BoldBDE.dproj b/BoldBDE.dproj new file mode 100644 index 00000000..071267db --- /dev/null +++ b/BoldBDE.dproj @@ -0,0 +1,143 @@ + + + {4105301E-57B2-4100-95E6-CFEFFF810168} + BoldBDE.dpk + True + Debug + 1 + Package + VCL + 19.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + BoldBDE + 1 + false + true + true + true + true + true + Bold 4.0 for Delphi (BDE Support) + 90 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;DUnitX.Loggers.GUI;$(DCC_Namespace) + 2077 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + Source\Common\Include\;$(DCC_UnitSearchPath) + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + vcl;vcldb;bdertl;$(DCC_UsePackage) + + + vcl;vcldb;$(DCC_UsePackage) + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + DEBUG;$(DCC_Define) + false + true + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + + MainSource + + + + + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + BoldBDE.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + False + + + 12 + + + + diff --git a/BoldBDE.res b/BoldBDE.res new file mode 100644 index 00000000..a1b23a82 Binary files /dev/null and b/BoldBDE.res differ diff --git a/BoldCom.dproj b/BoldCom.dproj new file mode 100644 index 00000000..6f9f182e --- /dev/null +++ b/BoldCom.dproj @@ -0,0 +1,195 @@ + + + {D19FAF40-7E3D-47AA-A13C-E4A727F5CE66} + BoldCom.dpk + True + Debug + 1 + Package + VCL + 19.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + BoldCom + 1 + false + true + true + true + true + true + Bold 4.0 for Delphi (COM Support) + 90 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;DUnitX.Loggers.GUI;Winapi;System.Win;$(DCC_Namespace) + 2077 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + Source\Common\Include\;$(DCC_UnitSearchPath) + Bold_Delphi;$(DCC_Define) + + + Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + vcl;$(DCC_UsePackage) + + + vcl;$(DCC_UsePackage) + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + DEBUG;$(DCC_Define) + false + true + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + + MainSource + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + BoldCom.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + False + + + 12 + + + + diff --git a/BoldCom.res b/BoldCom.res new file mode 100644 index 00000000..ea559daa Binary files /dev/null and b/BoldCom.res differ diff --git a/BoldComGUI.dpk b/BoldComGUI.dpk index 32bfb085..6a0aac12 100644 --- a/BoldComGUI.dpk +++ b/BoldComGUI.dpk @@ -31,7 +31,6 @@ package BoldComGUI; requires vcl, - VclJpg, Bold, BoldCom, DesignIDE; diff --git a/BoldComGUI.dproj b/BoldComGUI.dproj new file mode 100644 index 00000000..71f1295c --- /dev/null +++ b/BoldComGUI.dproj @@ -0,0 +1,194 @@ + + + {D112DB24-A42C-4AEC-BBED-D20E54732156} + BoldComGUI.dpk + True + Debug + 1 + Package + VCL + 19.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + BoldComGUI + 1 + false + true + true + true + true + true + Bold 4.0 for Delphi (COM GUI controls) + 90 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;DUnitX.Loggers.GUI;Winapi;$(DCC_Namespace) + 2077 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + Source\Common\Include\;$(DCC_UnitSearchPath) + + + System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + vcl;$(DCC_UsePackage) + + + vcl;$(DCC_UsePackage) + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + DEBUG;$(DCC_Define) + false + true + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + + MainSource + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + BoldComGUI.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + False + + + 12 + + + + diff --git a/BoldComGUI.res b/BoldComGUI.res new file mode 100644 index 00000000..42e41efe Binary files /dev/null and b/BoldComGUI.res differ diff --git a/BoldDBExpress.dproj b/BoldDBExpress.dproj new file mode 100644 index 00000000..4d1d587b --- /dev/null +++ b/BoldDBExpress.dproj @@ -0,0 +1,130 @@ + + + {A4468009-7C69-4778-A981-841EC1C5F3CB} + BoldDBExpress.dpk + True + Debug + 1 + Package + VCL + 19.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + BoldDBExpress + 1 + false + true + true + true + true + true + Bold 4.0 for Delphi (DBExpress Support) + 90 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;DUnitX.Loggers.GUI;$(DCC_Namespace) + 2077 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + Source\Common\Include\;$(DCC_UnitSearchPath) + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + DEBUG;$(DCC_Define) + false + true + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + + MainSource + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + BoldDBExpress.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + False + + + 12 + + + + diff --git a/BoldDBExpress.res b/BoldDBExpress.res new file mode 100644 index 00000000..8182af91 Binary files /dev/null and b/BoldDBExpress.res differ diff --git a/BoldDBIsam.dproj b/BoldDBIsam.dproj new file mode 100644 index 00000000..c2f924bc --- /dev/null +++ b/BoldDBIsam.dproj @@ -0,0 +1,131 @@ + + + {C33FD3D7-70BD-4A8C-8889-F542C9E07FBC} + BoldDBIsam.dpk + True + Debug + 1 + Package + VCL + 19.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + BoldDBIsam + 1 + false + true + true + true + true + true + Bold 4.0 for Delphi (DBIsam Support) + 90 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;DUnitX.Loggers.GUI;$(DCC_Namespace) + 2077 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + Source\Common\Include\;$(DCC_UnitSearchPath) + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + DEBUG;$(DCC_Define) + false + true + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + + MainSource + + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + BoldDBIsam.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + False + + + 12 + + + + diff --git a/BoldDOA.dproj b/BoldDOA.dproj new file mode 100644 index 00000000..b4c63645 --- /dev/null +++ b/BoldDOA.dproj @@ -0,0 +1,131 @@ + + + {6E5ACB9F-CA4D-4279-8FEF-60F92A76AF1D} + BoldDOA.dpk + True + Debug + 1 + Package + VCL + 19.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + BoldDOA + 1 + false + true + true + true + true + true + Bold 4.0 for Delphi (DOA Support) + 90 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;DUnitX.Loggers.GUI;FireDAC.Phys;$(DCC_Namespace) + 2077 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + Source\Common\Include\;$(DCC_UnitSearchPath) + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + DEBUG;$(DCC_Define) + false + true + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + + MainSource + + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + BoldDOA.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + False + + + 12 + + + + diff --git a/BoldDOA.res b/BoldDOA.res new file mode 100644 index 00000000..d7963959 Binary files /dev/null and b/BoldDOA.res differ diff --git a/BoldExPe.dproj b/BoldExPe.dproj new file mode 100644 index 00000000..d3280265 --- /dev/null +++ b/BoldExPe.dproj @@ -0,0 +1,152 @@ + + + {EDD022ED-7B27-4C5A-AAFA-50B225F31963} + BoldExPe.dpk + True + Debug + 1 + Package + VCL + 19.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + BoldExPe + 1 + false + true + true + true + true + true + Bold 4.0 for Delphi (External Persistence) + 90 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;DUnitX.Loggers.GUI;Winapi;$(DCC_Namespace) + 2077 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + Source\Common\Include\;$(DCC_UnitSearchPath) + + + System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + vcl;vclx;vcldb;$(DCC_UsePackage) + + + vcl;vclx;vcldb;$(DCC_UsePackage) + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + DEBUG;$(DCC_Define) + false + true + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + + MainSource + + + + + + + + + + + + + + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + BoldExPe.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + False + + + 12 + + + + diff --git a/BoldExPe.res b/BoldExPe.res new file mode 100644 index 00000000..36c6894c Binary files /dev/null and b/BoldExPe.res differ diff --git a/BoldExpert.res b/BoldExpert.res new file mode 100644 index 00000000..c00e4b8e Binary files /dev/null and b/BoldExpert.res differ diff --git a/BoldForDelphi.groupproj b/BoldForDelphi.groupproj new file mode 100644 index 00000000..2de2a844 --- /dev/null +++ b/BoldForDelphi.groupproj @@ -0,0 +1,96 @@ + + + {DFD5A34D-3F28-461E-9001-16DFEADD40A9} + + + + + + + + + + + + + + + + + + + + + + + Default.Personality.12 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/BoldIB.dproj b/BoldIB.dproj new file mode 100644 index 00000000..412cf446 --- /dev/null +++ b/BoldIB.dproj @@ -0,0 +1,141 @@ + + + {325F8AA8-90A0-45A3-9F01-A7487802FD96} + BoldIB.dpk + True + Debug + 1 + Package + VCL + 19.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + BoldIB + 1 + false + true + true + true + true + true + Bold 4.0 for Delphi (IBX Support) + 90 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;DUnitX.Loggers.GUI;IBX;$(DCC_Namespace) + 2077 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + Source\Common\Include\;$(DCC_UnitSearchPath) + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + vcl;vcldb;ibxpress;$(DCC_UsePackage) + + + vcl;vcldb;ibxpress;$(DCC_UsePackage) + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + DEBUG;$(DCC_Define) + false + true + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + + MainSource + + + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + BoldIB.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + False + + + 12 + + + + diff --git a/BoldIB.res b/BoldIB.res new file mode 100644 index 00000000..b9f9acf2 Binary files /dev/null and b/BoldIB.res differ diff --git a/BoldMMLink.dproj b/BoldMMLink.dproj new file mode 100644 index 00000000..bb62a3a1 --- /dev/null +++ b/BoldMMLink.dproj @@ -0,0 +1,142 @@ + + + {835F6110-BA89-4082-88F1-A8ACE5E95BD7} + BoldMMLink.dpk + True + Debug + 1 + Package + VCL + 19.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + BoldMMLink + 1 + false + true + true + true + true + true + Bold 4.0 for Delphi (ModelMaker Link) + 90 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;DUnitX.Loggers.GUI;Winapi;System.Win;$(DCC_Namespace) + 2077 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + Source\Common\Include\;$(DCC_UnitSearchPath) + + + Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + vcl;$(DCC_UsePackage) + + + vcl;$(DCC_UsePackage) + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + DEBUG;$(DCC_Define) + false + true + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + + MainSource + + + + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + BoldMMLink.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + False + + + 12 + + + + diff --git a/BoldMMLink.res b/BoldMMLink.res new file mode 100644 index 00000000..a70827e2 Binary files /dev/null and b/BoldMMLink.res differ diff --git a/BoldOLLE.dproj b/BoldOLLE.dproj new file mode 100644 index 00000000..8aa157f1 --- /dev/null +++ b/BoldOLLE.dproj @@ -0,0 +1,838 @@ + + + {3DB8E904-04CC-476B-8625-6B4AFD40AD5F} + BoldOLLE.dpk + True + Debug + 1 + Package + VCL + 19.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + BoldOLLE + 1 + false + true + true + true + true + true + Bold 4.0 for Delphi (Object Lending Library Extension) + 90 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;DUnitX.Loggers.GUI;Winapi;$(DCC_Namespace) + 2077 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + Source\Common\Include\;$(DCC_UnitSearchPath) + + + System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + DEBUG;$(DCC_Define) + false + true + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + + MainSource + + + + + + + + + + + + + + +
BoldOLLEHandles.res
+ + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + BoldOLLE.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + False + + + + + BoldOLLE.bpl + true + + + + + 1 + + + 0 + + + + + classes + 1 + + + classes + 1 + + + + + res\xml + 1 + + + res\xml + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + library\lib\armeabi + 1 + + + library\lib\armeabi + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + library\lib\mips + 1 + + + library\lib\mips + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\values-v21 + 1 + + + res\values-v21 + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-ldpi + 1 + + + res\drawable-ldpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-small + 1 + + + res\drawable-small + 1 + + + + + res\drawable-normal + 1 + + + res\drawable-normal + 1 + + + + + res\drawable-large + 1 + + + res\drawable-large + 1 + + + + + res\drawable-xlarge + 1 + + + res\drawable-xlarge + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + 1 + + + 1 + + + 0 + + + + + 1 + .framework + + + 1 + .framework + + + 0 + + + + + 1 + .dylib + + + 1 + .dylib + + + 0 + .dll;.bpl + + + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 0 + .bpl + + + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + 1 + + + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + + + + 1 + + + 1 + + + 1 + + + + + + + + Contents\Resources + 1 + + + Contents\Resources + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 0 + + + + + library\lib\armeabi-v7a + 1 + + + + + 1 + + + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + + + + + + + + + + + 12 + + + + + diff --git a/BoldOLLE.res b/BoldOLLE.res new file mode 100644 index 00000000..c753ee02 Binary files /dev/null and b/BoldOLLE.res differ diff --git a/BoldOLLEHandles.res b/BoldOLLEHandles.res new file mode 100644 index 00000000..9bc2ce0f Binary files /dev/null and b/BoldOLLEHandles.res differ diff --git a/BoldSQLDirect.dpk b/BoldSQLDirect.dpk index c8e26852..f23740c4 100644 --- a/BoldSQLDirect.dpk +++ b/BoldSQLDirect.dpk @@ -33,7 +33,7 @@ requires vcl, vcldb, Bold, - SqlDir80; + SqlDir260; contains BoldDatabaseAdapterSQLDirect in 'Source\Persistence\SQLDirect\BoldDatabaseAdapterSQLDirect.pas', diff --git a/BoldSQLDirect.dproj b/BoldSQLDirect.dproj new file mode 100644 index 00000000..b110b5b0 --- /dev/null +++ b/BoldSQLDirect.dproj @@ -0,0 +1,130 @@ + + + {132CB408-63B0-4ACE-AF3D-9A62692C9204} + BoldSQLDirect.dpk + True + Debug + 1 + Package + VCL + 19.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + BoldSQLDirect + 1 + false + true + true + true + true + true + Bold 4.0 for Delphi (SQLDirect Support) + 90 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;DUnitX.Loggers.GUI;$(DCC_Namespace) + 2077 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + Source\Common\Include\;$(DCC_UnitSearchPath) + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + DEBUG;$(DCC_Define) + false + true + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + + MainSource + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + BoldSQLDirect.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + False + + + 12 + + + + diff --git a/BoldSQLDirect.res b/BoldSQLDirect.res new file mode 100644 index 00000000..4b1a68d0 Binary files /dev/null and b/BoldSQLDirect.res differ diff --git a/BoldUDPProp.dpk b/BoldUDPProp.dpk index c156cc21..fdf84789 100644 --- a/BoldUDPProp.dpk +++ b/BoldUDPProp.dpk @@ -31,7 +31,8 @@ package BoldUDPProp; requires vcl, - Indy9v, + IndySystem, + IndyCore, Bold; contains diff --git a/BoldUDPProp.dproj b/BoldUDPProp.dproj new file mode 100644 index 00000000..6e0c624e --- /dev/null +++ b/BoldUDPProp.dproj @@ -0,0 +1,129 @@ + + + {B7BDFC5E-E47C-470B-A1F5-538B26AF78AA} + BoldUDPProp.dpk + True + Debug + 1 + Package + VCL + 19.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + BoldUDPProp + 1 + false + true + true + true + true + true + Bold 4.0 for Delphi (UDP Based Propagation) + 90 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;DUnitX.Loggers.GUI;$(DCC_Namespace) + 2077 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + Source\Common\Include\;$(DCC_UnitSearchPath) + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + DEBUG;$(DCC_Define) + false + true + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + + MainSource + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + BoldUDPProp.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + False + + + 12 + + + + diff --git a/BoldUDPProp.res b/BoldUDPProp.res new file mode 100644 index 00000000..e15e0ec9 Binary files /dev/null and b/BoldUDPProp.res differ diff --git a/BoldUml.dpk b/BoldUml.dpk index 2706a0e5..2b1191b0 100644 --- a/BoldUml.dpk +++ b/BoldUml.dpk @@ -1,33 +1,34 @@ package BoldUml; {$R *.res} -{A}{ ALIGN ON} -{C}{ ASSERTIONS ON} -{B}{ BOOLEVAL OFF} -{D}{ DEBUGINFO ON} -{X}{ EXTENDEDSYNTAX ON} -{G}{ IMPORTEDDATA ON} -{I}{ IOCHECKS ON} -{L}{ LOCALSYMBOLS ON} -{H}{ LONGSTRINGS ON} -{Z1}{ MINENUMSIZE 1} -{P}{ OPENSTRINGS ON} -{O}{ OPTIMIZATION OFF} -{Q}{ OVERFLOWCHECKS ON} -{R}{ RANGECHECKS ON} -{U}{ SAFEDIVIDE OFF} -{W}{ STACKFRAMES ON} -{T}{ TYPEDADDRESS OFF} -{V}{ VARSTRINGCHECKS ON} -{J}{ WRITEABLECONST ON} - -{$IMAGEBASE $00400000} -{$DESIGNONLY} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{ ALIGN 8} +{ ASSERTIONS ON} +{ BOOLEVAL OFF} +{ DEBUGINFO ON} +{ EXTENDEDSYNTAX ON} +{ IMPORTEDDATA ON} +{ IOCHECKS ON} +{ LOCALSYMBOLS ON} +{ LONGSTRINGS ON} +{ OPENSTRINGS ON} +{ OPTIMIZATION OFF} +{ OVERFLOWCHECKS ON} +{ RANGECHECKS ON} {$REFERENCEINFO ON} -{$IMPLICITBUILD ON} - +{ SAFEDIVIDE OFF} +{ STACKFRAMES ON} +{ TYPEDADDRESS OFF} +{ VARSTRINGCHECKS ON} +{ WRITEABLECONST ON} +{ MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Bold 4.0 for Delphi (Model editor)'} {$LIBSUFFIX '90'} +{$DESIGNONLY} +{$IMPLICITBUILD ON} requires vcl, @@ -72,6 +73,8 @@ contains BoldUMLBldLink in 'Source\UMLModel\ModelLinks\Bld\BoldUMLBldLink.pas', BoldCodePlugins in 'Source\UMLModel\Plugins\BoldCodePlugins.pas', BoldDbPlugins in 'Source\UMLModel\Plugins\BoldDbPlugins.pas', + BoldConstraintValidator in 'Source\Samples\ConstraintValidator\BoldConstraintValidator.pas', + BoldConstraintValidatorReg in 'Source\Samples\ConstraintValidator\BoldConstraintValidatorReg.pas', BoldModelOCLValidatorPlugIn in 'Source\UMLModel\Plugins\BoldModelOCLValidatorPlugIn.pas', BoldUMLModelEditPlugIn in 'Source\UMLModel\Plugins\BoldUMLModelEditPlugIn.pas', BoldUMLPluginCallBacks in 'Source\UMLModel\Plugins\BoldUMLPluginCallBacks.pas', diff --git a/BoldUml.dproj b/BoldUml.dproj new file mode 100644 index 00000000..0aaaeb6e --- /dev/null +++ b/BoldUml.dproj @@ -0,0 +1,176 @@ + + + {6FA5D617-693C-48B5-9532-360227794754} + BoldUml.dpk + True + Debug + 1 + Package + VCL + 19.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + BoldUml + 1 + false + true + true + true + true + true + Bold 4.0 for Delphi (Model editor) + 90 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;DUnitX.Loggers.GUI;Winapi;$(DCC_Namespace) + 2077 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + Source\Common\Include\;$(DCC_UnitSearchPath) + + + System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + vcl;$(DCC_UsePackage) + + + vcl;$(DCC_UsePackage) + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + DEBUG;$(DCC_Define) + false + true + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + + MainSource + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + BoldUml.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + False + + + 12 + + + + diff --git a/BoldUml.res b/BoldUml.res new file mode 100644 index 00000000..4fba3de8 Binary files /dev/null and b/BoldUml.res differ diff --git a/BoldUniDAC.dpk b/BoldUniDAC.dpk new file mode 100644 index 00000000..94a90712 --- /dev/null +++ b/BoldUniDAC.dpk @@ -0,0 +1,45 @@ +package BoldUniDAC; + +{$R *.res} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$DESCRIPTION 'Bold 4.0 for Delphi (UniDAC Support)'} +{$DESIGNONLY} +{$IMPLICITBUILD ON} + +requires + rtl, + vcldb, + ibxpress, + DesignIDE, + Bold; + +contains + BoldPersistenceHandleUniDACReg in 'Source\Persistence\UniDAC\BoldPersistenceHandleUniDACReg.pas', + BoldUniDACInterfaces in 'Source\Persistence\UniDAC\BoldUniDACInterfaces.pas', + UniDACConsts in 'Source\Persistence\UniDAC\UniDACConsts.pas', + BoldDatabaseAdapterUniDAC in 'Source\Persistence\UniDAC\BoldDatabaseAdapterUniDAC.pas'; + +end. diff --git a/BoldUtility.dpk b/BoldUtility.dpk index 5eeb76f7..65ae8934 100644 --- a/BoldUtility.dpk +++ b/BoldUtility.dpk @@ -46,19 +46,20 @@ contains BoldSelectionListBox in 'Source\Samples\BoldCheckListBox\BoldSelectionListBox.pas', BoldSelectionListBoxReg in 'Source\Samples\BoldCheckListBox\BoldSelectionListBoxReg.pas', BoldFormSaver in 'Source\Samples\FormSaver\BoldFormSaver.pas', +{ + BoldAttributeWideString in 'Source\Samples\Unicode\BoldAttributeWideString.pas', + BoldPMWideString in 'Source\Samples\Unicode\BoldPMWideString.pas', + BoldWideStringControlPack in 'Source\Samples\Unicode\BoldWideStringControlPack.pas', + BoldWideStringInterface in 'Source\Samples\Unicode\BoldWideStringInterface.pas', +} BoldEditOCLActionPropEditor in 'Source\Samples\IDE\BoldEditOCLActionPropEditor.pas', BoldSamplesReg in 'Source\Samples\IDE\BoldSamplesReg.pas', BoldLockUtils in 'Source\Samples\Misc\BoldLockUtils.pas', BoldObjectRetriever in 'Source\Samples\Misc\BoldObjectRetriever.pas', BoldModelLoader in 'Source\Samples\ModelLoader\BoldModelLoader.pas', BoldNewObjectInterceptor in 'Source\Samples\NewObjectInterceptor\BoldNewObjectInterceptor.pas', - BoldSortingGrid in 'Source\Samples\SortingGrid\BoldSortingGrid.pas', BoldSystemComparer in 'Source\Samples\SystemComparer\BoldSystemComparer.pas', BoldSystemDebuggerForm in 'Source\Samples\SystemDebugger\BoldSystemDebuggerForm.pas', - BoldUMLNameTrimmer in 'Source\Samples\UMLPlugins\BoldUMLNameTrimmer.pas', - BoldAttributeWideString in 'Source\Samples\Unicode\BoldAttributeWideString.pas', - BoldPMWideString in 'Source\Samples\Unicode\BoldPMWideString.pas', - BoldWideStringControlPack in 'Source\Samples\Unicode\BoldWideStringControlPack.pas', - BoldWideStringInterface in 'Source\Samples\Unicode\BoldWideStringInterface.pas'; + BoldUMLNameTrimmer in 'Source\Samples\UMLPlugins\BoldUMLNameTrimmer.pas'; end. diff --git a/BoldUtility.dproj b/BoldUtility.dproj new file mode 100644 index 00000000..ce7db656 --- /dev/null +++ b/BoldUtility.dproj @@ -0,0 +1,154 @@ + + + {2420DB83-B31E-48DD-BAC8-DC63F60827C0} + BoldUtility.dpk + True + Debug + 1 + Package + VCL + 19.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + BoldUtility + 1 + false + true + true + true + true + true + Bold 4.0 for Delphi (Utils) + 90 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;DUnitX.Loggers.GUI;Winapi;$(DCC_Namespace) + 2077 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + Source\Common\Include\;$(DCC_UnitSearchPath) + + + System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + vcl;vclx;$(DCC_UsePackage) + + + vcl;vclx;$(DCC_UsePackage) + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + DEBUG;$(DCC_Define) + false + true + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + + MainSource + + + + + + + + + + + + + + + + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + BoldUtility.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + False + + + 12 + + + + diff --git a/BoldUtility.res b/BoldUtility.res new file mode 100644 index 00000000..aea73fb4 Binary files /dev/null and b/BoldUtility.res differ diff --git a/BoldVCLGUI.dpk b/BoldVCLGUI.dpk index 3d93cff9..772595f6 100644 --- a/BoldVCLGUI.dpk +++ b/BoldVCLGUI.dpk @@ -1,45 +1,44 @@ package BoldVCLGUI; -{$R *.RES} -{A}{ ALIGN ON} -{C}{ ASSERTIONS ON} -{B}{ BOOLEVAL OFF} -{D}{ DEBUGINFO ON} -{X}{ EXTENDEDSYNTAX ON} -{G}{ IMPORTEDDATA ON} -{I}{ IOCHECKS ON} -{L}{ LOCALSYMBOLS ON} -{H}{ LONGSTRINGS ON} -{Z1}{ MINENUMSIZE 1} -{P}{ OPENSTRINGS ON} -{O}{ OPTIMIZATION OFF} -{Q}{ OVERFLOWCHECKS ON} -{R}{ RANGECHECKS ON} -{U}{ SAFEDIVIDE OFF} -{W}{ STACKFRAMES ON} -{T}{ TYPEDADDRESS OFF} -{V}{ VARSTRINGCHECKS ON} -{J}{ WRITEABLECONST ON} - -{$IMAGEBASE $00400000} -{$DESIGNONLY} +{$R *.res} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{ ALIGN 8} +{ ASSERTIONS ON} +{ BOOLEVAL OFF} +{ DEBUGINFO ON} +{ EXTENDEDSYNTAX ON} +{ IMPORTEDDATA ON} +{ IOCHECKS ON} +{ LOCALSYMBOLS ON} +{ LONGSTRINGS ON} +{ OPENSTRINGS ON} +{ OPTIMIZATION OFF} +{ OVERFLOWCHECKS ON} +{ RANGECHECKS ON} {$REFERENCEINFO ON} -{$IMPLICITBUILD ON} - +{ SAFEDIVIDE OFF} +{ STACKFRAMES ON} +{ TYPEDADDRESS OFF} +{ VARSTRINGCHECKS ON} +{ WRITEABLECONST ON} +{ MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} {$DESCRIPTION 'Bold 4.0 for Delphi (VCL GUI)'} {$LIBSUFFIX '90'} +{$DESIGNONLY} +{$IMPLICITBUILD ON} requires vcl, DesignIDE, - VclJpg, Bold; contains BoldCaptionController in 'Source\BoldAwareGUI\BoldControls\BoldCaptionController.pas', BoldCheckBox in 'Source\BoldAwareGUI\BoldControls\BoldCheckBox.pas', BoldComboBox in 'Source\BoldAwareGUI\BoldControls\BoldComboBox.pas', - BoldDataSet in 'Source\BoldAwareGUI\BoldControls\BoldDataSet.pas', BoldDragDropTarget in 'Source\BoldAwareGUI\BoldControls\BoldDragDropTarget.pas', BoldEdit in 'Source\BoldAwareGUI\BoldControls\BoldEdit.pas', BoldGrid in 'Source\BoldAwareGUI\BoldControls\BoldGrid.pas', @@ -63,6 +62,7 @@ contains BoldCheckboxStateControlPack in 'Source\BoldAwareGUI\ControlPacks\BoldCheckboxStateControlPack.pas', BoldControllerListControlPack in 'Source\BoldAwareGUI\ControlPacks\BoldControllerListControlPack.pas', BoldControlPack in 'Source\BoldAwareGUI\ControlPacks\BoldControlPack.pas', + BoldVariantControlPack in 'Source\BoldAwareGUI\ControlPacks\BoldVariantControlPack.pas', BoldDateTimeControlPack in 'Source\BoldAwareGUI\ControlPacks\BoldDateTimeControlPack.pas', BoldElementHandleFollower in 'Source\BoldAwareGUI\ControlPacks\BoldElementHandleFollower.pas', BoldFloatControlPack in 'Source\BoldAwareGUI\ControlPacks\BoldFloatControlPack.pas', @@ -76,6 +76,7 @@ contains BoldStringControlPack in 'Source\BoldAwareGUI\ControlPacks\BoldStringControlPack.pas', BoldViewerControlPack in 'Source\BoldAwareGUI\ControlPacks\BoldViewerControlPack.pas', BoldExceptionHandlers in 'Source\BoldAwareGUI\Core\BoldExceptionHandlers.pas', + BoldAction in 'Source\BoldAwareGUI\Actions\BoldAction.pas', BoldGUI in 'Source\BoldAwareGUI\Core\BoldGUI.pas', BoldGuiResourceStrings in 'Source\BoldAwareGUI\Core\BoldGuiResourceStrings.pas', BoldAFP in 'Source\BoldAwareGUI\FormGen\BoldAFP.pas', @@ -86,7 +87,6 @@ contains BoldAwareGuiReg in 'Source\BoldAwareGUI\IDE\BoldAwareGuiReg.pas', BoldComboBoxPropertyEditors in 'Source\BoldAwareGUI\IDE\BoldComboBoxPropertyEditors.pas', BoldControlPackPropertyEditors in 'Source\BoldAwareGUI\IDE\BoldControlPackPropertyEditors.pas', - BoldDataSetPropertyEditors in 'Source\BoldAwareGUI\IDE\BoldDataSetPropertyEditors.pas', BoldGridPropertyEditors in 'Source\BoldAwareGUI\IDE\BoldGridPropertyEditors.pas', BoldNodeDescriptionEditor in 'Source\BoldAwareGUI\IDE\BoldNodeDescriptionEditor.pas', BoldPropertiesControllerPropertyEditors in 'Source\BoldAwareGUI\IDE\BoldPropertiesControllerPropertyEditors.pas'; diff --git a/BoldVCLGUI.dproj b/BoldVCLGUI.dproj new file mode 100644 index 00000000..8ce4dd8a --- /dev/null +++ b/BoldVCLGUI.dproj @@ -0,0 +1,187 @@ + + + {4130A696-64EA-434B-989A-0F7ED2D11003} + BoldVCLGUI.dpk + True + Debug + 1 + Package + VCL + 19.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + BoldVCLGUI + 1 + false + true + true + true + true + true + Bold 4.0 for Delphi (VCL GUI) + 90 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;DUnitX.Loggers.GUI;Winapi;$(DCC_Namespace) + 2077 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + Source\Common\Include\;$(DCC_UnitSearchPath) + + + System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + vcl;$(DCC_UsePackage) + + + vcl;$(DCC_UsePackage) + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + DEBUG;$(DCC_Define) + false + true + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + + MainSource + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + BoldVCLGUI.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + False + + + 12 + + + + diff --git a/BoldVCLGUI.res b/BoldVCLGUI.res new file mode 100644 index 00000000..d122be74 Binary files /dev/null and b/BoldVCLGUI.res differ diff --git a/BoldXMILink.dproj b/BoldXMILink.dproj new file mode 100644 index 00000000..ce35d4c8 --- /dev/null +++ b/BoldXMILink.dproj @@ -0,0 +1,145 @@ + + + {2A4FC5D4-D12F-4EC3-9966-704BCD084A11} + BoldXMILink.dpk + True + Debug + 1 + Package + VCL + 19.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + BoldXMILink + 1 + false + true + true + true + true + true + Bold 4.0 for Delphi (XMI Link) + 90 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;DUnitX.Loggers.GUI;$(DCC_Namespace) + 2077 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + Source\Common\Include\;$(DCC_UnitSearchPath) + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + vcl;$(DCC_UsePackage) + + + vcl;$(DCC_UsePackage) + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + DEBUG;$(DCC_Define) + false + true + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + + MainSource + + + + + + + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + BoldXMILink.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + False + + + 12 + + + + diff --git a/BoldXMILink.res b/BoldXMILink.res new file mode 100644 index 00000000..381f7841 Binary files /dev/null and b/BoldXMILink.res differ diff --git a/Doc/Delphi and model Driven Architecture/Appendix_1.pdf b/Doc/Delphi and model Driven Architecture/Appendix_1.pdf new file mode 100644 index 00000000..ce00fd86 Binary files /dev/null and b/Doc/Delphi and model Driven Architecture/Appendix_1.pdf differ diff --git a/Doc/Delphi and model Driven Architecture/Appendix_2.pdf b/Doc/Delphi and model Driven Architecture/Appendix_2.pdf new file mode 100644 index 00000000..23aca5c4 Binary files /dev/null and b/Doc/Delphi and model Driven Architecture/Appendix_2.pdf differ diff --git a/Doc/Delphi and model Driven Architecture/Appendix_3.pdf b/Doc/Delphi and model Driven Architecture/Appendix_3.pdf new file mode 100644 index 00000000..0bd8b7ab Binary files /dev/null and b/Doc/Delphi and model Driven Architecture/Appendix_3.pdf differ diff --git a/Doc/Delphi and model Driven Architecture/Delphi and Model Driven Architecture.pdf b/Doc/Delphi and model Driven Architecture/Delphi and Model Driven Architecture.pdf new file mode 100644 index 00000000..ba09db83 Binary files /dev/null and b/Doc/Delphi and model Driven Architecture/Delphi and Model Driven Architecture.pdf differ diff --git a/Doc/Delphi and model Driven Architecture/ReadMe.txt b/Doc/Delphi and model Driven Architecture/ReadMe.txt new file mode 100644 index 00000000..b2a4f5d6 --- /dev/null +++ b/Doc/Delphi and model Driven Architecture/ReadMe.txt @@ -0,0 +1,5 @@ +This is documentation was written by Konstantin Gribachev https://www.linkedin.com/in/konstantin-gribachev-33a40330/ +He confirmed that it is ok to publish it in this opensource repository when I asked him directly. + +Roland Bengtsson +2022.04.27 diff --git a/Help/BfD.chm b/Help/BfD.chm new file mode 100644 index 00000000..8730c705 Binary files /dev/null and b/Help/BfD.chm differ diff --git a/QuickStart.txt b/QuickStart.txt new file mode 100644 index 00000000..2398dd0c --- /dev/null +++ b/QuickStart.txt @@ -0,0 +1,4 @@ +QuickStart & FAQ + +This file is meant to list most common questions. +Send your questions to roland.bengtsson@gmail.com diff --git a/README.md b/README.md index 44d54762..24d95297 100644 --- a/README.md +++ b/README.md @@ -1,5 +1,10 @@ # BoldForDelphi +This is AttracsBold branch. + +This is unicode compatible version of Bold with parts taken from Attracs private repository. +No changes should be done here. Use develop and master branch instead. + The original source code of the Bold library for Delphi Version 4.0.1.0 Bold for Delphi, Release 4.0 - 2004-04-23 diff --git a/Source/BoldAwareGUI/Actions/BoldAction.pas b/Source/BoldAwareGUI/Actions/BoldAction.pas new file mode 100644 index 00000000..a657a57f --- /dev/null +++ b/Source/BoldAwareGUI/Actions/BoldAction.pas @@ -0,0 +1,233 @@ +unit BoldAction; + +{$include bold.inc} + +interface + +uses + SysUtils, Windows, Messages, Classes, Graphics, Controls, + Forms, Dialogs, BoldControlPack, BoldHandles, BoldElements, + BoldElementHandleFollower, ExtCtrls, ActnList, + BoldCheckBoxStateControlPack, BoldStringControlPack, BoldHandle, + BoldVariantControlPack, StdCtrls; + +type + TBoldCheckBoxWithNilStateFollowerController = class(TBoldCheckBoxStateFollowerController) + private + FNilRepresentation: boolean; + published + property NilRepresentation: boolean read FNilRepresentation write FNilRepresentation default False; + end; + + TBoldAction = class(TCustomAction) + private + FBoldEnabled: TBoldCheckBoxWithNilStateFollowerController; + FBoldCaption: TBoldStringFollowerController; + FBoldVisible: TBoldCheckBoxWithNilStateFollowerController; + FBoldProperties: TBoldVariantFollowerController; + fBoldHandleFollower: TBoldElementHandleFollower; + fCaptionHandleFollower: TBoldElementHandleFollower; + fVisibleHandleFollower: TBoldElementHandleFollower; + fEnabledHandleFollower: TBoldElementHandleFollower; + procedure SetBoldEnabled(const Value: TBoldCheckBoxWithNilStateFollowerController); + procedure SetBoldCaption(const Value: TBoldStringFollowerController); + procedure SetBoldVisible(const Value: TBoldCheckBoxWithNilStateFollowerController); + procedure SetBoldHandle(const Value: TBoldElementHandle); + function GetBoldHandle: TBoldElementHandle; + function GetContextType: TBoldElementTypeInfo; + procedure AfterCaptionMakeUptoDate(Follower: TBoldFollower); + procedure AfterVisibleMakeUptoDate(Follower: TBoldFollower); + procedure AfterEnabledMakeUptoDate(Follower: TBoldFollower); + procedure AfterMakeUptoDate(Follower: TBoldFollower); + procedure SetBoldProperties(const Value: TBoldVariantFollowerController); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function Update: boolean; override; + published + property BoldHandle: TBoldElementHandle read GetBoldHandle write SetBoldHandle; + property BoldProperties: TBoldVariantFollowerController read fBoldProperties write SetBoldProperties; + property BoldCaption: TBoldStringFollowerController read FBoldCaption write SetBoldCaption; + property BoldEnabled: TBoldCheckBoxWithNilStateFollowerController read FBoldEnabled write SetBoldEnabled; + property HelpContext; + property HelpKeyword; + property HelpType; + property Hint; + property ImageIndex; + property ShortCut; + property SecondaryShortCuts; + property BoldVisible: TBoldCheckBoxWithNilStateFollowerController read FBoldVisible write SetBoldVisible; + property OnExecute; + property OnHint; + end; + +implementation + +uses +{$IFDEF BOLD_DELPHI16_OR_LATER} + Actions, +{$ENDIF} + Variants; + +const + // this is used for enabled and visible properties to avoid having to write true/false in expression + cDefaultValueForEmptyOcl = true; + cDefaultVisibleNilRepresentation = True; + cDefaultEnabledNilRepresentation = True; + +{ TBoldAction } + +procedure TBoldAction.AfterCaptionMakeUptoDate(Follower: TBoldFollower); +var + newText: string; +begin + if (csDesigning in ComponentState) then + begin + with fBoldCaption do + if Assigned(Renderer) then + NewText := Format('%s.%s', [Renderer.name, Expression]) + else if Expression <> '' then + NewText := Expression + else + NewText := name; + end + else + newText := fBoldCaption.GetCurrentAsString(Follower); + + if Caption <> newText then + Caption := newText; + + Self.Change; +end; + +procedure TBoldAction.AfterEnabledMakeUptoDate(Follower: TBoldFollower); +var + state: TCheckBoxState; +begin + state := fBoldEnabled.GetCurrentAsCheckBoxState(Follower); + if State = cbGrayed then + begin + if (FBoldEnabled.Expression = '') then + Enabled := cDefaultValueForEmptyOcl + else + Enabled := FBoldEnabled.NilRepresentation; + end + else + Enabled := state = cbChecked; +end; + +procedure TBoldAction.AfterMakeUptoDate(Follower: TBoldFollower); +var + Value: Variant; +begin + Value := TBoldVariantFollowerController(Follower.Controller).GetAsVariant(Follower); + Checked := VarIsType(Value, varBoolean) and Value; +end; + +procedure TBoldAction.AfterVisibleMakeUptoDate(Follower: TBoldFollower); +var + state: TCheckBoxState; +begin + state := fBoldVisible.GetCurrentAsCheckBoxState(Follower); + if State = cbGrayed then + begin + if (FBoldVisible.Expression = '') then + Visible := cDefaultValueForEmptyOcl + else + Visible := FBoldVisible.NilRepresentation; + end + else + Visible := state = cbChecked; +end; + +constructor TBoldAction.Create(AOwner: TComponent); +begin + inherited; + fBoldCaption := TBoldStringFollowerController.Create(Self); + fBoldCaption.OnGetContextType := GetContextType; + fBoldCaption.AfterMakeUptoDate := AfterCaptionMakeUptoDate; + + fBoldEnabled := TBoldCheckBoxWithNilStateFollowerController.Create(Self); + fBoldEnabled.NilRepresentation := cDefaultEnabledNilRepresentation; + fBoldEnabled.OnGetContextType := GetContextType; + fBoldEnabled.AfterMakeUptoDate := AfterEnabledMakeUptoDate; + + fBoldVisible := TBoldCheckBoxWithNilStateFollowerController.Create(Self); + fBoldVisible.NilRepresentation := cDefaultVisibleNilRepresentation; + FBoldVisible.OnGetContextType := GetContextType; + FBoldVisible.AfterMakeUptoDate := AfterVisibleMakeUptoDate; + + FBoldProperties:= TBoldVariantFollowerController.Create(self); + FBoldProperties.OnGetContextType := GetContextType; + FBoldProperties.AfterMakeUptoDate := AfterMakeUptoDate; + + fVisibleHandleFollower := TBoldElementHandleFollower.Create(AOwner, fBoldVisible); + fCaptionHandleFollower := TBoldElementHandleFollower.Create(AOwner, FBoldCaption); + fEnabledHandleFollower := TBoldElementHandleFollower.Create(AOwner, FBoldEnabled); + fBoldHandleFollower := TBoldElementHandleFollower.Create(AOwner, FBoldProperties); +end; + +destructor TBoldAction.Destroy; +begin + fVisibleHandleFollower.Free; + fEnabledHandleFollower.Free; + fCaptionHandleFollower.Free; + fBoldHandleFollower.Free; + + FBoldProperties.Free; + FBoldEnabled.Free; + FBoldCaption.Free; + FBoldVisible.Free; + inherited; +end; + +function TBoldAction.GetBoldHandle: TBoldElementHandle; +begin + Result := fBoldHandleFollower.BoldHandle; +end; + +function TBoldAction.GetContextType: TBoldElementTypeInfo; +begin + if assigned(BoldHandle) then + result := BoldHandle.StaticBoldType + else + result := nil; +end; + +procedure TBoldAction.SetBoldCaption( + const Value: TBoldStringFollowerController); +begin + FBoldCaption.Assign(Value); +end; + +procedure TBoldAction.SetBoldEnabled( + const Value: TBoldCheckBoxWithNilStateFollowerController); +begin + FBoldEnabled.Assign(Value); +end; + +procedure TBoldAction.SetBoldHandle(const Value: TBoldElementHandle); +begin + fVisibleHandleFollower.BoldHandle := Value; + fEnabledHandleFollower.BoldHandle := Value; + fCaptionHandleFollower.BoldHandle := Value; + fBoldHandleFollower.BoldHandle := Value; +end; + +procedure TBoldAction.SetBoldProperties(const Value: TBoldVariantFollowerController); +begin + FBoldProperties.Assign(Value); +end; + +procedure TBoldAction.SetBoldVisible( + const Value: TBoldCheckBoxWithNilStateFollowerController); +begin + FBoldVisible.Assign(Value); +end; + +function TBoldAction.Update: boolean; +begin + Result := true; //not inherited! +end; + +end. diff --git a/Source/BoldAwareGUI/BoldControls/BoldCaptionController.pas b/Source/BoldAwareGUI/BoldControls/BoldCaptionController.pas index e8293cf9..bfd799d6 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldCaptionController.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldCaptionController.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldCaptionController; {$UNDEF BOLDCOMCLIENT} @@ -7,12 +10,13 @@ interface uses Classes, Controls, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after + BoldEnvironmentVCL, BoldHandles, BoldElementHandleFollower, BoldElements, BoldControlPack, - BoldStringControlPack; + BoldStringControlPack, + BoldDefs; type TBoldCustomCaptionController = class; @@ -27,8 +31,8 @@ TBoldCustomCaptionController = class(TComponent, IBoldOCLComponent) fHandleFollower: TBoldElementHandleFollower; fTrackControl: TWinControl; function GetContextType: TBoldElementTypeInfo; - procedure SetExpression(Expression: String); - function GetExpression: String; + procedure SetExpression(const Value: TBoldExpression); + function GetExpression: TBoldExpression; function GetVariableList: TBoldExternalVariableList; function GetBoldHandle: TBoldElementHandle; @@ -53,26 +57,25 @@ TBoldCustomCaptionController = class(TComponent, IBoldOCLComponent) end; {---TBoldCaptionController---} + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldCaptionController = class(TBoldCustomCaptionController) published - {$IFNDEF T2H} property BoldHandle; property BoldProperties; property TrackControl; - {$ENDIF} end; implementation uses - SysUtils; + SysUtils, + BoldRev; type {---TWinControlWithCaption---} {Dummy class to access protected caption property of TWinControl} TWinControlWithCaption = class(TwinControl); - {---TBoldCustomCaptionController---} constructor TBoldCustomCaptionController.Create(AOwner: TComponent); begin @@ -110,7 +113,7 @@ procedure TBoldCustomCaptionController.SetCaption(s: TCaption); (s <> TrackedCaption) then begin fCaption := s; - TrackedCaption := Caption; //TrackedCaption ensures valid fTrackControl + TrackedCaption := Caption; end; end; @@ -119,11 +122,10 @@ procedure TBoldCustomCaptionController.SetTrackControl(Control: TWinControl); if Control <> fTrackControl then begin fTrackControl := Control; - Caption := Caption; //Update caption if new Control; + Caption := Caption; end; end; - procedure TBoldCustomCaptionController.SetBoldHandle(value: TBoldElementHandle); begin fHandleFollower.BoldHandle := value; @@ -158,7 +160,6 @@ function TBoldCustomCaptionController.GetBoldHandle: TBoldElementHandle; Result := fHandleFollower.BoldHandle; end; - function TBoldCustomCaptionController.GetContextType: TBoldElementTypeInfo; begin if assigned(BoldHandle) then @@ -167,15 +168,14 @@ function TBoldCustomCaptionController.GetContextType: TBoldElementTypeInfo; result := nil; end; -function TBoldCustomCaptionController.GetExpression: String; +function TBoldCustomCaptionController.GetExpression: TBoldExpression; begin result := BoldProperties.Expression; - end; -procedure TBoldCustomCaptionController.SetExpression(Expression: String); +procedure TBoldCustomCaptionController.SetExpression(const Value: TBoldExpression); begin - BoldProperties.Expression := Expression; + BoldProperties.Expression := Value; end; function TBoldCustomCaptionController.GetVariableList: TBoldExternalVariableList; @@ -183,5 +183,6 @@ function TBoldCustomCaptionController.GetVariableList: TBoldExternalVariableList result := BoldProperties.VariableList; end; -end. +initialization +end. diff --git a/Source/BoldAwareGUI/BoldControls/BoldCheckBox.pas b/Source/BoldAwareGUI/BoldControls/BoldCheckBox.pas index fdcbfeac..c5d3bee3 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldCheckBox.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldCheckBox.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldCheckBox; {$UNDEF BOLDCOMCLIENT} @@ -9,12 +12,13 @@ interface Classes, Controls, StdCtrls, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after + BoldEnvironmentVCL, BoldHandles, BoldElementHandleFollower, BoldElements, BoldControlPack, - BoldCheckboxStateControlPack; + BoldCheckboxStateControlPack, + BoldDefs; type TBoldCustomCheckBox = class; @@ -29,8 +33,8 @@ TBoldCustomCheckBox = class(TCustomCheckBox, IBoldOCLComponent) fHandleFollower: TBoldElementHandleFollower; fMyReadOnly: Boolean; function GetContextType: TBoldElementTypeInfo; - procedure SetExpression(Expression: String); - function GetExpression: String; + procedure SetExpression(const Value: TBoldExpression); + function GetExpression: TBoldExpression; function GetVariableList: TBoldExternalVariableList; function GetBoldHandle: TBoldElementHandle; @@ -61,6 +65,7 @@ TBoldCustomCheckBox = class(TCustomCheckBox, IBoldOCLComponent) end; {---TBoldCheckBox---} + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldCheckBox = class(TBoldCustomCheckBox) public {$IFNDEF T2H} @@ -116,9 +121,7 @@ implementation uses SysUtils, - BoldDefs, - BoldControlPackDefs, - BoldGuiResourceStrings; + BoldControlPackDefs; {---TBoldCustomCheckBox---} constructor TBoldCustomCheckBox.Create(AOwner: TComponent); @@ -177,7 +180,7 @@ procedure TBoldCustomCheckBox.SetState(v: TCheckBoxState); Perform(CM_CHANGED, 0, 0); end else - raise EBold.CreateFmt(sStateNotModifiable, [ClassName]); + raise EBold.CreateFmt('%s.State: Not modifiable', [ClassName]); end; end; @@ -241,14 +244,14 @@ function TBoldCustomCheckBox.GetContextType: TBoldElementTypeInfo; result := nil; end; -function TBoldCustomCheckBox.GetExpression: String; +function TBoldCustomCheckBox.GetExpression: TBoldExpression; begin result := BoldProperties.Expression; end; -procedure TBoldCustomCheckBox.SetExpression(Expression: String); +procedure TBoldCustomCheckBox.SetExpression(const Value: TBoldExpression); begin - BoldProperties.Expression := Expression; + BoldProperties.Expression := Value; end; function TBoldCustomCheckBox.GetVariableList: TBoldExternalVariableList; @@ -256,4 +259,6 @@ function TBoldCustomCheckBox.GetVariableList: TBoldExternalVariableList; result := BoldProperties.VariableList; end; +initialization + end. diff --git a/Source/BoldAwareGUI/BoldControls/BoldComboBox.pas b/Source/BoldAwareGUI/BoldControls/BoldComboBox.pas index a60d8059..4b11b469 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldComboBox.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldComboBox.pas @@ -1,6 +1,10 @@ +///////////////////////////////////////////////////////// + + unit BoldComboBox; {$UNDEF BOLDCOMCLIENT} +{$INCLUDE bold.inc} interface @@ -16,6 +20,7 @@ interface BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after BoldDefs, BoldControlsDefs, + BoldControlPackDefs, BoldHandles, BoldElements, BoldAbstractListHandle, @@ -38,10 +43,12 @@ TBoldComboBox = class; TBoldComboListController = class(TBoldAbstractListAsFollowerListController) published + property DragMode; + property DropMode; property NilElementMode; end; - TBoldCustomComboBox = class(TCustomComboBox, IBoldValidateableComponent) + TBoldCustomComboBox = class(TCustomComboBox, IBoldValidateableComponent, IBoldOCLComponent) private fAlignment: TAlignment; fHandleFollower: TBoldElementHandleFollower; @@ -51,6 +58,7 @@ TBoldCustomComboBox = class(TCustomComboBox, IBoldValidateableComponent) fBoldRowProperties: TBoldStringFollowerController; fBoldSelectChangeAction: TBoldComboSelectChangeAction; fBoldSetValueExpression: TBoldExpression; + fInternalChange: boolean; fColor: TColor; fEffectiveReadOnly: Boolean; fFocused: Boolean; @@ -60,15 +68,18 @@ TBoldCustomComboBox = class(TCustomComboBox, IBoldValidateableComponent) fReadOnly: Boolean; fOnSelectChanged: TNotifyEvent; fIsEditEvent: boolean; + fProcessingClick: Integer; fOnSelectChangedIsCalled:Boolean; + fAutoSearch: boolean; function GetBoldHandle: TBoldElementHandle; procedure SetBoldHandle(value: TBoldElementHandle); function GetFollower: TBoldFOllower; function GetBoldListHandle: TBoldAbstractListHandle; procedure SetBoldListHandle(value: TBoldAbstractListHandle); function GetListFollower: TBoldFOllower; - procedure _InsertItem(Follower: TBoldFollower); + procedure _InsertItem(Index: Integer; Follower: TBoldFollower); procedure _DeleteItem(Index: Integer; OwningFollower: TBoldFollower); + procedure _ReplaceItem(index: Integer; AFollower: TBoldFollower); procedure _RowAfterMakeUptoDate(Follower: TBoldFollower); procedure _AfterMakeUptoDate(Follower: TBoldFollower); procedure FontChanged(Sender: TObject); @@ -102,6 +113,12 @@ TBoldCustomComboBox = class(TCustomComboBox, IBoldValidateableComponent) {$IFNDEF BOLDCOMCLIENT} function ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: String): Boolean; {$ENDIF} + procedure WMChar(var Message: TWMChar); message WM_CHAR; + {IBoldOCLComponent} + function GetContextType: TBoldElementTypeInfo; + procedure SetExpression(const Value: TBoldExpression); + function GetVariableList: TBoldExternalVariableList; + function GetExpression: TBoldExpression; protected function HandleApplyException(E: Exception; Elem: TBoldElement; var discard: Boolean): boolean; procedure Change; override; @@ -139,6 +156,8 @@ TBoldCustomComboBox = class(TCustomComboBox, IBoldValidateableComponent) // property Items write SetItems; property ReadOnly: Boolean read FReadOnly write SetReadOnly default False; property Text: string read GetText write SetText; + procedure Click; override; + public constructor Create(AOwner: TComponent); override; destructor Destroy; override; @@ -146,6 +165,7 @@ TBoldCustomComboBox = class(TCustomComboBox, IBoldValidateableComponent) property SelectedElement: TBoldElement read GetSelectedElement; end; + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldComboBox = class(TBoldCustomCombobox) {$IFNDEF T2H} public @@ -224,9 +244,9 @@ implementation {$IFNDEF BOLDCOMCLIENT} BoldSystem, {$ENDIF} - BoldControlPackDefs, BoldListControlPack, BoldQueue, + BoldUtils, BoldGuiResourceStrings; { TBoldCustomComboBox } @@ -234,10 +254,17 @@ implementation type TWinControlHack = class(TWinControl) {We need access to Parents Font and Color property} end; + TBoldQueueableAccess = class(TBoldQueueable); + TBoldElementHandleAccess = class(TBoldElementHandle); -procedure TBoldCustomComboBox._InsertItem(Follower: TBoldFollower); +procedure TBoldCustomComboBox._InsertItem(Index: Integer; Follower: TBoldFollower); begin - Items.Insert(Follower.Index, ''); + Items.Insert(Index, ''); + if Assigned(Follower) then + begin + Follower.EnsureDisplayable; + Items[index] := TBoldStringFollowerController(Follower.Controller).GetCurrentAsString(Follower); + end; end; procedure TBoldCustomComboBox._DeleteItem(index: Integer; OwningFollower: TBoldFollower); @@ -245,13 +272,26 @@ procedure TBoldCustomComboBox._DeleteItem(index: Integer; OwningFollower: TBoldF Items.Delete(index); end; +procedure TBoldCustomComboBox._ReplaceItem(index: Integer; + AFollower: TBoldFollower); +var + s: string; +begin + AFollower.EnsureDisplayable; + s := TBoldStringFollowerController(AFollower.Controller).GetCurrentAsString(AFollower); + if s <> Items[index] then + Items[index] := s; +end; + procedure TBoldCustomComboBox._RowAfterMakeUptoDate(Follower: TBoldFollower); var index: Integer; begin index := Follower.index; if (index > -1) and (index < Items.Count) then + begin Items[index] := TBoldStringFollowerController(Follower.Controller).GetCurrentAsString(Follower); + end; Invalidate; // forces a redisplay of the edit-area, the windows component might go blank if the active row is removed and then reinserted fHandleFollower.Follower.MarkValueOutOfDate; @@ -266,12 +306,19 @@ procedure TBoldCustomComboBox._AfterMakeUptoDate(Follower: TBoldFollower); // if not (Style = csSimple) and DroppedDown then // PostMessage(Handle, CB_SHOWDROPDOWN, 0, 0); //FIXME Bad solution! CloseUp if changed while dropped down! - UpdateEffectiveColor; - UpdateEffectiveReadOnly; - UpdateEffectiveFont; - NewText := BoldProperties.GetCurrentAsString(Follower); - if inherited Text <> NewText then - SetEffectiveText(NewText); + if not fInternalChange then + begin + UpdateEffectiveColor; + UpdateEffectiveReadOnly; + UpdateEffectiveFont; + NewText := BoldProperties.GetCurrentAsString(Follower); + if inherited Text <> NewText then + begin + fInternalChange := true; + SetEffectiveText(NewText); + fInternalChange := false; + end; + end; end; procedure TBoldCustomComboBox.Change; @@ -306,7 +353,9 @@ procedure TBoldCustomComboBox.CMEnter(var Message: TCMEnter); procedure TBoldCustomComboBox.CMExit(var Message: TCMExit); begin if not (csDestroying in ComponentState) and (Follower.Controller.ApplyPolicy = bapExit) then + begin Follower.Apply; + end; SetFocused(False); inherited; end; @@ -328,7 +377,9 @@ procedure TBoldCustomComboBox.CMParentFontChanged(var Message: TMessage); if ParentFont then begin if Message.wParam <> 0 then +{$WARN UNSAFE_CAST OFF} SetFont(TFont(Message.lParam)) +{$WARN UNSAFE_CAST ON} else SetFont(TWinControlHack(Parent).Font); ParentFont := True; @@ -359,11 +410,9 @@ constructor TBoldCustomComboBox.Create(AOwner: TComponent); fBoldRowProperties.AfterMakeUptoDate := _RowAfterMakeUptoDate; fBoldRowProperties.OnGetContextType := GetContextForBoldRowProperties; fBoldListProperties := TBoldComboListController.Create(Self, fBoldRowProperties); - with fBoldListProperties do - begin - OnAfterInsertItem := _InsertItem; - OnAfterDeleteItem := _DeleteItem; - end; + fBoldListProperties.OnAfterInsertItem := _InsertItem; + fBoldListProperties.OnAfterDeleteItem := _DeleteItem; + fBoldListProperties.OnReplaceitem := _ReplaceItem; fHandleFollower := TBoldElementHandleFollower.Create(Owner, fBoldProperties); fListHandleFollower := TBoldListHandleFollower.Create(Owner, fBoldListProperties); fHandleFollower.PrioritizedQueuable := fListHandleFollower; @@ -481,6 +530,26 @@ function TBoldCustomComboBox.GetText: string; end; end; +function TBoldCustomComboBox.GetContextType: TBoldElementTypeInfo; +begin + result := GetContextForBoldProperties; +end; + +function TBoldCustomComboBox.GetExpression: TBoldExpression; +begin + result := self.BoldProperties.Expression; +end; + +procedure TBoldCustomComboBox.SetExpression(const Value: TBoldExpression); +begin + BoldProperties.Expression := Value; +end; + +function TBoldCustomComboBox.GetVariableList: TBoldExternalVariableList; +begin + result := BoldProperties.VariableList; +end; + function TBoldCustomComboBox.IsColorStored: Boolean; begin Result := not ParentColor; @@ -499,17 +568,26 @@ procedure TBoldCustomComboBox.KeyDown(var Key: Word; Shift: TShiftState); end; procedure TBoldCustomComboBox.KeyPress(var Key: Char); +var + Message: TMessage; +// lWideChar: WideChar; +// s: string; +// lKey: Char; begin inherited KeyPress(Key); - if (Key in [#32..#255]) then + if CharInSet(Key, [#32..#255]) then begin +{ lWideChar := GetWideCharFromWMCharMsg(LastWMCHarMessage); + s := lWideChar; + lKey := s[1]; if (Style <> csDropDownList) and (BoldSelectChangeAction <> bdcsSetReference) and - not BoldProperties.ValidateCharacter(Key, Follower) then + not BoldProperties.ValidateCharacter(lKey, Follower) then begin MessageBeep(0); Key := BOLDNULL; end; +} end; if Key = BOLDESC then begin @@ -517,13 +595,33 @@ procedure TBoldCustomComboBox.KeyPress(var Key: Char); SelectAll; Key := BOLDNULL; end; + if (Ord(Key) = 9) and DroppedDown then + begin + Message.Msg := CB_SETCURSEL; +{$WARN UNSAFE_CAST OFF} + TWMCommand(Message).NotifyCode := CBN_SELCHANGE; +{$WARN UNSAFE_CAST ON} + WndProc(Message); +// fAutoSearch := true; + + +// if ((Message.Msg = CB_SETCURSEL) and (BoldSelectChangeAction = bdcsSetReference)) or (TWMCommand(Message).NotifyCode = CBN_SELCHANGE) or (fAutoSearch) and not DroppedDown then +// if not (DroppedDown and (Message.Msg = 273) and (TWMCommand(Message).NotifyCode = CBN_SELCHANGE)) then + +// PostMessage(Handle, CBN_CLOSEUP, 0, 0); //FIXME Bad solution! CloseUp if changed while dropped down! +// CloseUp; +// Invalidate; +// Follower.Apply; +// SelectAll; + end; + if Follower.IsInDisplayList then + Follower.DisplayAll; end; procedure TBoldCustomComboBox.SetBoldHandle(Value: TBoldElementHandle); begin - if assigned(Value) and (BoldSelectChangeAction = bdcsSetReference) and - not (Value is TBoldReferenceHandle) then - raise EBold.Create(sHandleMustBeReferenceHandle); + if assigned(Value) and (BoldSelectChangeAction = bdcsSetReference) and not Value.CanSetValue then + raise EBold.CreateFMt('The BoldHandle property must be a TBoldReferenceHandle when BoldSelectChangeAction is bdscSetReference. It is %s', [Value.ClassName]); fHandleFollower.BoldHandle := value; end; @@ -679,18 +777,38 @@ procedure TBoldCustomComboBox.WndProc(var Message: TMessage); Discard: Boolean; LocalSelectedElement: TBoldElement; begin +{$WARN UNSAFE_CAST OFF} CallInherited := True; if not (csDesigning in ComponentState) then begin case Message.Msg of CB_SETCURSEL, - WM_COMMAND: - if ((Message.Msg = CB_SETCURSEL) and (BoldSelectChangeAction = bdcsSetReference)) or - (TWMCommand(Message).NotifyCode = CBN_SELCHANGE) then + WM_COMMAND, + 305: + begin +// CodeSite.Category := 'combo'; +// CodeSite.Send(IntToStr(Message.Msg) + ':' + IntToStr(TWMCommand(Message).NotifyCode)); +// CodeSite.Category := ''; + +// ( fAutoSearch and DroppedDown and (Message.Msg = CB_SETCURSEL) and (BoldSelectChangeAction = bdcsSetValue) and (TWMCommand(Message).NotifyCode = 0) ) + if not ((Message.Msg = 334) and (TWMCommand(Message).NotifyCode = 0) and not fAutoSearch) then + if ( + ( ( (Message.Msg = CB_SETCURSEL) and (BoldSelectChangeAction = bdcsSetReference) ) or (TWMCommand(Message).NotifyCode = CBN_SELCHANGE) or (fAutoSearch) and not DroppedDown) + or ((Message.Msg = 305) and DroppedDown) +// or (not (DroppedDown and (Message.Msg = WM_COMMAND) and (TWMCommand(Message).NotifyCode = CBN_SELCHANGE))) + or ( (Message.Msg = WM_COMMAND) and (TWMCommand(Message).NotifyCode = CBN_SELCHANGE) ) + ) + and not ( (Message.Msg = WM_COMMAND) and ( TWMCommand(Message).NotifyCode = 256 ) ) + and not ( (Message.Msg = WM_COMMAND) and ( TWMCommand(Message).NotifyCode = 1024 ) ) + and not ( (Message.Msg = WM_COMMAND) and ( TWMCommand(Message).NotifyCode = 3 ) ) +// and not ( (Message.Msg = WM_COMMAND) and ( TWMCommand(Message).NotifyCode = 1 ) ) + and not fInternalChange + then begin - if (Message.Msg = CB_SETCURSEL) and assigned(BoldListHandle) and (BoldListHandle.Count > Message.WParam) then +// CodeSite.Send(IntToStr(Message.Msg) + ':' + IntToStr(TWMCommand(Message).NotifyCode)); + if (Message.Msg = CB_SETCURSEL) and assigned(BoldListHandle) and (Cardinal(BoldListHandle.Count) > Message.WParam) then begin - if Message.WParam = -1 then + if NativeInt(Message.WParam) = -1 then LocalSelectedElement := nil else LocalSelectedElement := BoldListHandle.List[Message.WParam] @@ -703,7 +821,6 @@ procedure TBoldCustomComboBox.WndProc(var Message: TMessage); CallInherited := not EffectiveReadOnly; bdcsSetValue: begin - Follower.DiscardChange; if Assigned(BoldHandle) and Assigned(BoldHandle.value) then begin {$IFDEF BOLDCOMCLIENT} // BoldSetValueExpression @@ -724,7 +841,23 @@ procedure TBoldCustomComboBox.WndProc(var Message: TMessage); (not (elementToAssignTo is TBoldMember) or TBoldMember(ElementTOAssignTo).CanModify) then try - ElementToAssignTo.Assign(LocalSelectedElement); // checkme take from follwer instead? + if elementToAssignTo is TBoldObjectReference then + begin + ElementToAssignTo.Assign(LocalSelectedElement); + end + else + begin + if Assigned(LocalSelectedElement) then + BoldProperties.MayHaveChanged(LocalSelectedElement.AsString, Follower) + else + BoldProperties.MayHaveChanged('', Follower); + fInternalChange := true; + try + TBoldQueueableAccess(Follower).Display; + finally + fInternalChange := false; + end; + end; except on E: Exception do begin @@ -736,13 +869,13 @@ procedure TBoldCustomComboBox.WndProc(var Message: TMessage); end; {$ENDIF} end; - CallInherited := false; + CallInherited := true; end; bdcsSetReference: begin Follower.DiscardChange; - if assigned(BoldHandle) and (BoldHandle is TBoldReferenceHandle) then - (BoldHandle as TBoldReferenceHandle).Value := LocalSelectedElement; + if assigned(BoldHandle) and BoldHandle.CanSetValue then + TBoldElementHandleAccess(BoldHandle).SetValue(LocalSelectedElement); CallInherited := Message.Msg = CB_SETCURSEL; end; bdcsSetListIndex: @@ -779,7 +912,7 @@ procedure TBoldCustomComboBox.WndProc(var Message: TMessage); end; end; end; - + end; CB_SHOWDROPDOWN: if (Message.WParam=0) and EffectiveReadOnly then _AfterMakeUptoDate(Follower); {Restore text} //FIXME Maybe an UpdateEffectiveText? @@ -787,6 +920,7 @@ procedure TBoldCustomComboBox.WndProc(var Message: TMessage); end; if CallInherited then inherited WndProc(Message); +{$WARN UNSAFE_CAST ON} end; procedure TBoldCustomComboBox.SetBoldListProperties(Value: TBoldComboListController); @@ -795,14 +929,24 @@ procedure TBoldCustomComboBox.SetBoldListProperties(Value: TBoldComboListControl end; function TBoldCustomComboBox.GetSelectedElement: TBoldElement; +var + lFollower: TBoldFollower; begin +{$WARN UNSAFE_CAST OFF} with ListFollower.RendererData as TBoldFollowerList do begin if (ItemIndex >= 0)and (ItemIndex < Count) then - Result := Followers[ItemIndex].Element + begin + lFollower := Followers[ItemIndex]; + if Assigned(lFollower) then + Result := lFollower.Element + else + result := nil; + end else Result := nil; end; +{$WARN UNSAFE_CAST ON} end; function TBoldCustomComboBox.GetBoldHandle: TBoldElementHandle; @@ -812,7 +956,7 @@ function TBoldCustomComboBox.GetBoldHandle: TBoldElementHandle; function TBoldCustomComboBox.GetFollower: TBoldFOllower; begin - Result := fHandleFollower.Follower; + Result := fHandleFollower.Follower; end; function TBoldCustomComboBox.GetBoldListHandle: TBoldAbstractListHandle; @@ -822,7 +966,7 @@ function TBoldCustomComboBox.GetBoldListHandle: TBoldAbstractListHandle; function TBoldCustomComboBox.GetListFollower: TBoldFOllower; begin - Result := fListHandleFollower.Follower; + Result := fListHandleFollower.Follower; end; function TBoldCustomComboBox.GetContextForBoldProperties: TBoldElementTypeInfo; @@ -862,9 +1006,8 @@ function TBoldCustomComboBox.ValidateComponent(ComponentValidator: TBoldComponen procedure TBoldCustomComboBox.SetBoldSelectChangeAction(Value: TBoldComboSelectChangeAction); begin - if (Value = bdcsSetReference) and assigned(BoldHandle) and - not (BoldHandle is TBoldReferenceHandle) then - raise EBold.Create(sChangeActionCannotBeSetReference); + if (Value = bdcsSetReference) and assigned(BoldHandle) and not BoldHandle.CanSetValue then + raise EBold.Create('The BoldSelectChangeAction property can not be bdscSetReference when BoldHandle is not a TBoldReferenceHandle'); fBoldSelectChangeAction := Value; end; @@ -888,4 +1031,37 @@ function TBoldCustomComboBox.HandleApplyException(E: Exception; Elem: TBoldEleme ExceptionHandler.HandleApplyException(E, self, Elem, Discard, Result); end; +procedure TBoldCustomComboBox.Click; +var + aMsg: TWMCommand; +begin + Inc(fProcessingClick); + try + inherited; + if fProcessingClick=1 then + begin + with aMsg do begin + Msg := WM_COMMAND; + NotifyCode := CBN_SELCHANGE; + ItemID := ItemIndex; + Ctl := Handle; + Result := 0; + end; +{$WARN UNSAFE_CAST OFF} + WndProc(TMessage(aMsg)); +{$WARN UNSAFE_CAST ON} + end; + finally + Dec(fProcessingClick); + end; +end; + +procedure TBoldCustomComboBox.WMChar(var Message: TWMChar); +begin + fAutoSearch := true; + inherited; + fAutoSearch := false; +end; + end. + diff --git a/Source/BoldAwareGUI/BoldControls/BoldDataSet.UnitDoc b/Source/BoldAwareGUI/BoldControls/BoldDataSet.UnitDoc deleted file mode 100644 index 1bb7a513..00000000 --- a/Source/BoldAwareGUI/BoldControls/BoldDataSet.UnitDoc +++ /dev/null @@ -1,556 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - A handle containing the list of objects that should be exposed as a Dataset - The objects in the ListHandle will make up the rows in the dataset - - - Returns the model information for a field in the dataset - If the field refered to by the parameter exists, and contains an attribute or a role, the model information about this value is returned. If the field contains a calculated value (such as aPerson.firstName + ' ' + aPerson.lastName), the result is nil - - - - - - - - - - - - A collection of field descriptions that make up the dataset - - - - - - - - - - - This version of the Bold Dataset is intended for subclassing - - - - Exposes a list of objects as a TDataset to be used with reporting tools or other Dataset aware components - This components allows a list of bold objects to be exposed as a TDataset so that they can be displayed/edited by the rich set of db aware components available in Delphi and as third party components. - - - There is an example in the example folder that shows how to use the TBoldDataSet component with a reporting tool (QuickReport) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - The BoldProperties contains the OCL expression that is used to calculate the value of the field - - - - - - - - - - - - - - - Identical to BoldProperties.Expression - Identical to BoldProperties.Expression - - - - - - - The name of the field - The name of the field - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \ No newline at end of file diff --git a/Source/BoldAwareGUI/BoldControls/BoldDataSet.pas b/Source/BoldAwareGUI/BoldControls/BoldDataSet.pas deleted file mode 100644 index e81898cc..00000000 --- a/Source/BoldAwareGUI/BoldControls/BoldDataSet.pas +++ /dev/null @@ -1,1785 +0,0 @@ -unit BoldDataSet; - -interface - -uses - Classes, - DB, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after - BoldSystem, - BoldSystemRT, - BoldElements, - BoldSubscription, - BoldAbstractListHandle, - BoldListListControlPack, - BoldControlPack, - BoldControllerListControlPack, - BoldStringControlPack, - BoldListHandleFollower; - -type - TBDSBookmarkInfo = record - Flag: TBookmarkFlag; - Element: TBoldElement; - end; - - PBDSBookmarkInfo = ^TBDSBookmarkInfo; - - TBoldAbstractDataSet = class; - TBoldDataSet = class; - TBoldDataSetFieldDescription = class; - TBoldDataSetFieldDescriptions = class; - - { TBoldDataSetFieldDescription } - TBoldDataSetFieldDescription = class(TCollectionItem) - private - fRTInfo: TBoldMemberRTInfo; - fBoldProperties: TBoldStringFollowerController; - fBufferSize: integer; - fFieldName: string; - fFieldOfs: integer; - fFieldSize: integer; - fFieldType: TFieldType; - fRequired: boolean; - fUseFieldSize: boolean; - fInvalid: Boolean; - function GetDataSet: TBoldAbstractDataSet; - function GetExpression: string; - function GetFieldDescriptions: TBoldDataSetFieldDescriptions; - function GetListElementType: TBoldElementTypeInfo; - procedure SetBoldProperties(AValue: TBoldStringFollowerController); - procedure SetExpression(AValue: string); - function GetFieldOfs: integer; - function GetFieldSize: integer; - function GetFieldType: TFieldType; - function GetRequired: boolean; - function GetRTInfo: TBoldMemberRTInfo; - function GetUseFieldSize: boolean; - procedure SetFieldName(const Value: String); - function GetEffectiveFieldName: String; - procedure Invalidate; - procedure EnsureValid; - procedure AfterMakeUptoDate(Follower: TBoldFollower); - procedure DefineFieldType(aClass: TClass); - protected - function GetDisplayName: string; override; - public - constructor Create(AOwner: TCollection); override; - destructor Destroy; override; - procedure Assign(Source: TPersistent); override; - property BufferSize: integer read FBuffersize; - property EffectiveFieldName: String read GetEffectiveFieldName; - property FieldSize: integer read GetFieldSize; - property FieldType: TFieldType read GetFieldType; - property FieldOfs: integer read GetFieldOfs; - property ListelementType: TBoldElementTypeInfo read GetListelementType; - property Required: boolean read GetRequired; - property RTInfo: TBoldMemberRTInfo read GetRTInfo; - property UseFieldSize: boolean read GetUseFieldSize; - property Dataset: TBoldAbstractDataSet read GetDataset; - property FieldDescriptions: TBoldDataSetFieldDescriptions read GetFieldDescriptions; - property Expression: string read GetExpression write SetExpression; - published - property BoldProperties: TBoldStringFollowerController read FBoldProperties write SetBoldProperties; - property FieldName: String read fFieldName write SetFieldName; - end; - - { TBoldDataSetFieldDescriptions } - TBoldDataSetFieldDescriptions = class(TCollection) - private - FDataset: TBoldAbstractDataSet; - FFieldFollowers: TBoldControllerList; - function GetItem(AIndex: Integer): TBoldDataSetFieldDescription; - protected - function GetOwner: TPersistent; override; - property FieldFollowers: TBoldControllerList read FFieldFollowers; - public - constructor Create(AOwner: TBoldAbstractDataSet); - destructor Destroy; override; - function Add: TBoldDataSetFieldDescription; - procedure InvalidateFields; - property Items[index: Integer]: TBoldDataSetFieldDescription read GetItem; default; - property Dataset: TBoldAbstractDataSet read FDataset; - end; - - { TBoldAbstractDataSet } - TBoldAbstractDataSet = class(TDataSet) - private - FAutoOpen: boolean; - FBookmarkOfs: integer; - FContextSubscriber: TBoldPassthroughSubscriber; - FFieldDescriptions: TBoldDataSetFieldDescriptions; - FLayoutChanged: boolean; - FListFollowerController: TBoldListAsFollowerListController; - FListFollower: TBoldListHandleFollower; - FRecordPos: integer; - FBufferSize: integer; - FRecordSize: integer; - fLastKnownType: TBoldElementTypeInfo; - fInternalCursorReady: Boolean; - function GetIndexForBookmark(Bookmark: Pointer): integer; - procedure InsertElement(ABuffer: PChar); virtual; - procedure _ReceiveContext(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); - procedure BoldToBuffer(ABuffer: PChar); - procedure _InsertRow(Follower: TBoldFollower); - procedure _DeleteRow(index: Integer; owningFollower: TBoldFollower); - procedure BufferToBoldElement(AIndex: integer; ABuffer: PChar); - procedure BoldElementToBuffer(AIndex: integer; ABuffer: PChar); - function GetBookmarkInfo(Buffer: PChar): PBDSBookmarkInfo; - function GetActiveBoldElement: TBoldElement; - function GetActiveBoldObject: TBoldObject; - procedure SetAutoOpen(AValue: boolean); - function GetBoldRTInfo(AFieldName: string): TBoldMemberRTInfo; - function GetBoldHandle: TBoldAbstractListHandle; - procedure SetBoldHandle(NewValue: TBoldAbstractListHandle); - procedure SetFieldDescriptions(const Value: TBoldDataSetFieldDescriptions); - procedure EnsureRecordPosInValidRange; - protected - procedure Loaded; override; - function CreateNewElement: TBoldElement; virtual; - procedure TypeMayHaveChanged; - procedure TypeHasChanged; virtual; - procedure LayoutChanged; - procedure ClearCalcFields(Buffer: PChar); override; - procedure DoOnNewRecord; override; - function GetActiveRecBuf(var RecBuf: PChar): Boolean; - function GetListElementType: TBoldElementTypeInfo; virtual; - procedure DeleteAllFields; - { Mandatory overrides } - // Record buffer methods: - function AllocRecordBuffer: PChar; override; - procedure FreeRecordBuffer(var Buffer: PChar); override; - procedure InternalInitRecord(Buffer: PChar); override; - function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override; - procedure SetRecNo(Value: Integer); override; - function GetRecordSize: Word; override; - procedure SetFieldData(Field: TField; Buffer: Pointer); override; - // Bookmark methods: - procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override; - function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override; - procedure InternalGotoBookmark(Bookmark: Pointer); override; - procedure InternalSetToRecord(Buffer: PChar); override; - procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override; - procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override; - // Navigational methods: - procedure InternalFirst; override; - procedure InternalLast; override; - // Editing methods: - procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override; - procedure InternalDelete; override; - procedure InternalPost; override; - // Misc methods: - procedure InternalClose; override; - procedure InternalHandleException; override; - procedure InternalInitFieldDefs; override; - procedure InternalOpen; override; - function IsCursorOpen: Boolean; override; - function LocateRecord(const KeyFields: string; - const KeyValues: Variant; Options: TLocateOptions; - SyncCursor: Boolean): Boolean; - function ValuesInFields(AFields: TList; const KeyValues: Variant; Options: TLocateOptions): Boolean; - { Optional overrides } - function GetRecordCount: Integer; override; - function GetRecNo: Integer; override; - procedure DoAfterScroll; override; - function GetCanModify: boolean; override; - procedure InternalEdit; override; - procedure InternalCancel; override; - //Bold related methods - function GetList: TBoldList; - //Bold related properties - property List: TBoldList read GetList; - property ListElementType: TBoldElementTypeInfo read GetListElementType; - property BoldHandle: TBoldAbstractListHandle read GetBoldHandle write SetBoldHandle; - property AutoOpen: boolean read FAutoOpen write SetAutoOpen; - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - function BookmarkValid(Bookmark: TBookmark): Boolean; override; - function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override; - procedure CreateDefaultFields; - function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override; - function Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; override; - function Lookup(const KeyFields: string; const KeyValues: Variant; const ResultFields: string): Variant; override; - procedure TryToOpen; - property ActiveBoldElement: TBoldElement read GetActiveBoldElement ; - property ActiveBoldObject: TBoldObject read GetActiveBoldObject; - property BoldRTInfo[AFieldName: string]: TBoldMemberRTInfo read GetBoldRTInfo; - published - property FieldDescriptions: TBoldDataSetFieldDescriptions read fFieldDescriptions write SetFieldDescriptions; - end; - - { TBoldDataSet } - TBoldDataSet = class(TBoldAbstractDataSet) - published - {$IFNDEF T2H} - property Active; - property AutoOpen; - property BoldHandle; - //published from Dataset - property BeforePost; - property BeforeClose; - property BeforeInsert; - property AfterInsert; - property AfterOpen; - property BeforeScroll; - property AfterScroll; - property AfterCancel; - {$ENDIF} - end; - -implementation - -uses - SysUtils, - DBConsts, - Variants, - BoldDefs, - BoldAttributes, - BoldGuiResourceStrings, - BoldEnvironment; - -type - TBoldConvInfo = record - FBoldType: TClass; - FFieldType: TFieldType; - FBufferSize: integer; - FUseSize: boolean; - FUseDecimals: boolean; - end; - -const - // It is important that subclasses come after their superclass! - arConvInfo: array [0..14] of TBoldConvInfo = - ( - (FBoldType: TBAString; FFieldType: ftString; FBufferSize: 255; FUseSize: True; FUseDecimals: False), - (FBoldType: TBANumeric; FFieldType: ftInteger; FBufferSize: sizeof(integer); FUseSize: False; FUseDecimals: True), - (FBoldType: TBAInteger; FFieldType: ftInteger; FBufferSize: sizeof(integer); FUseSize: False; FUseDecimals: True), - (FBoldType: TBASmallInt; FFieldType: ftSmallint; FBufferSize: sizeof(smallint); FUseSize: False; FUseDecimals: True), - (FBoldType: TBAShortInt; FFieldType: ftSmallint; FBufferSize: sizeof(smallint); FUseSize: False; FUseDecimals: True), - (FBoldType: TBAWord; FFieldType: ftWord; FBufferSize: sizeof(word); FUseSize: False; FUseDecimals: True), - (FBoldType: TBAByte; FFieldType: ftSmallint; FBufferSize: sizeof(smallint); FUseSize: False; FUseDecimals: True), - (FBoldType: TBAFloat; FFieldType: ftFloat; FBufferSize: sizeof(double); FUseSize: False; FUseDecimals: True), - (FBoldType: TBACurrency; FFieldType: ftCurrency; FBufferSize: sizeof(double); FUseSize: False; FUseDecimals: True), - (FBoldType: TBABlob; FFieldType: ftBlob; FBufferSize: 40; FUseSize: true; FUseDecimals: False), - (FBoldType: TBADateTime; FFieldType: ftDateTime; FBufferSize: sizeof(TDateTime); FUseSize: False; FUseDecimals: False), - (FBoldType: TBADate; FFieldType: ftDate; FBufferSize: SizeOf(Longint); FUseSize: False; FUseDecimals: False), - (FBoldType: TBATime; FFieldType: ftTime; FBufferSize: SizeOf(Longint); FUseSize: False; FUseDecimals: False), - (FBoldType: TBAValueSet; FFieldType: ftInteger; FBufferSize: sizeof(integer); FUseSize: false; FUseDecimals: False), - (FBoldType: TBABoolean; FFieldType: ftBoolean; FBufferSize: sizeof(wordbool); FUseSize: false; FUseDecimals: False) - ); -// (FBoldType: 'TBAVALUESET'; FFieldType: ftDateTime; FBufferSize: sizeof(TDateTime); FUseSize: False; FUseDecimals: False), -// (FBoldType: 'TBABLOBCONTENT'; FFieldType: ftDateTime; FBufferSize: sizeof(TDateTime); FUseSize: False; FUseDecimals: False), - -{**************************************************************************** - TBoldDataSetFieldDescription - ****************************************************************************} - -constructor TBoldDataSetFieldDescription.Create(AOwner: TCollection); -begin - Assert(AOwner is TBoldDataSetFieldDescriptions); - inherited Create(AOwner); - FBoldProperties := TBoldStringFollowerController.Create(nil); - FBoldProperties.AfterMakeUptoDate := self.AfterMakeUptoDate; - fBoldProperties.OnGetContextType := GetListElementType; - FieldDescriptions.FieldFollowers.Add(FBoldProperties); - Invalidate; -end; - -destructor TBoldDataSetFieldDescription.Destroy; -begin - FieldDescriptions.FieldFollowers.Remove(FBoldProperties); - FreeAndNil(FBoldProperties); - inherited Destroy; -end; - -procedure TBoldDataSetFieldDescription.DefineFieldType(aClass: TClass); -var - i: integer; -begin - //if we didn't find the bold type, we will set the field type to string(255) - FFieldType := ftString; - FFieldSize := 255; - FBufferSize := 255; - FRequired := False; - - for i := high(arConvInfo) downto Low(arConvInfo) do - begin - with arConvInfo[i] do - begin - if AClass.inheritsfrom(arConvInfo[i].FBoldType) then - begin - self.FFieldType := arConvInfo[i].FFieldType; - self.FBufferSize := arConvInfo[i].FBufferSize; - self.FUseFieldSize := arConvInfo[i].FUseSize; - if FUseSize then - self.FFieldSize := arConvInfo[i].FBufferSize - else - self.FFieldSize := 0; - self.FRequired := False; - break; - end; - end; // with - end; // for -end; - -procedure TBoldDataSetFieldDescription.AfterMakeUptoDate(Follower: TBoldFollower); -var - LField: TField; - ActiveBuf: PChar; - - function FindFieldNo(ANo: integer): TField; - var - FieldIx: integer; - begin - result := nil; - for FieldIx := 0 to Dataset.FieldCount - 1 do - begin - if Dataset.Fields[FieldIx].FieldNo = ANo then - begin - result := Dataset.Fields[FieldIx]; - Exit; - end; - end; // for - end; - -begin - with Dataset do - begin - if not Active then - Exit; - - if not (Dataset.State in dsWriteModes) then - begin - UpdateCursorPos; - Resync([]); - end - else - begin - if GetActiveRecBuf(ActiveBuf) and (GetBookmarkInfo(ActiveBuf)^.Element = Follower.OwningFollower.Element) then - begin - BoldElementToBuffer(Follower.Index, ActiveBuf); - if not (State in [dsCalcFields, dsFilter, dsNewValue]) then - begin - LField := FindFieldNo(Follower.Index + 1); - if Assigned(LField) then - DataEvent(deFieldChange, LongInt(LField)); - end; - SetModified(True); - end - end - end; // with -end; - -function TBoldDataSetFieldDescription.GetEffectiveFieldName: String; -var - i: integer; -begin - if FieldName <> '' then - result := FieldName - else - begin - result := BoldProperties.Expression; - for i := 1 to length(Result) do - if Result[i] in ['.', '(', '-', '>', ')'] then - result[i] := '_' - end; -end; - -procedure TBoldDataSetFieldDescription.EnsureValid; -var - LFieldType: TBoldElementTypeInfo; -begin - if fInvalid then - begin - if not Assigned(ListElementType) then - raise EBold.CreateFmt(sCannotInitializeFieldsWithoutContext, [Dataset.Name]); - - LFieldType := ListElementType.Evaluator.ExpressionType(Expression, ListElementType, false); - if not Assigned(LFieldType) then - raise Exception.CreateFmt(sInvalidFieldExpression, [Expression]); - - if ListElementType.Evaluator is TBoldRTEvaluator then - fRTInfo := (ListElementType.Evaluator as TBoldRTEvaluator).RTInfo(Expression, ListElementType, false) - else - fRTInfo := nil; - - if LFieldType is TBoldAttributeTypeInfo then - begin - DefineFieldType(TBoldAttributeTypeInfo(LFieldType).AttributeClass); - if (fRTInfo is TBoldAttributeRTInfo) and - (TBoldAttributeRTInfo(FRTInfo).Length > 0) and - FUseFieldSize then - begin - FBufferSize := TBoldAttributeRTInfo(FRTInfo).Length + 1; - FFieldSize := FBufferSize - 1; - end; - end - else if LFieldType is TBoldClassTypeInfo then - begin - FFieldType := ftInteger; - FFieldSize := 0; - FBufferSize := sizeof(integer); - FRequired := False; - end - else - begin - FFieldType := ftString; - FFieldSize := 40; - FBufferSize := 40; - FRequired := False; - end; - fInvalid := false; - end; -end; - -function TBoldDataSetFieldDescription.GetFieldDescriptions: TBoldDataSetFieldDescriptions; -begin - result := TBoldDataSetFieldDescriptions(Collection); -end; - -function TBoldDataSetFieldDescription.GetDataset: TBoldAbstractDataSet; -begin - result := FieldDescriptions.Dataset; -end; - -function TBoldDataSetFieldDescription.GetListElementType: TBoldElementTypeInfo; -begin - result := Dataset.ListelementType; -end; - -function TBoldDataSetFieldDescription.GetExpression: string; -begin - result := FBoldProperties.Expression; -end; - -procedure TBoldDataSetFieldDescription.SetExpression(AValue: string); -begin - fBoldProperties.Expression := aValue; - Invalidate; -end; - -procedure TBoldDataSetFieldDescription.SetBoldProperties(AValue: TBoldStringFollowerController); -begin - if (AValue <> FBoldProperties) and Assigned(AValue) then - FBoldProperties.Assign(AValue); - invalidate; -end; - -procedure TBoldDataSetFieldDescription.Assign(Source: TPersistent); -begin - if source is TBoldDataSetFieldDescription then - begin - self.BoldProperties.Assign(TBoldDataSetFieldDescription(Source).BoldProperties); - self.FieldName := TBoldDataSetFieldDescription(Source).FieldName; - Invalidate; - end; -end; - -procedure TBoldDataSetFieldDescription.Invalidate; -begin - fInvalid := true; -end; - -function TBoldDataSetFieldDescription.GetFieldOfs: integer; -begin - EnsureValid; - Result := FFieldOfs; -end; - -function TBoldDataSetFieldDescription.GetFieldSize: integer; -begin - EnsureValid; - REsult := fFieldSize; -end; - -function TBoldDataSetFieldDescription.GetFieldType: TFieldType; -begin - EnsureValid; - result := fFieldType; -end; - -function TBoldDataSetFieldDescription.GetRequired: boolean; -begin - Ensurevalid; - result := fRequired; -end; - -function TBoldDataSetFieldDescription.GetRTInfo: TBoldMemberRTInfo; -begin - EnsureValid; - result := fRTInfo; -end; - -function TBoldDataSetFieldDescription.GetUseFieldSize: boolean; -begin - EnsureValid; - result := fUseFieldSize; -end; - -procedure TBoldDataSetFieldDescription.SetFieldName(const Value: String); -begin - fFieldName := Value; - Invalidate; -end; - -function TBoldDataSetFieldDescriptions.GetOwner: TPersistent; -begin - result := DataSet; -end; - -function TBoldDataSetFieldDescription.GetDisplayName: string; -begin - result := EffectiveFieldName + ' = ' + Expression; -end; - -{**************************************************************************** - TBoldDataSetFieldDescriptions -****************************************************************************} - -constructor TBoldDataSetFieldDescriptions.Create(AOwner: TBoldAbstractDataSet); -begin - inherited Create(TBoldDataSetFieldDescription); - FFieldFollowers := TBoldControllerList.Create(nil); - FDataset := AOwner; -end; - -destructor TBoldDataSetFieldDescriptions.Destroy; -begin - Clear; - FreeAndNil(FFieldFollowers); - inherited Destroy; -end; - -function TBoldDataSetFieldDescriptions.Add: TBoldDataSetFieldDescription; -begin - result := TBoldDataSetFieldDescription(inherited Add); - // B Crotaz 17/4/2002 - removed next line - // this will fail on an active dataset - // because this new field description has no fieldname - // and the dataset does a TryToOpen as part of LayoutChanged - // removed - FDataset.LayoutChanged; -end; - -function TBoldDataSetFieldDescriptions.GetItem(AIndex: Integer): TBoldDataSetFieldDescription; -begin - result := TBoldDataSetFieldDescription(inherited Items[AIndex]); -end; - -procedure TBoldDataSetFieldDescriptions.InvalidateFields; -var - i: integer; -begin - for i := 0 to count - 1 do - items[i].Invalidate; -end; - -{**************************************************************************** - TBoldAbstractDataSet - ****************************************************************************} - -constructor TBoldAbstractDataSet.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - fLastKnownType := nil; - fInternalCursorReady := false; - FContextSubscriber := TBoldPassthroughSubscriber.Create(_ReceiveContext); - - FFieldDescriptions := TBoldDataSetFieldDescriptions.Create(self); - FLayoutChanged := True; - - FListFollowerController := TBoldListAsFollowerListController.Create(self, FFieldDescriptions.FieldFollowers); - FListFollowerController.OnAfterInsertItem := _InsertRow; - FListFollowerController.OnAfterDeleteItem := _DeleteRow; - FListFollowerController.OnGetContextType := GetListElementType; - - FListFollower := TBoldListHandleFollower.Create(Owner, FListFollowerController); - FRecordSize := 0; - FRecordPos := -1; -end; - -destructor TBoldAbstractDataSet.Destroy; -begin - Close; - FRecordPos := -1; - FreeAndNil(FContextSubscriber); - FreeAndNil(FListFollower); - FreeAndNil(FListFollowerController); - FreeAndNil(FFieldDescriptions); - inherited Destroy; -end; - -function TBoldAbstractDataSet.GetListElementType: TBoldElementTypeInfo; -begin - if assigned(BoldHandle) then - result := BoldHandle.StaticBoldType - else - result := nil; -end; - -procedure TBoldAbstractDataSet.SetAutoOpen(AValue: boolean); -begin - if (FAutoOpen <> AValue) then - begin - FAutoOpen := AValue; - if FAutoOpen then - TryToOpen; - end; -end; - -procedure TBoldAbstractDataSet.TryToOpen; -begin - if not (csLoading in ComponentState) and - not (csDestroying in ComponentState) and - not Active then - try - Open; - except - // Eat exceptions quietly - end; -end; - -procedure TBoldAbstractDataSet.DoOnNewRecord; -begin - InsertElement(ActiveBuffer); - inherited DoOnNewRecord; -end; - -function TBoldAbstractDataSet.CreateNewElement: TBoldElement; -begin - result := nil; - if assigned(BoldHandle) and - assigned(BoldHandle.List) and - BoldHandle.List.CanCreateNew then - result := BoldHandle.List.AddNew; -end; - -procedure TBoldAbstractDataSet.InsertElement(ABuffer: PChar); -var - LElement: TBoldElement; -begin - lElement := CreateNewElement; - if not Assigned(LElement) then - Abort; - - fRecordPos := List.IndexOf(LElement); - - with GetBookmarkInfo(ABuffer)^ do - begin - Flag := bfInserted; - Element := LElement; - end; // with - BoldToBuffer(ABuffer); -end; - -function TBoldAbstractDataSet.GetBoldRTInfo(AFieldName: string): TBoldMemberRTInfo; -var - FieldDesc: TBoldDataSetFieldDescription; - i: integer; -begin - InternalInitFieldDefs; - FieldDesc := nil; - for i := 0 to FieldDescriptions.Count - 1 do - begin - if FieldDescriptions[i].EffectiveFieldName = AFieldName then - begin - FieldDesc := FieldDescriptions.Items[i]; - break; - end; - end; - - if Assigned(FieldDesc) then - result := FieldDesc.RTInfo - else - raise Exception.CreateFmt(sInvalidFieldName, [AFieldName]); -end; - -procedure TBoldAbstractDataSet.EnsureRecordPosInValidRange; -begin - if assigned(list) then - begin - if fRecordPos > List.Count-1 then - fRecordPos := List.Count-1 - end - else - fRecordPos := -1; -end; - -procedure TBoldAbstractDataSet._ReceiveContext(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); -begin - case RequestedEvent of - beDestroying: Close; - beValueIdentityChanged: - begin - TypeMayHaveChanged; - EnsureRecordPosInValidRange; - end; - beItemDeleted: EnsureRecordPosInValidRange; - end; -end; - -function TBoldAbstractDataSet.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; -var - BoldDataSetFieldDescription: TBoldDataSetFieldDescription; - BlobValue: TBABlob; - IndirectElement: TBoldIndirectElement; -begin - if IsEmpty then - Result := TMemoryStream.Create - else - begin - IndirectElement := TBoldIndirectElement.Create; - try - BoldDataSetFieldDescription := FieldDescriptions[Field.FieldNo - 1]; - List[RecNo - 1].EvaluateExpression(BoldDataSetFieldDescription.Expression, IndirectElement); - BlobValue := (IndirectElement.Value as TBABlob); - if not assigned(BlobValue) or BlobValue.IsNull then - result := TMemoryStream.Create - else - result := BlobValue.CreateBlobStream(TBoldBlobStreamMode(Mode)); - finally - IndirectElement.Free; - end; - end; -end; - -procedure TBoldAbstractDataSet.InternalEdit; -begin - inherited InternalEdit; -end; - -function TBoldAbstractDataSet.GetCanModify: boolean; -begin - result := True; -end; - -procedure TBoldAbstractDataSet.InternalCancel; -begin - if Assigned(ActiveBoldObject) then - ActiveBoldObject.Discard; -{CHECKME Is this needed??? - - if State = dsInsert then - begin - if SQL then - self.FListHandle.RemoveCurrentElement - end; -} - inherited; -end; - -function TBoldAbstractDataSet.Lookup(const KeyFields: string; const KeyValues: Variant; - const ResultFields: string): Variant; -begin - Result := null; - if LocateRecord(KeyFields, KeyValues, [loCaseInsensitive], false) then - begin - SetTempState(dsCalcFields); - try - CalculateFields(TempBuffer); - Result := FieldValues[ResultFields]; - finally - RestoreState(dsBrowse); - end; - end; -end; - -procedure TBoldAbstractDataSet.DoAfterScroll; -begin - if (FListFollower.Follower.CurrentIndex <> RecNo - 1) then - fListFollower.SetFollowerIndex(RecNo - 1); - inherited ; -end; - -function TBoldAbstractDataSet.ValuesInFields(AFields: TList; const KeyValues: Variant; Options: TLocateOptions): Boolean; -var - i: Integer; - - function CompareField(AField: TField; AValue: variant): boolean; - begin - if (loPartialKey in Options) then - begin - if (loCaseInsensitive in Options) then - Result := AnsiStrLIComp(PChar(AField.AsString), - PChar(VarToStr(AValue)), - Length(AValue)) = 0 - else - Result := AnsiStrLComp(PChar(AField.AsString), - PChar(VarToStr(AValue)), - Length(AValue)) = 0 - end - else - begin - if loCaseInsensitive in Options then - Result := AnsiStrIComp(PChar(AField.AsString), - PChar(VarToStr(AValue))) = 0 - else // aucune options - Result := AnsiStrComp(PChar(AField.AsString), - PChar(VarToStr(AValue))) = 0 - end; - end; - -begin - if AFields.count = 1 then - result := CompareField(TField(AFields[0]), KeyValues) - else - begin - Result := True; - for i := 0 to AFields.count - 1 do - begin - Result := Result and CompareField(TField(AFields[i]), KeyValues[i]); - if not Result then - Exit; - end; - end; -end; - -//called internally by Locate and Lookup -function TBoldAbstractDataSet.LocateRecord(const KeyFields: string; - const KeyValues: Variant; Options: TLocateOptions; - SyncCursor: Boolean): Boolean; -var - LFields: TList; - Locator: TBoldObjectLocator; - LocatorPtr: pointer; - LElement: TBoldElement; - i: Integer; -begin - result := false; - if BoldHandle.Count = 0 then - Exit; - - CheckBrowseMode; - CursorPosChanged; - SetTempState(dsFilter); - try - if UpperCase(KeyFields) = 'SELF' then // Do not localize - begin - LocatorPtr := Pointer(Integer(KeyValues)); - if Assigned(LocatorPtr) then - begin - try - Locator := TObject(LocatorPtr) as TBoldObjectLocator; - LElement := Locator.BoldObject; - with GetBookmarkInfo(TempBuffer)^ do - begin - Element := LElement; - Flag := bfCurrent; - end; - BoldToBuffer(TempBuffer); - FRecordPos := List.IndexOf(LElement); - Result := FRecordPos <> -1; - except - // Eat exceptions quietly - end - end - end - else - begin - LFields := TList.Create; - try - GetFieldList(LFields, KeyFields); - for i := 0 to List.Count - 1 do - begin - with GetBookmarkInfo(TempBuffer)^ do - begin - Element := List[i]; - Flag := bfCurrent; - end; - - BoldToBuffer(TempBuffer); - if ValuesInFields(LFields, KeyValues, Options) then - begin - FRecordPos := i; - Result := True; - break; - end; - end; //for - finally - LFields.Free; - end; - end; - finally - RestoreState(dsBrowse); - end; -end; - -function TBoldAbstractDataSet.Locate(const KeyFields: string; const KeyValues: Variant; - Options: TLocateOptions): Boolean; -begin - DoBeforeScroll; - Result := LocateRecord(KeyFields, KeyValues, Options, True); - if Result then - begin - Resync([rmExact, rmCenter]); - DoAfterScroll; - end; -end; - -function TBoldAbstractDataSet.BookmarkValid(Bookmark: TBookmark): Boolean; -begin - Result := GetIndexForBookmark(Bookmark) <> -1; -end; - -procedure TBoldAbstractDataSet.BoldToBuffer(ABuffer: PChar); -var - i: integer; -begin - for i := 0 to FieldDescriptions.Count - 1 do - BoldElementToBuffer(i, ABuffer); - - GetCalcFields(ABuffer); -end; - -procedure TBoldAbstractDataSet._DeleteRow(index: Integer; owningFollower: TBoldFollower); -begin - //_DeleteRow will also be called when closing the dataset, so do nothing - if not Active then - Exit; - - if State = dsInsert then - Exit; - UpdateCursorPos; - if BoldHandle.CurrentElement <> ActiveBoldElement then - if (State in dsWriteModes) then - Cancel - else - Resync([]) - else - if not (State in dsWriteModes) then - Resync([]); - -end; - -procedure TBoldAbstractDataSet._InsertRow(Follower: TBoldFollower); -begin - if State in [dsInsert, dsInactive] then - Exit; - if (State in dsWriteModes) then - UpdateRecord; - UpdateCursorPos; - Resync([]); -end; - -function TBoldAbstractDataSet.GetList: TBoldList; -begin - if Assigned(BoldHandle) then - result := BoldHandle.List - else - Result := nil; -end; - -procedure TBoldAbstractDataSet.BufferToBoldElement(AIndex: integer; ABuffer: PChar); -var - Locator: TBoldObjectLocator; - LocatorPointer: pointer; - LFieldAdr: pointer; - LFieldDescr: TBoldDataSetFieldDescription; - IndirectElement: TBoldIndirectElement; - LValue: TBoldElement; - LActiveElement: TBoldElement; -begin - LFieldDescr := FieldDescriptions[AIndex]; - - with LFieldDescr do - begin - LFieldAdr := ABuffer + FieldOfs; - - IndirectElement := TBoldIndirectElement.Create; - try - LValue := nil; - try - LActiveElement := GetBookmarkInfo(ABuffer)^.Element; - - LActiveElement.EvaluateExpression(Expression, IndirectElement); - LValue := IndirectElement.Value; - except - // Eat exceptions quietly - end; - - if Assigned(LValue) and LValue.Mutable then - case FieldType of // - ftBoolean: begin - if Boolean(LFieldAdr^) then - LValue.AsString := 'Y' - else - LValue.AsString := 'N' - end; - - ftString: begin - LValue.AsString := Copy(PChar(LFieldAdr), 1, BufferSize - 1); - end; - - ftInteger: begin - if LValue is TBoldObjectReference then - begin - if Integer(LFieldAdr^) <> 0 then - begin - LocatorPointer := Pointer(LFieldAdr^); - if Assigned(LocatorPointer) then - begin - Locator := TObject(LocatorPointer) as TBoldObjectLocator; - Locator.EnsureBoldObject; - TBoldObjectReference(LValue).BoldObject := Locator.BoldObject; - end - else - TBoldObjectReference(LValue).BoldObject := nil; - end - else - TBoldObjectReference(LValue).BoldObject := nil; - end - else if lValue is TBAValueSet then - (lValue as TBAValueSet).AsInteger := Integer(LFieldAdr^) - else - LValue.AsString := IntToStr(Integer(LFieldAdr^)); - end; - - ftCurrency, - ftFloat: begin - LValue.AsString := FloatToStr(Double(LFieldAdr^)); - end; - - ftTime: - if Double(LFieldAdr^) <> 0 then - LValue.AsString := TimeToStr(TimeStampToDateTime(MSecsToTimeStamp(Double(LFieldAdr^)))) - else - LValue.AsString := ''; - - ftDate: - if Double(LFieldAdr^) <> 0 then - LValue.AsString := DateToStr(TimeStampToDateTime(MSecsToTimeStamp(Double(LFieldAdr^)))) - else - LValue.AsString := ''; - - ftDateTime: - if Double(LFieldAdr^) <> 0 then - LValue.AsString := DateTimeToStr(TimeStampToDateTime(MSecsToTimeStamp(Double(LFieldAdr^)))) - else - LValue.AsString := ''; - end; // case - finally - IndirectElement.Free; - end; - end; // with -end; - -procedure TBoldAbstractDataSet.BoldElementToBuffer(AIndex: integer; ABuffer: PChar); -var - LDateTime: TDateTime; - LTimeStamp: TTimeStamp; - LInteger: integer; - LBoolean: boolean; - LFloat: double; - LFieldAdr: pointer; - IndirectElement: TBoldIndirectElement; - LActiveElement: TBoldElement; - LFieldDescr: TBoldDataSetFieldDescription; - Locator: TBoldObjectLocator; - LString: string; -begin - LFieldDescr := FieldDescriptions[AIndex]; - - with LFieldDescr do - begin - LFieldAdr := ABuffer + FieldOfs; - - IndirectElement := TBoldIndirectElement.Create; - try - FillChar(LFieldAdr^, BufferSize, 0); - try - LActiveElement := GetBookmarkInfo(ABuffer)^.Element; - LActiveElement.EvaluateExpression(Expression, IndirectElement); - if Assigned(IndirectElement.Value) then - case FieldType of // - ftBoolean: begin - if IndirectElement.Value.AsString = 'Y' then - LBoolean := True - else - LBoolean := False; - Move(LBoolean, LFieldAdr^, SizeOf(LBoolean)); - end; - - ftString: begin - StrLCopy(LFieldAdr, PChar(IndirectElement.Value.AsString), BufferSize - 1); - end; - - ftInteger: begin - if IndirectElement.Value is TBoldObjectReference then - begin - Locator := TBoldObjectReference(IndirectElement.Value).Locator; - Move(Integer(Pointer(Locator)), LFieldAdr^, BufferSize); - end - else if IndirectElement.Value is TBoldObject then - begin - Locator := TBoldObject(IndirectElement.Value).BoldObjectLocator; - Move(Integer(Pointer(Locator)), LFieldAdr^, BufferSize); - end - else if IndirectElement.Value is TBAValueSet then - begin - if (IndirectElement.Value as TBAValueSet).IsNull then - LInteger := 0 - else - lInteger := (IndirectElement.Value as TBAValueSet).AsInteger; - Move(LInteger, LFieldAdr^, BufferSize); - end - else - begin - if IndirectElement.Value.AsString = '' then - LInteger := 0 - else - LInteger := StrToInt(IndirectElement.Value.AsString); - Move(LInteger, LFieldAdr^, BufferSize); - end; - end; - - ftCurrency, - ftFloat: begin - LFloat := StrToFloat(IndirectElement.Value.AsString); - Move(LFloat, LFieldAdr^, BufferSize); - end; - - ftDate: begin - LTimeStamp.Date := 0; - if IndirectElement.Value is TBADate then - LTimeStamp := DateTimeToTimeStamp((IndirectElement.value as TBADate).asDate) - else - begin - LString := Trim(IndirectElement.Value.AsString); - if LString <> '' then - LTimeStamp := DateTimeToTimeStamp(StrToDate(IndirectElement.Value.AsString)); - end; - Move(LTimeStamp.Date, LFieldAdr^, BufferSize); - end; - - ftTime: begin - LTimeStamp.Time := 0; - if IndirectElement.value is TBATime then - lTimeStamp := DateTimeToTimeStamp((IndirectElement.value as TBATime).asTime) - else - begin - LString := Trim(IndirectElement.Value.AsString); - if LString <> '' then - LTimestamp := DateTimeToTimeStamp(StrToTime(IndirectElement.Value.AsString)); - end; - Move(LTimeStamp.Time, LFieldAdr^, BufferSize); - end; - - ftDateTime: begin - lFloat := 0; - if IndirectElement.Value is TBADateTime then - begin - lDateTime := (IndirectElement.value as TBADateTime).asDateTime; - LFloat := TimeStampToMSecs(DateTimeToTimeStamp(LDateTime)); - end - else - begin - LString := Trim(IndirectElement.Value.AsString); - if LString <> '' then - begin - LDateTime := StrToDateTime(IndirectElement.Value.AsString); - LFloat := TimeStampToMSecs(DateTimeToTimeStamp(LDateTime)); - end - end; - Move(LFloat, LFieldAdr^, BufferSize); - end; - - ftBlob, - ftMemo: begin - StrLCopy(LFieldAdr, PChar(IndirectElement.Value.AsString), BufferSize - 1); - end; - end; // case - except - // Eat exceptions quietly - end; - finally - IndirectElement.Free; - end; - end; // with -end; - -function TBoldAbstractDataSet.GetActiveBoldElement: TBoldElement; -var - ActiveBuf: PChar; -begin - if Active and GetActiveRecBuf(ActiveBuf) then - result := GetBookmarkInfo(ActiveBuf)^.Element - else - result := nil; -end; - -function TBoldAbstractDataSet.GetActiveBoldObject: TBoldObject; -begin - result := (ActiveBoldElement as TBoldObject); -end; - -function TBoldAbstractDataSet.GetBookmarkInfo(Buffer: PChar): PBDSBookmarkInfo; -begin - result := PBDSBookmarkInfo(Buffer + FBookmarkOfs); -end; - -//The AllocRecordBuffer method is called to allocate memory for a single record buffer. -//This method will be called internally by Delphi several times. -function TBoldAbstractDataSet.AllocRecordBuffer: PChar; -begin - GetMem(Result, FBufferSize); -end; - -//As you might expect, FreeRecordBuffer must free the memory allocated -//by the AllocRecordBuffer() method. -procedure TBoldAbstractDataSet.FreeRecordBuffer(var Buffer: PChar); -begin - FreeMem(Buffer); -end; - -//The InternalInitRecord method is called to initialize a record buffer. -//In this method, you could do things like set default field values or perform -//some type of initialization of custom record buffer data. -procedure TBoldAbstractDataSet.InternalInitRecord(Buffer: PChar); -begin - FillChar(Buffer^, FBufferSize, 0); -// InsertElement(Buffer); -end; - -//The primary function of the GetRecord method is to retrieve the record data -//for either the current, next or prior record in the dataset, depending on the value of the GetMode parameter, -//a TGetMode enumerated type which is defined as: TGetMode = (gmCurrent, gmNext, gmPrior) -// -//The return value may be any of the TGetResult enumerated values which is defined as: TGetResult = (grOK, grBOF, grEOF, grError) -// -// GrOk means success, grBOF means the dataset is at the beginning, -// grEOF means the dataset is at the end, and grError means an error has occurred. -// -// When the DoCheck parameter is True, and grError is the potential return value, -// an exception should be raised. - -// After having retrieved the current, next or prior record, the pysical file pointer(i.e. FRecordPos) -// should reflect the position of the record that was retrieved, for this reason the value of FReocordPos is -// incremented when the next record is requested, decremented when the prior record is requested, and unchanged -// when the current record is requested. - -function TBoldAbstractDataSet.GetRecord(Buffer: PChar; GetMode: TGetMode; - DoCheck: Boolean): TGetResult; -begin - Result := grError; - if not Assigned(List) then - begin - Result := grEOF; - exit; - end; - - if RecordCount = 0 then - Exit; - - result := grOk; - case GetMode of - gmCurrent: begin - if (FRecordPos < 0) or (FRecordPos >= RecordCount) then - result := grError; - end; - - gmNext: begin - if FRecordPos >= RecordCount - 1 then - begin - result := grEof; - end - else - Inc(FRecordPos, 1); - end; - - gmPrior: if FRecordPos <= 0 then - begin - result := grBof; - FRecordPos := -1; - end - else - Dec(FRecordPos, 1); - end; - - if result = grOk then - begin - GetCalcFields(Buffer); //maan: write the field data in the record buffer. - with GetBookmarkInfo(Buffer)^ do - begin - Element := List[FRecordPos]; - Flag := bfCurrent; - end; // with - BoldToBuffer(Buffer); - end - else - if (result = grError) and (DoCheck) then - DatabaseError(sNoRecordsFound); -end; - -//The GetRecordSize function should return the size of the data record. -//This does not include additional information contained in the record buffer -//such as the bookmark information. - -function TBoldAbstractDataSet.GetRecordSize: Word; -begin - Result := FRecordSize; -end; - -function TBoldAbstractDataSet.GetActiveRecBuf(var RecBuf: PChar): Boolean; -begin - case State of - dsBrowse: if IsEmpty then - RecBuf := nil - else - RecBuf := ActiveBuffer; - - dsEdit, - dsInsert: RecBuf := ActiveBuffer; - - dsSetKey: RecBuf := nil; - - dsCalcFields: RecBuf := CalcBuffer; - - dsFilter: RecBuf := TempBuffer; - - dsNewValue: RecBuf := nil; - - dsOldValue: RecBuf := nil; - else - RecBuf := nil; - end; - Result := RecBuf <> nil; -end; - -procedure TBoldAbstractDataSet.ClearCalcFields(Buffer: PChar); -begin - FillChar(Buffer[RecordSize], CalcFieldsSize, 0); -end; - -//GetFieldData may be called with a nil-pointer in the Buffer argument -//which means corresponds to an "IsNull" request for the related field -function TBoldAbstractDataSet.GetFieldData(Field: TField; Buffer: Pointer): Boolean; -var - LActiveElement: TBoldElement; - IndirectElement: TBoldIndirectElement; - LRecBuf: PChar; - Attr: TBoldAttribute; -begin - Result := False; - if not GetActiveRecBuf(LRecBuf) then - Exit; - - with Field do - begin - if FieldNo > 0 then - begin - with FieldDescriptions[Field.FieldNo - 1] do - begin - IndirectElement := TBoldIndirectElement.Create; - try - LActiveElement := GetBookmarkInfo(LRecBuf)^.Element; - LActiveElement.EvaluateExpression(Expression, IndirectElement); - if Assigned(IndirectElement.Value) and (IndirectElement.Value is TBoldAttribute) then - begin - Attr := TBoldAttribute(IndirectElement.Value); - result := not Attr.IsNull; - if Assigned(Buffer) and (Field.DataType=ftVariant) then - Variant(Buffer^) := IndirectElement.Value.GetAsVariant; - Field.readOnly := not Attr.CanModify; - end - else - result := True; - finally - IndirectElement.Free; - end; - if Assigned(Buffer) then - begin - Move((LRecBuf + FieldOfs)^, Buffer^ , Field.Datasize); - end; - end; // with - end - else - begin - if State in [dsBrowse, dsEdit, dsInsert, dsCalcFields] then - begin - Inc(LRecBuf, FRecordSize + Offset); - Result := Boolean(LRecBuf[0]); - if Result and (Buffer <> nil) then - Move(LRecBuf[1], Buffer^, DataSize); - end; - end; - if (DataType = ftString) and (fRecordSize > 30) then - DisplayWidth := 30; - end; -end; - -procedure TBoldAbstractDataSet.SetFieldData(Field: TField; Buffer: Pointer); -var - LRecBuf: PChar; -begin - with Field do - begin - if not (State in dsWriteModes) then - DatabaseError(SNotEditing); - - if not GetActiveRecBuf(LRecBuf) then - Exit; - - if FieldNo > 0 then - begin - if State = dsCalcFields then - DatabaseError(SNotEditing); - if ReadOnly and not (State in [dsSetKey, dsFilter]) then - DatabaseErrorFmt(SFieldReadOnly, [DisplayName]); - Validate(Buffer); - if FieldKind <> fkInternalCalc then - begin - with FieldDescriptions[Field.FieldNo - 1] do - begin - if not Assigned(Buffer) then - FillChar((LRecBuf + FieldOfs)^, BufferSize, #0) - else - Move(Buffer^, (LRecBuf + FieldOfs)^, BufferSize); - end; // with - BufferToBoldElement(Field.FieldNo - 1, LRecBuf); - end; - end - else {fkCalculated, fkLookup} - begin - Inc(LRecBuf, FRecordSize + Offset); - Boolean(LRecBuf[0]) := LongBool(Buffer); - if Boolean(LRecBuf[0]) then - Move(Buffer^, LRecBuf[1], DataSize); - end; - if not (State in [dsCalcFields, dsFilter, dsNewValue]) then - DataEvent(deFieldChange, Longint(Field)); - end; -end; - -//TDataSet.GetBookmarkData / TDataSet.SetBookmarkData -//The GetBookmarkData and SetBookmarkData methods provide a means for TDataSet to manipulate a record's bookmark data without repositioning the current record. - -procedure TBoldAbstractDataSet.GetBookmarkData(Buffer: PChar; Data: Pointer); -begin - TBoldElement(Data^) := GetBookmarkInfo(Buffer)^.Element; -end; - -//TDataSet.GetBookmarkFlag / TDataSet.SetBookmarkFlag -// -//Bookmark flags are used internally by TDataSet to determine whether -//a particular record is the current, first or last in the dataset. -//The first and last records are also referred to as the BOF and EOF cracks. -//You don't have to worry about setting the BOF and EOF flags as this is done internally -//by TDataSet. However, you must override the GetBookmarkFlag and SetBookmarkFlag methods -//to get and set the offset off the record buffer points to the bookmark flag. - -function TBoldAbstractDataSet.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; -begin - Result := GetBookmarkInfo(Buffer)^.Flag; -end; - -//see GetBookmarkFlag -procedure TBoldAbstractDataSet.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); -begin - GetBookmarkInfo(Buffer)^.Flag := Value; -end; - -function TBoldAbstractDataSet.GetIndexForBookmark(Bookmark: Pointer): integer; -begin - if Assigned(Bookmark) then - try - result := List.IndexOf(TBoldElement(Bookmark^)) - except - result := -1; - end - else - result := -1; -end; - -//maan: this method should position the physical file pointer (i.e. FRecordPos) on the record of interest -procedure TBoldAbstractDataSet.InternalGotoBookmark(Bookmark: Pointer); -var - LIndex: integer; -begin - LIndex := GetIndexForBookmark(Bookmark); - if LIndex >= 0 then - FRecordPos := LIndex; -end; - -procedure TBoldAbstractDataSet.InternalSetToRecord(Buffer: PChar); -begin - InternalGotoBookmark(@GetBookmarkInfo(Buffer)^.Element); -end; - -procedure TBoldAbstractDataSet.SetBookmarkData(Buffer: PChar; Data: Pointer); -begin - GetBookmarkInfo(Buffer)^.Element := Data; -end; - -//InternalFirst should position the current record to the beginning of the physical file. -procedure TBoldAbstractDataSet.InternalFirst; -begin - FRecordPos := -1; //BOF -end; - -//InternalLast should set the record to the end of the physical file. -procedure TBoldAbstractDataSet.InternalLast; -begin - FRecordPos := List.Count; //EOF -end; - -//InternalClose is called by TDataSet.Close. -//In this method, you should de-allocate all resources associated -//with the dataset that were allocated by InternalOpen or that were allocated -//throughout the course of using the dataset. -procedure TBoldAbstractDataSet.InternalClose; -begin - BindFields(False); - if DefaultFields then DestroyFields; // destroy the TField components - fInternalCursorReady := false; -end; - -procedure TBoldAbstractDataSet.InternalHandleException; -begin - BoldEffectiveEnvironment.HandleDesigntimeException(Self); -end; - -//The InternalDelete method deletes the current record from the dataset. -procedure TBoldAbstractDataSet.InternalDelete; -begin - ActiveBoldObject.Delete; - if List.Count = 0 then - FRecordPos := -1; -end; - -//InternalAddRecord is called when a record is inserted or appended to the dataset. -//The Buffer parameter points to the record buffer to be added to the dataset, -//and the Append parameter is True when a record is being appended and False -//when a record is being inserted. -procedure TBoldAbstractDataSet.InternalAddRecord(Buffer: Pointer; Append: Boolean); -var - RecPos: Integer; -begin - if Append then - begin - List.AddNew; - InternalLast; - end - else - begin - if FRecordPos = -1 then - RecPos := 0 - else - RecPos := FRecordPos; - List.InsertNew(RecPos); - end; -end; - -//The InternalOpen method is called by TDataSet.Open. -//In this method, you should open the underlying data source, -//initialize any internal fields or properties, create the field definitions (field defs) -//if necessary, and bind the field defs to the data. -//Additionally, this method should initialize the record position, -//determine record size and determine the record count. -procedure TBoldAbstractDataSet.InternalOpen; -begin - fInternalCursorReady := Assigned(BoldHandle) and BoldHandle.Enabled; - if not fInternalCursorReady then Exit; - FRecordPos := -1; //should be -1, we are not positioned at the first record yet - - if Assigned(BoldHandle.ListElementType) then - InternalInitFieldDefs; //populate FieldDefs - if DefaultFields then CreateFields; //populate Fields from FieldDefs: create TField components if no persistent fields - - BindFields(True); // bind FieldDefs to actual data - - BookmarkSize := SizeOf(TBDSBookmarkInfo); - //compute offsets to various record buffer segments - FBookmarkOfs := FRecordSize + CalcFieldsSize; - FBufferSize := FBookmarkOfs + BookmarkSize; -end; - -//The InternalPost method is called by TDataSet.Post. -//In this method, you should write the data from the active record buffer to the data file. -procedure TBoldAbstractDataSet.InternalPost; -begin - FRecordPos := List.IndexOf(ActiveBoldElement); - if (FRecordPos <> FListFollower.Follower.CurrentIndex) then - begin - FListFollower.SetFollowerIndex(FRecordPos); - CursorPosChanged; - end; -end; - -//The IsCursorOpen method is called internal to TDataSet to determine -//whether or not the data file has been opened or closed. -//Normally, the TDataSet descendant should maintain some boolean field -//which is used to determine the status of the data file. -function TBoldAbstractDataSet.IsCursorOpen: Boolean; -begin - //maan: should return true if we are ready to read from the physical file - Result := fInternalCursorReady ; -end; - -//The GetRecordCount method is one of the optional methods -//that you can override if you want to give Delphi 4's TDBGrid -//the ability to scroll relative to the cursor position in the dataset. -//While this feature makes sense for this implementation, -//there are many cases where this capability isn't practical or even possible. -//For example, if you are working with a huge amount of data, -//it might not be practical to obtain a record count, such as when communicating -//with a SQL server. - -function TBoldAbstractDataSet.GetRecordCount: Integer; -begin - if not Assigned(List) then - result := 0 - else - Result := List.Count; -end; - -function TBoldAbstractDataSet.GetRecNo: Integer; -var - ActiveBuf: PChar; - LIndex: integer; -begin - //maan: this function should return the ACTIVE record NOT the physical file position!!! - Result := 0; - if GetActiveRecBuf(ActiveBuf) then - begin - LIndex := List.IndexOf(GetBookmarkInfo(ActiveBuf)^.Element); - if (LIndex >= 0) and (LIndex < RecordCount) then - Result := LIndex + 1; - end; -end; - -procedure TBoldAbstractDataSet.InternalInitFieldDefs; -var - i: integer; -begin - FRecordSize := 0; - FieldDefs.Clear; - - for i := 0 to FieldDescriptions.Count - 1 do - begin - with FieldDescriptions[i] do - begin - TFieldDef.Create(FieldDefs, EffectiveFieldName, FieldType, FieldSize, Required, i + 1); - fFieldOfs := fRecordSize; - fRecordSize := fRecordSize + BufferSize; - end; - end; -end; - -procedure TBoldAbstractDataSet.LayoutChanged; -var - WasActive: boolean; -begin - WasActive := Active; - FLayoutChanged := True; - if WasActive then - Close; - - FieldDescriptions.InvalidateFields; - - if (WasActive or AutoOpen) and not (csDestroying in componentState) then - TryToOpen; -end; - -function TBoldAbstractDataSet.GetBoldHandle: TBoldAbstractListHandle; -begin - result := FListFollower.BoldHandle; -end; - -procedure TBoldAbstractDataSet.SetBoldHandle(NewValue: TBoldAbstractListHandle); -begin - if fListFollower.BoldHandle <> NewValue then - begin - fListFollower.BoldHandle := NewValue; - fContextSubscriber.CancelAllSubscriptions; - if assigned(NewValue) then - begin - NewValue.addsubscription(fContextSubscriber, beDestroying, beDestroying); - NewValue.addsubscription(fContextSubscriber, beValueIdentityChanged, beValueIdentityChanged); - if assigned(NewValue.List) then - NewValue.List.addsubscription(fContextSubscriber, beItemDeleted, beItemDeleted); - end; - end; -end; - -procedure TBoldAbstractDataSet.SetFieldDescriptions(const Value: TBoldDataSetFieldDescriptions); -begin - FieldDescriptions.Assign(Value); -end; - -procedure TBoldAbstractDataSet.TypeMayHaveChanged; -var - NewType: TBoldElementTypeInfo; -begin - NewType := ListElementType; - if (NewType <> fLastKnownType) then - begin - fLastKnownType := NewType; - TypeHasChanged; - end; -end; - -procedure TBoldAbstractDataSet.TypeHasChanged; -begin - //what to do? - LayOutChanged; -end; - -procedure TBoldAbstractDataSet.Loaded; -begin - if not (csdesigning in ComponentState) and (FieldDescriptions.Count = 0) then - CreateDefaultFields; - inherited; - if AutoOpen and not Active then - TryToOpen; -end; - -procedure TBoldAbstractDataSet.CreateDefaultFields; -var - i: integer; - NewField: TBoldDataSetFieldDescription; -begin - try - DeleteAllFields; - if Assigned(ListElementType) then - begin - if (ListElementType is TBoldClassTypeInfo) then - begin - with ListElementType as TBoldClassTypeInfo do - begin - for i := 0 to AllMembers.Count - 1 do - if AllMembers[i].IsAttribute then - begin - NewField := FieldDescriptions.Add; - NewField.Boldproperties.Expression := AllMembers[i].ExpressionName; - end; - end; - end - else if (ListElementType is TBoldAttributeTypeInfo) then - begin - FieldDescriptions.Add; - //Columns[ColCount - 1].Title.Caption := TBoldAttributeTypeInfo(ListElementType).ModelName; - end - else if (ListElementType is TBoldListTypeInfo) then - begin - FieldDescriptions.Add; - //Columns[ColCount - 1].Title.Caption := 'ClassName'; - end; - end; - finally - LayoutChanged; - end; -end; - -procedure TBoldAbstractDataSet.DeleteAllFields; -begin - while FieldDescriptions.Count > 0 do - FieldDescriptions.Delete(0); -end; - -procedure TBoldAbstractDataSet.SetRecNo(Value: Integer); -begin - // maan: when implemented this method should set the ACTIVE record; implementing this is not crucial. -end; - -end. - diff --git a/Source/BoldAwareGUI/BoldControls/BoldDragDropTarget.pas b/Source/BoldAwareGUI/BoldControls/BoldDragDropTarget.pas index 6ba6938b..38679cd0 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldDragDropTarget.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldDragDropTarget.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDragDropTarget; {$UNDEF BOLDCOMCLIENT} @@ -7,7 +10,7 @@ interface Classes, Controls, ExtCtrls, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after + BoldEnvironmentVCL, BoldElements, {$IFNDEF BOLDCOMCLIENT} BoldSystem, @@ -15,9 +18,11 @@ interface BoldControlpack, BoldElementHandleFollower, BoldReferenceHandle, - BoldNodeControlPack; + BoldNodeControlPack, + BoldDefs; type + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldDropTarget = class(TImage, IBoldOclComponent) private FIsDropTarget: Boolean; @@ -42,16 +47,16 @@ TBoldDropTarget = class(TImage, IBoldOclComponent) function GetContextType: TBoldElementTypeInfo; procedure SetEmptyImageIndex(const Value: integer); function GetElement: TBoldElement; - procedure SetExpression(Expression: String); - function GetExpression: String; + procedure SetExpression(const Value: TBoldExpression); + function GetExpression: TBoldExpression; function GetVariableList: TBoldExternalVariableList; protected property DraggedObject: TBoldObject read GetDraggedObject; property Element: TBoldElement read GetElement; procedure Notification(AComponent: TComponent; Operation: TOperation); override; public - constructor Create(owner: TComponent); override; - destructor Destroy; override; + constructor create(owner: TComponent); override; + destructor destroy; override; procedure DoStartDrag(var DragObject: TDragObject); override; procedure DoEndDrag(Target:TObject; X, Y: Integer); override; procedure MouseDown(BUTTON: TMouseButton; Shift: TShiftState; X, Y: Integer); override; @@ -68,14 +73,14 @@ TBoldDropTarget = class(TImage, IBoldOclComponent) end; implementation - uses Graphics, SysUtils, + BoldAttributes, {$IFNDEF BOLDCOMCLIENT} BoldGui, {$ENDIF} - BoldAttributes; + BoldRev; { TBoldDropTarget } @@ -111,11 +116,11 @@ constructor TBoldDropTarget.create(owner: TComponent); FRepresentations.OnGetContextType := GetContextType; fHandleFollower := TBoldElementHandleFollower.create(Owner, Representations); FRepresentations.AfterMakeUptoDate := AfterMakeUptoDate; - FNodeSelectionExpression := 'oclType.asstring->union(oclType.allsupertypes.asString)->union('''')'; // do not localize + FNodeSelectionExpression := 'oclType.asstring->union(oclType.allsupertypes.asString)->union('''')'; AfterMakeUptoDate(fHandleFollower.Follower); end; -destructor TBoldDropTarget.Destroy; +destructor TBoldDropTarget.destroy; begin FreeAndNil(FHandleFollower); FreeAndNil(FRepresentations); @@ -151,12 +156,9 @@ procedure TBoldDropTarget.DragDrop(Source: TObject; X, Y: Integer); procedure TBoldDropTarget.DragOver(Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); begin - // First set the hard accept value Accept := IsDropTarget and CanAcceptDraggedObject; - // Then, if we accept, invoke user code if Accept and Assigned(OnDragOver) then OnDragOver(Self, Source, X, Y, State, Accept); - // Make sure we only accept if hard conditions are true. Accept := Accept and IsDropTarget and CanAcceptDraggedObject; end; @@ -185,7 +187,6 @@ function TBoldDropTarget.GetCurrentNodeDescription: TBoldNodeDescription; begin ie := TBoldIndirectElement.create; try - // this code should move to the treeview support classes (or is it already there???) Element.EvaluateAndSubscribeToExpression(NodeSelectionExpression, fHandleFollower.Follower.Subscriber, ie); if ie.value is TBoldList then begin list := ie.value as TBoldList; @@ -285,9 +286,9 @@ procedure TBoldDropTarget.SetEmptyImageIndex(const Value: integer); FEmptyImageIndex := Value; end; -procedure TBoldDropTarget.SetExpression(Expression: String); +procedure TBoldDropTarget.SetExpression(const Value: TBoldExpression); begin - NodeSelectionExpression := Expression; + NodeSelectionExpression := Value; end; procedure TBoldDropTarget.SetImageList(const Value: TImageList); diff --git a/Source/BoldAwareGUI/BoldControls/BoldEdit.pas b/Source/BoldAwareGUI/BoldControls/BoldEdit.pas index 9eef2cf5..5d6d8826 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldEdit.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldEdit.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldEdit; {$UNDEF BOLDCOMCLIENT} @@ -13,13 +16,14 @@ interface Menus, Graphics, Buttons, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after + BoldEnvironmentVCL, BoldControlsDefs, BoldHandles, BoldElements, BoldControlPack, BoldElementHandleFollower, - BoldStringControlPack; + BoldStringControlPack, + BoldDefs; type {Forward declarations of all classes} @@ -45,10 +49,10 @@ TBoldCustomEdit = class(TCustomEdit, IBoldOCLComponent) fMaxLength: integer; {Bold stuff} function GetContextType: TBoldElementTypeInfo; - procedure SetExpression(Expression: String); - function GetExpression: String; + procedure SetExpression(const Value: TBoldExpression); + function GetExpression: TBoldExpression; function GetVariableList: TBoldExternalVariableList; - + function GetBoldHandle: TBoldElementHandle; procedure SetBoldHandle(value: TBoldElementHandle); function GetFollower: TBoldFOllower; @@ -99,7 +103,7 @@ TBoldCustomEdit = class(TCustomEdit, IBoldOCLComponent) property BeepOnInvalidKey: boolean read fBeepOnInvalidKey write fBeepOnInvalidKey default True; property Button: TSpeedButton read GetButton; - property ButtonControl: TWinControl read fBtnControl; //NOTE Do not publish. + property ButtonControl: TWinControl read fBtnControl; property EffectiveReadOnly: Boolean read GetEffectiveReadOnly; property EffectiveFont: TFont read GetEffectiveFont; property EffectiveColor: TColor read GetEffectiveColor write SetEffectiveColor; @@ -122,6 +126,7 @@ TBoldCustomEdit = class(TCustomEdit, IBoldOCLComponent) end; {---TBoldEdit---} + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldEdit = class(TBoldCustomEdit) public {$IFNDEF T2H} @@ -143,20 +148,16 @@ TBoldEdit = class(TBoldCustomEdit) property Anchors; property AutoSelect; property AutoSize; -// property BiDiMode; property BorderStyle; property CharCase; -// property Color; property Constraints; property Ctl3D; property DragCursor; property DragKind; property DragMode; property Enabled; -// property Font; property HideSelection; -// property ImeMode; -// property ImeName; + property MaxLength; property ParentColor; property ParentCtl3D; @@ -164,11 +165,9 @@ TBoldEdit = class(TBoldCustomEdit) property ParentShowHint; property PasswordChar; property PopupMenu; -// property ReadOnly; property ShowHint; property TabOrder; property TabStop; -// property Text; property Visible; property OnChange; property OnClick; @@ -196,15 +195,14 @@ implementation uses BoldControlPackDefs, SysUtils, - Forms, // bssingle - {$IFNDEF BOLDCOMCLIENT} // uses - BoldSystem, // For Specialized Drag/Drop in EditBox - BoldGUI, // For Specialized Drag/Drop in EditBox + BoldUtils, + Forms, + {$IFNDEF BOLDCOMCLIENT} + BoldSystem, + BoldGUI, BoldReferenceHandle, BoldRootedHandles, {$ENDIF} - BoldDefs, - BoldGuiResourceStrings, BoldCommonBitmaps; { TBoldComboButton } @@ -217,6 +215,7 @@ TBoldComboButton = class(TSpeedButton) X, Y: Integer); override; end; + {---TBoldCustomEdit---} constructor TBoldCustomEdit.Create(AOwner: TComponent); begin @@ -271,7 +270,7 @@ procedure TBoldCustomEdit.DoEndDrag(Target: TObject; X, Y: Integer); procedure TBoldCustomEdit.DragOver(Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); begin - {$IFNDEF BOLDCOMCLIENT} //dragdrop + {$IFNDEF BOLDCOMCLIENT} if (BoldProperties.DropMode = bdpReplace) and (assigned(BoldHandle)) and (not assigned(BoldHandle.Value) or (BoldHandle.Value is TBoldObject)) and @@ -290,7 +289,7 @@ procedure TBoldCustomEdit.DragOver(Source: TObject; X, Y: Integer; State: TDragS procedure TBoldCustomEdit.DragDrop(Source: TObject; X, Y: Integer); begin - {$IFNDEF BOLDCOMCLIENT} //dragdrop + {$IFNDEF BOLDCOMCLIENT} if (BoldProperties.DropMode = bdpReplace) and (assigned(BoldHandle)) and (not assigned(BoldHandle.Value) or (BoldHandle.Value is TBoldObject)) and @@ -373,17 +372,17 @@ function TBoldCustomEdit.GetEffectiveColor: TColor; procedure TBoldCustomEdit.SetEffectiveColor(v: TColor); begin - if (EffectiveColor <> v) and not ParentColor then + if EffectiveColor <> v then inherited Color := v; end; -procedure TBoldCustomEdit.SetText(value: string); //CHECKME Remove? Text is not published any longer! +procedure TBoldCustomEdit.SetText(value: string); begin if not (csLoading in ComponentState) then if not EffectiveReadOnly then inherited Text := value else - raise EBold.CreateFmt(sTextNotModifiable, [ClassName]); + raise EBold.CreateFmt('%s.Text: Not modifiable', [ClassName]); end; function TBoldCustomEdit.GetText: string; @@ -411,13 +410,13 @@ procedure TBoldCustomEdit.InvalidKey(Key: Char); procedure TBoldCustomEdit.KeyPress(var Key: Char); begin inherited KeyPress(Key); - if (Key in [#32..#255]) and + if CharInSet(Key, [#32..#255]) and not BoldProperties.ValidateCharacter(Key, Follower) then begin InvalidKey(Key); Key := BOLDNULL; end - else if Key = #1 then // CTRL-A + else if Key = #1 then begin SelectAll; end @@ -471,12 +470,9 @@ procedure TBoldCustomEdit.AfterMakeUptoDate(Follower: TBoldFollower); inherited MaxLength := EffectiveMaxLength; - if not ParentColor then - begin - ec := EffectiveColor; - BoldProperties.SetColor(ec, Color, Follower); - EffectiveColor := ec; - end; + ec := EffectiveColor; + BoldProperties.SetColor(ec, Color, Follower); + EffectiveColor := ec; end; @@ -667,7 +663,6 @@ procedure TBoldCustomEdit.SetEditRect; var Loc: TRect; begin -// SendMessage(Handle, EM_GETRECT, 0, LongInt(@Loc)); Loc.Bottom := ClientHeight+1; Loc.Right := ClientWidth-1; Loc.Top := 0; @@ -686,15 +681,13 @@ procedure TBoldCustomEdit.SetEditRect; end; procedure TBoldCustomEdit.WMSize(var message: TWMSize); -//var -// MinHeight: Integer; + begin inherited; -// if (csDesigning in ComponentState) then -// FGrid.SetBounds(0, Height + 1, 10, 10); -// MinHeight := GetMinHeight; -// if Height < MinHeight then Height := MinHeight -// else begin + + + + if Assigned(fBtnControl) and Assigned(fButton) then SetEditRect; end; @@ -710,7 +703,6 @@ procedure TBoldCustomEdit.SetButtonStyle(const Value: TBoldEditButtonStyle); begin if Assigned(fBtnControl) then fBtnControl.Visible := False; - //NOTE Skip destruction of button and recreation of control in runtime to eliminate flicker. if (csDesigning in ComponentState) then RecreateWnd; end @@ -749,7 +741,6 @@ procedure TBoldComboButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin with TBoldCustomEdit(Parent.Parent) do - //CHECKME We may need to skip the change of focus if the popupcontrol is visible! if (Handle <> GetFocus) and CanFocus then begin SetFocus; @@ -763,8 +754,7 @@ procedure TBoldComboButton.MouseDown(Button: TMouseButton; Shift: TShiftState; procedure TBoldComboButton.MouseMove(Shift: TShiftState; X, Y: Integer); begin inherited MouseMove (Shift, X, Y); -// if (ssLeft in Shift) and (GetCapture = Parent.Handle) then -// MouseDragToGrid(Self, TDBLookupCombo(Parent.Parent).FGrid, X, Y); + end; function TBoldCustomEdit.GetBoldHandle: TBoldElementHandle; @@ -785,15 +775,15 @@ function TBoldCustomEdit.GetContextType: TBoldElementTypeInfo; result := nil; end; -function TBoldCustomEdit.GetExpression: String; +function TBoldCustomEdit.GetExpression: TBoldExpression; begin result := BoldProperties.Expression; end; -procedure TBoldCustomEdit.SetExpression(Expression: String); +procedure TBoldCustomEdit.SetExpression(const Value: TBoldExpression); begin Assert(Assigned(BoldProperties)); - BoldProperties.Expression := Expression; + BoldProperties.Expression := Value; end; function TBoldCustomEdit.GetVariableList: TBoldExternalVariableList; @@ -801,4 +791,6 @@ function TBoldCustomEdit.GetVariableList: TBoldExternalVariableList; result := BoldProperties.VariableList; end; +initialization + end. diff --git a/Source/BoldAwareGUI/BoldControls/BoldGrid.pas b/Source/BoldAwareGUI/BoldControls/BoldGrid.pas index 474ca763..cc3354a4 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldGrid.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldGrid.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldGrid; {$UNDEF BOLDCOMCLIENT} @@ -6,9 +9,9 @@ interface uses {$IFDEF DELPHI6_OR_LATER} - Types, // IFDEF DELPHI6_OR_LATER + Types, {$ELSE} - Windows, // else-part of IFDEF DELPHI6_OR_LATER + Windows, {$ENDIF} Messages, Graphics, @@ -17,8 +20,8 @@ interface Menus, StdCtrls, Classes, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after - {$IFNDEF BOLDCOMCLIENT} // uses + BoldEnvironmentVCL, + {$IFNDEF BOLDCOMCLIENT} BoldSystem, {$ENDIF} BoldCommonBitmaps, @@ -72,7 +75,6 @@ TBoldGridCheckBoxPainterRenderer = class(TBoldAsStringRenderer) TBoldConstraintRenderer = class(TBoldAsStringRenderer) {Override draw in Controllers since we need access to follower} - procedure DefaultMakeUptodateAndSetMayModifyAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldStringFollowerController; Subscriber: TBoldSubscriber); override; procedure DrawOnCanvas(Follower: TBoldFollower; Canvas: TCanvas; Rect: TRect; Alignment: TAlignment; Margins: TPoint); override; end; @@ -81,9 +83,9 @@ TBoldConstraintRenderer = class(TBoldAsStringRenderer) TBoldGridColumns = class(TCollection) private fGrid: TBoldCustomGrid; - function GetColumn(index: Integer): TBoldGridColumn; - procedure MoveColumn(FromIndex, ToIndex: Longint); - procedure SetColumn(index: Integer; Value: TBoldGridColumn); + function GetColumn(index: Integer): TBoldGridColumn; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure MoveColumn(FromIndex, ToIndex: Longint); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetColumn(index: Integer; Value: TBoldGridColumn); {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected function GetOwner: TPersistent; override; public @@ -95,7 +97,6 @@ TBoldGridColumns = class(TCollection) end; { TBoldColumnTitle } - // Borrowed from TDBGrid TBoldColumnTitle = class(TPersistent) private fAlignment: TAlignment; @@ -254,34 +255,34 @@ TBoldCustomGrid = class(TCustomGrid, IBoldValidateableComponent) fIsDragging: Boolean; fIsMultiSelecting: Boolean; fLastMouseDownShiftState: TShiftState; + fPostDisplayEventSet: boolean; procedure EnsureOneFixedCol; function GetBoldHandle: TBoldAbstractListHandle; - function GetBoldList: TBoldList; - function GetCurrentBoldElement: TBoldElement; - function GetFollower: TBoldFOllower; - function GetOptions: TGridOptions; + function GetBoldList: TBoldList; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetCurrentBoldElement: TBoldElement; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetFollower: TBoldFOllower; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetOptions: TGridOptions; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetSelected(DataRow: integer): Boolean; procedure SetBoldHandle(value: TBoldAbstractListHandle); - procedure SetColumns(Value: TBoldGridColumns); - procedure SetController(Value: TBoldListAsFollowerListController); - procedure SetOptions(val: TGridOptions); + procedure SetColumns(Value: TBoldGridColumns); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetController(Value: TBoldListAsFollowerListController); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetOptions(val: TGridOptions); {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetSelection(aRow: Integer; Shift: TShiftState; ForceClearOfOtherRows: Boolean; IgnoreToggles: Boolean); procedure TypeMayHaveChanged; - // DRAW FUNCTIONS function CellFont(Column: TBoldGridColumn): TFont; function GetString(GridCol, DataRow: Integer): string; function HighlightCell(AState: TGridDrawState; aRow: integer): Boolean; - // EDIT FUNCTIONS procedure _AfterMakeCellUptoDate(Follower: TBoldFollower); procedure _DeleteRow(index: Integer; owningFollower: TBoldFollower); - procedure _InsertRow(Follower: TBoldFollower); + procedure _InsertRow(index: Integer; OwningFollower: TBoldFollower); + procedure _ReplaceRow(index: Integer; AFollower: TBoldFollower); procedure AdjustCol(Col: Integer); function DefaultTitlePopup(Col: Integer): TPopupMenu; procedure DefaultTitlePopupOnClick(Sender: TObject); function GetCellFollower(ListCol, DataRow: Integer): TBoldFollower; function GetCurrentCellFollower: TBoldFollower; function GetMultiSelect: Boolean; - function GetRowFollower(DataRow: Integer): TBoldFollower; + function GetRowFollower(DataRow: Integer): TBoldFollower; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure InvalidateFromRow(DisplayDataRow: Longint); procedure SetCurrentRow(DataRow: Integer); procedure SetMultiSelect(V: Boolean); @@ -294,16 +295,18 @@ TBoldCustomGrid = class(TCustomGrid, IBoldValidateableComponent) function ColumnIsCheckBox(col: integer): Boolean; procedure WMChar(var Msg: TWMChar); message WM_CHAR; {$ENDIF} - function GetMutableList: TBoldList; + function GetMutableList: TBoldList; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetShowTitleRow: Boolean; procedure SetShowTitleRow(const Value: Boolean); function GetTitleRow: integer; procedure GetActiveRange(var FirstActive, LastActive: integer); property MultiSelect: Boolean read GetMultiSelect write SetMultiSelect; procedure EnsureRowActive(DataRow: integer); - procedure DisplayAvailableFollowers; + procedure DisplayAvailableFollowers; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetCellText(col, row: integer): string; procedure _FontChanged(Sender: TObject); + procedure PostDisplayEvent(Sender: TObject); + procedure SetPostDisplayEvent; protected { Protected declarations } procedure _AfterMakeListUptoDate(Follower: TBoldFollower); virtual; @@ -318,8 +321,8 @@ TBoldCustomGrid = class(TCustomGrid, IBoldValidateableComponent) procedure ColWidthsChanged; override; function CreateColumns: TBoldGridColumns; dynamic; procedure CreateDefaultColumns; virtual; - function DataRow(GridRow: Integer): Integer; - function GridRow(Datarow: Integer): Integer; + function DataRow(GridRow: Integer): Integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GridRow(Datarow: Integer): Integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure DblClick; override; procedure DefaultColumns; procedure DeleteAllColumns; @@ -393,12 +396,13 @@ TBoldCustomGrid = class(TCustomGrid, IBoldValidateableComponent) procedure DisplayAllCells; function AsClipBoardText: String; procedure ActivateAllCells; - property ColCount;// read GetColCount; + property ColCount; property CellText[col, row: integer]: string read GetCellText; property MutableList: TBoldList read GetMutableList; end; { TBoldGrid } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldGrid = class(TBoldCustomGrid) public {$IFNDEF T2H} @@ -431,7 +435,7 @@ TBoldGrid = class(TBoldCustomGrid) property Color; property Constraints; property Columns; - {$IFNDEF BCB} // for some reason, the below line gives an error in the generated .hpp-file + {$IFNDEF BCB} property Ctl3d; {$ENDIF} property DefaultColWidth; @@ -484,7 +488,6 @@ TBoldGrid = class(TBoldCustomGrid) end; { TBoldInplaceEdit } - // Used to access Font property of InplaceEditor TBoldInplaceEdit = class(TInplaceEdit) private {$IFNDEF BOLDCOMCLIENT} @@ -532,19 +535,18 @@ implementation uses SysUtils, Forms, - {$IFNDEF BOLDCOMCLIENT} // uses + {$IFNDEF BOLDCOMCLIENT} BoldAttributes, BoldSystemRT, BoldAFP, BoldGUI, {$ENDIF} -// BoldGridRTColEditor BoldEnvironment, - BoldGuiResourceStrings, BoldDefs, BoldListControlPack, + BoldUtils, TypInfo, - BoldMath; + BoldMath, BoldQueue; const ColumnTitleValues = [cvTitleColor..cvTitleFont]; @@ -565,12 +567,12 @@ TBoldInplaceCombo = class(TCombobox) protected procedure WndProc(var Message: TMessage); override; public - constructor createWithInplaceEditor(InplaceEdit: TBoldInplaceEdit); + constructor CreateWithInplaceEditor(InplaceEdit: TBoldInplaceEdit); end; { TBoldInplaceCombo } -constructor TBoldInplaceCombo.createWithInplaceEditor(InplaceEdit: TBoldInplaceEdit); +constructor TBoldInplaceCombo.CreateWithInplaceEditor(InplaceEdit: TBoldInplaceEdit); begin inherited Create(InplaceEdit); fInplaceEdit := InplaceEdit; @@ -619,7 +621,6 @@ procedure TBoldInplaceEdit.BoundsChanged; var R: TRect; begin - // This method replaces ancestor method, as it doesn't seem to do the right thING Assert(Assigned(Grid)); R := Rect(2, 2, TBoldCustomGrid(Grid).Columns[TBoldCustomGrid(Grid).Col].Width - 2, Height); SendMessage(Handle, EM_SETRECTNP, 0, LongInt(@R)); @@ -632,9 +633,8 @@ procedure TBoldInplaceEdit.KeyPress(var Key: Char); begin inherited KeyPress(Key); Grid := TBoldCustomGrid(Owner); - // when editing, clear all other selected rows Grid.SetSelection(grid.DataRow(grid.Row), [], true, false); - if (Key in [#32..#255]) and + if CharInSet(Key, [#32..#255]) and not Grid.Columns[Grid.Col].BoldProperties.ValidateCharacter(Key, Grid.CurrentCellFollower) then begin MessageBeep(0); @@ -774,7 +774,7 @@ procedure TBoldColumnTitle._FontChanged(Sender: TObject); Exclude(fColumn.fAssignedValues, cvTitleFont) else Include(fColumn.fAssignedValues, cvTitleFont); - Changed; // ??? + Changed; end; function TBoldColumnTitle.GetAlignment: TAlignment; @@ -916,7 +916,7 @@ constructor TBoldGridColumn.Create(theCollection: TCollection); begin inherited Create(theCollection); if not (theCollection is TBoldGridColumns) then - raise EBold.CreateFmt(sCannotCreateColumnOutsideCollection, [ClassName]); + raise EBold.CreateFmt('%s.Create: Cannot create TBoldGridColumn outside a TBoldGridColumns', [ClassName]); fGrid := (theCollection as TBoldGridColumns).Grid; FBoldProperties := TBoldStringFollowerController.Create(fGrid); fColor := fGrid.Color; @@ -937,7 +937,6 @@ constructor TBoldGridColumn.Create(theCollection: TCollection); end; destructor TBoldGridColumn.Destroy; - // CollectionItem removes itself from collection when destroyed begin if fGrid.fFixedColumn = self then fGrid.fFixedColumn := nil; @@ -955,7 +954,6 @@ destructor TBoldGridColumn.Destroy; procedure TBoldGridColumn.Assign(Source: TPersistent); -// Code mainly from DBGrids var SourceCol: TBoldGridColumn; begin @@ -976,12 +974,11 @@ procedure TBoldGridColumn.Assign(Source: TPersistent); if cvAlignment in SourceCol.AssignedValues then Alignment := SourceCol.Alignment; Title := SourceCol.Title; -// if cvReadOnly in SourceCol.AssignedValues then -// ReadOnly := SourceCol.ReadOnly; -// DropDownRows := SourceCol.DropDownRows; -// ButtonStyle := SourceCol.ButtonStyle; -// PickList := SourceCol.PickList; -// PopupMenu := SourceCol.PopupMenu; + + + + + finally if Assigned(Collection) then Collection.EndUpdate; @@ -1012,8 +1009,7 @@ procedure TBoldGridColumn.RestoreDefaults; FTitle.RestoreDefaults; FAssignedValues := []; RefreshDefaultFont; -// FreeAndNil(FPickList); -// ButtonStyle := cbsAuto; + Changed(FontAssigned); end; @@ -1155,11 +1151,11 @@ constructor TBoldCustomGrid.Create(AOwner: TComponent); fBoldProperties := TBoldListAsFollowerListController.Create(self, fBoldColumnsProperties); fBoldProperties.OnAfterInsertItem := _InsertRow; fBoldProperties.OnAfterDeleteItem := _DeleteRow; + fBoldProperties.OnReplaceitem := _ReplaceRow; fBoldProperties.AfterMakeUptoDate := _AfterMakeListUptoDate; fBoldProperties.BeforeMakeUptoDate := _BeforeMakeListUptoDate; fBoldProperties.OnGetContextType := GetHandleStaticType; fHandleFollower := TBoldListHandleFollower.Create(Owner, fBoldProperties); - // fHandleFollower.OnHandleIndexChanged := HandleIndexChanged; FColumns := CreateColumns; fAnchor := 0; Options := [goFixedVertLine, goFixedHorzLine, goVertLine, @@ -1209,7 +1205,7 @@ procedure TBoldCustomGrid.TypeMayHaveChanged; {$ENDIF} begin if BoldEffectiveEnvironment.RunningInIDE and (not Assigned(BoldHandle) or not Assigned(BoldHandle.List) or (BoldHandle.List.Count = 0)) then - Exit; // only update at runtime if there are values, avoids update on every UML model change. + Exit; NewListElementType := GetHandleListElementType; if (NewListElementType <> fCurrentListElementType) then @@ -1242,12 +1238,11 @@ procedure TBoldCustomGrid.DeleteAllColumns; Columns[ColCount - 1].Free; if columns.count = 0 then AddColumn; - // ensure column 0 EnsureOneFixedCol; end; procedure TBoldCustomGrid.CreateDefaultColumns; -{$IFNDEF BOLDCOMCLIENT} // defaultcolumns +{$IFNDEF BOLDCOMCLIENT} var i: integer; ListElementType: TBoldElementTypeInfo; @@ -1266,7 +1261,7 @@ procedure TBoldCustomGrid.CreateDefaultColumns; {$ENDIF} begin - {$IFNDEF BOLDCOMCLIENT} // defaultcolumns + {$IFNDEF BOLDCOMCLIENT} ListElementType := GetHandleListElementType; DeleteAllColumns; UsedFirstCol := false; @@ -1298,7 +1293,7 @@ procedure TBoldCustomGrid.CreateDefaultColumns; end else if (ListElementType is TBoldListTypeInfo) then begin - GetEmptyCol.Title.Caption := sCaptionClassName; + GetEmptyCol.Title.Caption := 'ClassName'; end; end; if Columns.Count = 2 then @@ -1313,14 +1308,14 @@ procedure TBoldCustomGrid.CreateDefaultColumns; AddColumn; with Columns[ColCount - 1] do begin - Boldproperties.Expression := 'self.oclType'; //do not localize - Title.Caption := sCaptionType; + Boldproperties.Expression := 'self.oclType'; + Title.Caption := 'Type'; end; AddColumn; with Columns[ColCount - 1] do begin Boldproperties.Expression := ''; - Title.Caption := sCaptionAsString; + Title.Caption := 'AsString'; end; end; if BoldShowConstraints then @@ -1370,7 +1365,6 @@ procedure TBoldCustomGrid.ColumnMoved(FromIndex, ToIndex: Longint); begin Columns.MoveColumn(FromIndex, ToIndex); inherited ColumnMoved(FromIndex, ToIndex); - // Redraw affected columns for Col := MinIntValue([FromIndex, ToIndex]) to MaxIntValue([FromIndex, ToIndex]) do Columns.Update(Columns[Col]); end; @@ -1406,21 +1400,17 @@ procedure TBoldCustomGrid.EnsureOneFixedCol; not fIsEnsuringFixedCol then begin fIsEnsuringFixedCol := true; - // there must be atleast one column more than the fixed column while Columns.Count < 2 do if not FirstIsOK then Columns.Insert(0) else Columns.Add; - - // see if the existing first column can be used as our fixed column... if not FirstIsOk then Columns.Insert(0); fFixedColumn := Columns[0]; - // make this column the fixed column. fFixedColumn.BoldProperties.Expression := ''; - fFixedColumn.Title.Caption := ''; // Clear the title + fFixedColumn.Title.Caption := ''; fFixedColumn.Color := Self.FixedColor; if not (csDesigning in componentstate) then fFixedColumn.BoldProperties.Renderer := fFirstColumnRenderer; @@ -1452,6 +1442,12 @@ procedure TBoldCustomGrid.MoveColumn(FromIndex, ToIndex: Longint); inherited MoveColumn(FromIndex, ToIndex); end; +procedure TBoldCustomGrid.PostDisplayEvent(Sender: TObject); +begin + Invalidate; + fPostDisplayEventSet := false; +end; + function TBoldCustomGrid.CreateEditor: TInplaceEdit; begin Result := TBoldInplaceEdit.Create(self); @@ -1460,13 +1456,11 @@ function TBoldCustomGrid.CreateEditor: TInplaceEdit; end; procedure TBoldCustomGrid.EditStop; - // Same as OnExit for each cell var CellFollower: TBoldFollower; begin CellFollower := CurrentCellFollower; - // if the grid is changed under our feet (for example because it is sorted, and we just changed the sort order) - // then ignore the edit stop + if assigned(CellFollower) and (CellFollower.Controller.ApplyPolicy = bapExit) then CellFollower.Apply; @@ -1486,9 +1480,8 @@ function TBoldCustomGrid.GetEditText(GridCol, GridRow: Longint): string; end; procedure TBoldCustomGrid.SetEditText(GridCol, GridRow: Longint; const Value: string); - // called for each change == OnChange begin - if not (csDesigning in ComponentState) and Editormode and assigned(CurrentCellFollower) then // CHECKME heeded? + if not (csDesigning in ComponentState) and Editormode and assigned(CurrentCellFollower) then TBoldStringFollowerController(CurrentCellFollower.Controller).MayHaveChanged(Value, CurrentCellFollower) end; @@ -1510,7 +1503,7 @@ procedure TBoldCustomGrid.DblClick; else if BoldProperties.DefaultDblClick and Assigned(CurrentBoldElement) then begin - {$IFDEF BOLDCOMCLIENT} // autoform + {$IFDEF BOLDCOMCLIENT} AutoForm := nil; {$ELSE} AutoForm := AutoFormProviderRegistry.FormForElement(CurrentBoldElement); @@ -1538,14 +1531,6 @@ procedure TBoldCustomGrid.SetBoldHandle(Value: TBoldAbstractListHandle); fHandleFollower.BoldHandle := value; end; -function TBoldCustomGrid.DataRow(GridRow: Integer): Integer; -begin - if HasGhostRow then - Result := -1 - else - Result := GridRow - FixedRows; -end; - function TBoldCustomGrid.GetCurrentBoldElement: TBoldElement; begin if Assigned(CurrentCellFollower) then @@ -1580,14 +1565,20 @@ procedure TBoldCustomGrid.SetOptions(val: TGridOptions); inherited Options := val - [goRangeSelect]; end; +procedure TBoldCustomGrid.SetPostDisplayEvent; +begin + if fPostDisplayEventSet then + exit; + fPostDisplayEventSet := true; + BoldInstalledQueue.AddEventToPostDisplayQueue(PostDisplayEvent, nil, self) +end; + procedure TBoldCustomGrid.SetSelection(aRow: Integer; Shift: TShiftState; ForceClearOfOtherRows: Boolean; IgnoreToggles: Boolean); begin if aRow = -1 then Exit; fIsMultiSelecting := MultiSelect and ((ssShift in Shift) or (ssCtrl in Shift)); - - // Clear previous selection, Select one item if not ((ssShift in Shift) or (ssCtrl in Shift)) or not MultiSelect then begin if (not Follower.SubFollowers[aRow].Selected) or ForceClearOfOtherRows then @@ -1596,22 +1587,15 @@ procedure TBoldCustomGrid.SetSelection(aRow: Integer; Shift: TShiftState; ForceC fBoldProperties.SetSelected(Follower, aRow, True); end; end; - - // Select range from first selected item if (ssShift in Shift) and MultiSelect then begin fBoldProperties.SelectRange(Follower, aRow); end; - - - // Toggle selection on current item if (ssCtrl in Shift) and MultiSelect and (not IgnoreToggles) then begin fBoldProperties.ToggleSelected(Follower, aRow); end; - // At this point we would rather have invalidated col 0, - // but that does not yield desired redraw WHEN THE GRID SCROLLS. Invalidate; AdjustActiveRange; @@ -1659,7 +1643,7 @@ procedure TBoldCustomGrid.DefaultTitlePopupOnClick(Sender: TObject); begin TMenuItem(Sender).checked := not TMenuItem(Sender).checked; - if Pos('__mnuBoldGridCWA', TMenuItem(Sender).name) = 1 then // do not translate + if Pos('__mnuBoldGridCWA', TMenuItem(Sender).name) = 1 then with Columns[TMenuItem(Sender).Owner.Tag] do if TMenuItem(Sender).checked then CWAdjust := CWAdjust + [TBoldCWAdjust(TMenuItem(Sender).Tag)] @@ -1687,22 +1671,21 @@ function TBoldCustomGrid.DefaultTitlePopup(Col: Integer): TPopupMenu; M := TMenuItem.Create(TheDefaultTitlePopup); M.Caption := GetEnumName(TypeInfo(TBoldCWAdjust), I); M.OnClick := DefaultTitlePopupOnClick; - M.name := '__mnuBoldGridCWA' + GetEnumName(TypeInfo(TBoldCWAdjust), I); // do not translate + M.name := '__mnuBoldGridCWA' + GetEnumName(TypeInfo(TBoldCWAdjust), I); M.Tag := I; M.RadioItem := False; Items.Add(M); end; M := TMenuItem.Create(TheDefaultTitlePopup); - M.Caption := '-'; // do not translate - M.name := '__mnuBoldGridSeparator'; // do not translate + M.Caption := '-'; + M.name := '__mnuBoldGridSeparator'; Items.Add(M); M := TMenuItem.Create(TheDefaultTitlePopup); - M.Caption := sClosePopup; - M.name := '__mnuBoldGridCancel'; // do not translate + M.Caption := '&Close Popup'; + M.name := '__mnuBoldGridCancel'; Items.Add(M); - // Additional possibilities: - // M := nil; - // * Alignment + + end; end; Result := TheDefaultTitlePopup; @@ -1753,11 +1736,10 @@ procedure TBoldCustomGrid.MouseUp(BUTTON: TMouseButton; Shift: TShiftState; X, Y if (Button = mbLeft) then begin if not fIsDragging then - SetSelection(DataRow(Row), Shift, true, false) // Call setselection with currentrow and shiftstate + SetSelection(DataRow(Row), Shift, true, false) else begin - // starting a drag on a nonselected row with ctrl pressed should select the row - // odd behaviour cuases VCL to clear the shiftstate when we expect a ssCTRL, so we check the MouseDownstate instead + if not selected[DataRow(Row)] and (ssCtrl in fLastMouseDownShiftState) then SetSelection(DataRow(Row), fLastMouseDownShiftState, true, false) end; @@ -1793,14 +1775,13 @@ procedure TBoldCustomGrid.MouseDown(BUTTON: TMouseButton; Shift: TShiftState; X, {$ENDIF} inherited; - // Top Left cell marks all rows - // FIXME FIXEDROW handling + if (fLastMouseDownGridCoord.y <> -1) and (fLastMouseDownGridCoord.Y = TitleRow) then begin if fLastMouseDownGridCoord.X = Pred(FixedCols) then begin fBoldProperties.SelectAll(Follower, True); - ReallyInvalidateCol(Pred(FixedCols)); // FIXME InvalidateCol doesn't invalidate last when scrolling + ReallyInvalidateCol(Pred(FixedCols)); AdjustActiveRange; end else @@ -1810,17 +1791,15 @@ procedure TBoldCustomGrid.MouseDown(BUTTON: TMouseButton; Shift: TShiftState; X, fLastMouseDownScreenCoord := Point(-1, -1); end; end - else //mark clicked row + else begin - if (Button = mbLeft) and (fLastMouseDownGridCoord.Y >= FixedRows) then // if clicking outside datacells, y is -1 + if (Button = mbLeft) and (fLastMouseDownGridCoord.Y >= FixedRows) then begin Row := fLastMouseDownGridCoord.Y; - // if the click is in column 0 and it is already selected, don't reselect anything if not ((fLastMouseDownGridCoord.x = pred(FixedCols)) and Selected[fLastMouseDownGridCoord.y]) then - SetSelection(DataRow(Row), Shift, false, true) // SetSelection Invalidates entire grid + SetSelection(DataRow(Row), Shift, false, true) end; end; - // drag if on col 0 if (Button = mbLeft) and (fLastMouseDownGridCoord.X = Pred(FixedCols)) then begin try @@ -1835,31 +1814,33 @@ procedure TBoldCustomGrid.MouseDown(BUTTON: TMouseButton; Shift: TShiftState; X, procedure TBoldCustomGrid.KeyDown(var KEY: Word; Shift: TShiftState); const - RowMovementKeys = [VK_LEFT, VK_RIGHT, VK_UP, VK_PRIOR, VK_DOWN, VK_NEXT, VK_HOME, VK_END, VK_TAB]; + RowMovementKeys = [VK_UP, VK_PRIOR, VK_DOWN, VK_NEXT, VK_HOME, VK_END, VK_TAB]; begin if Key in Rowmovementkeys then begin HideEditor; - if (ssShift in Shift) and MultiSelect and (key <> VK_TAB) then + if (ssShift in Shift) and MultiSelect then fIsMultiSelecting := true; end; - if CanEditShow and (Key = VK_DELETE) and (Shift = []) then + if (Key = VK_DELETE) and (Shift = []) then begin - ShowEditor; - InplaceEditor.Text := ''; - SetEditText(Col, Row, ''); + if (goEditing in Options) and not (BoldHandle.List.Count = 0) then begin + ShowEditor; + InplaceEditor.Text := ''; + SetEditText(Col, Row, ''); + end; end; - + if (Row = RowCount - 1) and (KEY = 40) then {40 = KeyDown} begin if AddNewAtEnd and (fBoldProperties.NilElementMode<>neAddLast) then begin BoldHandle.List.AddNew; - Follower.EnsureDisplayable; // Force control to get in sync with Object Layer + Follower.EnsureDisplayable; end else - KEY := 0; // Avoid walking below last row + KEY := 0; end; {$IFNDEF BOLDCOMCLIENT} if not (Key in RowMovementKeys) and not (Key in [VK_LEFT, VK_RIGHT]) and ColumnIsCheckBox(Col) then @@ -1871,13 +1852,12 @@ procedure TBoldCustomGrid.KeyDown(var KEY: Word; Shift: TShiftState); procedure TBoldCustomGrid.KeyUp(var KEY: Word; Shift: TShiftState); begin - if (KEY in [33..40]) and not Editormode then //PGUP..DOWN + if KEY in [33..40] then begin - //FIXME: It *is* possible to make non-consecutive selections with keyboard. - // I think the algorithm has to be rewritten to accommodate this. - // Also: Check how Delphi/Windows implements keyboard selections (keys/combinations) - Exclude(Shift, ssCtrl); // Cannot make non-consecutive selections with keyboard - SetSelection(DataRow(Row), Shift, true, true); // Call setselection with currentrow and shiftstate + + + Exclude(Shift, ssCtrl); + SetSelection(DataRow(Row), Shift, true, true); end; inherited; end; @@ -1889,9 +1869,11 @@ function TBoldCustomGrid.GetString(GridCol, DataRow: Integer): string; else begin EnsureRowActive(DataRow); - // if a cell's controller has not be created yet then you'll get an AV (ex: setting the CWAdjust flag) if Assigned(CellFollowers[GridCol, DataRow]) and Assigned(CellFollowers[GridCol, DataRow].Controller) then + begin + Follower.EnsureDisplayable; Result := TBoldStringFollowerController(CellFollowers[GridCol, DataRow].Controller).GetCurrentAsString(CellFollowers[GridCol, DataRow]); + end; end; end; @@ -1942,9 +1924,8 @@ procedure TBoldCustomGrid.AdjustCol(Col: Integer); procedure TBoldCustomGrid.ColWidthsChanged; begin inherited; - // By including TopLeftChanged, [caAllowGrow, caAllowShrink] - // effectively freezes the column width - // TopLeftChanged; + + end; function TBoldCustomGrid.CanEditAcceptKey(KEY: Char): Boolean; @@ -1958,7 +1939,7 @@ function TBoldCustomGrid.CanEditModify: Boolean; if not Assigned(CurrentCellFollower) then Result := False else - Result := CurrentCellFollower.Controller.MayModify(CurrentCellFollower) and + Result := CurrentCellFollower.MayModify and not Columns[Col].ColReadOnly; end; @@ -1966,9 +1947,8 @@ function TBoldCustomGrid.CanEditShow: Boolean; begin Result := (inherited CanEditShow) and Assigned(CurrentCellFollower) and not Columns[Col].ColReadOnly; - // editable if we have a write-allowing renderer or a lookup-handle result := result and - (CurrentCellFollower.RendererData.MayModify + (CurrentCellFollower.MayModify {$IFNDEF BOLDCOMCLIENT} or assigned(Columns[Col].LookupHandle) {$ENDIF}); @@ -1994,6 +1974,31 @@ procedure TBoldCustomGrid.TopLeftChanged; FOnTopLeftChanged(Self); end; +function TBoldCustomGrid.GetRowFollower(DataRow: Integer): TBoldFollower; +begin + if (DataRow >= 0) and (datarow < Follower.SubFollowerCount) then + begin + Result := Follower.SubFollowers[DataRow]; + end + else + result := nil; +end; + +function TBoldCustomGrid.GetCellFollower(ListCol, DataRow: Integer): TBoldFollower; +var + RowFollower: TBoldFollower; +begin + RowFollower := GetRowFollower(DataRow); + if assigned(RowFollower) and + (ListCol >= 0) and + (listCol < RowFollower.SubFollowerCount) then + begin + Result := RowFollower.SubFollowers[ListCol]; + end + else + result := nil; +end; + procedure TBoldCustomGrid.DrawCell(ACol, aRow: Longint; ARect: TRect; AState: TGridDrawState); var aListRow: Integer; @@ -2002,10 +2007,9 @@ procedure TBoldCustomGrid.DrawCell(ACol, aRow: Longint; ARect: TRect; AState: TG cl: TColor; TempRect: TRect; FrameFlags1, FrameFlags2: DWORD; - + CellFollower: TBoldFollower; begin -// if (csDesigning in ComponentState) and (aRow > 0) then -// Exit; //FIXME Removed to test Grids in designtime + if Follower.IsInDisplayList then exit; aListRow := DataRow(aRow); if (ACol > Columns.Count - 1) then @@ -2037,7 +2041,7 @@ procedure TBoldCustomGrid.DrawCell(ACol, aRow: Longint; ARect: TRect; AState: TG begin if (aRow = TitleRow) then {Title row} begin - if Assigned(DrawColumn.Title) then // Attempts to redraw before column is done creating + if Assigned(DrawColumn.Title) then begin Font.Assign(DrawColumn.Title.Font); Align := DrawColumn.Title.Alignment; @@ -2045,13 +2049,23 @@ procedure TBoldCustomGrid.DrawCell(ACol, aRow: Longint; ARect: TRect; AState: TG TBoldAsStringRenderer.DrawStringOnCanvas(Canvas, ARect, Align, Point(1, 1), DrawColumn.Title.Caption); end end - else if RowFollowers[aListRow].Displayable then + else begin + if not Assigned(RowFollowers[aListRow]) or RowFollowers[aListRow].IsInDisplayList then + begin + SetPostDisplayEvent; + exit; + end; + CellFollower := CellFollowers[ACol, aListRow]; + if not Assigned(CellFollower) or CellFollower.IsInDisplayList then + begin + SetPostDisplayEvent; + exit; + end; with Columns[ACol].BoldProperties do begin - // Render font and color - SetFont(Canvas.Font, CellFont(DrawColumn), CellFollowers[ACol, aListRow]); - SetColor(cl, DrawColumn.Color, CellFollowers[ACol, aListRow]) + SetFont(Canvas.Font, CellFont(DrawColumn), CellFollower); + SetColor(cl, DrawColumn.Color, CellFollower) end; if HighlightCell(AState, aRow) then @@ -2068,7 +2082,9 @@ procedure TBoldCustomGrid.DrawCell(ACol, aRow: Longint; ARect: TRect; AState: TG OnDrawCell(DrawColumn, Canvas, ACol, aRow, ARect, AState); end else - Columns[ACol].BoldProperties.DrawOnCanvas(CellFollowers[ACol, aListRow], Canvas, ARect, DrawColumn.Alignment, Point(2, 2)); + begin + Columns[ACol].BoldProperties.DrawOnCanvas(CellFollower, Canvas, ARect, DrawColumn.Alignment, Point(2, 2)); + end; end; if (gdFixed in AState) and Ctl3D and ((FrameFlags1 or FrameFlags2) <> 0) then @@ -2091,6 +2107,19 @@ procedure TBoldCustomGrid.DrawCell(ACol, aRow: Longint; ARect: TRect; AState: TG end; end; +function TBoldCustomGrid.GridRow(Datarow: Integer): Integer; +begin + Result := Datarow + FixedRows; +end; + +function TBoldCustomGrid.DataRow(GridRow: Integer): Integer; +begin + if HasGhostRow then + Result := -1 + else + Result := GridRow - FixedRows; +end; + procedure TBoldCustomGrid._AfterMakeCellUptoDate(Follower: TBoldFollower); var DisplayGridRow: Integer; @@ -2112,44 +2141,30 @@ procedure TBoldCustomGrid.InvalidateFromRow(DisplayDataRow: Longint); InvalidateRow(I); end; -procedure TBoldCustomGrid._InsertRow(Follower: TBoldFollower); -begin - if Follower.Index < fInvalidateFrom then - fInvalidateFrom := Follower.Index; - fLastInsertedRowIndex := Follower.Index; -end; - -procedure TBoldCustomGrid._DeleteRow(index: Integer; owningFollower: TBoldFollower); +procedure TBoldCustomGrid._InsertRow(index: Integer; OwningFollower: TBoldFollower); begin if Index < fInvalidateFrom then fInvalidateFrom := Index; + fLastInsertedRowIndex := Index; end; -procedure TBoldCustomGrid.SetCurrentRow(DataRow: Integer); +procedure TBoldCustomGrid._ReplaceRow(index: Integer; + AFollower: TBoldFollower); begin - Row := GridRow(MaxIntValue([0, DataRow])); // Need to make sure we never focus on row 0 - ReallyInvalidateCol(0); // Need to redraw first column FIXME let renderer to this too + if Index < fInvalidateFrom then + fInvalidateFrom := Index; end; -function TBoldCustomGrid.GetRowFollower(DataRow: Integer): TBoldFollower; +procedure TBoldCustomGrid._DeleteRow(index: Integer; owningFollower: TBoldFollower); begin - if datarow < Follower.SubFollowerCount then - Result := Follower.SubFollowers[DataRow] - else - result := nil; + if Index < fInvalidateFrom then + fInvalidateFrom := Index; end; -function TBoldCustomGrid.GetCellFollower(ListCol, DataRow: Integer): TBoldFollower; -var - RowFollower: TBoldFollower; +procedure TBoldCustomGrid.SetCurrentRow(DataRow: Integer); begin - RowFollower := GetRowFollower(DataRow); - if assigned(RowFollower) and - (ListCol >= 0) and - (listCol < RowFollower.SubFollowerCount) then - Result := RowFollower.SubFollowers[ListCol] - else - result := nil; + Row := GridRow(MaxIntValue([0, DataRow])); + ReallyInvalidateCol(0); end; function TBoldCustomGrid.GetCurrentCellFollower; @@ -2161,11 +2176,16 @@ function TBoldCustomGrid.GetCurrentCellFollower; end; function TBoldCustomGrid.GetSelected(DataRow: integer): Boolean; +var + lBoldFollower: TBoldFollower; begin + Result := false; if (DataRow >= 0) and (DataRow < Follower.SubFollowerCount) then - Result := RowFollowers[DataRow].Selected - else - Result := false; + begin + lBoldFollower := RowFollowers[DataRow]; + if Assigned(lBoldFollower) then + Result := RowFollowers[DataRow].Selected; + end; end; procedure TBoldCustomGrid._AfterMakeListUptoDate(Follower: TBoldFollower); @@ -2180,12 +2200,9 @@ procedure TBoldCustomGrid._AfterMakeListUptoDate(Follower: TBoldFollower); RowCount := FixedRows + 1 else RowCount := Follower.SubFollowerCount + FixedRows; - - // if exactly one row has been inserted, then select it. if AutoSelectNewRows and (fSubFollowerCountBeforeMakeUpToDate = Follower.SubFollowerCount - 1) then begin - // perhaps this is a bit overkill, but it works. anyone with a better suggestion? BoldHandle.CurrentIndex := fLastInsertedRowIndex; Follower.CurrentIndex := fLastInsertedRowIndex; SetCurrentRow(Follower.CurrentIndex); @@ -2196,19 +2213,17 @@ procedure TBoldCustomGrid._AfterMakeListUptoDate(Follower: TBoldFollower); not assigned(RowFollowers[Follower.CurrentIndex]) or (fEditedElementBeforeMakeUpToDate <> RowFollowers[Follower.CurrentIndex].Element)) then EditorMode := false; - +{ if (fSubFollowerCountBeforeMakeUpToDate = 0) and (Follower.SubFollowerCount > 0) and (Follower.CurrentIndex <> -1) then begin Follower.SubFollowers[Follower.CurrentIndex].Selected := true; end; - +} AdjustActiveRange; if fInvalidateFrom <> MAXINT then InvalidateFromRow(fInvalidateFrom); - - // setting the currentRow will reset the LeftCol if GridRow(Follower.CurrentIndex) < RowCount then begin OldLeftCol := LeftCol; @@ -2216,7 +2231,7 @@ procedure TBoldCustomGrid._AfterMakeListUptoDate(Follower: TBoldFollower); LeftCol := OldLeftCol; end; - if not fIsMultiSelecting and + if not fIsMultiSelecting and (Follower.CurrentIndex <> -1) and (Follower.SubFollowerCount > 0) and assigned(Follower.SubFollowers[Follower.CurrentIndex]) and not Follower.SubFollowers[Follower.CurrentIndex].Selected then begin @@ -2242,7 +2257,7 @@ function TBoldCustomGrid.GetFollower: TBoldFOllower; procedure TBoldCustomGrid._BeforeMakeListUpToDate(Follower: TBoldFollower); begin - TypeMayHaveChanged; // IMPROVEME, subscribe to listidentitychanged instead. + TypeMayHaveChanged; fMakingListUpToDate := True; AdjustActiveRange; fInvalidateFrom := MAXINT; @@ -2311,8 +2326,7 @@ function TBoldInplaceEdit.GetDestElement(CellFollower: TBoldFollower; Column: TB result := nil; if assigned(cellFollower) and assigned(CellFollower.Element) then begin - // if the event is active, then return the element in the grid, otherwise - // see if we get any useful element from the cell. + if assigned(Column.OnLookupChange) then result := CellFollower.Element else @@ -2406,7 +2420,7 @@ procedure TBoldInplaceEdit.InitCombo(var Message: TWMWindowPosChanged); ListElement := fEditColumn.LookupHandle.List[i]; Combo.Items.AddObject( - Renderer.GetAsStringAndSubscribe(ListElement, fEditColumn.LookUpProperties, nil), + ListElement.EvaluateExpressionAsString(fEditColumn.LookUpProperties.Expression, fEditColumn.LookUpProperties.Representation), ListElement); if (CellValue = ListElement) or @@ -2471,7 +2485,6 @@ function TBoldCustomGrid.GetEditLimit: Integer; begin result := 0; {$IFNDEF BOLDCOMCLIENT} - // set the maxlength of the editor; El := TBoldInplaceEdit(InplaceEditor).GetDestElement(CurrentCellFollower, Columns[Col]); if (el is TBAString) and assigned((el as TBAString).BoldAttributeRTInfo) then Result := (el as TBAString).BoldAttributeRTInfo.Length; @@ -2562,7 +2575,6 @@ procedure TBoldGridCheckBoxPainterRenderer.CheckBoxClick(BUTTON: TMouseButton; S begin GridCoord := GRid.MouseCoord(X, Y); CellRect.Left := 0; - // sum the column widths of the fixed cols and then the visible cols. for i := 0 to Grid.FixedCols - 1 do CellRect.Left := CellRect.Left + Grid.Columns[i].Width + Grid.GridLineWidth; for i := GRid.LeftCol to GridCoord.x - 1 do @@ -2604,7 +2616,7 @@ procedure TBoldGridCheckBoxPainterRenderer.ToggleValue(GridCoord: TGridCoord; Gr ie: TBoldIndirectElement; begin CurrentFollower := Grid.CellFollowers[GridCoord.x, GridCoord.y-Grid.FixedRows]; - if CurrentFollower.rendererData.MayModify then + if CurrentFollower.MayModify then begin if fColumn.ColumnHasCheckBoxOverrides then begin @@ -2715,12 +2727,6 @@ procedure TBoldGridCheckBoxPainterRenderer.DrawOnCanvas(Follower: TBoldFollower; { TBoldConstraintRenderer } -procedure TBoldConstraintRenderer.DefaultMakeUptodateAndSetMayModifyAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldStringFollowerController; Subscriber: TBoldSubscriber); -begin - inherited DefaultMakeUptoDateAndSetMayModifyAndSubscribe(Element, RendererData, FollowerController, Subscriber); - RendererData.MayModify := false; -end; - procedure TBoldConstraintRenderer.DrawOnCanvas(Follower: TBoldFollower; Canvas: TCanvas; Rect: TRect; Alignment: TAlignment; Margins: TPoint); var @@ -2768,7 +2774,7 @@ procedure TBoldCustomGrid.EnsureConstraintColumn; with AddColumn do begin SetIndex(1); - BoldProperties.Expression := 'constraints->exists(c|not c)'; // do not localize + BoldProperties.Expression := 'constraints->exists(c|not c)'; Width := bmpBoldGridSelected.Width + 3; Title.Caption := '§'; BoldProperties.Renderer := TBoldConstraintRenderer.Create(Self); @@ -2781,7 +2787,7 @@ procedure TBoldGridColumn.SetIndex(Value: Integer); begin fGrid.fBoldColumnsProperties.Move(index, value); inherited; - fGrid.Invalidate; // Fixes a bug in Borland grid to invalidate col that does not handle scrolled grids + fGrid.Invalidate; end; procedure TBoldCustomGrid.ReallyInvalidateCol(Column: integer); @@ -2816,7 +2822,7 @@ procedure TBoldCustomGrid.AdjustActiveRange; begin GetActiveRange(FirstActive, LastActive); BoldProperties.SetActiveRange(Follower, firstActive, lastActive, 10); - EnsureActiveCellFollowerExpressions; +// EnsureActiveCellFollowerExpressions; end; end; @@ -2827,11 +2833,6 @@ procedure TBoldCustomGrid.Resize; AdjustActiveRange; end; -function TBoldCustomGrid.GridRow(Datarow: Integer): Integer; -begin - Result := Datarow + FixedRows; -end; - function TBoldCustomGrid.GetShowTitleRow: Boolean; begin result := fixedRows = 1; @@ -2872,13 +2873,13 @@ function TBoldCustomGrid.ValidateComponent(ComponentValidator: TBoldComponentVal begin Context := GetHandleStaticType; result := ComponentValidator.ValidateExpressionInContext( - '', Context, format('%s%s', [NamePrefix, Name])); // do not localize + '', Context, format('%s%s', [NamePrefix, Name])); if assigned(context) then for i := 0 to Columns.Count - 1 do result := ComponentValidator.ValidateExpressionInContext( Columns[i].BoldProperties.Expression, Context, - format('%s%s.Column[%d]', [NamePrefix, Name, i])) and result; // do not localize + format('%s%s.Column[%d]', [NamePrefix, Name, i])) and result; end; procedure TBoldCustomGrid.LookUpChange(sender: Tobject; DestElement: TBoldElement; EditColumn: TBoldGridColumn); @@ -2921,7 +2922,6 @@ function TBoldCustomGrid.AsClipBoardText: String; var Col, Row: integer; begin - // as the grid is optimizing the active followers, we need to activate them manually ActivateAllCells; Result := ''; for row := 0 to RowCount - 1 do @@ -2954,7 +2954,7 @@ procedure TBoldGridColumn.SetCheckBoxRendererIfAppropriate; begin ListElementTypeInfo := Grid.BoldHandle.ListElementType; SystemTypeInfo := ListElementTypeInfo.SystemTypeInfo as TBoldSystemTypeInfo; - BooleanTypeInfo := SystemTypeinfo.AttributeTypeInfoByExpressionName['Boolean']; // do not localize + BooleanTypeInfo := SystemTypeinfo.AttributeTypeInfoByExpressionName['Boolean']; ResultTypeInfo := SystemTypeinfo.Evaluator.ExpressionType(BoldProperties.Expression, ListElementTypeInfo, false, BoldProperties.VariableList); if (assigned(ResultTypeInfo) and ResultTypeInfo.ConformsTo(BooleanTypeInfo)) or ColumnHasCheckBoxOverrides then begin @@ -2973,13 +2973,11 @@ function TBoldGridColumn.ColumnHasCheckBoxOverrides: Boolean; function TBoldGridColumn.GetCurrentCheckBoxState( Follower: TBoldFollower): TCheckBoxState; begin - // will only be called if ColumnHasCheckBoxOverrides returns true result := cbGrayed; end; procedure TBoldGridColumn.SetCurrentCheckBoxState(Follower: TBoldFollower; NewValue: TCheckBoxState); begin - // will only be called if ColumnHasCheckBoxOverrides returns true end; function TBoldGridColumn.GetLookupContext: TBoldElementTypeInfo; @@ -3041,7 +3039,6 @@ procedure TBoldCustomGrid.GetActiveRange(var FirstActive, LastActive: integer); begin firstActive := DataRow(TopRow) - 1; LastActive := DataRow(TopRow + VisibleRowCount) + 1; - // extend range to include all selected elements for i := 0 to FirstActive - 1 do if Selected[i] then begin @@ -3071,7 +3068,6 @@ procedure TBoldCustomGrid.EnsureRowActive(DataRow: integer); else if DataRow > LastActive then LastActive := DataRow; BoldProperties.SetActiveRange(Follower, firstActive, lastActive, 10); - // this can fail if the FollowerHandle is invalid... Follower.EnsureDisplayable; end; end; @@ -3095,7 +3091,7 @@ procedure TBoldCustomGrid.DisplayAllCells; BoldProperties.SelectAll(Follower, true); Invalidate; AdjustActiveRange; - EnsureActiveCellFollowerExpressions; {TODO: Remove? AdjustActiveRange already calls this method, why call it again??} + EnsureActiveCellFollowerExpressions; Follower.EnsureDisplayable; BoldProperties.SelectAll(Follower, false); BoldProperties.SetSelected(Follower, DataRow(Row), true); @@ -3114,4 +3110,7 @@ procedure TBoldCustomGrid.EnsureActiveCellFollowerExpressions; end; end; + +initialization + end. diff --git a/Source/BoldAwareGUI/BoldControls/BoldGridRTColEditor.pas b/Source/BoldAwareGUI/BoldControls/BoldGridRTColEditor.pas index c4d6b314..5e36624e 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldGridRTColEditor.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldGridRTColEditor.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldGridRTColEditor; {$UNDEF BOLDCOMCLIENT} @@ -12,7 +15,7 @@ interface Classes, BoldDefs, BoldGrid, - {$IFNDEF BOLDCOMCLIENT} // uses + {$IFNDEF BOLDCOMCLIENT} BoldOclPropEditor, {$ENDIF} BoldSystemRT, @@ -69,7 +72,6 @@ implementation uses SysUtils, - BoldGuiResourceStrings, BoldUtils; {$R *.dfm} @@ -135,14 +137,14 @@ procedure TfrmRTColEditor.GetColumns; var i: integer; begin - for i := 1 to Grid.ColCount - 1 do + for i := 1 to Grid.ColCount-1 do lbxColumns.Items.AddObject(EGrid.Columns[i].Title.Caption, EGrid.Columns[i]); end; procedure TfrmRTColEditor.Execute(BoldCustomGrid: TBoldCustomGrid); begin if not Assigned(BoldCustomGrid) then - raise EBold.CreateFmt(sExecuteGridNotAssigned, [ClassName]); + raise EBold.CreateFmt('%s.Execute: BoldCustomGrid not assigned', [ClassName]); Grid := BoldCustomGrid; CurrentGridColumn := nil; @@ -177,8 +179,8 @@ procedure TfrmRTColEditor.cmdAddColumnClick(Sender: TObject); Grid.AddColumn; with EGrid do begin - Columns[ColCount - 1].Title.Caption := sNewColumn; - lbxColumns.Items.AddObject(Columns[ColCount - 1].Title.Caption, Columns[ColCount - 1]); + Columns[ColCount-1].Title.Caption := ''; + lbxColumns.Items.AddObject(Columns[ColCount-1].Title.Caption, Columns[ColCount-1]); end; end; @@ -192,12 +194,12 @@ procedure TfrmRTColEditor.cmdDeleteColumnClick(Sender: TObject); procedure TfrmRTColEditor.PropertyKeyPress(Sender: TObject; var Key: Char); begin if not Assigned(CurrentGridColumn) then - Key := BOLDNULL; + Key := BOLDNULL; end; procedure TfrmRTColEditor.cmdOCLEditorClick(Sender: TObject); begin - {$IFNDEF BOLDCOMCLIENT} // ocleditor + {$IFNDEF BOLDCOMCLIENT} with TBoldOCLPropEditForm.Create(nil) do try Context := EGrid.GetHandleListElementType; @@ -210,4 +212,6 @@ procedure TfrmRTColEditor.cmdOCLEditorClick(Sender: TObject); {$ENDIF} end; +initialization + end. diff --git a/Source/BoldAwareGUI/BoldControls/BoldImage.pas b/Source/BoldAwareGUI/BoldControls/BoldImage.pas index d91171e0..38262c4c 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldImage.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldImage.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldImage; {$UNDEF BOLDCOMCLIENT} @@ -10,20 +13,22 @@ interface Classes, Graphics, Controls, - Forms, // TBorderStyle - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after + Forms, + BoldEnvironmentVCL, BoldControlsDefs, BoldHandles, BoldElementHandleFollower, BoldControlPack, BoldViewerControlPack, - BoldElements; + BoldElements, + BoldDefs; type {forward declarations} TBoldImage = class; {-- TBoldImage --} + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldImage = class(TCustomControl, IBoldOCLComponent) private fBoldProperties: TBoldViewerFollowerController; @@ -38,16 +43,16 @@ TBoldImage = class(TCustomControl, IBoldOCLComponent) fQuickDraw: Boolean; fScale: Double; fDisplayRect: TRect; - FOnResize: TNotifyEvent; + FOnResize: TNotifyEvent; function GetContextType: TBoldElementTypeInfo; - procedure SetExpression(Expression: String); - function GetExpression: String; + procedure SetExpression(const Value: TBoldExpression); + function GetExpression: TBoldExpression; function GetVariableList: TBoldExternalVariableList; function GetBoldHandle: TBoldElementHandle; function GetFollower: TBoldFOllower; procedure SetBorderStyle(Value: TBorderStyle); - procedure SetAutoSize(Value: Boolean); + procedure SetAutoSize(Value: Boolean); reintroduce; procedure SetDrawFocus(Value: Boolean); procedure SetBoldProperties(Value: TBoldViewerFollowerController); procedure SetBoldHandle(value: TBoldElementHandle); @@ -95,7 +100,6 @@ TBoldImage = class(TCustomControl, IBoldOCLComponent) property Scale: Integer read GetScale write SetScale default 100; property Center: Boolean read fCenter write fCenter; property QuickDraw: Boolean read fQuickDraw write fQuickDraw; -// property ContentType: string //Use this property to specify property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle; property OnResize: TNotifyEvent read FOnResize write FOnResize; {Standard properties} @@ -138,8 +142,6 @@ implementation uses SysUtils, - BoldGuiResourceStrings, - BoldDefs, BoldControlPackDefs; {-- TBoldImage --} @@ -205,7 +207,6 @@ function TBoldImage.GetViewer: TBoldAbstractViewAdapter; procedure TBoldImage.SetViewer(Value: TBoldAbstractViewAdapter); begin fBoldProperties.MayHaveChanged(Value, Follower); -// Invalidate; end; procedure TBoldImage.SetBorderStyle(Value: TBorderStyle); @@ -314,12 +315,10 @@ procedure TBoldImage.WMSize(var Message: TMessage); procedure TBoldImage.CMTextChanged(var Message: TMessage); begin inherited; -// FIXME Invalidate to redraw Caption when there is no picture end; procedure TBoldImage.WMEraseBkgnd(var Message: TWMEraseBkgnd); begin -//Ignore erase background to prevent flicker end; {} @@ -447,7 +446,7 @@ procedure TBoldImage.Paint; if (csDesigning in ComponentState) then S := '(' + Name + ')' else - S := ''; //FIXME Some text in runtime? + S := ''; Size := TextExtent(S); R := ClientRect; TextRect(R, (R.Right - Size.cx) div 2, (R.Bottom - Size.cy) div 2, S); @@ -536,8 +535,7 @@ procedure TBoldImage.PasteFromClipboard; aViewer: TBoldAbstractViewAdapter; function GetViewer: TBoldAbstractViewAdapter; - // FixMe: Could be a classmethod on TBoldAbstractViewAdapter - // reuse in method above aswell /JoHo + var I: Integer; begin @@ -564,7 +562,7 @@ procedure TBoldImage.PasteFromClipboard; Follower.Apply; end else - raise EBold.CreateFmt(sUnknownFileFormat, [ClassName, FileName]); + raise EBold.CreateFmt('%s.LoadFromFile: File format unknown: File: ''%s''', [ClassName, FileName]); end; end; @@ -586,14 +584,14 @@ function TBoldImage.GetContextType: TBoldElementTypeInfo; Result := nil; end; -function TBoldImage.GetExpression: String; +function TBoldImage.GetExpression: TBoldExpression; begin Result := BoldProperties.Expression; end; -procedure TBoldImage.SetExpression(Expression: String); +procedure TBoldImage.SetExpression(const Value: TBoldExpression); begin - BoldProperties.Expression := Expression; + BoldProperties.Expression := Value; end; function TBoldImage.GetVariableList: TBoldExternalVariableList; diff --git a/Source/BoldAwareGUI/BoldControls/BoldImageBitmap.pas b/Source/BoldAwareGUI/BoldControls/BoldImageBitmap.pas index 5030286c..0272ce8f 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldImageBitmap.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldImageBitmap.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldImageBitmap; {$UNDEF BOLDCOMCLIENT} @@ -5,7 +8,7 @@ interface uses - Windows, // Delphi Units + Windows, Classes, Graphics, Clipbrd, @@ -29,7 +32,7 @@ TBoldViewBitmapAdapter = class(TBoldAbstractViewAdapter) function HasChanged: Boolean; override; class function CanReadContent(const ContentType: string): Boolean; override; function ContentType: string; override; - class function Description: string; override; // How to handle Localizastion? + class function Description: string; override; {Clipboard} procedure CopyToClipboard; override; class function CanPasteFromClipboard(const AcceptedContentType: string): Boolean; override; @@ -39,7 +42,7 @@ TBoldViewBitmapAdapter = class(TBoldAbstractViewAdapter) procedure SaveToStream(Stream: TStream); override; {Files} class function DefaultExtension: string; override; - class function FileFilter: string; override; // How to handle Localizastion? + class function FileFilter: string; override; class function CanLoadFromFile(const Filename: string): Boolean; override; procedure LoadFromFile(const Filename: string); override; procedure SaveToFile(const Filename: string); override; @@ -54,12 +57,7 @@ implementation uses SysUtils, - BoldGuiResourceStrings; - -const - MIME_image_bmp = 'image/bmp'; - MIME_image_bitmap = 'image/bitmap'; - + BoldRev; {-- TBoldViewBitmapAdapter --} @@ -105,8 +103,8 @@ class function TBoldViewBitmapAdapter.CanReadContent(const ContentType: string): begin S := AnsiLowerCase(ContentType); Result := (S = '') or - (S = MIME_image_bitmap) or - (S = MIME_image_bmp); + (S = 'image/bitmap') or + (S = 'image/bmp'); end; function TBoldViewBitmapAdapter.ContentType: string; @@ -114,12 +112,12 @@ function TBoldViewBitmapAdapter.ContentType: string; if Empty then Result := '' else - Result := MIME_image_bitmap + Result := 'image/bitmap' end; class function TBoldViewBitmapAdapter.Description: string; begin - Result := sBitMapImage; + Result := 'Bitmap image' end; {Clipboard} @@ -136,8 +134,8 @@ class function TBoldViewBitmapAdapter.CanPasteFromClipboard(const AcceptedConten S := AnsiLowerCase(AcceptedContentType); Result := Clipboard.HasFormat(CF_BITMAP) and ((S = '') or - (S = 'image/*') or // do not localize - (S = MIME_image_bitmap)); + (S = 'image/*') or + (S = 'image/bitmap')); end; procedure TBoldViewBitmapAdapter.PasteFromClipboard; @@ -162,12 +160,12 @@ procedure TBoldViewBitmapAdapter.SaveToStream(Stream: TStream); {Files} class function TBoldViewBitmapAdapter.DefaultExtension: string; begin - Result := 'bmp'; // do not localize + Result := 'bmp'; end; class function TBoldViewBitmapAdapter.FileFilter: string; begin - Result := Format('%s (*.bmp)|*.bmp', [Description]); // do not localize + Result := Format('%s (*.bmp)|*.bmp', [Description]); end; class function TBoldViewBitmapAdapter.CanLoadFromFile(const Filename: string): Boolean; @@ -176,7 +174,7 @@ class function TBoldViewBitmapAdapter.CanLoadFromFile(const Filename: string): B begin Extension := ExtractFileExt(FileName); Extension := Copy(Extension, 2, Length(Extension)); - Result := CompareText(Extension, 'bmp') = 0; // do not localize + Result := CompareText(Extension, 'bmp') = 0; end; procedure TBoldViewBitmapAdapter.LoadFromFile(const Filename: string); @@ -235,5 +233,5 @@ function TBoldViewBitmapAdapter.Height: Integer; initialization TBoldViewBitmapAdapter.RegisterViewAdapter(TBoldViewBitmapAdapter); - + end. diff --git a/Source/BoldAwareGUI/BoldControls/BoldImageJPEG.pas b/Source/BoldAwareGUI/BoldControls/BoldImageJPEG.pas index eff55bbb..1ce3dfc2 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldImageJPEG.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldImageJPEG.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldImageJPEG; {$UNDEF BOLDCOMCLIENT} @@ -30,7 +33,7 @@ TBoldViewJPEGAdapter = class(TBoldAbstractViewAdapter) function HasChanged: Boolean; override; class function CanReadContent(const ContentType: string): Boolean; override; function ContentType: string; override; - class function Description: string; override; // How to handle Localizastion? + class function Description: string; override; {Clipboard} procedure CopyToClipboard; override; class function CanPasteFromClipboard(const AcceptedContentType: string): Boolean; override; @@ -40,7 +43,7 @@ TBoldViewJPEGAdapter = class(TBoldAbstractViewAdapter) procedure SaveToStream(Stream: TStream); override; {Files} class function DefaultExtension: string; override; - class function FileFilter: string; override; // How to handle Localizastion? + class function FileFilter: string; override; class function CanLoadFromFile(const Filename: string): Boolean; override; procedure LoadFromFile(const Filename: string); override; procedure SaveToFile(const Filename: string); override; @@ -55,10 +58,8 @@ implementation uses SysUtils, - BoldGuiResourceStrings; + BoldRev; -const - MIME_image_jpeg = 'image/jpeg'; {-- TBoldViewJPEGAdapter --} @@ -103,7 +104,7 @@ class function TBoldViewJPEGAdapter.CanReadContent(const ContentType: string): B S: string; begin S := AnsiLowerCase(ContentType); - Result := (S = MIME_image_jpeg); + Result := (S = 'image/jpeg'); end; function TBoldViewJPEGAdapter.ContentType: string; @@ -111,12 +112,12 @@ function TBoldViewJPEGAdapter.ContentType: string; if Empty then Result := '' else - Result := MIME_image_jpeg + Result := 'image/jpeg' end; class function TBoldViewJPEGAdapter.Description: string; begin - Result := sJpegImage; + Result := 'JPEG image' end; {Clipboard} @@ -132,12 +133,12 @@ class function TBoldViewJPEGAdapter.CanPasteFromClipboard(const AcceptedContentT begin S := AnsiLowerCase(AcceptedContentType); Result := Clipboard.HasFormat(CF_BITMAP) and - ((S = '') or (S = 'image/*') or (S = MIME_image_jpeg)); // do not localize + ((S = '') or (S = 'image/*') or (S = 'image/jpeg')); end; type THack = class(TJPEGImage) - end; //FIX to access NewBitmap so LoadFromClipboardFormat does not return an exception. + end; procedure TBoldViewJPEGAdapter.PasteFromClipboard; var @@ -173,12 +174,12 @@ procedure TBoldViewJPEGAdapter.SaveToStream(Stream: TStream); {Files} class function TBoldViewJPEGAdapter.DefaultExtension: string; begin - Result := 'jpg'; // do not localize + Result := 'jpg'; end; class function TBoldViewJPEGAdapter.FileFilter: string; begin - Result := Format('%s (*.jpg, *.jpeg)|*.jpg;*.jpeg', [Description]); // do not localize + Result := Format('%s (*.jpg, *.jpeg)|*.jpg;*.jpeg', [Description]); end; class function TBoldViewJPEGAdapter.CanLoadFromFile(const Filename: string): Boolean; @@ -187,8 +188,8 @@ class function TBoldViewJPEGAdapter.CanLoadFromFile(const Filename: string): Boo begin Extension := ExtractFileExt(FileName); Extension := Copy(Extension, 2, Length(Extension)); - Result := (CompareText(Extension, 'jpg') = 0) or // do not localize - (CompareText(Extension, 'jpeg') = 0); // do not localize + Result := (CompareText(Extension, 'jpg') = 0) or + (CompareText(Extension, 'jpeg') = 0); end; procedure TBoldViewJPEGAdapter.LoadFromFile(const Filename: string); @@ -215,6 +216,7 @@ procedure TBoldViewJPEGAdapter.SaveToFile(const Filename: string); end; end; + {Canvas} procedure TBoldViewJPEGAdapter.Paint(Canvas: TCanvas; Rect: TRect); begin @@ -247,5 +249,4 @@ function TBoldViewJPEGAdapter.Height: Integer; initialization TBoldViewJPEGAdapter.RegisterViewAdapter(TBoldViewJPEGAdapter); - end. diff --git a/Source/BoldAwareGUI/BoldControls/BoldLabel.pas b/Source/BoldAwareGUI/BoldControls/BoldLabel.pas index 7b834f6b..f811b0ee 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldLabel.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldLabel.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLabel; {$UNDEF BOLDCOMCLIENT} @@ -10,12 +13,13 @@ interface Graphics, Controls, StdCtrls, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after + BoldEnvironmentVCL, BoldHandles, BoldControlPack, BoldElements, BoldStringControlPack, - BoldElementHandleFollower; + BoldElementHandleFollower, + BoldDefs; type {Forward declaration of classes} @@ -31,8 +35,8 @@ TBoldCustomLabel = class(TCustomLabel, IBoldOCLComponent) fMyColor: TColor; fMyFont: TFont; function GetContextType: TBoldElementTypeInfo; - procedure SetExpression(Expression: String); - function GetExpression: String; + procedure SetExpression(const Value: TBoldExpression); + function GetExpression: TBoldExpression; function GetVariableList: TBoldExternalVariableList; procedure _FontChanged(sender: TObject); procedure AfterMakeUptoDate(Follower: TBoldFollower); @@ -72,6 +76,7 @@ TBoldCustomLabel = class(TCustomLabel, IBoldOCLComponent) end; { TBoldLabel } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldLabel = class(TBoldCustomLabel) public {$IFNDEF T2H} @@ -138,7 +143,7 @@ constructor TBoldCustomLabel.Create(AOwner: TComponent); fMyFont.OnChange := _FontChanged; fMyColor := EffectiveColor; if (csDesigning in ComponentState) then - ParentColor := True; //CHECKME This should not be necesary... + ParentColor := True; end; destructor TBoldCustomLabel.Destroy; @@ -211,7 +216,7 @@ function TBoldCustomLabel.GetEffectiveColor: TColor; procedure TBoldCustomLabel.SetEffectiveColor(v: TColor); begin - if (EffectiveColor <> v) and not ParentColor then + if EffectiveColor <> v then begin inherited Color := v; if (csDesigning in ComponentState) then @@ -236,7 +241,6 @@ procedure TBoldCustomLabel.AfterMakeUptoDate(Follower: TBoldFollower); begin if (csDesigning in ComponentState) then begin - // caption during design-time with BoldProperties do if Assigned(Renderer) then NewText := Format('%s.%s', [Renderer.name, Expression]) @@ -246,20 +250,16 @@ procedure TBoldCustomLabel.AfterMakeUptoDate(Follower: TBoldFollower); NewText := name; end else - // Caption at run-time newText := BoldProperties.GetCurrentAsString(Follower); if Text <> newText then Text := newText; BoldProperties.SetFont(EffectiveFont, Font, Follower); - if not parentColor then - begin - ec := EffectiveColor; - BoldProperties.SetColor(ec, Color, Follower); - EffectiveColor := ec; - end; -end; + ec := EffectiveColor; + BoldProperties.SetColor(ec, Color, Follower); + EffectiveColor := ec; +end; function TBoldCustomLabel.GetText: TCaption; begin @@ -284,14 +284,14 @@ function TBoldCustomLabel.GetContextType: TBoldElementTypeInfo; result := nil; end; -function TBoldCustomLabel.GetExpression: String; +function TBoldCustomLabel.GetExpression: TBoldExpression; begin result := BoldProperties.Expression; end; -procedure TBoldCustomLabel.SetExpression(Expression: String); +procedure TBoldCustomLabel.SetExpression(const Value: TBoldExpression); begin - BoldProperties.Expression := Expression; + BoldProperties.Expression := Value; end; function TBoldCustomLabel.GetVariableList: TBoldExternalVariableList; @@ -328,4 +328,3 @@ procedure TBoldCustomLabel.DragDrop(Source: TObject; X, Y: Integer); end; end. - diff --git a/Source/BoldAwareGUI/BoldControls/BoldListBox.pas b/Source/BoldAwareGUI/BoldControls/BoldListBox.pas index 06d4584f..3b57c079 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldListBox.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldListBox.pas @@ -1,6 +1,10 @@ +///////////////////////////////////////////////////////// + + unit BoldListBox; {$UNDEF BOLDCOMCLIENT} +{$INCLUDE bold.inc} interface @@ -22,7 +26,8 @@ interface BoldControlPack, BoldListHandleFollower, BoldListListControlPack, - BoldStringControlPack; + BoldStringControlPack, + BoldDefs; // CHECKME is a destroywind needed that saves the extra list. // when is DestroyWnd actually called. @@ -42,8 +47,8 @@ TBoldCustomListBox = class(TCustomListBox, IBoldOCLComponent) fBoldRowProperties: TBoldStringFollowerController; function GetContextType: TBoldElementTypeInfo; - procedure SetExpression(Expression: String); - function GetExpression: String; + procedure SetExpression(const Value: TBoldExpression); + function GetExpression: TBoldExpression; function GetVariableList: TBoldExternalVariableList; function GetBoldHandle: TBoldAbstractListHandle; @@ -54,10 +59,10 @@ TBoldCustomListBox = class(TCustomListBox, IBoldOCLComponent) function GetCurrentBoldElement: TBoldElement; function GetCurrentBoldObject: TBoldObject; function GetBoldList: TBoldList; - function GetItemIndex: Integer; + function GetItemIndex: Integer; reintroduce; function GetBoldHandleIndexLock: Boolean; procedure SetBoldHandleIndexLock(Value: Boolean); - procedure SetItemIndex(Value: Integer); + procedure SetItemIndex(Value: Integer); reintroduce; procedure SetSelected(index: Integer; V: Boolean); procedure InternalSetSelected(index: integer; v: Boolean); procedure SetSelection(aRow: Integer; Shift: TShiftState); @@ -65,7 +70,7 @@ TBoldCustomListBox = class(TCustomListBox, IBoldOCLComponent) procedure SetAlignment(Value: TAlignment); procedure _BeforeMakeUptoDate(Follower: TBoldFollower); procedure _AfterMakeUptoDate(Follower: TBoldFollower); - procedure _InsertItem(Follower: TBoldFollower); + procedure _InsertItem(index: Integer; Follower: TBoldFollower); procedure _DeleteItem(index: Integer; OwningFollower: TBoldFollower); procedure _RowAfterMakeUptoDate(Follower: TBoldFollower); procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM; @@ -105,6 +110,7 @@ TBoldCustomListBox = class(TCustomListBox, IBoldOCLComponent) end; {---TBoldListBox---} + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldListBox = class(TBoldCustomListBox) public {$IFNDEF T2H} @@ -177,6 +183,7 @@ implementation BoldGui, // IFNDEF BOLDCOMCLIENT {$ENDIF} BoldControlPackDefs, + BoldGuiResourceStrings, BoldListControlPack; {---TBoldCustomListBox---} @@ -187,13 +194,10 @@ constructor TBoldCustomListBox.Create(AOwner: TComponent); fBoldRowProperties.AfterMakeUptoDate := _RowAfterMakeUptoDate; fBoldRowProperties.OnGetContextType := GetContextType; fBoldProperties := TBoldListAsFollowerListController.Create(Self, fBoldRowProperties); - with fBoldProperties do - begin - OnAfterInsertItem := _InsertItem; - OnAfterDeleteItem := _DeleteItem; - BeforeMakeUptoDate := _BeforeMakeUptoDate; - AfterMakeUptoDate := _AfterMakeUptoDate; - end; + fBoldProperties.OnAfterInsertItem := _InsertItem; + fBoldProperties.OnAfterDeleteItem := _DeleteItem; + fBoldProperties.BeforeMakeUptoDate := _BeforeMakeUptoDate; + fBoldProperties.AfterMakeUptoDate := _AfterMakeUptoDate; fHandleFollower := TBoldListHandleFollower.Create(Owner, fBoldProperties); DragMode := dmAutomatic; Style := lbOwnerDrawVariable; @@ -361,11 +365,13 @@ function TBoldCustomListBox.GetCurrentBoldElement: TBoldElement; var Subfollower: TBoldFollower; begin - SubFollower := Follower.SubFollowers[ItemIndex]; - if assigned(SubFollower) then - Result := Subfollower.Element - else - Result := nil; + Result := nil; + if ItemIndex <> -1 then + begin + SubFollower := Follower.SubFollowers[ItemIndex]; + if assigned(SubFollower) then + Result := Subfollower.Element + end; end; function TBoldCustomListBox.GetBoldList: TBoldList; @@ -401,9 +407,11 @@ procedure TBoldCustomListBox._RowAfterMakeUptoDate(Follower: TBoldFollower); Items[index] := TBoldStringFollowerController(Follower.Controller).GetCurrentAsString(Follower); end; -procedure TBoldCustomListBox._InsertItem(Follower: TBoldFollower); +procedure TBoldCustomListBox._InsertItem(index: Integer; Follower: TBoldFollower); begin - Items.Insert(Follower.Index, ''); + Assert(Assigned(Follower)); + Follower.EnsureDisplayable; + Items.Insert(Follower.Index, TBoldStringFollowerController(Follower.Controller).GetCurrentAsString(Follower)); end; procedure TBoldCustomListBox._DeleteItem(index: Integer; OwningFollower: TBoldFollower); @@ -453,6 +461,8 @@ procedure TBoldCustomListBox.CNDrawItem(var Message: TWMDrawItem); State: TOwnerDrawState; SignedItemId: integer; // this variable is used to suppress warning from D4 when comparing signed and unsigned values begin + {$WARN UNSAFE_CAST OFF} + {$WARN UNSAFE_CODE OFF} with Message.DrawItemStruct^ do begin State := TOwnerDrawState(LongRec(itemState).Lo); @@ -467,6 +477,8 @@ procedure TBoldCustomListBox.CNDrawItem(var Message: TWMDrawItem); //FIXME Apperens of selected and current... Canvas.DrawFocusRect(rcItem); end; + {$WARN UNSAFE_CAST ON} + {$WARN UNSAFE_CODE ON} end; procedure TBoldCustomListBox.DefaultSetFontAndColor(index: Integer); @@ -479,12 +491,10 @@ procedure TBoldCustomListBox.DefaultSetFontAndColor(index: Integer); Canvas.Brush.Color := ec; // Selected state yields default highlight colors SubFollower := Follower.SubFollowers[index]; - if assigned(Subfollower) and Subfollower.Selected then - with Canvas do - begin - Brush.Color := clHighlight; - Font.Color := clHighlightText; - end; + if assigned(Subfollower) and Subfollower.Selected then begin + Canvas.Brush.Color := clHighlight; + Canvas.Font.Color := clHighlightText; + end; end; procedure TBoldCustomListBox.DefaultDrawItem(Index: integer; Rect: TRect); @@ -553,9 +563,9 @@ function TBoldCustomListBox.GetExpression: String; result := BoldRowProperties.Expression; end; -procedure TBoldCustomListBox.SetExpression(Expression: String); +procedure TBoldCustomListBox.SetExpression(const Value: TBoldExpression); begin - BoldRowProperties.Expression := Expression; + BoldRowProperties.Expression := Value; end; function TBoldCustomListBox.GetBoldHandleIndexLock: Boolean; @@ -594,3 +604,4 @@ procedure TBoldCustomListBox.InternalSetSelected(index: integer; v: Boolean); end. + diff --git a/Source/BoldAwareGUI/BoldControls/BoldMemo.pas b/Source/BoldAwareGUI/BoldControls/BoldMemo.pas index 663e486e..470abaca 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldMemo.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldMemo.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldMemo; {$UNDEF BOLDCOMCLIENT} @@ -11,12 +14,13 @@ interface Controls, StdCtrls, Menus, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after + BoldEnvironmentVCL, BoldHandles, BoldElements, BoldControlPack, BoldStringControlPack, - BoldElementHandleFollower; + BoldElementHandleFollower, + BoldDefs; type TBoldCustomMemo = class; @@ -36,8 +40,8 @@ TBoldCustomMemo = class(TCustomMemo, IBoldOCLComponent) fMyReadOnly: Boolean; fMaxLength: integer; function GetContextType: TBoldElementTypeInfo; - procedure SetExpression(Expression: String); - function GetExpression: String; + procedure SetExpression(const Value: TBoldExpression); + function GetExpression: TBoldExpression; function GetVariableList: TBoldExternalVariableList; procedure _FontChanged(sender: TObject); @@ -89,6 +93,7 @@ TBoldCustomMemo = class(TCustomMemo, IBoldOCLComponent) end; {---TBoldMemo---} + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldMemo = class(TBoldCustomMemo) public {$IFNDEF T2H} @@ -151,8 +156,7 @@ implementation uses SysUtils, - BoldGuiResourceStrings, - BoldDefs, + BoldUtils, BoldControlPackDefs; {---TBoldCustomMemo---} @@ -290,7 +294,7 @@ function TBoldCustomMemo.GetEffectiveColor: TColor; procedure TBoldCustomMemo.SetEffectiveColor(v: TColor); begin - if (EffectiveColor <> v) and not ParentColor then + if EffectiveColor <> v then inherited Color := v; end; @@ -300,7 +304,7 @@ procedure TBoldCustomMemo.SetText(value: string); if not EffectiveReadOnly then inherited Text := value else - raise Exception.CreateFmt(sTextNotModifiable, [ClassName]); + raise Exception.CreateFmt('%s.Text: Not modifiable', [ClassName]); end; function TBoldCustomMemo.GetText: string; @@ -318,13 +322,13 @@ function TBoldCustomMemo.GetPopupmenu: TPopupMenu; procedure TBoldCustomMemo.KeyPress(var Key: Char); begin inherited KeyPress(Key); - if (Key in [#32..#255]) and + if CharInSet(Key, [#32..#255]) and not BoldProperties.ValidateCharacter(Key, Follower) then begin MessageBeep(0); Key := BOLDNULL; end; - + if Key = BOLDESC then begin Follower.DiscardChange; @@ -363,12 +367,9 @@ procedure TBoldCustomMemo.AfterMakeUptoDate(Follower: TBoldFollower); inherited ReadOnly := FMyReadOnly or not BoldProperties.MayModify(Follower); BoldProperties.SetFont(EffectiveFont, Font, Follower); - if not ParentColor then - begin - ec := EffectiveColor; - BoldProperties.SetColor(ec, Color, Follower); - EffectiveColor := ec; - end; + ec := EffectiveColor; + BoldProperties.SetColor(ec, Color, Follower); + EffectiveColor := ec; EffectiveMaxLength := 0; RendererDataMaxLength := (Follower.RendererData as TBoldStringRendererData).MaxStringLength; @@ -390,7 +391,7 @@ procedure TBoldCustomMemo.CMEnter(var Message: TCMEnter); procedure TBoldCustomMemo.CMExit(var Message: TCMExit); begin if (Follower.Controller.ApplyPolicy = bapExit) then - Follower.Apply; + Follower.Apply; SetFocused(False); DoExit; end; @@ -413,14 +414,14 @@ function TBoldCustomMemo.GetContextType: TBoldElementTypeInfo; Result := nil; end; -function TBoldCustomMemo.GetExpression: String; +function TBoldCustomMemo.GetExpression: TBoldExpression; begin result := BoldProperties.Expression; end; -procedure TBoldCustomMemo.SetExpression(Expression: String); +procedure TBoldCustomMemo.SetExpression(const Value: TBoldExpression); begin - BoldProperties.Expression := Expression; + BoldProperties.Expression := Value; end; function TBoldCustomMemo.GetVariableList: TBoldExternalVariableList; @@ -428,5 +429,6 @@ function TBoldCustomMemo.GetVariableList: TBoldExternalVariableList; result := BoldProperties.VariableList; end; -end. +initialization +end. diff --git a/Source/BoldAwareGUI/BoldControls/BoldNavigator.pas b/Source/BoldAwareGUI/BoldControls/BoldNavigator.pas index 2150fb0c..512701a4 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldNavigator.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldNavigator.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldNavigator; {$UNDEF BOLDCOMCLIENT} @@ -11,9 +14,9 @@ interface Controls, ExtCtrls, Buttons, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after + BoldEnvironmentVCL, BoldElements, - {$IFNDEF BOLDCOMCLIENT} // uses + {$IFNDEF BOLDCOMCLIENT} BoldSystem, {$ENDIF} BoldDefs, @@ -24,7 +27,7 @@ interface BoldControlPack, BoldCommonBitmaps, BoldListControlPack, - BoldListListControlPack; + BoldListListControlPack; type { forward declarations } @@ -97,12 +100,13 @@ TBoldCustomNavigator = class(TBoldNavigateBtnImageIndexOwner) public constructor Create(AOwner: TComponent); override; destructor Destroy; override; - procedure Assign(Source: TPersistent); override; + procedure assign(Source: TPersistent); override; procedure BtnClick(index: TBoldNavigateBtn); procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; end; { TBoldNavigator } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldNavigator = class(TBoldCustomNavigator) published {$IFNDEF T2H} @@ -161,7 +165,6 @@ implementation BoldControlsDefs; var -// BtnTypeName: array[TBoldNavigateBtn] of PChar = ('FIRST', 'PRIOR', 'NEXT', 'LAST', 'INSERT', 'DELETE', 'MOVEUP', 'MOVEDOWN'); //Do not localize BtnHintId: array[TBoldNavigateBtn] of Pointer = (@SNavHintFirst, @SNavHintPrior, @SNavHintNext, @SNavHintLast, @SNavHintNew, @SNavHintDelete, @SNavHintMoveUp, @SNavHintMoveDown); procedure TBoldCustomNavigator.InitHints; @@ -202,8 +205,7 @@ procedure TBoldCustomNavigator.SetHints(Value: TStrings); procedure TBoldCustomNavigator.GetChildren(Proc: TGetChildProc; ROOT: TComponent); begin - // Implementation is empty to prevent control - // from behaving like a TPanel + end; procedure TBoldCustomNavigator.SetVisible(Value: TBoldButtonSet); @@ -444,10 +446,10 @@ constructor TBoldCustomNavigator.Create(AOwner: TComponent); fBoldProperties.AfterMakeUptoDate := _AfterMakeUptoDate; fBoldProperties.BeforeMakeUptoDate := _BeforeMakeUptoDate; - fDeleteQuestion := sDeleteQuestion; + fDeleteQuestion := 'Delete "%1:s"?'; {$IFNDEF BOLDCOMCLIENT} - fUnlinkQuestion := sUnlinkQuestion; - fRemoveQuestion := sRemoveQuestion; + fUnlinkQuestion := 'Unlink "%1:s" from "%2:s"?'; + fRemoveQuestion := 'Remove "%1:s" from the list?'; {$ENDIF} end; @@ -513,7 +515,6 @@ procedure TBoldCustomNavigator.BtnClick(index: TBoldNavigateBtn); if BoldDeleteMode = dmDefault then begin - // Delete from classlists, remove from other lists if assigned(BoldHandle.ObjectList) and (BoldHandle.ObjectList.OwningElement is TBoldSystem) then EffectiveDeleteMode := dmDelete else @@ -526,7 +527,6 @@ procedure TBoldCustomNavigator.BtnClick(index: TBoldNavigateBtn); begin if assigned(RoleRTInfo) then begin - // linkobjects will be deleted... other objects will be unlinked if RoleRTInfo.RoleType = rtLinkRole then EffectiveDeleteMode := dmDelete else @@ -592,7 +592,7 @@ procedure TBoldCustomNavigator.BtnClick(index: TBoldNavigateBtn); nbInsert: CurrentIndex := List.IndexOf(MutableList.AddNew); nbDelete: - Delete(fConfirmDelete); //FIXME Localize + Delete(fConfirmDelete); nbMoveUp: List.Move(CurrentIndex, CurrentIndex - 1); nbMoveDown: @@ -685,7 +685,7 @@ function TBoldCustomNavigator.MapMinus(CanDeleteObject: Boolean): Boolean; dmUnlinkAllAndDelete: Result := True; else - raise EBold.CreateFmt(sUnknownDeleteMode, [ClassName]); + raise EBold.CreateFmt('%s.MapMinus: Unknown delete mode', [ClassName]); end; end; @@ -750,9 +750,10 @@ procedure TBoldCustomNavigator.SetImages(const Value: TImageList); procedure TBoldCustomNavigator._BeforeMakeUptoDate(Follower: TBoldFollower); begin - fBoldProperties.SetActiveRange(Follower, BoldHandle.CurrentIndex, BoldHandle.CurrentIndex); + if Assigned(BoldHandle) then + fBoldProperties.SetActiveRange(Follower, BoldHandle.CurrentIndex, BoldHandle.CurrentIndex) end; -end. - +initialization +end. diff --git a/Source/BoldAwareGUI/BoldControls/BoldPageControl.pas b/Source/BoldAwareGUI/BoldControls/BoldPageControl.pas index a8f77e2d..b3f7b3e7 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldPageControl.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldPageControl.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPageControl; {$UNDEF BOLDCOMCLIENT} @@ -7,7 +10,7 @@ interface uses Classes, Controls, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after + BoldEnvironmentVCL, Boldhandles, BoldControlPack, BoldElementHandleFollower, @@ -16,6 +19,7 @@ interface ComCtrls; type + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldPageControl = class(TPageControl) private { Private declarations } @@ -32,8 +36,8 @@ TBoldPageControl = class(TPageControl) property Follower: TBoldFollower read GetFollower; public { Public declarations } - constructor Create(owner: TComponent); override; - destructor Destroy; override; + constructor create(owner: TComponent); override; + destructor destroy; override; published { Published declarations } property BoldHandle: TBoldElementHandle read GetBoldHandle write SetBoldHandle; @@ -57,7 +61,7 @@ constructor TBoldPageControl.create(owner: TComponent); fBoldProperties.OnGetContextType := _GetContextType; end; -destructor TBoldPageControl.Destroy; +destructor TBoldPageControl.destroy; begin FreeAndNil(fHandleFollower); FreeAndNil(fBoldProperties); @@ -107,4 +111,6 @@ function TBoldPageControl._GetContextType: TBoldElementTypeInfo; result := nil; end; +initialization + end. diff --git a/Source/BoldAwareGUI/BoldControls/BoldProgressBar.pas b/Source/BoldAwareGUI/BoldControls/BoldProgressBar.pas index 49f56dd6..a22f4c45 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldProgressBar.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldProgressBar.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldProgressBar; {$UNDEF BOLDCOMCLIENT} @@ -9,18 +12,20 @@ interface Controls, ComCtrls, Menus, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after + BoldEnvironmentVCL, BoldElements, BoldHandles, BoldControlPack, BoldNumericControlPack, - BoldElementHandleFollower; + BoldElementHandleFollower, + BoldDefs; type { forward declarations } TBoldProgressBar = class; { TBoldProgressBar } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldProgressBar = class(TProgressBar, IBoldOCLComponent) private FEffectiveReadOnly: Boolean; @@ -28,8 +33,8 @@ TBoldProgressBar = class(TProgressBar, IBoldOCLComponent) FBoldProperties: TBoldIntegerFollowerController; fHandleFollower: TBoldElementHandleFollower; function GetContextType: TBoldElementTypeInfo; - procedure SetExpression(Expression: String); - function GetExpression: String; + procedure SetExpression(const Value: TBoldExpression); + function GetExpression: TBoldExpression; function GetVariableList: TBoldExternalVariableList; procedure AfterMakeUptoDate(Follower: TBoldFollower); function GetBoldHandle: TBoldElementHandle; @@ -61,7 +66,6 @@ implementation uses BoldControlPackDefs, - BoldDefs, SysUtils, BoldGuiResourceStrings, BoldControlsDefs; @@ -163,14 +167,14 @@ function TBoldProgressBar.GetContextType: TBoldElementTypeInfo; result := nil; end; -function TBoldProgressBar.GetExpression: String; +function TBoldProgressBar.GetExpression: TBoldExpression; begin result := BoldProperties.Expression; end; -procedure TBoldProgressBar.SetExpression(Expression: String); +procedure TBoldProgressBar.SetExpression(const Value: TBoldExpression); begin - BoldProperties.Expression := Expression; + BoldProperties.Expression := Value; end; function TBoldProgressBar.GetPosition: integer; diff --git a/Source/BoldAwareGUI/BoldControls/BoldPropertiesController.pas b/Source/BoldAwareGUI/BoldControls/BoldPropertiesController.pas index dad7c269..87632a61 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldPropertiesController.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldPropertiesController.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPropertiesController; {$UNDEF BOLDCOMCLIENT} @@ -6,12 +9,13 @@ interface uses Classes, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after + BoldEnvironmentVCL, BoldElements, BoldHandles, BoldControlPack, BoldStringControlPack, - BoldElementHandleFollower; + BoldElementHandleFollower, + BoldOclVariables; type { forward declarations } @@ -67,6 +71,7 @@ TBoldDrivenProperty = class(TCollectionItem) end; { TBoldPropertiesController } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldPropertiesController = class(TComponent) private FHandleFollower: TBoldElementHandleFollower; @@ -91,6 +96,9 @@ TBoldPropertiesController = class(TComponent) property DrivenProperties: TBoldDrivenPropertyCollection read FDrivenProperties write SetDrivenProperties; end; + procedure CreatePropertyControllerMapping(aBoldHandle: TBoldElementHandle; aExpression: string; + aVCLComponent: TComponent; aPropertyName: string; aReadOnly: boolean = true; aBoldVariables: TBoldOclVariables = nil); + implementation uses @@ -98,15 +106,27 @@ implementation TypInfo, BoldControlPackDefs, BoldControlsDefs, - BoldGuiResourceStrings, {$IFNDEF BOLDCOMCLIENT} - BoldSystem, // IFNDEF BOLDCOMCLIENT + BoldSystem, {$ENDIF} Variants, BoldGuard; -const - EventNameOnExit = 'OnExit'; +procedure CreatePropertyControllerMapping(aBoldHandle: TBoldElementHandle; aExpression: string; + aVCLComponent: TComponent; aPropertyName: string; aReadOnly: boolean; aBoldVariables: TBoldOclVariables); +var + lBoldPropertiesController: TBoldPropertiesController; + lBoldDrivenProperty: TBoldDrivenProperty; +begin + lBoldPropertiesController:= TBoldPropertiesController.Create(aVCLComponent); + lBoldPropertiesController.BoldHandle:= aBoldHandle; + lBoldPropertiesController.BoldProperties.Expression:= aExpression; + lBoldPropertiesController.BoldProperties.Variables := aBoldVariables; + lBoldDrivenProperty:= lBoldPropertiesController.DrivenProperties.Add; + lBoldDrivenProperty.VCLComponent:= aVCLComponent; + lBoldDrivenProperty.PropertyName:= aPropertyName; + lBoldDrivenProperty.ReadOnly:= aReadOnly; +end; { TBoldPropertiesController } @@ -180,20 +200,16 @@ constructor TBoldDrivenProperty.Create(Collection: TCollection); end; procedure TBoldDrivenProperty.EnsureValidPropertyName; -// Searches through the list of properties of the assigned component to check that PropertyName -// is valid for this particular component type. If not, it empties Property Name. -// This is called by the Component property setter SetVCLComponent. -// This is not used anymore at the moment. It was easy when we did not cater for property paths ! + + + var PropList: TPropList; Count, I: Integer; Found: Boolean; begin - // At least clear the property when we clear the component if not Assigned(VCLComponent) then PropertyName := ''; - - // Original code below exit; Found := False; I := 0; @@ -202,7 +218,7 @@ procedure TBoldDrivenProperty.EnsureValidPropertyName; Count := GetPropList(VCLComponent.ClassInfo, BoldPropertiesController_SupportedPropertyTypes, @PropList); while (I < Count) and (not Found) do begin - Found := PropList[I]^.Name = PropertyName; + Found := String(PropList[I]^.Name) = PropertyName; Inc(I); end; end; @@ -214,7 +230,6 @@ procedure TBoldDrivenProperty.SetVCLComponent(const Value: TComponent); var AllowHookUnHook: Boolean; begin - //We don't support the two way update for collections of more than one driven property AllowHookUnHook := assigned(value) and not ((csDesigning in Value.ComponentState) or (Collection.Count > 1)); @@ -240,7 +255,6 @@ procedure TBoldDrivenProperty.SetReadOnly(const Value: Boolean); end; procedure TBoldDrivenProperty.DoOnExit(Sender: TObject); -// Event that we have assigned as the OnExit of VCLComponent (Hooked) begin if (not ReadOnly) and PropertiesController.BoldProperties.MayModify(PropertiesController.HandleFollower.Follower) then begin @@ -248,31 +262,27 @@ procedure TBoldDrivenProperty.DoOnExit(Sender: TObject); if PropertiesController.BoldProperties.ApplyPolicy = bapExit then PropertiesController.HandleFollower.Follower.Apply; end; - //Call the original event if Assigned(FOnExit) then FOnExit(Sender); end; procedure TBoldDrivenProperty.HookOnExit; -// This method, replaces any existing OnExit event of VCLComponent with ours var DoOnExitMethod: TNotifyEvent; begin - // We could have simply used TWinControl(VCLComponent).OnExit := ... if only it was not protected ! - // Has the VCLComponent got an OnExit event ? - if Assigned(VCLComponent) and Assigned(GetPropInfo(VCLComponent.ClassInfo, EventNameOnExit)) then + + if Assigned(VCLComponent) and Assigned(GetPropInfo(VCLComponent.ClassInfo, 'OnExit')) then begin - FOnExit := TNotifyEvent(Typinfo.GetMethodProp(VCLComponent, EventNameOnExit)); + FOnExit := TNotifyEvent(Typinfo.GetMethodProp(VCLComponent, 'OnExit')); DoOnExitMethod := DoOnExit; - Typinfo.SetMethodProp(VCLComponent, EventNameOnExit, TMethod(DoOnExitMethod)); + Typinfo.SetMethodProp(VCLComponent, 'OnExit', TMethod(DoOnExitMethod)); end; end; procedure TBoldDrivenProperty.UnhookOnExit; begin - // Reassign the original event - if Assigned(VCLComponent) and Assigned(GetPropInfo(VCLComponent.ClassInfo, EventNameOnExit)) then - Typinfo.SetMethodProp(VCLComponent, EventNameOnExit, TMethod(FOnExit)); + if Assigned(VCLComponent) and Assigned(GetPropInfo(VCLComponent.ClassInfo, 'OnExit')) then + Typinfo.SetMethodProp(VCLComponent, 'OnExit', TMethod(FOnExit)); end; procedure TBoldDrivenProperty.SetPropertyValue(Follower: TBoldFollower); @@ -298,7 +308,7 @@ procedure TBoldDrivenProperty.SetPropertyValue(Follower: TBoldFollower); if assigned(PropertiesController.BoldHandle) and assigned(Follower.element) then begin - Follower.Element.EvaluateExpression(PropertiesController.BoldProperties.Expression, ie); + Follower.Element.EvaluateExpression(PropertiesController.BoldProperties.Expression, ie, false, PropertiesController.BoldProperties.VariableList); SendElement := ie.Value; end else @@ -314,11 +324,10 @@ function TBoldDrivenProperty.GetPropertiesController: TBoldPropertiesController; procedure TBoldDrivenProperty.ConvertRelativeProp(StartInstance: TObject; PropNamePath: String; var LastObject: TObject; var PropName: String); -// This method will follow the objects specified in the PropNamePath starting from StartInstance -// and set the LastObject and PropName -// E.g: ConvertRelativeProp(Label1,'FocusControl.Font.Size') will return -// LastObject points to instance of Font -// LastProp : Size + + + + var I, ColIndex, OpenBracketPos: Integer; @@ -328,22 +337,19 @@ procedure TBoldDrivenProperty.ConvertRelativeProp(StartInstance: TObject; begin BoldGuard := TBoldGuard.Create(Path); Path := TStringList.Create; - - //convert . notation to commas so we can use CommaText function Path.CommaText := StringReplace(PropNamePath, '.', ',', [rfReplaceAll]); LastObject := StartInstance; for I := 0 to Path.Count - 1 do begin - // The path may very well follow unassigned links. This check prevents an AV if not Assigned(LastObject) then Exit; PathItem := Path[I]; OpenBracketPos := Pos('[', PathItem); if OpenBracketPos = 0 then begin - if (I < Path.Count - 1) //Special case for when the last property is of tkClass we don't want - //to loose LastObject to be in fact the Previous before Last ! + if (I < Path.Count - 1) + and (GetPropInfo(LastObject.ClassInfo, PathItem)^.PropType^.Kind = tkClass) then begin LastObject := TObject(Typinfo.GetOrdProp(LastObject, PathItem)) @@ -373,16 +379,13 @@ procedure TBoldDrivenProperty.SetRelativePropValue(StartInstance: TObject; TypeKind: TTypeKind; PropInfo: PPropInfo; begin - // No property specified if PropNamePath = '' then Exit; ConvertRelativeProp(StartInstance, PropNamePath, LastObject, PropName); - // Property path followed unassigned links if not Assigned(LastObject) then Exit; PropInfo := GetPropInfo(LastObject.ClassInfo, PropName); - // Property name misspelled if not Assigned(PropInfo) then Exit; TypeKind := PropInfo^.PropType^.Kind; @@ -392,29 +395,25 @@ procedure TBoldDrivenProperty.SetRelativePropValue(StartInstance: TObject; {$IFDEF BOLDCOMCLIENT} VarValue := Value.AsVariant; {$ELSE} - VarValue := Value.GetAsVariant; + VarValue := Value.AsVariant; {$ENDIF} end else - // Handle nil equivalents for various property types case TypeKind of tkEnumeration: VarValue := 0; tkInteger: VarValue := 0; else VarValue := PropertiesController.BoldProperties.NilStringRepresentation; end; - - // Special case for booleans that don't seem to be handled properly by SetPropValue if VarType(VarValue) = varBoolean then begin if VarValue then - VarValue := 'True' // do not localize + VarValue := 'True' else - VarValue := 'False'; // do not localize + VarValue := 'False'; end; if TypeKind = tkClass then begin - // Special case for objects PropertyObj := TObject(Typinfo.GetOrdProp(LastObject, PropName)); if PropertyObj is TStrings then begin @@ -436,19 +435,27 @@ procedure TBoldDrivenProperty.SetRelativePropValue(StartInstance: TObject; end; end else if TypeKind = tkInteger then - // This is needed to handle an error in TypInfo when setting CARDINAL properties try + if not VarIsNull(VarValue) then SetOrdProp(LastObject, PropName, VarValue) except on E: Exception do - raise Exception.CreateFmt(sCannotSetIntegerProperty, [PropNamePath, VarValue, e.Message]); + raise Exception.CreateFmt('Could not set the integer %s property to value %s. (%s)', [PropNamePath, VarValue, e.Message]); + end + else if TypeKind = tkFloat then + try + if VarIsFloat(VarValue) then + SetPropValue(LastObject, PropName, VarValue); + except + on E: Exception do + raise Exception.CreateFmt('Could not set the float %s property to value %s. (%s)', [PropNamePath, VarValue, e.Message]); end else try SetPropValue(LastObject, PropName, VarValue); except on E: Exception do - raise Exception.CreateFmt(sCannotSetProperty, [PropNamePath, VarValue, e.Message]); + raise Exception.CreateFmt('Could not set the %s property to value %s. (%s)', [PropNamePath, VarValue, e.Message]); end; end; @@ -469,17 +476,17 @@ function TBoldDrivenProperty.GetDisplayName: string; if assigned(VCLComponent) then result := VCLComponent.Name else - result := ''; // do not localize + result := ''; if trim(propertyName) <> '' then result := result + '.' + trim(PropertyName) else - result := result + '.'; // do not localize + result := result + '.'; if ReadOnly then - result := result + ' (RO)' // do not localize + result := result + ' (RO)' else - result := result + ' (RW)'; // do not localize + result := result + ' (RW)'; end; { TBoldDrivenPropertyCollection } @@ -518,4 +525,6 @@ function TBoldPropertiesController.GetContextType: TBoldElementTypeInfo; result := nil; end; +initialization + end. diff --git a/Source/BoldAwareGUI/BoldControls/BoldRichEdit.pas b/Source/BoldAwareGUI/BoldControls/BoldRichEdit.pas index e9def6ac..cd3a55ff 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldRichEdit.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldRichEdit.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldRichEdit; {$UNDEF BOLDCOMCLIENT} @@ -138,8 +141,9 @@ implementation StdCtrls, BoldDefs, BoldControlPackDefs, + BoldUtils, SysUtils, - BoldGuiResourceStrings; + BoldRev; {---TBoldCustomRichEdit---} constructor TBoldCustomRichEdit.Create(AOwner: TComponent); @@ -290,7 +294,7 @@ procedure TBoldCustomRichEdit.SetText(value: string); if not EffectiveReadOnly then inherited Text := value else - raise EBold.CreateFmt(sTextNotModifiable, [ClassName]); + raise EBold.Create('TBoldEdit.Text: Not modifiable'); end; function TBoldCustomRichEdit.GetText: string; @@ -308,7 +312,7 @@ function TBoldCustomRichEdit.GetPopupmenu: TPopupMenu; procedure TBoldCustomRichEdit.KeyPress(var Key: Char); begin inherited KeyPress(Key); - if (Key in [#32..#255]) and + if CharInSet(Key, [#32..#255]) and not BoldProperties.ValidateCharacter(Key, Follower) then begin MessageBeep(0); @@ -380,4 +384,7 @@ function TBoldCustomRichEdit.GetFollower: TBoldFollower; Result := fHandleFollower.Follower; end; +initialization + + end. diff --git a/Source/BoldAwareGUI/BoldControls/BoldStringsPropertyController.pas b/Source/BoldAwareGUI/BoldControls/BoldStringsPropertyController.pas index 2a6b02fe..74bccc28 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldStringsPropertyController.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldStringsPropertyController.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldStringsPropertyController; {$UNDEF BOLDCOMCLIENT} @@ -23,6 +26,7 @@ TBoldStringsPropertyController = class; TBoldControlSubFollowerEvent = procedure (Sender: TObject; Index: Integer; OwningFollower: TBoldFollower) of object; { TBoldStringsPropertyController } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldStringsPropertyController = class(TComponent) private fHandleFollower: TBoldListHandleFollower; @@ -38,6 +42,8 @@ TBoldStringsPropertyController = class(TComponent) fOnListBeforeInsertItem: TBoldControlSubFollowerEvent; fOnListAfterDeleteItem: TBoldControlSubFollowerEvent; fOnItemAfterMakeUpToDate: TBoldControlFollowerEvent; + fOnReplaceItem: TBoldControlSubFollowerEvent; + fStringsChanged: boolean; function GetBoldHandle: TBoldAbstractListHandle; procedure SetBoldHandle(value: TBoldAbstractListHandle); procedure SetBoldProperties(Value: TBoldListAsFollowerListController); @@ -46,13 +52,16 @@ TBoldStringsPropertyController = class(TComponent) procedure _ListBeforeMakeUptoDate(Follower: TBoldFollower); procedure _ListAfterMakeUptoDate(Follower: TBoldFollower); procedure _ListBeforeInsertItem(index: Integer; OwningFollower: TBoldFollower); - procedure _ListAfterInsertItem(Follower: TBoldFollower); + procedure _ListAfterInsertItem(index: Integer; Follower: TBoldFollower); procedure _ListAfterDeleteItem(index: Integer; OwningFollower: TBoldFollower); - procedure _ListBeforeDeleteItem(Follower: TBoldFollower); + procedure _ListBeforeDeleteItem(index: Integer; Follower: TBoldFollower); procedure _ItemAfterMakeUptoDate(Follower: TBoldFollower); procedure _ItemBeforeMakeUptoDate(Follower: TBoldFollower); + procedure _ListReplaceItem(index: Integer; AFollower: TBoldFollower); function GetStringsProperty: TStrings; procedure SetVCLComponent(const Value: TComponent); + procedure MarkStringsChanged; + procedure EndUpdate; protected procedure Notification(AComponent: TComponent; Operation: TOperation); override; property StringsProperty: TStrings read GetStringsProperty; @@ -87,6 +96,19 @@ implementation {-- TBoldStringsPropertyController ----------------------------------------------------------} +procedure TBoldStringsPropertyController.MarkStringsChanged; +var + Strings: TStrings; +begin + if not fStringsChanged then + begin + fStringsChanged := true; + Strings := StringsProperty; + if Assigned(Strings) then + Strings.BeginUpdate; + end; +end; + constructor TBoldStringsPropertyController.Create(AOwner: TComponent); begin inherited; @@ -99,6 +121,7 @@ constructor TBoldStringsPropertyController.Create(AOwner: TComponent); begin OnAfterInsertItem := _ListAfterInsertItem; OnAfterDeleteItem := _ListAfterDeleteItem; + OnReplaceitem := _ListReplaceItem; OnBeforeInsertItem := _ListBeforeInsertItem; OnBeforeDeleteItem := _ListBeforeDeleteItem; BeforeMakeUptoDate := _ListBeforeMakeUptoDate; @@ -144,7 +167,7 @@ procedure TBoldStringsPropertyController._ListAfterMakeUptoDate(Follower: TBoldF begin Strings := StringsProperty; if Assigned(Strings) then - Strings.EndUpdate; + EndUpdate; if Assigned(fOnListAfterMakeUptoDate) then fOnListAfterMakeUptoDate(self, Follower); end; @@ -156,17 +179,36 @@ procedure TBoldStringsPropertyController._ListBeforeMakeUptoDate(Follower: TBold Strings := StringsProperty; if Assigned(Strings) then begin - Strings.BeginUpdate; if Follower.SubFollowerCount <> Strings.Count then if Follower.SubFollowerCount = 0 then + begin + MarkStringsChanged; Strings.Clear + end else - raise EBold.CreateFmt(sStringsControlledByOtherMeans, [Name]); + raise EBold.CreateFmt('Strings property controlled by "%s" changed by other means', [Name]); end; if Assigned(fOnListBeforeMakeUptoDate) then fOnListBeforeMakeUptoDate(self, Follower); end; +procedure TBoldStringsPropertyController._ListReplaceItem(index: Integer; + AFollower: TBoldFollower); +var + Strings: TStrings; +begin + Strings := StringsProperty; + if Assigned(Strings) then + begin + AFollower.EnsureDisplayable; + MarkStringsChanged; + Strings.Objects[Index] := AFollower; + Strings[Index] := TBoldStringFollowerController(AFollower.Controller).GetCurrentAsString(AFollower); + end; + if Assigned(fOnReplaceItem) then + fOnReplaceItem(self, index, AFollower); +end; + procedure TBoldStringsPropertyController._ListAfterDeleteItem(index: Integer; OwningFollower: TBoldFollower); var @@ -174,18 +216,25 @@ procedure TBoldStringsPropertyController._ListAfterDeleteItem(index: Integer; begin Strings := StringsProperty; if Assigned(Strings) then + begin + MarkStringsChanged; Strings.Delete(Index); + end; if Assigned(fOnListAfterDeleteItem) then fOnListAfterDeleteItem(self, index, OwningFollower); end; -procedure TBoldStringsPropertyController._ListAfterInsertItem(Follower: TBoldFollower); +procedure TBoldStringsPropertyController._ListAfterInsertItem(index: Integer; Follower: TBoldFollower); var Strings: TStrings; begin Strings := StringsProperty; if Assigned(Strings) then - Strings.InsertObject(Follower.Index, '', Follower); + begin + Follower.EnsureDisplayable; + MarkStringsChanged; + Strings.InsertObject(Index, TBoldStringFollowerController(Follower.Controller).GetCurrentAsString(Follower), Follower); + end; if Assigned(fOnListAfterInsertItem) then fOnListAfterInsertItem(self, Follower); end; @@ -194,14 +243,26 @@ procedure TBoldStringsPropertyController._ItemAfterMakeUptoDate(Follower: TBoldF var index: Integer; Strings: TStrings; + s: string; begin Strings := StringsProperty; if Assigned(Strings) then begin index := Follower.index; if (index > -1) and (index < Strings.Count) then - Strings[index] := TBoldStringFollowerController(Follower.Controller).GetCurrentAsString(Follower); - Strings.Objects[index] := Follower; + begin + s := TBoldStringFollowerController(Follower.Controller).GetCurrentAsString(Follower); + if s <> Strings[index] then + begin + MarkStringsChanged; + Strings[index] := TBoldStringFollowerController(Follower.Controller).GetCurrentAsString(Follower); + end; + if Strings.Objects[index] <> Follower then + begin + MarkStringsChanged; + Strings.Objects[index] := Follower; + end; + end; end; if Assigned(fOnItemAfterMakeUptoDate) then fOnItemAfterMakeUptoDate(self, Follower); @@ -230,7 +291,7 @@ function TBoldStringsPropertyController.GetStringsProperty: TStrings; end; end; -procedure TBoldStringsPropertyController._ListBeforeDeleteItem(Follower: TBoldFollower); +procedure TBoldStringsPropertyController._ListBeforeDeleteItem(index: Integer; Follower: TBoldFollower); begin if Assigned(fOnListBeforeDeleteItem) then fOnListBeforeDeleteItem(self, Follower); @@ -260,4 +321,17 @@ procedure TBoldStringsPropertyController.SetVCLComponent(const Value: TComponent PropertyName := ''; end; +procedure TBoldStringsPropertyController.EndUpdate; +var + Strings: TStrings; +begin + if fStringsChanged then + begin + Strings := StringsProperty; + if Assigned(Strings) then + Strings.EndUpdate; + fStringsChanged := false; + end; +end; + end. diff --git a/Source/BoldAwareGUI/BoldControls/BoldTrackBar.pas b/Source/BoldAwareGUI/BoldControls/BoldTrackBar.pas index cfc6e4d1..e4d75772 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldTrackBar.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldTrackBar.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldTrackBar; {$UNDEF BOLDCOMCLIENT} @@ -13,7 +16,7 @@ interface CommCtrl, Menus, BoldDefs, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after + BoldEnvironmentVCL, BoldControlPackDefs, BoldHandles, BoldElements, @@ -26,6 +29,7 @@ interface TBoldTrackBar = class; { TBoldTrackBar } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldTrackBar = class(TTrackBar, IBoldOCLComponent) private FBoldProperties: TBoldIntegerFollowerController; @@ -33,8 +37,8 @@ TBoldTrackBar = class(TTrackBar, IBoldOCLComponent) fHandleFollower: TBoldElementHandleFollower; FReadOnly: Boolean; function GetContextType: TBoldElementTypeInfo; - procedure SetExpression(Expression: String); - function GetExpression: String; + procedure SetExpression(const Value: TBoldExpression); + function GetExpression: TBoldExpression; function GetVariableList: TBoldExternalVariableList; procedure AfterMakeUptoDate(Follower: TBoldFollower); procedure CMExit(var Message: TCMExit); message CM_EXIT; @@ -239,14 +243,14 @@ function TBoldTrackBar.GetContextType: TBoldElementTypeInfo; result := nil; end; -function TBoldTrackBar.GetExpression: String; +function TBoldTrackBar.GetExpression: TBoldExpression; begin result := BoldProperties.Expression; end; -procedure TBoldTrackBar.SetExpression(Expression: String); +procedure TBoldTrackBar.SetExpression(const Value: TBoldExpression); begin - BoldProperties.Expression := Expression; + BoldProperties.Expression := Value; end; function TBoldTrackBar.GetVariableList: TBoldExternalVariableList; diff --git a/Source/BoldAwareGUI/BoldControls/BoldTreeView.pas b/Source/BoldAwareGUI/BoldControls/BoldTreeView.pas index 5f214699..2ad18e8d 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldTreeView.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldTreeView.pas @@ -1,6 +1,10 @@ +///////////////////////////////////////////////////////// + + unit BoldTreeView; {$UNDEF BOLDCOMCLIENT} +{$INCLUDE bold.inc} interface @@ -16,7 +20,7 @@ interface BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after {$IFNDEF BOLDCOMCLIENT} // uses BoldSystem, // IFNDEF BOLDCOMCLIENT - BoldGui, // IFNDEF BOLDCOMCLIENT + BoldGui, // IFNDEF BOLDCOMCLIENT {$ENDIF} BoldElements, BoldHandles, @@ -36,6 +40,9 @@ TBoldCustomTreeView = class; TBoldTreeView = class; TBoldTreeNode = class; + TDestroyWndNotifyEvent = procedure (Sender: TObject) of object; + TCreateWndNotifyEvent = procedure (Sender: TObject) of object; + {---TBoldTreeNode---} TBoldTreeNode = class(TTreeNode) private @@ -56,21 +63,21 @@ TBoldTreeNode = class(TTreeNode) end; {---TBoldCustomTreeView---} - TBoldCustomTreeView = class(TCustomTreeView, IBoldValidateableComponent) + TBoldCustomTreeView = class(TTreeView, IBoldValidateableComponent) private fHandleFollower: TBoldElementHandleFollower; - FTreeController: TBoldTreeFollowerController; - FMaxLevels: Integer; - FAutoExpandLevels: Integer; - FSelectInserted: Boolean; - FSelectedIndexDelta: Integer; + fTreeController: TBoldTreeFollowerController; + fMaxLevels: Integer; + fAutoExpandLevels: Integer; + fSelectInserted: Boolean; + fSelectedIndexDelta: Integer; fSelectedImageIndex: integer; fStateImageSelected: integer; fStateImageUnselected: integer; - FNodeExpansion: TBoldNodeExpansionMethod; - FDragFollower: TBoldFollower; - FEditFollower: TBoldFollower; - FUpdateCount: Integer; + fNodeExpansion: TBoldNodeExpansionMethod; + fDragFollower: TBoldFollower; + fEditFollower: TBoldFollower; + fUpdateCount: Integer; fMultiSelect: Boolean; fSelectAnchor: TBoldTreeNode; fLastSelectedNode: TBoldTreeNode; @@ -82,6 +89,9 @@ TBoldCustomTreeView = class(TCustomTreeView, IBoldValidateableComponent) fSelectedElementPreUpdate: TBoldElement; fSelectedNodeDescriptionPreUpdate: TBoldNodeDescription; fNodesHaveBeenDeleted: Boolean; + FItemsRecreated: Boolean; + FOnDestroyWnd: TDestroyWndNotifyEvent; + FOnCreateWnd: TCreateWndNotifyEvent; procedure _CustomDrawItem(Sender: TCustomTreeView; Node: TTreeNode; State: TCustomDrawState; var DefaultDraw: Boolean); procedure ClearAllSelections; procedure SetBoldHandle(Value: TBoldElementHandle); @@ -99,7 +109,7 @@ TBoldCustomTreeView = class(TCustomTreeView, IBoldValidateableComponent) procedure SetMultiSelect(NewValue: Boolean); procedure UpdateMultiSelect(Node: TBoldTreeNode; Shift: TShiftState; MouseDirection: TBoldMouseDirection); {$IFNDEF BOLDCOMCLIENT} - function ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: String): Boolean; + function ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: string): Boolean; {$ENDIF} property MultiSelect: Boolean read fMultiSelect write SetMultiSelect default false; function GetPopupElement: TBoldElement; @@ -117,7 +127,7 @@ TBoldCustomTreeView = class(TCustomTreeView, IBoldValidateableComponent) function CreateNode: TTreeNode; override; procedure CreateWnd; override; procedure DestroyWnd; override; - procedure DeleteNode(Follower: TBoldFollower); virtual; + procedure DeleteNode(Index: integer; Follower: TBoldFollower); virtual; procedure DisplayText(Follower: TBoldFollower); virtual; procedure DisplayIcon(Follower: TBoldFollower); virtual; procedure DoEndDrag(Target: TObject; X, Y: Integer); override; @@ -128,7 +138,7 @@ TBoldCustomTreeView = class(TCustomTreeView, IBoldValidateableComponent) procedure Edit(const Item: TTVItem); override; procedure Expand(Node: TTreeNode); override; function GetPopupMenu: TPopupMenu; override; - procedure InsertNode(Follower: TBoldFollower); virtual; + procedure InsertNode(Index: integer; Follower: TBoldFollower); virtual; procedure KeyUp(var Key: Word; Shift: TShiftState); override; procedure KeyPress(var Key: Char); override; @@ -140,7 +150,7 @@ TBoldCustomTreeView = class(TCustomTreeView, IBoldValidateableComponent) function TreeFollowerControllerClass: TBoldTreeFollowerControllerClass; virtual; {To be published} property AutoExpandLevels: Integer read FAutoExpandLevels write SetAutoExpandLevels default -1; - property BoldHandle: TBoldElementHandle read GetBoldHandle write SetBoldHandle; + property BoldHandle: TBoldElementHandle read GetBoldHandle write SetBoldHandle; property BoldProperties: TBoldTreeFollowerController read FTreeController write SetTreeController; property MaxLevels: Integer read FMaxLevels write SetMaxLevels default -1; property NodeExpansion: TBoldNodeExpansionMethod read FNodeExpansion write FNodeExpansion default neDemand; @@ -152,19 +162,23 @@ TBoldCustomTreeView = class(TCustomTreeView, IBoldValidateableComponent) public constructor Create(aOwner: TComponent); override; destructor Destroy; override; +// procedure LogNodes; procedure DragDrop(Source: TObject; X, Y: Integer); override; function GetElementAt(X, Y: Integer): TBoldElement; function GetFollowerAt(X, Y: Integer): TBoldFollower; procedure FillListWithSelectedObjects(List: TBoldObjectList); - function FindListPartByNames(const NodeDescName, ListPartName: String): TBoldGenericListPart; + function FindListPartByNames(const NodeDescName, ListPartName: string): TBoldGenericListPart; property CurrentFollower: TBoldFollower read GetCurrentFollower; property CurrentElement: TBoldElement read GetCurrentElement; property PopupElement: TBoldElement read GetPopupElement; property Selected: TBoldTreeNode read GetSelected write SetSelected; property RootFollower: TBoldFollower read GetRootFollower; + property OnDestroyWnd: TDestroyWndNotifyEvent read FOnDestroyWnd write FOnDestroyWnd; + property OnCreateWnd: TCreateWndNotifyEvent read FOnCreateWnd write FOnCreateWnd; end; {---TBoldTreeView---} + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldTreeView = class(TBoldCustomTreeView) public {$IFNDEF T2H} @@ -243,12 +257,14 @@ implementation uses SysUtils, - BoldUtils; + BoldUtils, BoldQueue; {---TBoldTreeNode---} + function TBoldTreeNode.GetNodeDescription: TBoldNodeDescription; var I: Integer; + bnd: TBoldNodeDescriptions; begin // Check if cache is accurate. if Assigned(FNodeDescription) and (FNodeDescription.NodeFollowerController = Follower.Controller) then @@ -258,16 +274,14 @@ function TBoldTreeNode.GetNodeDescription: TBoldNodeDescription; else begin I := 0; - with TBoldTreeView(TreeView).BoldProperties.NodeDescriptions do - begin - while (I Follower.Controller) do - Inc(I); - if (Items[I].NodeFollowerController = Follower.Controller) then - FNodeDescription := Items[I] - else - FNodeDescription := nil; - Result := FNodeDescription; - end; + bnd:=TBoldTreeView(TreeView).BoldProperties.NodeDescriptions; + while (I < bnd.Count) and (bnd.Items[I].NodeFollowerController <> Follower.Controller) do + Inc(I); + if (bnd.Items[I].NodeFollowerController = Follower.Controller) then + FNodeDescription := bnd.Items[I] + else + FNodeDescription := nil; + Result := FNodeDescription; end; end; @@ -283,23 +297,23 @@ function TBoldTreeNode.ExistsInParent: Boolean; {---TBoldCustomTreeView---} (*Constructor and destructor*) + constructor TBoldCustomTreeView.Create(aOwner: TComponent); begin inherited Create(aOwner); - FTreeController := TreeFollowerControllerClass.Create(Self); - FTreeController.OnAfterInsertItem := InsertNode; - FTreeController.OnBeforeDeleteItem := DeleteNode; - FTreeController.OnIconChanged := DisplayIcon; - FTreeController.OnTextChanged := DisplayText; - FTreeController.OnGetContextType := GetContextType; - FTreeController.AfterMakeUptoDate := AfterMakeUptoDate; - FTreeController.BeforeMakeUptoDate := BeforeMakeUptoDate; - + fTreeController := TreeFollowerControllerClass.Create(Self); + fTreeController.OnAfterInsertItem := InsertNode; + fTreeController.OnBeforeDeleteItem := DeleteNode; + fTreeController.OnIconChanged := DisplayIcon; + fTreeController.OnTextChanged := DisplayText; + fTreeController.OnGetContextType := GetContextType; + fTreeController.AfterMakeUptoDate := AfterMakeUptoDate; + fTreeController.BeforeMakeUptoDate := BeforeMakeUptoDate; fHandleFollower := TBoldElementHandleFollower.Create(Owner, FTreeController); - FMaxLevels := -1; - FAutoExpandLevels := -1; - FNodeExpansion := neDemand; + fMaxLevels := -1; + fAutoExpandLevels := -1; + fNodeExpansion := neDemand; fSelectedImageIndex := -1; fStateImageSelected := -1; fStateImageUnselected := -1; @@ -309,7 +323,7 @@ constructor TBoldCustomTreeView.Create(aOwner: TComponent); destructor TBoldCustomTreeView.Destroy; begin FreeAndNil(fHandleFollower); - FreeAndNil(FTreeController); + FreeAndNil(fTreeController); inherited Destroy; end; @@ -341,24 +355,24 @@ procedure TBoldCustomTreeView.SetMaxLevels(Value: Integer); var I: Integer; begin - for I := 0 to Follower.SubFollowerCount-1 do + for I := 0 to Follower.SubFollowerCount - 1 do begin //Update this node - if (Follower.SubFollowers[I].Controller as TBoldNodeFollowerController).HideNodeWithNoChildren then + if (Follower.SubFollowers[I].Controller as TBoldNodeFollowerController).HideNodeWithNoChildren then DoInsertHiddenNode(Follower.SubFollowers[I]) else SetNodeState(TBoldTreeNode(Follower.SubFollowers[I].ControlData)); //Recurse through subfollowers - if Follower.SubFollowers[I].Active and (Follower.SubFollowers[I].SubFollowerCount>=BoldNodeListIndex) and Follower.SubFollowers[I].SubFollowers[BoldNodeListIndex].Active then - DoList(Level+1, Follower.SubFollowers[I].SubFollowers[BoldNodeListIndex]) + if Follower.SubFollowers[I].Active and (Follower.SubFollowers[I].SubFollowerCount >= BoldNodeListIndex) and Follower.SubFollowers[I].SubFollowers[BoldNodeListIndex].Active then + DoList(Level + 1, Follower.SubFollowers[I].SubFollowers[BoldNodeListIndex]) end; end; begin RootFollower.EnsureDisplayable; - if Value<-1 then + if Value < -1 then Value := -1; - if (Value<>FMaxLevels) then + if (Value <> FMaxLevels) then begin FMaxLevels := Value; BeginUpdate; @@ -376,7 +390,7 @@ procedure TBoldCustomTreeView.SetAutoExpandLevels(Value: Integer); Node: TBoldTreeNode; begin RootFollower.EnsureDisplayable; - if Value<-1 then + if Value < -1 then Value := -1; FAutoExpandLevels := Value; if (FAutoExpandLevels <> -1) then @@ -384,7 +398,7 @@ procedure TBoldCustomTreeView.SetAutoExpandLevels(Value: Integer); I := 0; BeginUpdate; try - while (I 0) and (csRecreating in ControlState) then begin + FItemsRecreated := True; + if Assigned(FOnDestroyWnd) then FOnDestroyWnd(Self); + end; RootFollower.Active := false; Items.Clear; - Inherited DestroyWnd; + inherited DestroyWnd; end; function TBoldCustomTreeView.GetSelected: TBoldTreeNode; @@ -469,6 +492,7 @@ procedure TBoldCustomTreeView.EndUpdate; end; (*Display values add and remove of nodes*) + procedure TBoldCustomTreeView.DisplayText(Follower: TBoldFollower); var Node: TTreeNode; @@ -546,12 +570,16 @@ function TBoldCustomTreeView.DoInsertVisibleNode(Follower: TBoldFollower): TBold ParentNode: TTreeNode; PrevSiblingNode: TTreeNode; I: Integer; + lBoldTreeNode: TBoldTreeNode; + s: string; +// TextController: TBoldStringFollowerController; +// lTextFollower: TBoldFollower; begin - + s := ''; ParentNode := nil; PrevSiblingNode := nil; I := Follower.Index; - while not Assigned(PrevSiblingNode) and (I #32) and - not (FEditFollower.Controller as TBoldStringFollowerController).ValidateCharacter(Key, FEditFollower) then + not (FEditFollower.Controller as TBoldStringFollowerController).ValidateCharacter(Key, FEditFollower) then begin MessageBeep(0); Key := #0; @@ -762,11 +802,13 @@ procedure TBoldCustomTreeView.Edit(const Item: TTVItem); S: string; Node: TTreeNode; - function GetNodeFromItem(Item: TTVItem):TTreeNode; + function GetNodeFromItem(Item: TTVItem): TTreeNode; begin with Item do - if (state and TVIF_PARAM) <> 0 then Result := Pointer(lParam) - else Result := Items.GetNode(hItem); + if (state and TVIF_PARAM) <> 0 then Result := Pointer(lParam) + {$WARN UNSAFE_CAST OFF} + else Result := Items.GetNode(hItem); + {$WARN UNSAFE_CAST ON} end; begin @@ -907,6 +949,7 @@ procedure TBoldCustomTreeView.DragDrop(Source: TObject; X, Y: Integer); end; (*Popup menu*) + function TBoldCustomTreeView.GetPopupmenu: TPopupMenu; begin Result := inherited GetPopupMenu; @@ -915,33 +958,36 @@ function TBoldCustomTreeView.GetPopupmenu: TPopupMenu; end; (*Expand and collapse*) + function TBoldCustomTreeView.CanExpand(Node: TTreeNode): Boolean; var I: Integer; ChildNode: TBoldTreeNode; + lFollower: TBoldFollower; begin - Result := inherited CanExpand(Node) and Assigned(TBoldTreeNode(Node).Follower) and ((MaxLevels=-1) or (Node.Level BoldNodeListIndex) then + (lFollower.SubFollowerCount > BoldNodeListIndex) then begin - for I := 0 to TBoldTreeNode(Node).Follower.SubFollowers[BoldNodeListIndex].SubFollowerCount-1 do + for I := 0 to lFollower.SubFollowers[BoldNodeListIndex].SubFollowerCount - 1 do begin - ChildNode := (TBoldTreeNode(Node).Follower.SubFollowers[BoldNodeListIndex].SubFollowers[I].ControlData as TBoldTreeNode); + ChildNode := (lFollower.SubFollowers[BoldNodeListIndex].SubFollowers[I].ControlData as TBoldTreeNode); if Assigned(ChildNode) and - ((MaxLevels = -1) or (ChildNode.Level < MaxLevels)) and - not TBoldTreeNode(ChildNode).ExistsInParent and - ((ChildNode.Follower.SubFollowerCount = 0) or (not ChildNode.Follower.SubFollowers[BoldNodeListIndex].Active)) then + ((MaxLevels = -1) or (ChildNode.Level < MaxLevels)) and + not TBoldTreeNode(ChildNode).ExistsInParent and + ((ChildNode.Follower.SubFollowerCount = 0) or (not ChildNode.Follower.SubFollowers[BoldNodeListIndex].Active)) then begin ChildNode.HasChildren := False; (ChildNode.Follower.Controller as TBoldNodeFollowerController).SetActiveRange(ChildNode.Follower, BoldNodeListIndex, BoldNodeTextIndex); @@ -976,6 +1022,7 @@ procedure TBoldCustomTreeView.Collapse(Node: TTreeNode); end; (*Other*) + function TBoldCustomTreeView.CanChange(Node: TTreeNode): Boolean; begin Result := inherited CanChange(Node); @@ -1027,10 +1074,11 @@ function TBoldCustomTreeView.GetContextType: TBoldElementTypeInfo; end; {$IFNDEF BOLDCOMCLIENT} -function TBoldCustomTreeView.ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: String): Boolean; + +function TBoldCustomTreeView.ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: string): Boolean; var j, i: integer; - BaseName: String; + BaseName: string; Context: TBoldElementTypeInfo; begin // We want to evaluate everything. Thus suboptimized expressions. @@ -1043,28 +1091,28 @@ function TBoldCustomTreeView.ValidateComponent(ComponentValidator: TBoldComponen with BoldProperties.NodeDescriptions[i] do begin Context := NodeFollowerController.ContextType; - BaseName:= format('%s%s.Node[%d:%s]', [NamePrefix, self.Name, i, Name]); // do not localize + BaseName := format('%s%s.Node[%d:%s]', [NamePrefix, self.Name, i, Name]); // do not localize Result := ComponentValidator.ValidateExpressionInContext('', Context, BaseName); if Assigned(Context) then begin Result := ComponentValidator.ValidateExpressionInContext( - IconController.Expression, - Context, - BaseName + '.IconController') and Result; // do not localize + IconController.Expression, + Context, + BaseName + '.IconController') and Result; // do not localize Result := ComponentValidator.ValidateExpressionInContext( - TextController.Expression, - Context, - BaseName + '.TextController') and Result; // do not localize + TextController.Expression, + Context, + BaseName + '.TextController') and Result; // do not localize for j := 0 to ListController.Parts.Count - 1 do begin Result := ComponentValidator.ValidateExpressionInContext( - ListController.Parts[j].ControllerExpression, - Context, - BaseName + format('.ListPart[%d]', [j])) and Result; // do not localize + ListController.Parts[j].ControllerExpression, + Context, + BaseName + format('.ListPart[%d]', [j])) and Result; // do not localize end; end; end; @@ -1074,7 +1122,7 @@ function TBoldCustomTreeView.ValidateComponent(ComponentValidator: TBoldComponen function TBoldCustomTreeView.TreeFollowerControllerClass: TBoldTreeFollowerControllerClass; begin - result := TBoldTreeFollowerController; + Result := TBoldTreeFollowerController; end; procedure TBoldCustomTreeView.SetMultiSelect(NewValue: Boolean); @@ -1186,12 +1234,15 @@ procedure TBoldCustomTreeView.FillListWithSelectedObjects(List: TBoldObjectList) destructor TBoldTreeNode.destroy; begin inherited; + if Assigned(FFollower) and (FFollower.ControlData = self) then + FFollower.ControlData := nil; if TreeView.fLastSelectedNode = self then TreeView.fLastSelectedNode := nil; if TreeView.fSelectAnchor = self then TreeView.fSelectAnchor := nil; if TreeView.fPopupNode = self then TreeView.fPopupNode := nil; + FFollower := nil; end; function TBoldTreeNode.GetTreeView: TBoldTreeView; @@ -1214,7 +1265,7 @@ procedure TBoldCustomTreeView.SetSelectionInSubtree(Node: TTreeNode; Selected: B procedure TBoldTreeNode.UpdateIcon; begin - if assigned(Follower) and assigned(Follower.SubFollowers[1]) then + if assigned(Follower) and assigned(Follower.Controller) and assigned(Follower.SubFollowers[1]) then Follower.SubFollowers[1].MarkValueOutOfDate; end; @@ -1240,7 +1291,36 @@ procedure TBoldCustomTreeView.KeyUp(var Key: Word; Shift: TShiftState); UpdateMultiSelect(Selected as TBoldTreeNode, Shift, dirMouseDown); end; -function TBoldCustomTreeView.FindListPartByNames(const NodeDescName, ListPartName: String): TBoldGenericListPart; +//procedure TBoldCustomTreeView.LogNodes; +//var +// lIndex: Integer; +// lBoldTreeNode: TBoldTreeNode; +// lBoldFollowerController: TBoldFollowerController; +//begin +// CodeSite.Category := 'LogNodes'; +// CodeSite.Send('**** Start LogNodes ***'); +// +// for lIndex := 0 to Items.Count - 1 do +// begin +// lBoldTreeNode := Items[lIndex] as TBoldTreeNode; +// if Assigned(lBoldTreeNode.Follower) then +// begin +// CodeSite.Send('lBoldTreeNode.Follower ', Integer(lBoldTreeNode.Follower)); +// Assert(lBoldTreeNode.Follower is TBoldFollower); +// lBoldFollowerController := lBoldTreeNode.Follower.AssertedController; +// CodeSite.Send('Integer(lBoldFollowerController)', Integer(lBoldFollowerController)); +// CodeSite.Send(lBoldFollowerController.ClassName); +// if not (lBoldFollowerController is TBoldNodeFollowerController) then +// begin +// raise exception.Create('Improper Controller has been assigned'); +// end; +// end; +// end; +// CodeSite.Send('**** End LogNodes ***'); +// CodeSite.Category := ''; +//end; + +function TBoldCustomTreeView.FindListPartByNames(const NodeDescName, ListPartName: string): TBoldGenericListPart; var NodeDesc: TBoldNodeDescription; begin @@ -1256,9 +1336,11 @@ procedure TBoldCustomTreeView._CustomDrawItem(Sender: TCustomTreeView; Node: TTr Follower: TBoldfollower; aColor: TColor; TextController: TBoldStringFollowerController; + lBoldTreeNode: TBoldTreeNode; begin - Follower := (Node as TBoldTreeNode).Follower; - if assigned(Follower) then + lBoldTreeNode := Node as TBoldTreeNode; + Follower := lBoldTreeNode.Follower; + if assigned(Follower) and not Follower.IsInDisplayList and Assigned(Follower.Controller) then begin TextController := (Follower.Controller as TBoldNodeFollowerController).TextFollowerController; if not (cdsSelected in State) then @@ -1271,3 +1353,5 @@ procedure TBoldCustomTreeView._CustomDrawItem(Sender: TCustomTreeView; Node: TTr end; end. + + diff --git a/Source/BoldAwareGUI/BoldControls/BoldTreeViewConfig.pas b/Source/BoldAwareGUI/BoldControls/BoldTreeViewConfig.pas index dc8a1a99..b92d1ada 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldTreeViewConfig.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldTreeViewConfig.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldTreeViewConfig; {$UNDEF BOLDCOMCLIENT} @@ -9,8 +12,8 @@ interface BoldGenericListControlPack, BoldNodeControlPack, BoldSystemRT, - {$IFDEF BOLDCOMCLIENT} // uses - BoldSystem, // to get the ObjectSpace interfaces + {$IFDEF BOLDCOMCLIENT} + BoldSystem, {$ENDIF} BoldTreeView; @@ -22,7 +25,7 @@ implementation SysUtils, BoldUtils; -{$IFDEF BOLDCOMCLIENT} // BoldGenericTreeView +{$IFDEF BOLDCOMCLIENT} procedure BoldGenericTreeView(SystemTypeInfo: IBoldSystemTypeInfo; TreeView: TBoldTreeViewCom); begin end; @@ -33,11 +36,11 @@ procedure FillListpartForAttr(RTAttr: TBoldAttributeRTInfo; var s: string; begin - s := format('''%s: '' + %s.asString', [RTAttr.ExpressionName, RTAttr.ExpressionName]); // do not localize + s := format('''%s: '' + %s.asString', [RTAttr.ExpressionName, RTAttr.ExpressionName]); s[2] := UpCase(s[2]); ListPart.ElementExpression := s; ListPart.InterpretAsList := False; - ListPart.ControllerExpression := '''AttributeNode'''; // do not localize + ListPart.ControllerExpression := '''AttributeNode'''; end; @@ -54,15 +57,13 @@ procedure FillListpartForRole(RTRole: TBoldRoleRTInfo; ListPart.ControllerExpression := format('''%s''', [RoleName]); ListPart.InterpretAsList := False; if DefiningClass = RTRole.ClassTypeInfo then - with TreeView.BoldProperties.NodeDescriptions.Add do - begin + with TreeView.BoldProperties.NodeDescriptions.Add do begin Name := RoleName; s := format('''%s:''', [RTRole.ExpressionName]); s[2] := UpCase(s[2]); TextController.Expression := s; - with ListController.Parts.Add do - begin - ControllerExpression := 'oclType'; // do not localize + with ListController.Parts.Add do begin + ControllerExpression := 'oclType'; InterpretAsList := RTRole.IsMultiRole; end; end; @@ -76,9 +77,8 @@ procedure FillNodeDescriptorForClass(ClassTypeInfo: TBoldClassTypeInfo; Role: TBoldRoleRTInfo; begin NodeDescriptor.Name := ClassTypeInfo.ExpressionName; - NodeDescriptor.TextController.Expression := 'self.asString + '': '' + oclType.asString'; // do not localize - for i := 0 to ClassTypeInfo.AllMembers.Count - 1 do - begin + NodeDescriptor.TextController.Expression := 'self.asString + '': '' + oclType.asString'; + for i := 0 to ClassTypeInfo.AllMembers.Count-1 do begin DefiningClass := ClassTypeInfo; while i < DefiningClass.FirstOwnMemberIndex do DefiningClass := DefiningClass.SuperClassTypeInfo; @@ -104,18 +104,15 @@ procedure BoldGenericTreeView(SystemTypeInfo: TBoldSystemTypeInfo; TreeView: TBo var i: integer; begin - with TreeView.BoldProperties.NodeDescriptions.Add do - begin - Name := 'AttributeNode'; // do not localize + With TreeView.BoldProperties.NodeDescriptions.Add do begin + Name := 'AttributeNode'; end; - with TreeView.BoldProperties.parts.add do - begin + With TreeView.BoldProperties.parts.add do begin InterpretAsList := true; end; - for i := 0 to SystemTypeInfo.TopSortedClasses.count - 1 do - begin + for i := 0 to SystemTypeInfo.TopSortedClasses.count-1 do begin FillNodeDescriptorForClass( SystemTypeInfo.TopSortedClasses[i], TreeView.BoldProperties.NodeDescriptions.Add, diff --git a/Source/BoldAwareGUI/BoldControls/BoldXCVTreeView.pas b/Source/BoldAwareGUI/BoldControls/BoldXCVTreeView.pas index 5fc82724..a4706ee0 100644 --- a/Source/BoldAwareGUI/BoldControls/BoldXCVTreeView.pas +++ b/Source/BoldAwareGUI/BoldControls/BoldXCVTreeView.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldXCVTreeView; interface @@ -9,6 +12,7 @@ interface type + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldXCVTreeView = class(TBoldTreeView) private fOnCut: TNotifyEvent; diff --git a/Source/BoldAwareGUI/BoldDevex/BoldAFPCxGridProviderUnit.pas b/Source/BoldAwareGUI/BoldDevex/BoldAFPCxGridProviderUnit.pas new file mode 100644 index 00000000..758ac61f --- /dev/null +++ b/Source/BoldAwareGUI/BoldDevex/BoldAFPCxGridProviderUnit.pas @@ -0,0 +1,196 @@ +unit BoldAFPCxGridProviderUnit; + +interface + +uses + cxGrid, + cxGridBoldSupportUnit, + BoldAFPDefault, + BoldAFP, + BoldAbstractListHandle; + +type + TBoldCxGridFormProviderForList = class(TBoldDefaultFormProvider) + private + fGrid: TcxGrid; + fListHandle: TBoldAbstractListHandle; + function GetlistHandle: TBoldAbstractListHandle; + protected + procedure EnsureHandle; override; + procedure PreEnsureComponents; override; + property Grid: TcxGrid read fGrid; + property ListHandle: TBoldAbstractListHandle read GetlistHandle; + end; + + TBoldCxGridObjectAutoFormProvider = class(TBoldDefaultObjectAutoFormProvider) + protected + procedure EnsureMultiRoleMemberControls; override; + end; + +implementation + +uses + BoldElements, + BoldReferenceHandle, + BoldListHandle, + BoldSystemRT, +// BoldNavigator, + BoldSystem, + Controls, + ComCtrls, + SysUtils, + cxGridCustomPopupMenu, + cxGridPopupMenu; + +const + BOXMARGIN = 8; + BOXSPACING = 2; + CONTROLMARGIN = 10; + LISTBOXLABELHEIGHT = 18; + MAXFORMHEIGHT = 450; + MINFORMHEIGHT = 150; + EDITHEIGHT = 20; + EDITWIDTH = 121; + LISTBOXHEIGHT = 97; + LISTBOXWIDTH = 121; + PANELHEIGHT = 35; + +{ TBoldCxGridFormProviderForList } + +procedure TBoldCxGridFormProviderForList.EnsureHandle; +var + DesignTimeContext: TBoldElementTypeInfo; +begin + BoldHandle := TBoldReferenceHandle.Create(Form); + DesignTimeContext := Element.BoldType; + if DesignTimeContext is TBoldListTypeInfo then + DesignTimeContext := (DesignTimeContext as TBoldListTypeInfo).ListElementTypeInfo; + BoldHandle.StaticValueTypeName := DesignTimeContext.ExpressionName; + BoldHandle.OnObjectDeleted := DefaultReceiveObjectGone; + BoldHandle.OnValueDestroyed := DefaultReceiveObjectGone; + inherited; +end; + +function TBoldCxGridFormProviderForList.GetlistHandle: TBoldAbstractListHandle; +begin + if not assigned(fListHandle) then + begin + fListHandle := TBoldListHandle.Create(Form); + fListHandle.RootHandle := BoldHandle; + end; + Result := fListHandle; +end; + +procedure TBoldCxGridFormProviderForList.PreEnsureComponents; +var + lcxGridBoldTableView: TcxGridBoldTableView; + lcxGridPopupMenu: TcxGridPopupMenu; +begin + inherited; + fGrid := TcxGrid.Create(Form); + with fGrid do + begin + Name := 'Grid'; // do not localize + fGrid.Levels.Add; + lcxGridBoldTableView := fGrid.CreateView(TcxGridBoldTableView) as TcxGridBoldTableView; + lcxGridBoldTableView.OptionsBehavior.ImmediateEditor := false; + lcxGridBoldTableView.OptionsBehavior.IncSearch := true; + Levels[0].GridView := lcxGridBoldTableView; + lcxGridBoldTableView.OptionsSelection.MultiSelect := true; + lcxGridBoldTableView.DataController.BoldAutoColumns := true; + lcxGridBoldTableView.DataController.BoldHandle := ListHandle; + + lcxGridPopupMenu := TcxGridPopupMenu.Create(Form); + lcxGridPopupMenu.Grid := fGrid; + +// BoldShowConstraints := BoldShowConstraintsInAutoFormGrids; +// BoldAutoColumns := True; + + Align := alClient; + Parent := Target; + end; + +{ with TBoldNavigator.Create(Form) do + begin + Parent := Target; + Align := alBottom; + Boldhandle := ListHandle; + name := 'BoldNavigator'; // do not localize + end; +} + Form.Caption := Element.BoldType.ModelName; + ListHandle.Name := 'BoldListHandle'; // do not localize +end; + +{ TBoldCxGridObjectAutoFormProvider } + +procedure TBoldCxGridObjectAutoFormProvider.EnsureMultiRoleMemberControls; +var + i: integer; + Member: TBoldMemberRTInfo; + ListHandle: TBoldListHandle; + lGrid: TcxGrid; + lView: TcxGridBoldTableView; + TabSheet: TTabSheet; + DesInfo: longint; + ValueType: TBoldElementTypeInfo; +// Navigator: TBoldNavigator; +begin + for i := 0 to MemberRTInfoList.Count - 1 do + begin + Member := MemberRTInfoList[i]; + if Member.IsMultiRole then + begin + if MemberShouldBeDisplayed(Member) then + begin + TabSheet := CreateTabSheet(Member.ModelName, MakeComponentName('Tab', ClassTypeInfo, Member)); // do not localize + + listHandle := TBoldListHandle.Create(TabSheet); // must be tabsheet for "ActivateTabSheetHandle" to work + ListHandle.Enabled := False; + TabSheet.OnShow := ActivateTabSheetHandle; + + LongRec(desinfo).Lo := CONTROLMARGIN; //set Left + LongRec(desinfo).Hi := CONTROLMARGIN; //Set Top; + listHandle.DesignInfo := desInfo; + listHandle.RootHandle := BoldHandle; + listHandle.Expression := Member.ExpressionName; + listHandle.MutableListExpression := Member.ExpressionName; + listHandle.Name := MakeComponentName('Handle', ClassTypeInfo, Member); // do not localize + ValueType := Member.BoldType; + if ValueType is TBoldListTypeInfo then + ValueType := (ValueType as TBoldListTypeInfo).ListElementTypeInfo; + listHandle.RootTypeName := ValueType.ExpressionName; + listHandle.StaticSystemHandle := self.BoldHandle.StaticSystemHandle; + + lGrid := TcxGrid.Create(TabSheet); + lGrid.Name := MakeComponentName('Grid', ClassTypeInfo, Member); // do not localize + lGrid.Levels.Add; + lView := lGrid.CreateView(TcxGridBoldTableView) as TcxGridBoldTableView; + lView.OptionsBehavior.ImmediateEditor := false; + lView.OptionsBehavior.IncSearch := true; + lGrid.Levels[0].GridView := lView; + lView.DataController.BoldHandle := ListHandle; + lView.DataController.BoldAutoColumns := True; + lView.OptionsSelection.MultiSelect := true; + lGrid.Align := alClient; + lGrid.Parent := TabSheet; + +{ Navigator := TBoldNavigator.Create(Form); + NAvigator.align := alBottom; + Navigator.BoldHandle := ListHandle; + Navigator.Parent := TabSheet; +} + end; + end; + end; +end; + +initialization + AutoFormProviderRegistry.RegisterListProvider(bvtClass, TBoldObjectList, TBoldCxGridFormProviderForList); + AutoFormProviderRegistry.RegisterProvider(bvtClass, TBoldObject, TBoldCxGridObjectAutoFormProvider); + +finalization + AutoFormProviderRegistry.UnregisterProvider(TBoldDefaultObjectListAutoFormProvider); + AutoFormProviderRegistry.UnregisterProvider(TBoldCxGridObjectAutoFormProvider); + +end. diff --git a/Source/BoldAwareGUI/BoldDevex/BoldToCxConverterForm.dfm b/Source/BoldAwareGUI/BoldDevex/BoldToCxConverterForm.dfm new file mode 100644 index 00000000..fd405537 --- /dev/null +++ b/Source/BoldAwareGUI/BoldDevex/BoldToCxConverterForm.dfm @@ -0,0 +1,112 @@ +object frmBoldToCxConverter: TfrmBoldToCxConverter + Left = 0 + Top = 0 + Caption = 'Select Components' + ClientHeight = 598 + ClientWidth = 763 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object DetectedComponentsGrid: TcxGrid + Left = 0 + Top = 0 + Width = 763 + Height = 392 + Align = alClient + TabOrder = 0 + object tv: TcxGridTableView + Navigator.Buttons.CustomButtons = <> + ScrollbarAnnotations.CustomAnnotations = <> + OnSelectionChanged = tvSelectionChanged + DataController.Summary.DefaultGroupSummaryItems = <> + DataController.Summary.FooterSummaryItems = <> + DataController.Summary.SummaryGroups = <> + OptionsCustomize.ColumnFiltering = False + OptionsCustomize.ColumnGrouping = False + OptionsCustomize.ColumnHidingOnGrouping = False + OptionsCustomize.ColumnHorzSizing = False + OptionsCustomize.ColumnMoving = False + OptionsCustomize.ColumnSorting = False + OptionsSelection.CellSelect = False + OptionsSelection.MultiSelect = True + OptionsSelection.HideFocusRectOnExit = False + object tvColumn1: TcxGridColumn + Caption = 'Component' + Width = 209 + end + object tvColumn2: TcxGridColumn + Caption = 'Type' + Width = 132 + end + object tvColumn3: TcxGridColumn + Caption = 'Ocl Type' + Width = 211 + end + object tvColumn4: TcxGridColumn + Caption = 'Convert to' + Width = 186 + end + end + object DetectedComponentsGridLevel1: TcxGridLevel + GridView = tv + end + end + object Panel1: TPanel + Left = 0 + Top = 558 + Width = 763 + Height = 40 + Align = alBottom + TabOrder = 1 + DesignSize = ( + 763 + 40) + object cxCancelButton: TcxButton + Left = 680 + Top = 7 + Width = 75 + Height = 25 + Anchors = [akRight, akBottom] + Cancel = True + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 0 + OnClick = cxCancelButtonClick + end + object cxConvert: TcxButton + Left = 562 + Top = 7 + Width = 110 + Height = 25 + Anchors = [akRight, akBottom] + Caption = 'Convert Selected' + Enabled = False + ModalResult = 1 + TabOrder = 1 + end + object cxRemoveAfterConvertionCheckbox: TcxCheckBox + Left = 9 + Top = 11 + Anchors = [akLeft, akBottom] + Caption = 'Remove old components after convertion' + State = cbsChecked + TabOrder = 2 + end + end + object cxMemoLog: TcxMemo + Left = 0 + Top = 392 + Align = alBottom + Properties.ReadOnly = True + Properties.ScrollBars = ssVertical + TabOrder = 2 + Height = 166 + Width = 763 + end +end diff --git a/Source/BoldAwareGUI/BoldDevex/BoldToCxConverterForm.pas b/Source/BoldAwareGUI/BoldDevex/BoldToCxConverterForm.pas new file mode 100644 index 00000000..b1ac6e63 --- /dev/null +++ b/Source/BoldAwareGUI/BoldDevex/BoldToCxConverterForm.pas @@ -0,0 +1,55 @@ +unit BoldToCxConverterForm; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, cxGraphics, cxControls, cxLookAndFeels, cxLookAndFeelPainters, + cxCustomData, cxFilter, + cxData, cxDataStorage, cxEdit, cxDropDownEdit, Menus, cxContainer, cxCheckBox, + StdCtrls, cxButtons, cxGridCustomTableView, cxGridTableView, cxGridCustomView, + cxClasses, cxGridLevel, cxGrid, cxNavigator, cxStyles, ExtCtrls, + cxTextEdit, cxMemo, dxDateRanges, dxScrollbarAnnotations; + +type + TfrmBoldToCxConverter = class(TForm) + DetectedComponentsGrid: TcxGrid; + DetectedComponentsGridLevel1: TcxGridLevel; + tv: TcxGridTableView; + tvColumn1: TcxGridColumn; + tvColumn2: TcxGridColumn; + tvColumn3: TcxGridColumn; + tvColumn4: TcxGridColumn; + cxConvert: TcxButton; + cxCancelButton: TcxButton; + cxRemoveAfterConvertionCheckbox: TcxCheckBox; + Panel1: TPanel; + cxMemoLog: TcxMemo; + procedure cxCancelButtonClick(Sender: TObject); + procedure tvSelectionChanged(Sender: TcxCustomGridTableView); + private + { Private declarations } + public + { Public declarations } + end; + +var + frmBoldToCxConverter: TfrmBoldToCxConverter; + +implementation + +{$R *.dfm} + +procedure TfrmBoldToCxConverter.cxCancelButtonClick(Sender: TObject); +begin + Self.Close; +end; + +procedure TfrmBoldToCxConverter.tvSelectionChanged( + Sender: TcxCustomGridTableView); +begin + cxConvert.Enabled := tv.Controller.SelectedRecordCount > 0; + cxConvert.Caption := Format('Convert %d Selected', [tv.Controller.SelectedRecordCount]); +end; + +end. diff --git a/Source/BoldAwareGUI/BoldDevex/BoldToCxConverterUnit.pas b/Source/BoldAwareGUI/BoldDevex/BoldToCxConverterUnit.pas new file mode 100644 index 00000000..228b6d26 --- /dev/null +++ b/Source/BoldAwareGUI/BoldDevex/BoldToCxConverterUnit.pas @@ -0,0 +1,804 @@ +unit BoldToCxConverterUnit; + +interface + +uses + Classes, + Controls, + SysUtils, + BoldEdit, + BoldVariantControlPack, + BoldStringControlPack, + BoldComboBox, + BoldGrid, + BoldMemo, + BoldLabel, + Buttons, + cxBoldEditors, + cxGridBoldSupportUnit, + cxGridPopupMenu, + BoldToCxConverterForm, + BoldCaptionController, + BoldPropertiesController, + StdCtrls, + cxGridCustomTableView, + cxTextEdit, + cxLabel, + cxGroupBox, + cxButtons, + cxMemo, + TypInfo; + +type + TBoldToCxConverter = class(TComponent) + private + fBoldToCxConverterForm : TfrmBoldToCxConverter; + fBoldComponents : TStringList; + fLog: TStringList; + + function ConvertGrid(aBoldGrid : TBoldGrid): Boolean; + procedure CopyBoldColumn(aBoldColumn : TBoldGridColumn; aCxGridBoldColumn : TCxGridBoldColumn); + procedure CountNumberOfBoldComponents(var vBoldComponentCount: Integer; AOwner: TComponent); + procedure FoundBoldComponent(aComponent: TComponent); + procedure FoundTBoldGrid(aGrid: TBoldGrid); + procedure FoundTBoldEdit(aEdit: TBoldEdit); + procedure FoundTBoldMemo(aMemo: TBoldMemo); + procedure FoundTBoldLabel(aLabel: TBoldLabel); + procedure FoundTBoldComboBox(aComboBox : TBoldComboBox); + procedure FoundTEdit(aEdit: TEdit); + procedure FoundTLabel(aLabel: TLabel); + procedure FoundTMemo(aMemo: TMemo); + procedure FoundTGroupBox(aBox: TGroupBox); + procedure FoundTSpeedButton(aButton: TSpeedButton); + function ConvertTBoldEdit(aBoldEdit: TBoldEdit): Boolean; + function ConvertTBoldEditToDateEdit(aBoldEdit: TBoldEdit): Boolean; + function ConvertTBoldMemo(aBoldMemo: TBoldMemo): Boolean; + function ConvertTBoldLabel(aBoldLabel: TBoldLabel): Boolean; + function ConvertTBoldComboBox(aBoldComboBox: TBoldComboBox): Boolean; + function ConvertTEdit(aEdit: TEdit): Boolean; + function ConvertTMemo(aMemo: TMemo): Boolean; + function ConvertTLabel(aLabel: TLabel): Boolean; + function ConvertTGroupBox(aBox: TGroupBox): Boolean; + function ConvertTSpeedButton(aButton: TSpeedButton): Boolean; + procedure CopyPublishedProperties(FromControl, ToControl: TControl); + procedure CopyFollowerProperties(FromFollower: TBoldStringFollowerController; ToFollower: TBoldVariantFollowerController); + procedure CopyBoldComboListControllerProperties(FromComboListController: BoldComboBox.TBoldComboListController; ToComboListController: cxBoldEditors.TBoldComboListController); + procedure CheckEvents(AEventList: array of string; AObject: TObject); + function TryRename(aComponent: TComponent): Boolean; + protected + function GridController : TcxGridDataController; + public + constructor Create(AOwner : TComponent); override; + destructor Destroy;override; + { Public declarations } + published + { Published declarations } + end; + +const + Ctrlf = #13#10; + +// cTControlEvents: array[0..9] of string = ('OnAlignPosition', 'OnDockDrop', 'OnDockOver', 'OnEnter', 'OnExit', 'OnGetSiteInfo', 'OnKeyDown', 'OnKeyPress', 'OnKeyUp', 'OnUnDock'); +// cTWinControlEvents: array[0..10] of string = ('OnAlignInsertBefore', 'OnAlignPosition', 'OnDockDrop', 'OnDockOver', 'OnEnter', 'OnExit', 'OnGetSiteInfo', 'OnKeyDown', 'OnKeyPress', 'OnKeyUp', 'OnUnDock'); +{ cTEditEvents: array[0..20] of String = ('OnChange', 'OnClick', 'OnContextPopup', 'OnDblClick', 'OnDragDrop', 'OnDragOver', 'OnEndDock', + 'OnEndDrag', 'OnEnter', 'OnExit', 'OnKeyDown', 'OnKeyPress', 'OnKeyUp', 'OnMouseActivate', 'OnMouseDown', + 'OnMouseEnter', 'OnMouseLeave', 'OnMouseMove', 'OnMouseUp', 'OnStartDock', 'OnStartDrag'); + cTLabelEvents: array[0..14] of String = ('OnClick', 'OnContextPopup', 'OnDblClick', 'OnDragDrop', 'OnDragOver', 'OnEndDock', 'OnEndDrag', + 'OnMouseActivate', 'OnMouseDown', 'OnMouseMove', 'OnMouseUp', 'OnMouseEnter', 'OnMouseLeave', 'OnStartDock', 'OnStartDrag'); + cTMemoEvents: array[0..20] of String = ('OnChange', 'OnClick', 'OnContextPopup', 'OnDblClick', 'OnDragDrop', 'OnDragOver', 'OnEndDock', 'OnEndDrag', + 'OnEnter', 'OnExit', 'OnKeyDown', 'OnKeyPress', 'OnKeyUp', 'OnMouseActivate', 'OnMouseDown', 'OnMouseEnter', + 'OnMouseLeave', 'OnMouseMove', 'OnMouseUp', 'OnStartDock', 'OnStartDrag'); + cTGroupBoxEvents: array[0..22] of String = ('OnAlignInsertBefore', 'OnAlignPosition', 'OnClick', 'OnContextPopup', 'OnDblClick', 'OnDragDrop', 'OnDockDrop', + 'OnDockOver', 'OnDragOver', 'OnEndDock', 'OnEndDrag', 'OnEnter', 'OnExit', 'OnGetSiteInfo', 'OnMouseActivate', + 'OnMouseDown', 'OnMouseEnter', 'OnMouseLeave', 'OnMouseMove', 'OnMouseUp', 'OnStartDock', 'OnStartDrag', 'OnUnDock'); + cTSpeedButtonEvents: array[0..7] of String = ('OnClick', 'OnDblClick', 'OnMouseActivate', 'OnMouseDown', 'OnMouseEnter', 'OnMouseLeave', 'OnMouseMove', 'OnMouseUp');} + + cEvents: array[0..32] of String = ('OnAlignInsertBefore', 'OnAlignPosition', 'OnCanResize', 'OnChange', 'OnClick', 'OnConstrainedResize', 'OnContextPopup', + 'OnDblClick', 'OnDockDrop', 'OnDockOver', 'OnDragDrop', 'OnDragOver', 'OnEndDock', 'OnEndDrag', 'OnEnter', 'OnExit', + 'OnGetSiteInfo', 'OnKeyDown', 'OnKeyPress', 'OnKeyUp', 'OnMouseActivate', 'OnMouseDown', 'OnMouseEnter', 'OnMouseLeave', + 'OnMouseMove', 'OnMouseUp', 'OnMouseWheel', 'OnMouseWheelDown', 'OnMouseWheelUp', 'OnResize', 'OnStartDock', 'OnStartDrag', 'OnUnDock'); + +procedure Register; + +implementation +uses Dialogs, cxGrid,Forms, BoldElements, CxEdit, CxGridLevel; + +procedure Register; +begin + RegisterComponents('AT Core', [TBoldToCxConverter]); +end; + +{ TBoldToCxGridConverter } + +constructor TBoldToCxConverter.Create(AOwner: TComponent); +var + vBoldComponentCount : Integer; + I,j : Integer; + vComponent: TComponent; + res: Boolean; +begin + inherited; + fBoldComponents := TStringList.Create; + fLog := TStringList.Create; + Application.CreateForm(TfrmBoldToCxConverter,fBoldToCxConverterForm); + CountNumberOfBoldComponents(vBoldComponentCount, AOwner); + GridController.RecordCount := vBoldComponentCount; + + for I := 0 to AOwner.ComponentCount - 1 do + begin + vComponent := AOwner.Components[I]; + // TODO + if (vComponent is TBoldGrid) then FoundTBoldGrid(vComponent as TBoldGrid); + if (vComponent is TBoldEdit) then FoundTBoldEdit(vComponent as TBoldEdit); + if (vComponent is TBoldMemo) then FoundTBoldMemo(vComponent as TBoldMemo); + if (vComponent is TBoldLabel) then FoundTBoldLabel(vComponent as TBoldLabel); + if (vComponent is TBoldComboBox) then FoundTBoldComboBox(vComponent as TBoldComboBox); + if (vComponent is TEdit) then FoundTEdit(vComponent as TEdit); + if (vComponent is TLabel) then FoundTLabel(vComponent as TLabel); + if (vComponent is TMemo) then FoundTMemo(vComponent as TMemo); + if (vComponent is TGroupBox) then FoundTGroupBox(vComponent as TGroupBox); + if (vComponent is TSpeedButton) then FoundTSpeedButton(vComponent as TSpeedButton); + + if (vComponent is TBoldCaptionController) then fLog.Add('Achtung: Form enthält einen TBoldCaptionController'); + if (vComponent is TBoldPropertiesController) then fLog.Add('Achtung: Form enthält einen TBoldPropertiesController'); + end; + + if fLog.Count > 0 then + fBoldToCxConverterForm.cxMemoLog.Lines.AddStrings(fLog); + + if fBoldToCxConverterForm.ShowModal = mrOK then + begin + for j := GridController.RecordCount - 1 downto 0 do + if not GridController.IsRowSelected(j) then + fBoldComponents.Delete(fBoldComponents.IndexOf(GridController.GetValue(j,0))); + for I := fBoldComponents.Count - 1 downto 0 do + begin + vComponent := fBoldComponents.Objects[I] as TComponent; + res := false; + // TODO + if vComponent is TBoldGrid then res := ConvertGrid(vComponent as TBoldGrid); + if vComponent is TBoldMemo then res := ConvertTBoldMemo(vComponent as TBoldMemo); + if vComponent is TBoldLabel then res := ConvertTBoldLabel(vComponent as TBoldLabel); + if vComponent is TEdit then res := ConvertTEdit(vComponent as TEdit); + if vComponent is TMemo then res := ConvertTMemo(vComponent as TMemo); + if vComponent is TLabel then res := ConvertTLabel(vComponent as TLabel); + if vComponent is TGroupBox then res := ConvertTGroupBox(vComponent as TGroupBox); + if vComponent is TSpeedButton then res := ConvertTSpeedButton(vComponent as TSpeedButton); + if vComponent is TBoldEdit then + begin + if GridController.Values[I,3] = 'TcxBoldDateEdit' then + res := ConvertTBoldEditToDateEdit(vComponent as TBoldEdit) + else + res := ConvertTBoldEdit(vComponent as TBoldEdit) + end; + if vComponent is TBoldComboBox then res := ConvertTBoldComboBox(vComponent as TBoldComboBox); + + // Altes Component löschen + if res and fBoldToCxConverterForm.cxRemoveAfterConvertionCheckbox.Checked then + vComponent.Free; + end; + end; +end; + +destructor TBoldToCxConverter.Destroy; +begin + fBoldToCxConverterForm.Close; + fBoldToCxConverterForm.Free; + fBoldComponents.Free; + fLog.Free; + inherited; +end; + +procedure TBoldToCxConverter.FoundBoldComponent(aComponent : TComponent); +begin + fBoldComponents.AddObject(aComponent.Name,aComponent); + GridController.Values[fBoldComponents.Count - 1, 0] := aComponent.Name; + GridController.Values[fBoldComponents.Count - 1, 1] := aComponent.ClassName; +end; + +procedure TBoldToCxConverter.FoundTBoldComboBox(aComboBox: TBoldComboBox); +begin + FoundBoldComponent(aComboBox); + GridController.Values[fBoldComponents.Count - 1, 3] := 'TcxBoldComboBox'; +end; + +procedure TBoldToCxConverter.FoundTBoldGrid(aGrid : TBoldGrid); +begin + FoundBoldComponent(aGrid); + GridController.Values[fBoldComponents.Count - 1, 3] := 'TcxGridBoldTableView'; +end; + +procedure TBoldToCxConverter.FoundTBoldLabel(aLabel: TBoldLabel); +begin + CheckEvents(cEvents, aLabel); + FoundBoldComponent(aLabel); + GridController.Values[fBoldComponents.Count - 1, 3] := 'TcxBoldLabel'; +end; + +procedure TBoldToCxConverter.FoundTBoldMemo(aMemo: TBoldMemo); +begin + CheckEvents(cEvents, aMemo); + FoundBoldComponent(aMemo); + GridController.Values[fBoldComponents.Count - 1, 3] := 'TcxBoldMemo'; +end; + +procedure TBoldToCxConverter.FoundTEdit(aEdit: TEdit); +begin + CheckEvents(cEvents, aEdit); + FoundBoldComponent(aEdit); + GridController.Values[fBoldComponents.Count - 1, 3] := 'TcxTextEdit'; +end; + +procedure TBoldToCxConverter.FoundTGroupBox(aBox: TGroupBox); +begin + CheckEvents(cEvents, aBox); + FoundBoldComponent(aBox); + GridController.Values[fBoldComponents.Count - 1, 3] := 'TcxGroupBox'; +end; + +procedure TBoldToCxConverter.FoundTLabel(aLabel: TLabel); +begin + CheckEvents(cEvents, aLabel); + FoundBoldComponent(aLabel); + GridController.Values[fBoldComponents.Count - 1, 3] := 'TcxLabel'; +end; + +procedure TBoldToCxConverter.FoundTMemo(aMemo: TMemo); +begin + CheckEvents(cEvents, aMemo); + FoundBoldComponent(aMemo); + GridController.Values[fBoldComponents.Count - 1, 3] := 'TcxMemo'; +end; + +procedure TBoldToCxConverter.FoundTSpeedButton(aButton: TSpeedButton); +begin + CheckEvents(cEvents, aButton); + FoundBoldComponent(aButton); + GridController.Values[fBoldComponents.Count - 1, 3] := 'TcxButton'; +end; + +procedure TBoldToCxConverter.FoundTBoldEdit(aEdit : TBoldEdit); +var + ExpressionType: TBoldElementTypeInfo; + vProposedComponent: string; +begin + CheckEvents(cEvents, aEdit); + ExpressionType := nil; + FoundBoldComponent(aEdit); + vProposedComponent := 'Unknown'; + + if Assigned(aEdit.BoldHandle) and Assigned(aEdit.BoldHandle.BoldType) and Assigned(aEdit.BoldHandle.BoldType.Evaluator) then + ExpressionType := aEdit.BoldHandle.BoldType.Evaluator.ExpressionType(aEdit.BoldProperties.expression,aEdit.BoldHandle.BoldType,false); + + if Assigned(ExpressionType) then + begin + GridController.Values[fBoldComponents.Count - 1, 2] := ExpressionType.DelphiName; + + if ExpressionType.DelphiName = 'TBADateTime' then + vProposedComponent := 'TcxBoldDateEdit' + else if ExpressionType.DelphiName = 'TBABoolean' then + vProposedComponent := 'TcxBoldCheckBox' + else + vProposedComponent := 'TcxBoldTextEdit'; + end; + GridController.Values[fBoldComponents.Count - 1, 3] := vProposedComponent; +end; + +function TBoldToCxConverter.GridController: TcxGridDataController; +begin + Result := fBoldToCxConverterForm.tv.DataController; +end; + +function TBoldToCxConverter.TryRename(aComponent: TComponent): Boolean; +begin + try + ValidateRename(aComponent, aComponent.Name, 'old' + aComponent.Name); + result := true; + except + on e: Exception do begin + ShowMessage(Format('%s (%s): %s', [aComponent.Name, aComponent.ClassName, e.Message])); + result := false; + end; + end; +end; + +procedure TBoldToCxConverter.CountNumberOfBoldComponents(var vBoldComponentCount: Integer; AOwner: TComponent); +var + I: Integer; + vComponent: TComponent; +begin + vBoldComponentCount := 0; + for I := 0 to AOwner.ComponentCount - 1 do + begin + vComponent := AOwner.Components[I]; + // TODO + if (vComponent is TBoldGrid) or (vComponent is TBoldEdit) or (vComponent is TBoldComboBox) or (vComponent is TBoldMemo) or (vComponent is TBoldLabel) + or (vComponent is TEdit) or (vComponent is TLabel) or (vComponent is TMemo) or (vComponent is TGroupBox) or (vComponent is TSpeedButton) + then + Inc(vBoldComponentCount); + end; +end; + +procedure TBoldToCxConverter.CopyBoldColumn(aBoldColumn: TBoldGridColumn;aCxGridBoldColumn: TCxGridBoldColumn); +begin + aCxGridBoldColumn.DataBinding.BoldProperties.Expression := aBoldColumn.BoldProperties.Expression; + aCxGridBoldColumn.Caption := aBoldColumn.Title.Caption; + aCxGridBoldColumn.name := 'Column' + IntToStr(aCxGridBoldColumn.Index); + if aBoldColumn.BoldProperties.Expression <> '' then + try + aCxGridBoldColumn.name := 'col' + AnsiUpperCase(aBoldColumn.BoldProperties.Expression[1]) + Copy(aBoldColumn.BoldProperties.Expression, 2, 1000); + except + // ignore rename attept + end; +end; + +procedure TBoldToCxConverter.CopyBoldComboListControllerProperties(FromComboListController : BoldComboBox.TBoldComboListController; ToComboListController: cxBoldEditors.TBoldComboListController); +begin + with FromComboListController do + begin + ToComboListController.DragMode := DragMode; + ToComboListController.DropMode := DropMode; + ToComboListController.NilElementMode := NilElementMode; + end; + +end; + +procedure TBoldToCxConverter.CheckEvents(AEventList: array of string; AObject: TObject); +var + i: Integer; + method: TMethod; + str, name: String; +begin + str := ''; + for i := Low(AEventList) to High(AEventList) do begin + if TypInfo.IsPublishedProp(AObject, AEventList[i]) then begin + method := TypInfo.GetMethodProp(AObject, AEventList[i]); + if method.Data <> nil then begin + name := TObject(Method.Data).MethodName(Method.Code); + str := str + Format('%s=%s; ', [AEventList[i], name]); + end; + end; + end; + if str <> '' then + fLog.Add(Format('Events von %s (%s): %s', [(AObject as TComponent).Name, AObject.ClassName, str])); +end; + +function TBoldToCxConverter.ConvertGrid(aBoldGrid : TBoldGrid): Boolean; +var + vCxGrid : TCxGrid; + vCxLevel: TCxGridLevel; + vCxGridBoldTableView : TcxGridBoldTableView; + vCol : Integer; +begin + result := false; + if not TryRename(aBoldGrid) then Exit; + vCxGrid := TcxGrid.Create(aBoldGrid.Owner); + CopyPublishedProperties (aBoldGrid,vCxGrid); + + vCxGridBoldTableView := vCxGrid.CreateView(TcxGridBoldTableView) as TcxGridBoldTableView; + vCxGridBoldTableView.Name := vCxGrid.Name + 'BoldTableView'; + + vCxGridBoldTableView.DataController.BoldHandle := aBoldGrid.BoldHandle; + if vCxGrid.Levels.Count = 0 then + vCxLevel := vCxGrid.Levels.Add + else + vCxLevel := vCxGrid.Levels[0]; + vCxLevel.GridView := vCxGridBoldTableView; + vCxGridBoldTableView.OptionsData.Editing := False; + vCxGridBoldTableView.OptionsView.GroupByBox := False; + vCxGridBoldTableView.OptionsBehavior.CellHints := True; + vCxGridBoldTableView.OptionsSelection.CellSelect := False; + + for vCol := 1 to aBoldGrid.ColCount - 1 do + CopyBoldColumn(aBoldGrid.Columns[vCol],vCxGridBoldTableView.CreateItem as TcxGridBoldColumn ); + result := true; +end; + +function TBoldToCxConverter.ConvertTEdit(aEdit: TEdit): Boolean; +var + vCxEdit : TcxTextEdit; +begin + result := false; + if not TryRename(aEdit) then Exit; + vCxEdit := TcxTextEdit.Create(aEdit.Owner); + vCxEdit.Autosize := aEdit.Autosize; + CopyPublishedProperties(aEdit, vCxEdit); + + vCxEdit.Properties.AutoSelect := aEdit.AutoSelect; + vCXEdit.Style.BorderStyle := ebsFlat; //ABoldEdit.BorderStyle; + vCxEdit.Properties.CharCase := aEdit.CharCase; + vCXEdit.Style.Color := aEdit.Color; + vCxEdit.DragCursor := aEdit.DragCursor; + vCxEdit.DragKind := aEdit.DragKind; + vCxEdit.DragMode := aEdit.DragMode; + vCxEdit.Style.Font := aEdit.Font; + vCxEdit.ParentColor := aEdit.ParentColor; //?? + vCxEdit.ParentFont := aEdit.ParentFont; //?? + vCxEdit.Properties.PasswordChar := aEdit.PasswordChar; + vCxEdit.PopupMenu := aEdit.PopupMenu; + vCxEdit.TabOrder := aEdit.TabOrder; + vCxEdit.TabStop := aEdit.TabStop; + + vCxEdit.Text := aEdit.Text; + if aEdit.ReadOnly then + vCxEdit.Properties.ReadOnly := aEdit.ReadOnly; + if aEdit.MaxLength <> 0 then + vCxEdit.Properties.MaxLength := aEdit.MaxLength; + result := true; +end; + +function TBoldToCxConverter.ConvertTGroupBox(aBox: TGroupBox): Boolean; +var + vCxEdit : TcxGroupBox; + i: Integer; +begin + result := false; + if not TryRename(aBox) then Exit; + vCxEdit := TcxGroupBox.Create(aBox.Owner); + CopyPublishedProperties(aBox, vCxEdit); + + vCXEdit.Style.BorderStyle := ebsFlat; //ABoldEdit.BorderStyle; + vCXEdit.Style.Color := aBox.Color; + vCxEdit.DragCursor := aBox.DragCursor; + vCxEdit.DragKind := aBox.DragKind; + vCxEdit.DragMode := aBox.DragMode; + vCxEdit.Style.Font := aBox.Font; + vCxEdit.ParentColor := aBox.ParentColor; //?? + vCxEdit.ParentFont := aBox.ParentFont; //?? + vCxEdit.PopupMenu := aBox.PopupMenu; + vCxEdit.TabOrder := aBox.TabOrder; + vCxEdit.TabStop := aBox.TabStop; + + vCxEdit.Caption := aBox.Caption; + + for i := aBox.ControlCount - 1 downto 0 do + (aBox.Controls[i] as TControl).Parent := vCxEdit; + result := true; +end; + +function TBoldToCxConverter.ConvertTLabel(aLabel: TLabel): Boolean; +var + vCxEdit : TcxLabel; +begin + result := false; + if not TryRename(aLabel) then Exit; + vCxEdit := TcxLabel.Create(aLabel.Owner); + vCxEdit.Properties.WordWrap := aLabel.WordWrap; + vCxEdit.Autosize := aLabel.Autosize; + CopyPublishedProperties(aLabel, vCxEdit); + + vCXEdit.Style.BorderStyle := ebsNone; + vCXEdit.Style.Color := aLabel.Color; + vCxEdit.DragCursor := aLabel.DragCursor; + vCxEdit.DragKind := aLabel.DragKind; + vCxEdit.DragMode := aLabel.DragMode; + vCxEdit.Style.Font := aLabel.Font; + vCxEdit.ParentColor := aLabel.ParentColor; //?? + vCxEdit.ParentFont := aLabel.ParentFont; //?? + vCxEdit.PopupMenu := aLabel.PopupMenu; + + vCxEdit.Caption := aLabel.Caption; + vCxEdit.Properties.Alignment.Horz := aLabel.Alignment; + case aLabel.Layout of + tlTop: vCxEdit.Properties.Alignment.Vert := taTopJustify; + tlCenter: vCxEdit.Properties.Alignment.Vert := taVCenter; + tlBottom: vCxEdit.Properties.Alignment.Vert := taBottomJustify; + end; + + vCxEdit.Transparent := True; + result := true; +end; + +function TBoldToCxConverter.ConvertTMemo(aMemo: TMemo): Boolean; +var + vCxEdit : TcxMemo; +begin + result := false; + if not TryRename(aMemo) then Exit; + vCxEdit := TcxMemo.Create(aMemo.Owner); + CopyPublishedProperties(aMemo, vCxEdit); + + vCXEdit.Style.BorderStyle := ebsFlat; + vCXEdit.Style.Color := aMemo.Color; + vCxEdit.DragCursor := aMemo.DragCursor; + vCxEdit.DragKind := aMemo.DragKind; + vCxEdit.DragMode := aMemo.DragMode; + vCxEdit.Style.Font := aMemo.Font; + vCxEdit.ParentColor := aMemo.ParentColor; //?? + vCxEdit.ParentFont := aMemo.ParentFont; //?? + vCxEdit.PopupMenu := aMemo.PopupMenu; + if aMemo.ReadOnly then + vCxEdit.Properties.ReadOnly := aMemo.ReadOnly; + vCxEdit.TabOrder := aMemo.TabOrder; + vCxEdit.TabStop := aMemo.TabStop; + + vCxEdit.Lines := aMemo.Lines; + vCxEdit.Properties.ScrollBars := aMemo.ScrollBars; + vCxEdit.Properties.WantReturns := aMemo.WantReturns; + vCxEdit.Properties.WantTabs := aMemo.WantTabs; + vCxEdit.Properties.WordWrap := aMemo.WordWrap; + result := true; +end; + +function TBoldToCxConverter.ConvertTSpeedButton(aButton: TSpeedButton): Boolean; +var + vCxEdit : TcxButton; +begin + result := false; + if not TryRename(aButton) then Exit; + vCxEdit := TcxButton.Create(aButton.Owner); + CopyPublishedProperties(aButton, vCxEdit); + + vCxEdit.ParentFont := aButton.ParentFont; //?? + vCxEdit.PopupMenu := aButton.PopupMenu; + vCxEdit.Caption := aButton.Caption; + if aButton.Glyph <> nil then + vCxEdit.Glyph.SetBitmap(aButton.Glyph); + vCxEdit.TabStop := false; + vCxEdit.SpeedButtonOptions.CanBeFocused := false; + if aButton.Action <> nil then + vCxEdit.Action := aButton.Action; + result := true; +end; + +procedure TBoldToCxConverter.CopyPublishedProperties(FromControl, ToControl : TControl); +var + OldName : string; +begin + + with FromControl do + begin + ToControl.Align := Align; + ToControl.AlignWithMargins := AlignWithMargins; + ToControl.Anchors := Anchors; + ToControl.Constraints := Constraints; + ToControl.Cursor := Cursor; + ToControl.Height := Height; + ToControl.HelpContext := HelpContext; + ToControl.HelpKeyword := HelpKeyword; + ToControl.HelpType := HelpType; + ToControl.Hint := Hint; + ToControl.Left := Left; + ToControl.Margins := Margins; + ToControl.Parent := Parent; + ToControl.Tag := Tag; + ToControl.Top := Top; + ToControl.Width := Width; + ToControl.Enabled := Enabled; + ToControl.ShowHint := ShowHint; + ToControl.Visible := Visible; + + OldName := Name; + Name := 'old' + Name; + end; + ToControl.Name := OldName; + +end; + +function TBoldToCxConverter.ConvertTBoldEdit(aBoldEdit : TBoldEdit): Boolean; +var + vCxBoldEdit : TcxBoldTextEdit; +begin + result := false; + if not TryRename(aBoldEdit) then Exit; + vCxBoldEdit := TcxBoldTextEdit.Create(aBoldEdit.Owner); + CopyPublishedProperties(aBoldEdit, vCxBoldEdit); + vCxBoldEdit.DataBinding.BoldHandle := aBoldEdit.BoldHandle; + vCxBoldEdit.DataBinding.BoldProperties.Expression := aBoldEdit.BoldProperties.Expression; + CopyFollowerProperties(aBoldEdit.BoldProperties,vCxBoldEdit.DataBinding.BoldProperties); + + vCxBoldEdit.Properties.Alignment.Horz := aBoldEdit.Alignment; + vCxBoldEdit.Properties.AutoSelect := aBoldEdit.AutoSelect; + vCxBoldEdit.Autosize := aBoldEdit.Autosize; + vCXBoldEdit.Style.BorderStyle := ebsFlat; //ABoldEdit.BorderStyle; + vCxBoldEdit.Properties.CharCase := aBoldEdit.CharCase; + vCXBoldEdit.Style.Color := aBoldEdit.Color; + vCxBoldEdit.DragCursor := aBoldEdit.DragCursor; + vCxBoldEdit.DragKind := aBoldEdit.DragKind; + vCxBoldEdit.DragMode := aBoldEdit.DragMode; + vCxBoldEdit.Style.Font := aBoldEdit.Font; + vCxBoldEdit.ParentColor := aBoldEdit.ParentColor; //?? + vCxBoldEdit.ParentFont := aBoldEdit.ParentFont; //?? + vCxBoldEdit.Properties.PasswordChar := aBoldEdit.PasswordChar; + + vCxBoldEdit.PopupMenu := aBoldEdit.PopupMenu; + if aBoldEdit.ReadOnly then + vCxBoldEdit.Properties.ReadOnly := aBoldEdit.ReadOnly; + if aBoldEdit.MaxLength <> 0 then + vCxBoldEdit.Properties.MaxLength := aBoldEdit.MaxLength; + vCxBoldEdit.TabOrder := aBoldEdit.TabOrder; + vCxBoldEdit.TabStop := aBoldEdit.TabStop; + vCxBoldEdit.Text := ''; + result := true; +end; + +function TBoldToCxConverter.ConvertTBoldEditToDateEdit(aBoldEdit : TBoldEdit): Boolean; +var + vCxBoldDateEdit : TcxBoldDateEdit; +begin + result := false; + if not TryRename(aBoldEdit) then Exit; + vCxBoldDateEdit := TcxBoldDateEdit.Create(aBoldEdit.Owner); + CopyPublishedProperties(aBoldEdit, vCxBoldDateEdit); + vCxBoldDateEdit.DataBinding.BoldHandle := aBoldEdit.BoldHandle; + vCxBoldDateEdit.DataBinding.BoldProperties.Expression := aBoldEdit.BoldProperties.Expression; + CopyFollowerProperties(aBoldEdit.BoldProperties,vCxBoldDateEdit.DataBinding.BoldProperties); + + vCxBoldDateEdit.Properties.Alignment.Horz := aBoldEdit.Alignment; + vCxBoldDateEdit.Properties.AutoSelect := aBoldEdit.AutoSelect; + vCxBoldDateEdit.Autosize := aBoldEdit.Autosize; + vCxBoldDateEdit.Style.BorderStyle := ebsFlat; //ABoldEdit.BorderStyle; + vCxBoldDateEdit.Properties.CharCase := aBoldEdit.CharCase; + vCxBoldDateEdit.Style.Color := aBoldEdit.Color; + vCxBoldDateEdit.DragCursor := aBoldEdit.DragCursor; + vCxBoldDateEdit.DragKind := aBoldEdit.DragKind; + vCxBoldDateEdit.DragMode := aBoldEdit.DragMode; + vCxBoldDateEdit.Style.Font := aBoldEdit.Font; + vCxBoldDateEdit.ParentColor := aBoldEdit.ParentColor; //?? + vCxBoldDateEdit.ParentFont := aBoldEdit.ParentFont; //?? + vCxBoldDateEdit.Properties.PasswordChar := aBoldEdit.PasswordChar; + + vCxBoldDateEdit.PopupMenu := aBoldEdit.PopupMenu; + if aBoldEdit.ReadOnly then + vCxBoldDateEdit.Properties.ReadOnly := aBoldEdit.ReadOnly; + if aBoldEdit.MaxLength <> 0 then + vCxBoldDateEdit.Properties.MaxLength := aBoldEdit.MaxLength; + vCxBoldDateEdit.TabOrder := aBoldEdit.TabOrder; + vCxBoldDateEdit.TabStop := aBoldEdit.TabStop; + result := true; +end; + + +function TBoldToCxConverter.ConvertTBoldLabel(aBoldLabel: TBoldLabel): Boolean; +var + vCxEdit : TcxBoldLabel; +begin + result := false; + if not TryRename(aBoldLabel) then Exit; + vCxEdit := TcxBoldLabel.Create(aBoldLabel.Owner); + vCxEdit.Properties.WordWrap := aBoldLabel.WordWrap; + vCxEdit.Autosize := aBoldLabel.Autosize; + CopyPublishedProperties(aBoldLabel, vCxEdit); + + vCxEdit.DataBinding.BoldHandle := aBoldLabel.BoldHandle; + vCxEdit.DataBinding.BoldProperties.Expression := aBoldLabel.BoldProperties.Expression; + CopyFollowerProperties(aBoldLabel.BoldProperties,vCxEdit.DataBinding.BoldProperties); + + vCXEdit.Style.BorderStyle := ebsNone; + vCXEdit.Style.Color := aBoldLabel.Color; + vCxEdit.DragCursor := aBoldLabel.DragCursor; + vCxEdit.DragKind := aBoldLabel.DragKind; + vCxEdit.DragMode := aBoldLabel.DragMode; + vCxEdit.Style.Font := aBoldLabel.Font; + vCxEdit.ParentColor := aBoldLabel.ParentColor; //?? + vCxEdit.ParentFont := aBoldLabel.ParentFont; //?? + vCxEdit.PopupMenu := aBoldLabel.PopupMenu; + + vCxEdit.Caption := aBoldLabel.Caption; + vCxEdit.Properties.Alignment.Horz := aBoldLabel.Alignment; + case aBoldLabel.Layout of + tlTop: vCxEdit.Properties.Alignment.Vert := taTopJustify; + tlCenter: vCxEdit.Properties.Alignment.Vert := taVCenter; + tlBottom: vCxEdit.Properties.Alignment.Vert := taBottomJustify; + end; + + vCxEdit.Transparent := True; + result := true; +end; + +function TBoldToCxConverter.ConvertTBoldMemo(aBoldMemo: TBoldMemo): Boolean; +var + vCxEdit : TcxBoldMemo; +begin + result := false; + if not TryRename(aBoldMemo) then Exit; + vCxEdit := TcxBoldMemo.Create(aBoldMemo.Owner); + CopyPublishedProperties(aBoldMemo, vCxEdit); + vCxEdit.DataBinding.BoldHandle := aBoldMemo.BoldHandle; + vCxEdit.DataBinding.BoldProperties.Expression := aBoldMemo.BoldProperties.Expression; + CopyFollowerProperties(aBoldMemo.BoldProperties,vCxEdit.DataBinding.BoldProperties); + + vCXEdit.Style.BorderStyle := ebsFlat; + vCXEdit.Style.Color := aBoldMemo.Color; + vCxEdit.DragCursor := aBoldMemo.DragCursor; + vCxEdit.DragKind := aBoldMemo.DragKind; + vCxEdit.DragMode := aBoldMemo.DragMode; + vCxEdit.Style.Font := aBoldMemo.Font; + vCxEdit.ParentColor := aBoldMemo.ParentColor; //?? + vCxEdit.ParentFont := aBoldMemo.ParentFont; //?? + vCxEdit.PopupMenu := aBoldMemo.PopupMenu; + if aBoldMemo.ReadOnly then + vCxEdit.Properties.ReadOnly := aBoldMemo.ReadOnly; + vCxEdit.TabOrder := aBoldMemo.TabOrder; + vCxEdit.TabStop := aBoldMemo.TabStop; + + vCxEdit.Lines := aBoldMemo.Lines; + vCxEdit.Properties.ScrollBars := aBoldMemo.ScrollBars; + vCxEdit.Properties.WantReturns := aBoldMemo.WantReturns; + vCxEdit.Properties.WantTabs := aBoldMemo.WantTabs; + vCxEdit.Properties.WordWrap := aBoldMemo.WordWrap; + result := true; +end; + +procedure TBoldToCxConverter.CopyFollowerProperties(FromFollower : TBoldStringFollowerController; ToFollower : TBoldVariantFollowerController); +begin + with FromFollower do + begin + ToFollower.Expression := Expression; + ToFollower.ApplyPolicy := ApplyPolicy; + ToFollower.CleanOnEqual := CleanOnEqual; + ToFollower.DragMode := DragMode; + ToFollower.DropMode := DropMode; + ToFollower.NilRepresentation := NilStringRepresentation; + ToFollower.Representation := Representation; + ToFollower.Variables := Variables; + //Renderer One is variant and the other stringrenderer + end; +end; + +function TBoldToCxConverter.ConvertTBoldComboBox(aBoldComboBox : TBoldComboBox): Boolean; +var + vCxBoldComboBox : TcxBoldComboBox; +begin + result := false; + if not TryRename(aBoldComboBox) then Exit; + vCxBoldComboBox := TcxBoldComboBox.Create(aBoldComboBox.Owner); + CopyPublishedProperties (aBoldComboBox, vCxBoldComboBox); + CopyFollowerProperties(aBoldComboBox.BoldProperties,vCxBoldComboBox.DataBinding.BoldProperties); + CopyBoldComboListControllerProperties(aBoldComboBox.BoldListProperties, vCxBoldComboBox.Properties.BoldLookupListProperties); + + vCxBoldComboBox.DataBinding.BoldHandle := aBoldComboBox.BoldHandle; + CopyFollowerProperties(aBoldComboBox.BoldRowProperties, vCxBoldComboBox.Properties.BoldRowProperties); + vCxBoldComboBox.Properties.BoldLookupListHandle := aBoldComboBox.BoldListHandle; + + vCxBoldComboBox.Properties.Alignment.Horz := aBoldComboBox.Alignment; + vCxBoldComboBox.AlignWithMargins := ABoldComboBox.AlignWithMargins; + //vCxBoldComboBox.Properties.AutoSelect := aBoldComboBox.AutoSelect; + //vCxBoldComboBox.Autosize := aBoldComboBox.Autosize; + vCXBoldComboBox.Style.BorderStyle := ebsFlat; //ABoldComboBox.BorderStyle; + vCxBoldComboBox.Properties.CharCase := aBoldComboBox.CharCase; + vCXBoldComboBox.Style.Color := aBoldComboBox.Color; + vCxBoldComboBox.DragCursor := aBoldComboBox.DragCursor; + vCxBoldComboBox.DragKind := aBoldComboBox.DragKind; + vCxBoldComboBox.DragMode := aBoldComboBox.DragMode; + vCxBoldComboBox.Style.Font := aBoldComboBox.Font; + vCxBoldComboBox.ParentColor := aBoldComboBox.ParentColor; + // vCxBoldComboBox.ParentCtl3D := aBoldComboBox.ParentCtl3D; + //MaxLength + vCxBoldComboBox.ParentFont := aBoldComboBox.ParentFont; + vCxBoldComboBox.ParentShowHint := aBoldComboBox.ParentShowHint; + //vCxBoldComboBox.Properties.PasswordChar := aBoldComboBox.PasswordChar; + + vCxBoldComboBox.PopupMenu := aBoldComboBox.PopupMenu; + if aBoldComboBox.ReadOnly then + vCxBoldComboBox.Properties.ReadOnly := aBoldComboBox.ReadOnly; + vCxBoldComboBox.TabOrder := aBoldComboBox.TabOrder; + vCxBoldComboBox.TabStop := aBoldComboBox.TabStop; + vCxBoldComboBox.Properties.BoldSelectChangeAction := aBoldComboBox.BoldSelectChangeAction; + vCxBoldComboBox.Properties.BoldSetValueExpression := aBoldComboBox.BoldSetValueExpression; + + vCXBoldCombobox.Properties.OnChange := aBoldComboBox.OnChange; + vCXBoldCombobox.OnClick := aBoldComboBox.OnClick; + vCXBoldCombobox.OnContextPopup := aBoldComboBox.OnContextPopup; + vCXBoldCombobox.OnDblClick := aBoldComboBox.OnDblClick; + vCXBoldCombobox.OnDragDrop := aBoldComboBox.OnDragDrop; + vCXBoldCombobox.OnDragOver := aBoldComboBox.OnDragOver; + //vCXBoldCombobox.Properties.OnDrawItem := aBoldComboBox.OnDrawItem; + //vCXBoldCombobox.OnDropDown := ???? + vCXBoldCombobox.OnEndDock := aBoldComboBox.OnEndDock; + vCXBoldCombobox.OnEndDrag := aBoldComboBox.OnEndDrag; + vCXBoldCombobox.OnEnter := aBoldComboBox.OnEnter; + vCXBoldCombobox.OnExit := aBoldComboBox.OnExit; + vCXBoldCombobox.OnKeyDown := aBoldComboBox.OnKeyDown; + vCXBoldCombobox.OnKeyPress := aBoldComboBox.OnKeyPress; + vCXBoldCombobox.OnKeyUp := aBoldComboBox.OnKeyUp; + //vCXBoldCombobox.Properties.OnMeasureItem := aBoldComboBox.OnMeasureItem; + //vCXBoldCombobox.Properties.OnSelectChanged := aBoldComboBox.OnSelectChanged; + vCXBoldCombobox.OnStartDock := aBoldComboBox.OnStartDock; + vCXBoldCombobox.OnStartDrag := aBoldComboBox.OnStartDrag; + vCXBoldCombobox.PopupMenu := aBoldComboBox.PopupMenu; + + result := true; +end; + +end. diff --git a/Source/BoldAwareGUI/BoldDevex/BoldToCxGridConverterUnit.pas b/Source/BoldAwareGUI/BoldDevex/BoldToCxGridConverterUnit.pas new file mode 100644 index 00000000..7d563e14 --- /dev/null +++ b/Source/BoldAwareGUI/BoldDevex/BoldToCxGridConverterUnit.pas @@ -0,0 +1,106 @@ +unit BoldToCxGridConverterUnit; + +interface + +uses + BoldGrid, + Classes, + cxGridBoldSupportUnit, + cxGridPopupMenu, + SysUtils; + +type + TBoldToCxGridConverter = class(TComponent) + private + procedure ConvertGrid(aBoldGrid : TBoldGrid); + procedure CopyBoldColumn(aBoldColumn : TBoldGridColumn; aCxGridBoldColumn : TCxGridBoldColumn); + protected + { Protected declarations } + public + constructor Create(AOwner : TComponent); override; + { Public declarations } + published + { Published declarations } + end; + +const + Ctrlf = #13#10; + +procedure Register; + +implementation +uses Dialogs, cxGrid; + +procedure Register; +begin + RegisterComponents('AT Core', [TBoldToCxGridConverter]); +end; + +{ TBoldToCxGridConverter } + +procedure TBoldToCxGridConverter.CopyBoldColumn(aBoldColumn: TBoldGridColumn;aCxGridBoldColumn: TCxGridBoldColumn); +begin + aCxGridBoldColumn.DataBinding.BoldProperties.Expression := aBoldColumn.BoldProperties.Expression; + aCxGridBoldColumn.Caption := aBoldColumn.Title.Caption; + try + aCxGridBoldColumn.name := 'col' + AnsiUpperCase(aBoldColumn.BoldProperties.Expression[1]) + Copy(aBoldColumn.BoldProperties.Expression, 2, 1000); + except + aCxGridBoldColumn.name := 'Column' + IntToStr(aCxGridBoldColumn.Index); + end; +end; + +constructor TBoldToCxGridConverter.Create(AOwner: TComponent); +var + I : Integer; + vGrid : TBoldGrid; +begin + inherited; + for I := 0 to AOwner.ComponentCount - 1 do + begin + if AOwner.Components[I] is TBoldGrid then + begin + vGrid := AOwner.Components[I] as TBoldGrid; + if MessageDlg('Convert ' + vGrid.Name + ' into a cxBoldGrid ?',mtWarning,[mbYes,mbNo],0) = 6 then + ConvertGrid(vGrid); + end; + end; +end; + + +procedure TBoldToCxGridConverter.ConvertGrid(aBoldGrid : TBoldGrid); +var + vCxGrid : TCxGrid; + vCxGridBoldTableView : TcxGridBoldTableView; + vCol : Integer; +begin + + vCxGrid := TcxGrid.Create(aBoldGrid.Owner); + vCxGrid.Name := 'cx'+ aBoldGrid.Name; + vCxGrid.Parent := aBoldGrid.Parent; + vCxGrid.Left := aBoldGrid.Left; + vCxGrid.Top := aBoldGrid.Top; + vCxGrid.Width := aBoldGrid.Width; + vCxGrid.Height := aBoldGrid.Height; + vCxGrid.Align := aBoldGrid.Align; + vCxGrid.Anchors := aBoldGrid.Anchors; + + vCxGridBoldTableView := vCxGrid.CreateView(TcxGridBoldTableView) as TcxGridBoldTableView; + vCxGridBoldTableView.Name := vCxGrid.Name + 'BoldTableView'; + + vCxGridBoldTableView.DataController.BoldHandle := aBoldGrid.BoldHandle; + vCxGrid.Levels[0].GridView := vCxGridBoldTableView; + vCxGridBoldTableView.OptionsData.Editing := False; + vCxGridBoldTableView.OptionsView.GroupByBox := False; + vCxGridBoldTableView.OptionsBehavior.CellHints := True; + vCxGridBoldTableView.OptionsSelection.CellSelect := False; + + for vCol := 1 to aBoldGrid.ColCount - 1 do + CopyBoldColumn(aBoldGrid.Columns[vCol],vCxGridBoldTableView.CreateItem as TcxGridBoldColumn ); + + ShowMessage('Successfully converted ' + aBoldGrid.name + ' into a TcxBoldGrid' + CtrLf + + 'Remember to remove old boldgrid and this converter component.' + Ctrlf + + 'Add a TcxGridPopupMenu component if you want to use menus on the grids header.'); + +end; + +end. diff --git a/Source/BoldAwareGUI/BoldDevex/cxBoldEditConsts.pas b/Source/BoldAwareGUI/BoldDevex/cxBoldEditConsts.pas new file mode 100644 index 00000000..28bccf8b --- /dev/null +++ b/Source/BoldAwareGUI/BoldDevex/cxBoldEditConsts.pas @@ -0,0 +1,39 @@ +unit cxBoldEditConsts; + +interface + +// v2.03 - 25 Jan 2011 2007-2011 Daniel Mauric + +resourcestring + scxSBoldEditRepositoryTextItem = 'BoldTextEdit|Represents a Bold aware single line text editor'; + scxSBoldComboBoxRepositoryTextItem = 'BoldComboBox|Represents a Bold aware combo box editor'; + scxSBoldLookupComboBoxRepositoryTextItem = 'BoldLookupComboBox|Represents a Bold aware lookup combo box editor'; + scxSBoldExtLookupComboBoxRepositoryTextItem = 'BoldExtLookupComboBox|Represents a Bold aware lookup combo using grid as its drop down control'; + +implementation + +uses + dxCore; + +procedure AddEditorsResourceStringNames(AProduct: TdxProductResourceStrings); + + procedure InternalAdd(const AResourceStringName: string; AAdress: Pointer); + begin + AProduct.Add(AResourceStringName, AAdress); + end; + +begin + InternalAdd('scxSBoldEditRepositoryTextItem', @scxSBoldEditRepositoryTextItem); + InternalAdd('scxSBoldComboBoxRepositoryTextItem', @scxSBoldComboBoxRepositoryTextItem); + InternalAdd('scxSBoldLookupComboBoxRepositoryTextItem', @scxSBoldLookupComboBoxRepositoryTextItem); + InternalAdd('scxSBoldExtLookupComboBoxRepositoryTextItem', @scxSBoldExtLookupComboBoxRepositoryTextItem); +end; + + +initialization + dxResourceStringsRepository.RegisterProduct('Bold ExpressEditors Library', @AddEditorsResourceStringNames); + +finalization + dxResourceStringsRepository.UnRegisterProduct('Bold ExpressEditors Library'); + +end. diff --git a/Source/BoldAwareGUI/BoldDevex/cxBoldEditRepositoryItems.pas b/Source/BoldAwareGUI/BoldDevex/cxBoldEditRepositoryItems.pas new file mode 100644 index 00000000..e6a1b1ce --- /dev/null +++ b/Source/BoldAwareGUI/BoldDevex/cxBoldEditRepositoryItems.pas @@ -0,0 +1,134 @@ +unit cxBoldEditRepositoryItems; + +interface + +// v2.03 - 25 Jan 2011 2007-2011 Daniel Mauric + +uses + cxEdit, + cxBoldEditors, + cxBoldExtLookupComboBox, + cxBoldLookupComboBox; + +type + TcxEditRepositoryBoldStringItem = class(TcxEditRepositoryItem) + private + function GetProperties: TcxBoldTextEditProperties; + procedure SetProperties(Value: TcxBoldTextEditProperties); + public + class function GetEditPropertiesClass: TcxCustomEditPropertiesClass; override; + published + property Properties: TcxBoldTextEditProperties read GetProperties write SetProperties; + end; + + TcxEditRepositoryBoldComboBoxItem = class(TcxEditRepositoryItem) + private + function GetProperties: TcxBoldComboBoxProperties; + procedure SetProperties(Value: TcxBoldComboBoxProperties); + public + class function GetEditPropertiesClass: TcxCustomEditPropertiesClass; override; + published + property Properties: TcxBoldComboBoxProperties read GetProperties write SetProperties; + end; + + TcxEditRepositoryBoldLookupComboBoxItem = class(TcxEditRepositoryItem) + private + function GetProperties: TcxBoldLookupComboBoxProperties; + procedure SetProperties(Value: TcxBoldLookupComboBoxProperties); + public + class function GetEditPropertiesClass: TcxCustomEditPropertiesClass; override; + published + property Properties: TcxBoldLookupComboBoxProperties read GetProperties write SetProperties; + end; + + TcxEditRepositoryBoldExtLookupComboBoxItem = class(TcxEditRepositoryItem) + private + function GetProperties: TcxBoldExtLookupComboBoxProperties; + procedure SetProperties(Value: TcxBoldExtLookupComboBoxProperties); + public + class function GetEditPropertiesClass: TcxCustomEditPropertiesClass; override; + published + property Properties: TcxBoldExtLookupComboBoxProperties read GetProperties write SetProperties; + end; + +implementation + +uses + Classes; + +{ TcxEditRepositoryBoldStringItem } + +class function TcxEditRepositoryBoldStringItem.GetEditPropertiesClass: TcxCustomEditPropertiesClass; +begin + Result := TcxBoldTextEditProperties; +end; + +function TcxEditRepositoryBoldStringItem.GetProperties: TcxBoldTextEditProperties; +begin + Result := inherited Properties as TcxBoldTextEditProperties; +end; + +procedure TcxEditRepositoryBoldStringItem.SetProperties( + Value: TcxBoldTextEditProperties); +begin + inherited Properties := Value; +end; + +{ TcxEditRepositoryBoldComboBoxItem } + +class function TcxEditRepositoryBoldComboBoxItem.GetEditPropertiesClass: TcxCustomEditPropertiesClass; +begin + Result := TcxBoldComboBoxProperties; +end; + +function TcxEditRepositoryBoldComboBoxItem.GetProperties: TcxBoldComboBoxProperties; +begin + Result := inherited Properties as TcxBoldComboBoxProperties; +end; + +procedure TcxEditRepositoryBoldComboBoxItem.SetProperties( + Value: TcxBoldComboBoxProperties); +begin + inherited Properties := Value; +end; + +{ TcxEditRepositoryBoldLookupComboBoxItem } + +class function TcxEditRepositoryBoldLookupComboBoxItem.GetEditPropertiesClass: TcxCustomEditPropertiesClass; +begin + result := TcxBoldLookupComboBoxProperties; +end; + +function TcxEditRepositoryBoldLookupComboBoxItem.GetProperties: TcxBoldLookupComboBoxProperties; +begin + Result := inherited Properties as TcxBoldLookupComboBoxProperties; +end; + +procedure TcxEditRepositoryBoldLookupComboBoxItem.SetProperties( + Value: TcxBoldLookupComboBoxProperties); +begin + inherited Properties := Value; +end; + +{ TcxEditRepositoryBoldExtLookupComboBoxItem } + +class function TcxEditRepositoryBoldExtLookupComboBoxItem.GetEditPropertiesClass: TcxCustomEditPropertiesClass; +begin + result := TcxBoldExtLookupComboBoxProperties; +end; + +function TcxEditRepositoryBoldExtLookupComboBoxItem.GetProperties: TcxBoldExtLookupComboBoxProperties; +begin + Result := inherited Properties as TcxBoldExtLookupComboBoxProperties; +end; + +procedure TcxEditRepositoryBoldExtLookupComboBoxItem.SetProperties( + Value: TcxBoldExtLookupComboBoxProperties); +begin + inherited Properties := Value; +end; + +initialization + RegisterClasses([TcxEditRepositoryBoldStringItem, TcxEditRepositoryBoldComboBoxItem, TcxEditRepositoryBoldLookupComboBoxItem, TcxEditRepositoryBoldExtLookupComboBoxItem]); + +end. diff --git a/Source/BoldAwareGUI/BoldDevex/cxBoldEditors.pas b/Source/BoldAwareGUI/BoldDevex/cxBoldEditors.pas new file mode 100644 index 00000000..e7fff10c --- /dev/null +++ b/Source/BoldAwareGUI/BoldDevex/cxBoldEditors.pas @@ -0,0 +1,6369 @@ +unit cxBoldEditors; + +{$ASSERTIONS ON} +{$INCLUDE Bold.inc} + +{$DEFINE Constraints} + +{.$DEFINE BoldDevExLog} + +{.$DEFINE LOGCHANGES} + +(* + cxBoldEditors v2.60 - 26 July 2017 + 2007-2017 Daniel Mauric +*) + +interface + +uses + Classes, + SysUtils, + + cxClasses, + cxControls, + cxEdit, + cxTextEdit, + cxDropDownEdit, + cxCalendar, + cxTimeEdit, + cxMemo, + cxCurrencyEdit, + cxMaskEdit, + cxCheckBox, + cxSpinEdit, + cxButtonEdit, + cxHyperLinkEdit, + cxProgressBar, + cxBarEditItem, + dxBar, + cxContainer, + {$IFDEF DevExScheduler} + cxDateNavigator, + {$ENDIF} + cxLabel, + cxImage, + cxRichEdit, + cxCheckListBox, + cxListBox, + cxListView, ComCtrls, + cxDataUtils, + + cxLookAndFeelPainters, // for TcxCheckBoxState = (cbsUnchecked, cbsChecked, cbsGrayed); + StdCtrls, // for TCheckBoxState = (cbUnchecked, cbChecked, cbGrayed); + cxGraphics, + Controls,// for TCaption + Messages, // for TMessage + Windows, + + BoldSubscription, + BoldVariantControlPack, + BoldCheckboxStateControlPack, + BoldControllerListControlPack, + BoldElementHandleFollower, + BoldControlPack, + BoldHandles, + BoldElements, + BoldControlPackDefs, + BoldSystem, + BoldSystemRT, + BoldListHandleFollower, + BoldListListControlPack, + BoldControlsDefs, + BoldDefs, + BoldAbstractListHandle, + BoldComponentvalidator; + +type + TcxCustomBoldEditDefaultValuesProvider = class; + TcxBoldEditDataBinding = class; + TBoldComboListController = class; + TcxCustomBoldTextEditProperties = class; + TcxBoldTextEditProperties = class; + TcxBoldTextEdit = class; + TcxBoldDateEdit = class; + + IcxBoldEditProperties = Interface + ['{D50859F1-F550-4CE6-84DE-5074921512E5}'] + procedure SetStoredValue(aValue: Variant; aBoldHandle: TBoldElementHandle; aEdit: TcxCustomEdit; aFollower: TBoldFollower; var aDone: boolean); + function BoldElementToEditValue(aFollower: TBoldFollower; aElement: TBoldElement; aEdit: TcxCustomEdit): variant; + function CanEdit(aBoldHandle: TBoldElementHandle; aFollower: TBoldFollower): boolean; + end; + + TBoldComboListController = class(TBoldAbstractListAsFollowerListController) + published + property NilElementMode; + end; + + TcxCustomBoldTextEditProperties = class(TcxCustomTextEditProperties, IcxBoldEditProperties, IBoldValidateableComponent) + private + fListHandleFollower: TBoldListHandleFollower; + fBoldListProperties: TBoldAbstractListAsFollowerListController; // TBoldComboListController; + fBoldRowProperties: TBoldVariantFollowerController; + fBoldSelectChangeAction: TBoldComboSelectChangeAction; + fBoldSetValueExpression: TBoldExpression; + function GetBoldListHandle: TBoldAbstractListHandle; + function GetListFollower: TBoldFollower; + procedure SetBoldListHandle(const Value: TBoldAbstractListHandle); + procedure SetBoldListProperties(const Value: TBoldAbstractListAsFollowerListController); + procedure SetRowProperties(const Value: TBoldVariantFollowerController); + function GetContextForBoldRowProperties: TBoldElementTypeInfo; + procedure SetBoldSelectChangeAction(Value: TBoldComboSelectChangeAction); + // IBoldValidateableComponent + function ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: string): Boolean; + // IcxBoldEditProperties + procedure SetStoredValue(aValue: Variant; aBoldHandle: TBoldElementHandle; aEdit: TcxCustomEdit; aFollower: TBoldFollower; var aDone: boolean); + function BoldElementToEditValue(aFollower: TBoldFollower; aElement: TBoldElement; aEdit: TcxCustomEdit): variant; + function CanEdit(aBoldHandle: TBoldElementHandle; aFollower: TBoldFollower): boolean; + procedure SetBoldSetValueExpression(const Value: TBoldExpression); + protected + function IsNilRepresentation(AValue: Variant): boolean; + procedure _InsertItem(Index: Integer; Follower: TBoldFollower); + procedure _ReplaceItem(Index: Integer; Follower: TBoldFollower); + procedure _DeleteItem(Index: Integer; OwningFollower: TBoldFollower); + procedure _RowAfterMakeUptoDate(Follower: TBoldFollower); + procedure _BeforeMakeUptoDate(Follower: TBoldFollower); + procedure _AfterMakeUptoDate(Follower: TBoldFollower); + property BoldLookupListHandle: TBoldAbstractListHandle read GetBoldListHandle write SetBoldListHandle; + property BoldLookupListProperties: TBoldAbstractListAsFollowerListController read fBoldListProperties write SetBoldListProperties; + property BoldRowProperties: TBoldVariantFollowerController read fBoldRowProperties write SetRowProperties; + property BoldSelectChangeAction: TBoldComboSelectChangeAction read fBoldSelectChangeAction write SetBoldSelectChangeAction default bdcsSetValue; + property BoldSetValueExpression: TBoldExpression read fBoldSetValueExpression write SetBoldSetValueExpression; + public + constructor Create(AOwner: TPersistent); override; + destructor Destroy; override; + class function GetContainerClass: TcxContainerClass; override; + function IsEditValueValid(var EditValue: TcxEditValue; AEditFocused: Boolean): Boolean; override; + property LookupListFollower: TBoldFollower read GetListFollower; + end; + + TcxBoldComboBoxProperties = class(TcxCustomComboBoxProperties, IcxBoldEditProperties, IBoldValidateableComponent) + private + fListHandleFollower: TBoldListHandleFollower; + fBoldListProperties: TBoldComboListController; + fBoldRowProperties: TBoldVariantFollowerController; + fBoldSelectChangeAction: TBoldComboSelectChangeAction; + fBoldSetValueExpression: TBoldExpression; + function GetBoldListHandle: TBoldAbstractListHandle; + function GetListFollower: TBoldFollower; + procedure SetBoldListHandle(const Value: TBoldAbstractListHandle); + procedure SetBoldListProperties(const Value: TBoldComboListController); + procedure SetRowProperties(const Value: TBoldVariantFollowerController); + function GetContextForBoldRowProperties: TBoldElementTypeInfo; + procedure SetBoldSelectChangeAction(Value: TBoldComboSelectChangeAction); + // IBoldValidateableComponent + function ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: string): Boolean; + // IcxBoldEditProperties + procedure SetStoredValue(aValue: Variant; aBoldHandle: TBoldElementHandle; aEdit: TcxCustomEdit; aFollower: TBoldFollower; var aDone: boolean); + function BoldElementToEditValue(aFollower: TBoldFollower; aElement: TBoldElement; aEdit: TcxCustomEdit): variant; + function CanEdit(aBoldHandle: TBoldElementHandle; aFollower: TBoldFollower): boolean; + procedure SetBoldSetValueExpression(const Value: TBoldExpression); + protected + procedure _InsertItem(Index: Integer; Follower: TBoldFollower); + procedure _ReplaceItem(Index: Integer; Follower: TBoldFollower); + procedure _DeleteItem(Index: Integer; OwningFollower: TBoldFollower); + procedure _RowAfterMakeUptoDate(Follower: TBoldFollower); + procedure _BeforeMakeUptoDate(Follower: TBoldFollower); + procedure _AfterMakeUptoDate(Follower: TBoldFollower); + function GetAlwaysPostEditValue: Boolean; override; + public + constructor Create(AOwner: TPersistent); override; + destructor Destroy; override; + procedure Assign(Source: TPersistent); override; + class function GetContainerClass: TcxContainerClass; override; + function IsEditValueValid(var EditValue: TcxEditValue; AEditFocused: Boolean): Boolean; override; + function IsDisplayValueValid(var DisplayValue: TcxEditValue; AEditFocused: Boolean): Boolean; override; + property LookupListFollower: TBoldFollower read GetListFollower; + published + property BoldLookupListHandle: TBoldAbstractListHandle read GetBoldListHandle write SetBoldListHandle; + property BoldLookupListProperties: TBoldComboListController read fBoldListProperties write SetBoldListProperties; + property BoldRowProperties: TBoldVariantFollowerController read fBoldRowProperties write SetRowProperties; + property BoldSelectChangeAction: TBoldComboSelectChangeAction read fBoldSelectChangeAction write SetBoldSelectChangeAction default bdcsSetValue; + property BoldSetValueExpression: TBoldExpression read fBoldSetValueExpression write SetBoldSetValueExpression; + + property Alignment; + property AssignedValues; + property AutoSelect; + property BeepOnError; + property ButtonGlyph; + property CaseInsensitive; + property CharCase; + property ClearKey; + property DropDownAutoWidth; + property DropDownListStyle; + property DropDownRows; + property DropDownSizeable; + property DropDownWidth; + property HideSelection; + property IgnoreMaskBlank; + property ImeMode; + property ImeName; + property ImmediateDropDown; +// property ImmediatePost; + property ImmediateUpdateText; + property IncrementalSearch; + property ItemHeight; + property MaskKind; + property EditMask; + property MaxLength; + property OEMConvert; + property PopupAlignment; + property PostPopupValueOnTab; + property ReadOnly; + property Revertable; +// property Sorted; + property UseLeftAlignmentOnEditing; + property ValidateOnEnter; + property ValidationOptions; + property OnChange; + property OnCloseUp; + property OnDrawItem; + property OnEditValueChanged; + property OnInitPopup; + property OnMeasureItem; + property OnNewLookupDisplayText; + property OnPopup; + property OnValidate; + end; + + TcxSingleLinkEditProperties = class(TcxCustomHyperLinkEditProperties {TcxCustomHyperLinkEditProperties}) + published + property Alignment; + property AssignedValues; +// property AutoComplete; // deprecated + property AutoSelect; + property ClearKey; + property ImeMode; + property ImeName; + property IncrementalSearch; + property LinkColor; + property LookupItems; +// property LookupItemsSorted; +// property Prefix; + property ReadOnly; + property StartKey; + property SingleClick; + property UseLeftAlignmentOnEditing; +// property UsePrefix; + property ValidateOnEnter; + property ValidationOptions; + property OnChange; + property OnEditValueChanged; + property OnStartClick; + property OnValidate; + end; + + + TcxBoldTextEditProperties = class(TcxCustomBoldTextEditProperties) + published + property BoldLookupListHandle; + property BoldLookupListProperties; + property BoldRowProperties; + property BoldSelectChangeAction; + property BoldSetValueExpression; + property Alignment; + property AssignedValues; + property AutoSelect; + property BeepOnError; + property CharCase; + property ClearKey; + property EchoMode; + property HideSelection; + property ImeMode; + property ImeName; + property IncrementalSearch; + property OEMConvert; + property PasswordChar; + property ReadOnly; + property UseLeftAlignmentOnEditing; + + property ValidateOnEnter; + property ValidationOptions; + property OnChange; + property OnEditValueChanged; + property OnNewLookupDisplayText; + property OnValidate; + end; + + TcxCustomBoldEditDefaultValuesProvider = class(TcxCustomEditDefaultValuesProvider) + private + fBoldHandleFollower: TBoldAbstractHandleFollower; // handle follower is needed if we end up needing to access follower + fBoldProperties: TBoldFollowerController; +// fcxBoldEditDataBinding: TcxBoldEditDataBinding; + +// TODO: Place subscriptions instead of FreeNotification +// procedure FreeNotification(Sender: TComponent); + + function GetFollower: TBoldFollower; +// procedure SetBoldHandle(const Value: TBoldElementHandle); + procedure SetBoldProperties(const Value: TBoldFollowerController); + procedure SetHandleFollower(const Value: TBoldAbstractHandleFollower); + function GetBoldHandle: TBoldElementHandle; + protected + function GetBoldElementTypeInfo: TBoldElementTypeInfo; +// property DataBinding: TcxBoldEditDataBinding read fcxBoldEditDataBinding; + public + constructor Create(AOwner: TPersistent); override; + destructor Destroy; override; +// function CanSetEditMode: Boolean; override; + function DefaultAlignment: TAlignment; override; + function DefaultBlobKind: TcxBlobKind; override; + function DefaultCanModify: Boolean; override; +// function DefaultDisplayFormat: string; override; +// function DefaultEditFormat: string; override; +// function DefaultEditMask: string; override; + function DefaultIsFloatValue: Boolean; override; + function DefaultMaxLength: Integer; override; +// function DefaultMaxValue: Double; override; +// function DefaultMinValue: Double; override; +// function DefaultPrecision: Integer; override; +// function DefaultReadOnly: Boolean; override; +// function DefaultRequired: Boolean; override; + function IsBlob: Boolean; override; + function IsCurrency: Boolean; override; + function IsDataAvailable: Boolean; override; +// function IsDataStorage: Boolean; override; +// function IsDisplayFormatDefined(AIsCurrencyValueAccepted: Boolean): Boolean; override; +// function IsOnGetTextAssigned: Boolean; override; +// function IsOnSetTextAssigned: Boolean; override; + function IsValidChar(AChar: Char): Boolean; override; + + property Follower: TBoldFollower read GetFollower; + property BoldHandle: TBoldElementHandle read GetBoldHandle{ write SetBoldHandle}; + property BoldProperties: TBoldFollowerController read fBoldProperties write SetBoldProperties; + property BoldHandleFollower: TBoldAbstractHandleFollower read fBoldHandleFollower write SetHandleFollower; + end; + + TcxBoldEditDataBinding = class(TcxEditDataBinding) + private + fInternalChange: integer; + fBoldHandleFollower: TBoldElementHandleFollower; + fCurrentElementType: TBoldElementTypeInfo; + fBoldFollowerController: TBoldFollowerController; + fValueOrDefinitionInvalid: boolean; + fBrokenConstraints: TStringList; + fShowHintIfCaptionDoesntFit: boolean; + procedure SetBoldHandle(const Value: TBoldElementHandle); + function GetFollower: TBoldFollower; + function GetBoldHandle: TBoldElementHandle; + function GetDefaultValuesProvider: TcxCustomBoldEditDefaultValuesProvider; + + procedure SetBoldProperties(const Value: TBoldVariantFollowerController); + function GetBoldProperties: TBoldVariantFollowerController; + +{$IFDEF Constraints} + procedure SubscribeToConstraints(aElement: TBoldElement); +{$ENDIF} + function GetValueOrDefinitionInvalid: boolean; + procedure SetValueOrDefinitionInvalid(const Value: boolean); + function GetIsInInternalChange: boolean; + function GetBrokenConstraints: TStringList; + function GetHasBrokenConstraints: boolean; + protected + // IBoldOCLComponent + function GetContextType: TBoldElementTypeInfo; + procedure SetExpression(const Value: TBoldExpression); + function GetVariableList: TBoldExternalVariableList; + function GetExpression: TBoldExpression; + + // IBoldValidateableComponent + function ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: string): Boolean; + + procedure _AfterMakeUptoDate(Follower: TBoldFollower); virtual; + + function ValidateTypeConforms(aExpressionType: TBoldElementTypeInfo): string; virtual; + + function MayModify: boolean; virtual; + procedure TypeMayHaveChanged; + procedure DoChanged; virtual; + + property BoldFollowerController: TBoldFollowerController read fBoldFollowerController; + + procedure InternalSetValue(const aValue: TcxEditValue); virtual; + function InternalGetValue(Follower: TBoldFollower): Variant; + function ImmediatePost: boolean; virtual; + + procedure ValidateDisplayValue(var ADisplayValue: TcxEditValue; var AErrorText: TCaption; var AError: Boolean); + + function HandleApplyException(E: Exception; Elem: TBoldElement; var Discard: Boolean): Boolean; + procedure DefaultValuesChanged; override; + function GetModified: Boolean; override; + function GetStoredValue: TcxEditValue; override; + function IsRefreshDisabled: Boolean; + procedure Reset; override; + procedure SetStoredValue(const Value: TcxEditValue); override; + procedure DataChanged; virtual; + procedure DataSetChange; virtual; + procedure EditingChanged; virtual; + function IsLookupControl: Boolean; virtual; + procedure UpdateData; virtual; + property DefaultValuesProvider: TcxCustomBoldEditDefaultValuesProvider read GetDefaultValuesProvider; + procedure DoEnter; virtual; + procedure DoExit; virtual; + property ValueOrDefinitionInvalid: boolean read GetValueOrDefinitionInvalid write SetValueOrDefinitionInvalid; + property BrokenConstraints: TStringList read GetBrokenConstraints; + property HasBrokenConstraints: boolean read GetHasBrokenConstraints; + public + constructor Create(AEdit: TcxCustomEdit); override; + destructor Destroy; override; + procedure Assign(Source: TPersistent); override; + function CanCheckEditorValue: Boolean; override; + function CanModify: Boolean; override; + function CanPostEditorValue: Boolean; override; + function ExecuteAction(Action: TBasicAction): Boolean; override; + class function GetDefaultValuesProviderClass: TcxCustomEditDefaultValuesProviderClass; override; + procedure SetModified; override; + function UpdateAction(Action: TBasicAction): Boolean; override; + procedure UpdateDisplayValue; override; + property Follower: TBoldFollower read GetFollower; + property IsInInternalChange: boolean read GetIsInInternalChange; + published + property BoldHandle: TBoldElementHandle read GetBoldHandle write SetBoldHandle; +// property BoldHandleFollower: TBoldElementHandleFollower read fBoldHandleFollower write SetBoldHandleFollower; +// property BoldProperties: TBoldVariantFollowerController read fBoldProperties write SetBoldProperties; + property BoldProperties: TBoldVariantFollowerController read GetBoldProperties write SetBoldProperties; + property ShowHintIfCaptionDoesntFit: boolean read fShowHintIfCaptionDoesntFit write fShowHintIfCaptionDoesntFit default false; + end; + + TcxBoldTextEditDataBinding = class(TcxBoldEditDataBinding) + end; + + TcxBoldDateTimeEditDataBinding = class(TcxBoldEditDataBinding) + protected + function ValidateTypeConforms(aExpressionType: TBoldElementTypeInfo): string; override; + end; + + TcxBoldTimeEditDataBinding = class(TcxBoldEditDataBinding) + protected + function ValidateTypeConforms(aExpressionType: TBoldElementTypeInfo): string; override; + end; + + TcxBoldCheckBoxEditDataBinding = class(TcxBoldEditDataBinding) + protected + function ValidateTypeConforms(aExpressionType: TBoldElementTypeInfo): string; override; + function ImmediatePost: boolean; override; + public + function MayModify: boolean; override; // TODO: move this up to TcxBoldEditDataBinding + end; + + TcxBoldNumericEditDataBinding = class(TcxBoldEditDataBinding) + protected + function ValidateTypeConforms(aExpressionType: TBoldElementTypeInfo): string; override; + end; + + TcxBoldFloatEditDataBinding = class(TcxBoldEditDataBinding) + protected + function ValidateTypeConforms(aExpressionType: TBoldElementTypeInfo): string; override; + end; + + TcxBoldCurrencyEditDataBinding = class(TcxBoldEditDataBinding) + protected + function ValidateTypeConforms(aExpressionType: TBoldElementTypeInfo): string; override; + end; + + TcxBoldBlobEditDataBinding = class(TcxBoldEditDataBinding) + protected + function ValidateTypeConforms(aExpressionType: TBoldElementTypeInfo): string; override; + end; + + TcxBoldComboBoxEditDataBinding = class(TcxBoldTextEditDataBinding) + protected + function GetModified: Boolean; override; + function ImmediatePost: boolean; override; + public + constructor Create(AEdit: TcxCustomEdit); override; + end; + + TcxBoldTextEdit = class(TcxCustomTextEdit, IBoldValidateableComponent, IBoldOCLComponent) + private + function GetActiveProperties: TcxBoldTextEditProperties; + function GetProperties: TcxBoldTextEditProperties; + procedure SetProperties(Value: TcxBoldTextEditProperties); + function GetDataBinding: TcxBoldTextEditDataBinding; + procedure SetDataBinding(Value: TcxBoldTextEditDataBinding); + protected + class function GetDataBindingClass: TcxEditDataBindingClass; override; + function ValidateKeyDown(var Key: Word; Shift: TShiftState): Boolean; override; + function ValidateKeyPress(var Key: Char): Boolean; override; + procedure DoValidateDisplayValue(var ADisplayValue: TcxEditValue; var AErrorText: TCaption; var AError: Boolean); override; + procedure DoOnChange; override; + procedure DoChange; override; + procedure Paint; override; + public + class function GetPropertiesClass: TcxCustomEditPropertiesClass; override; + property ActiveProperties: TcxBoldTextEditProperties read GetActiveProperties; + procedure DoEnter; override; + procedure DoExit; override; + published + property DataBinding: TcxBoldTextEditDataBinding read GetDataBinding write SetDataBinding implements IBoldValidateableComponent, IBoldOCLComponent; + property Properties: TcxBoldTextEditProperties read GetProperties write SetProperties; + property Anchors; + property AutoSize; + property BeepOnEnter; + property Constraints; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property ImeMode; + property ImeName; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property Style; + property StyleDisabled; + property StyleFocused; + property StyleHot; + property TabOrder; + property TabStop; +{$IFDEF DELPHI12} + property TextHint; +{$ENDIF} + property Visible; + property OnClick; +{$IFDEF DELPHI5} + property OnContextPopup; +{$ENDIF} + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEditing; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseEnter; + property OnMouseLeave; + property OnMouseMove; + property OnMouseUp; + property OnStartDrag; + property OnEndDock; + property OnStartDock; + end; +{ + TcxCustomBoldDateEditProperties = class(TcxCustomDateEditProperties) + end; + + TcxBoldDateEditProperties = class(TcxCustomBoldDateEditProperties) + end; +} + + TcxBoldDateEdit = class(TcxCustomDateEdit, IBoldValidateableComponent, IBoldOCLComponent) + private + function GetActiveProperties: TcxDateEditProperties; + function GetProperties: TcxDateEditProperties; + procedure SetProperties(Value: TcxDateEditProperties); + function GetDataBinding: TcxBoldDateTimeEditDataBinding; + procedure SetDataBinding(Value: TcxBoldDateTimeEditDataBinding); + protected + class function GetDataBindingClass: TcxEditDataBindingClass; override; + function ValidateKeyDown(var Key: Word; Shift: TShiftState): Boolean; override; + function ValidateKeyPress(var Key: Char): Boolean; override; + procedure DoChange; override; + procedure DoOnChange; override; + function CanDropDown: Boolean; override; + procedure Paint; override; + procedure HidePopup(Sender: TcxControl; AReason: TcxEditCloseUpReason); override; + procedure DoValidateDisplayValue(var ADisplayValue: TcxEditValue; var AErrorText: TCaption; var AError: Boolean); override; + public + class function GetPropertiesClass: TcxCustomEditPropertiesClass; override; + property ActiveProperties: TcxDateEditProperties read GetActiveProperties; + procedure DoEnter; override; + procedure DoExit; override; + published + property DataBinding: TcxBoldDateTimeEditDataBinding read GetDataBinding write SetDataBinding implements IBoldValidateableComponent, IBoldOCLComponent; + property Properties: TcxDateEditProperties read GetProperties write SetProperties; + property Anchors; + property AutoSize; + property BeepOnEnter; +// property BiDiMode; + property Constraints; + property DragCursor; + property DragKind; +// property Date; + property DragMode; +// property EditValue; + property Enabled; + property ImeMode; + property ImeName; +// property ParentBiDiMode; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property Style; + property StyleDisabled; + property StyleFocused; + property StyleHot; + property TabOrder; + property TabStop default True; +{$IFDEF DELPHI12} + property TextHint; +{$ENDIF} + property Visible; + property OnClick; + {$IFDEF DELPHI5} + property OnContextPopup; + {$ENDIF} + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEditing; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnStartDrag; + property OnStartDock; + end; + + TcxBoldMemo = class(TcxCustomMemo, IBoldValidateableComponent, IBoldOCLComponent) + private + function GetActiveProperties: TcxMemoProperties; + function GetDataBinding: TcxBoldTextEditDataBinding; + function GetProperties: TcxMemoProperties; + procedure SetDataBinding(Value: TcxBoldTextEditDataBinding); + procedure SetProperties(Value: TcxMemoProperties); + protected + class function GetDataBindingClass: TcxEditDataBindingClass; override; + procedure DoChange; override; + procedure Paint; override; + procedure DoValidateDisplayValue(var ADisplayValue: TcxEditValue; var AErrorText: TCaption; var AError: Boolean); override; + public + class function GetPropertiesClass: TcxCustomEditPropertiesClass; override; + property ActiveProperties: TcxMemoProperties read GetActiveProperties; + procedure DoEnter; override; + procedure DoExit; override; + published + property Align; + property Anchors; + property Constraints; + property DataBinding: TcxBoldTextEditDataBinding read GetDataBinding write SetDataBinding implements IBoldValidateableComponent, IBoldOCLComponent; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property ImeMode; + property ImeName; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property Properties: TcxMemoProperties read GetProperties write SetProperties; + property ShowHint; + property Style; + property StyleDisabled; + property StyleFocused; + property StyleHot; + property TabOrder; + property TabStop; +{$IFDEF DELPHI12} + property TextHint; +{$ENDIF} + property Visible; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEditing; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseEnter; + property OnMouseLeave; + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + end; + + TcxBoldTimeEdit = class(TcxCustomTimeEdit, IBoldValidateableComponent, IBoldOCLComponent) + private + function GetActiveProperties: TcxTimeEditProperties; + function GetDataBinding: TcxBoldTimeEditDataBinding; + function GetProperties: TcxTimeEditProperties; + procedure SetDataBinding(Value: TcxBoldTimeEditDataBinding); + procedure SetProperties(Value: TcxTimeEditProperties); + protected + class function GetDataBindingClass: TcxEditDataBindingClass; override; + procedure DoChange; override; + function ValidateKeyDown(var Key: Word; Shift: TShiftState): Boolean; override; + function ValidateKeyPress(var Key: Char): Boolean; override; + procedure DoValidateDisplayValue(var ADisplayValue: TcxEditValue; var AErrorText: TCaption; var AError: Boolean); override; + procedure Paint; override; + public + class function GetPropertiesClass: TcxCustomEditPropertiesClass; override; + property ActiveProperties: TcxTimeEditProperties read GetActiveProperties; + procedure DoEnter; override; + procedure DoExit; override; + published + property Anchors; + property AutoSize; + property BeepOnEnter; + property Constraints; + property DataBinding: TcxBoldTimeEditDataBinding read GetDataBinding write SetDataBinding implements IBoldValidateableComponent, IBoldOCLComponent; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property ImeMode; + property ImeName; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property Properties: TcxTimeEditProperties read GetProperties write SetProperties; + property ShowHint; + property Style; + property StyleDisabled; + property StyleFocused; + property StyleHot; + property TabOrder; + property TabStop; +{$IFDEF DELPHI12} + property TextHint; +{$ENDIF} + property Visible; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEditing; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseEnter; + property OnMouseLeave; + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + end; + + TcxBoldCurrencyEdit = class(TcxCustomCurrencyEdit, IBoldValidateableComponent, IBoldOCLComponent) + private + function GetActiveProperties: TcxCurrencyEditProperties; + function GetDataBinding: TcxBoldCurrencyEditDataBinding; + function GetProperties: TcxCurrencyEditProperties; + procedure SetDataBinding(Value: TcxBoldCurrencyEditDataBinding); + procedure SetProperties(Value: TcxCurrencyEditProperties); + protected + class function GetDataBindingClass: TcxEditDataBindingClass; override; + procedure DoValidateDisplayValue(var ADisplayValue: TcxEditValue; var AErrorText: TCaption; var AError: Boolean); override; + procedure DoChange; override; + procedure Paint; override; + public + class function GetPropertiesClass: TcxCustomEditPropertiesClass; override; + property ActiveProperties: TcxCurrencyEditProperties read GetActiveProperties; + procedure DoEnter; override; + procedure DoExit; override; + published + property Anchors; + property AutoSize; + property BeepOnEnter; + property Constraints; + property DataBinding: TcxBoldCurrencyEditDataBinding read GetDataBinding write SetDataBinding implements IBoldValidateableComponent, IBoldOCLComponent; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property ImeMode; + property ImeName; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property Properties: TcxCurrencyEditProperties read GetProperties write SetProperties; + property ShowHint; + property Style; + property StyleDisabled; + property StyleFocused; + property StyleHot; + property TabOrder; + property TabStop; +{$IFDEF DELPHI12} + property TextHint; +{$ENDIF} + property Visible; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnEditing; + property OnEndDock; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + end; + + TcxBoldMaskEdit = class(TcxCustomMaskEdit, IBoldValidateableComponent, IBoldOCLComponent) + private + function GetActiveProperties: TcxMaskEditProperties; + function GetDataBinding: TcxBoldTextEditDataBinding; + function GetProperties: TcxMaskEditProperties; + procedure SetDataBinding(Value: TcxBoldTextEditDataBinding); + procedure SetProperties(Value: TcxMaskEditProperties); + protected + class function GetDataBindingClass: TcxEditDataBindingClass; override; + function SupportsSpelling: Boolean; override; + procedure DoValidateDisplayValue(var ADisplayValue: TcxEditValue; var AErrorText: TCaption; var AError: Boolean); override; + procedure Paint; override; + public + class function GetPropertiesClass: TcxCustomEditPropertiesClass; override; + property ActiveProperties: TcxMaskEditProperties read GetActiveProperties; + procedure DoEnter; override; + procedure DoExit; override; + published + property Anchors; + property AutoSize; + property BeepOnEnter; + property Constraints; + property DataBinding: TcxBoldTextEditDataBinding read GetDataBinding write SetDataBinding implements IBoldValidateableComponent, IBoldOCLComponent; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property ImeMode; + property ImeName; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property Properties: TcxMaskEditProperties read GetProperties write SetProperties; + property ShowHint; + property Style; + property StyleDisabled; + property StyleFocused; + property StyleHot; + property TabOrder; + property TabStop; +{$IFDEF DELPHI12} + property TextHint; +{$ENDIF} + property Visible; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEditing; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseEnter; + property OnMouseLeave; + property OnMouseMove; + property OnMouseUp; + property OnStartDrag; + property OnEndDock; + property OnStartDock; + end; + + TcxBoldCheckBox = class(TcxCustomCheckBox, IBoldValidateableComponent, IBoldOCLComponent) + private + function GetActiveProperties: TcxCheckBoxProperties; + function GetDataBinding: TcxBoldCheckBoxEditDataBinding; + function GetProperties: TcxCheckBoxProperties; + procedure SetDataBinding(Value: TcxBoldCheckBoxEditDataBinding); + procedure SetProperties(Value: TcxCheckBoxProperties); + protected + class function GetDataBindingClass: TcxEditDataBindingClass; override; + procedure DoValidateDisplayValue(var ADisplayValue: TcxEditValue; var AErrorText: TCaption; var AError: Boolean); override; + procedure Toggle; override; + procedure Paint; override; + procedure Initialize; override; + procedure DoChange; override; + public + class function GetPropertiesClass: TcxCustomEditPropertiesClass; override; + property ActiveProperties: TcxCheckBoxProperties read GetActiveProperties; + procedure DoEnter; override; + procedure DoExit; override; + property Checked; + published + property Action; + property Align; + property Anchors; + property AutoSize; + property Caption; + property Constraints; + property DataBinding: TcxBoldCheckBoxEditDataBinding read GetDataBinding write SetDataBinding implements IBoldValidateableComponent, IBoldOCLComponent; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property ParentBackground; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property Properties: TcxCheckBoxProperties read GetProperties write SetProperties; + property ShowHint; + property Style; + property StyleDisabled; + property StyleFocused; + property StyleHot; + property TabOrder; + property TabStop; + property Transparent; +// property TextHint; + property Visible; + property OnClick; + property OnContextPopup; + property OnDragDrop; + property OnDragOver; + property OnEditing; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseEnter; + property OnMouseLeave; + property OnMouseMove; + property OnMouseUp; + property OnStartDrag; + property OnEndDock; + property OnStartDock; + end; + + TcxBoldComboBox = class(TcxCustomComboBox, IBoldValidateableComponent, IBoldOCLComponent) + private + function GetActiveProperties: TcxBoldComboBoxProperties; + function GetDataBinding: TcxBoldComboBoxEditDataBinding; + function GetProperties: TcxBoldComboBoxProperties; + procedure SetDataBinding(Value: TcxBoldComboBoxEditDataBinding); + procedure SetProperties(Value: TcxBoldComboBoxProperties); + protected + class function GetDataBindingClass: TcxEditDataBindingClass; override; + procedure DoValidateDisplayValue(var ADisplayValue: TcxEditValue; var AErrorText: TCaption; var AError: Boolean); override; + function SupportsSpelling: Boolean; override; + function CanDropDown: Boolean; override; + procedure Paint; override; + public + class function GetPropertiesClass: TcxCustomEditPropertiesClass; override; + property ActiveProperties: TcxBoldComboBoxProperties read GetActiveProperties; + procedure DoEnter; override; + procedure DoExit; override; + property ItemIndex; + published + property Anchors; + property AutoSize; + property BeepOnEnter; + property Constraints; + property DataBinding: TcxBoldComboBoxEditDataBinding read GetDataBinding write SetDataBinding implements IBoldValidateableComponent, IBoldOCLComponent; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property ImeMode; + property ImeName; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property Properties: TcxBoldComboBoxProperties read GetProperties write SetProperties; + property ShowHint; + property Style; + property StyleDisabled; + property StyleFocused; + property StyleHot; + property TabOrder; + property TabStop; +{$IFDEF DELPHI12} + property TextHint; +{$ENDIF} + property Visible; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEditing; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseEnter; + property OnMouseLeave; + property OnMouseMove; + property OnMouseUp; + property OnStartDrag; + property OnEndDock; + property OnStartDock; + end; + + // perhaps use TBoldIntegerFollowerController ? + TcxBoldSpinEdit = class(TcxCustomSpinEdit, IBoldValidateableComponent, IBoldOCLComponent) + private + function GetActiveProperties: TcxSpinEditProperties; + function GetProperties: TcxSpinEditProperties; + function GetDataBinding: TcxBoldNumericEditDataBinding; + procedure SetDataBinding(Value: TcxBoldNumericEditDataBinding); + procedure SetProperties(Value: TcxSpinEditProperties); + protected + class function GetDataBindingClass: TcxEditDataBindingClass; override; + procedure DoValidateDisplayValue(var ADisplayValue: TcxEditValue; var AErrorText: TCaption; var AError: Boolean); override; + procedure Paint; override; + public + class function GetPropertiesClass: TcxCustomEditPropertiesClass; override; + property ActiveProperties: TcxSpinEditProperties read GetActiveProperties; + procedure DoEnter; override; + procedure DoExit; override; + property Value; + published + property Anchors; + property AutoSize; + property BeepOnEnter; + property Constraints; + property DataBinding: TcxBoldNumericEditDataBinding read GetDataBinding write SetDataBinding implements IBoldValidateableComponent, IBoldOCLComponent; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property ImeMode; + property ImeName; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property Properties: TcxSpinEditProperties read GetProperties write SetProperties; + property ShowHint; + property Style; + property StyleDisabled; + property StyleFocused; + property StyleHot; + property TabOrder; + property TabStop; +{$IFDEF DELPHI12} + property TextHint; +{$ENDIF} + property Visible; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEditing; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseEnter; + property OnMouseLeave; + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + end; + + TcxBoldButtonEdit = class(TcxCustomButtonEdit, IBoldValidateableComponent, IBoldOCLComponent) + private + function GetActiveProperties: TcxButtonEditProperties; + function GetDataBinding: TcxBoldTextEditDataBinding; + function GetProperties: TcxButtonEditProperties; + procedure SetDataBinding(Value: TcxBoldTextEditDataBinding); + procedure SetProperties(Value: TcxButtonEditProperties); + protected + class function GetDataBindingClass: TcxEditDataBindingClass; override; + procedure DoValidateDisplayValue(var ADisplayValue: TcxEditValue; var AErrorText: TCaption; var AError: Boolean); override; + procedure Paint; override; + public + class function GetPropertiesClass: TcxCustomEditPropertiesClass; override; + property ActiveProperties: TcxButtonEditProperties read GetActiveProperties; + procedure DoEnter; override; + procedure DoExit; override; + published + property Anchors; + property AutoSize; + property BeepOnEnter; + property Constraints; + property DataBinding: TcxBoldTextEditDataBinding read GetDataBinding write SetDataBinding implements IBoldValidateableComponent, IBoldOCLComponent; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property ImeMode; + property ImeName; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property Properties: TcxButtonEditProperties read GetProperties write SetProperties; + property ShowHint; + property Style; + property StyleDisabled; + property StyleFocused; + property StyleHot; + property TabOrder; + property TabStop; +{$IFDEF DELPHI12} + property TextHint; +{$ENDIF} + property Visible; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEditing; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseEnter; + property OnMouseLeave; + property OnMouseMove; + property OnMouseUp; + property OnStartDrag; + property OnEndDock; + property OnStartDock; + end; + + TcxBoldHyperLinkEdit = class(TcxCustomHyperLinkEdit, IBoldValidateableComponent, IBoldOCLComponent) + private + function GetActiveProperties: TcxHyperLinkEditProperties; + function GetDataBinding: TcxBoldTextEditDataBinding; + function GetProperties: TcxHyperLinkEditProperties; + procedure SetDataBinding(Value: TcxBoldTextEditDataBinding); + procedure SetProperties(Value: TcxHyperLinkEditProperties); + protected + class function GetDataBindingClass: TcxEditDataBindingClass; override; + procedure DoValidateDisplayValue(var ADisplayValue: TcxEditValue; var AErrorText: TCaption; var AError: Boolean); override; + procedure Paint; override; + public + class function GetPropertiesClass: TcxCustomEditPropertiesClass; override; + property ActiveProperties: TcxHyperLinkEditProperties read GetActiveProperties; + procedure DoEnter; override; + procedure DoExit; override; + published + property Anchors; + property AutoSize; + property BeepOnEnter; + property Constraints; + property DataBinding: TcxBoldTextEditDataBinding read GetDataBinding write SetDataBinding implements IBoldValidateableComponent, IBoldOCLComponent; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property ImeMode; + property ImeName; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property Properties: TcxHyperLinkEditProperties read GetProperties write SetProperties; + property ShowHint; + property Style; + property StyleDisabled; + property StyleFocused; + property StyleHot; + property TabOrder; + property TabStop; +{$IFDEF DELPHI12} + property TextHint; +{$ENDIF} + property Visible; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnEditing; + property OnEndDock; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + end; + + TcxBoldProgressBar = class(TcxCustomProgressBar, IBoldValidateableComponent, IBoldOCLComponent) + private + function GetActiveProperties: TcxProgressBarProperties; + function GetDataBinding: TcxBoldNumericEditDataBinding; + procedure SetDataBinding(Value: TcxBoldNumericEditDataBinding); + function GetProperties: TcxProgressBarProperties; + procedure SetProperties(Value: TcxProgressBarProperties); + protected + class function GetDataBindingClass: TcxEditDataBindingClass; override; + procedure Initialize; override; + procedure Paint; override; + public + class function GetPropertiesClass: TcxCustomEditPropertiesClass; override; + property ActiveProperties: TcxProgressBarProperties read GetActiveProperties; + published + property Align; + property Anchors; + property AutoSize; + property Constraints; + property DataBinding: TcxBoldNumericEditDataBinding read GetDataBinding write SetDataBinding implements IBoldValidateableComponent, IBoldOCLComponent; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property Properties: TcxProgressBarProperties read GetProperties write SetProperties; + property ShowHint; + property Style; + property StyleDisabled; + property StyleFocused; + property StyleHot; + property TabOrder; + property TabStop; + property Transparent; + property Visible; + property OnContextPopup; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseEnter; + property OnMouseLeave; + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + end; + + TcxBarBoldEditItem = class(TcxCustomBarEditItem) + private + fInternalChange: integer; + fBoldHandleFollower: TBoldElementHandleFollower; + fBoldProperties: TBoldVariantFollowerController; + procedure SetBoldHandle(const Value: TBoldElementHandle); + function GetFollower: TBoldFollower; + function GetBoldHandle: TBoldElementHandle; + procedure SetBoldProperties(const Value: TBoldVariantFollowerController); + protected + function GetContextType: TBoldElementTypeInfo; + procedure _AfterMakeUptoDate(Follower: TBoldFollower); +// function CanEdit: Boolean; override; +// procedure DoEditValueChanged(Sender: TObject); override; + procedure EditValueChanged(Sender: TObject); + procedure EditExit(Sender: TObject); + function GetControlClass(AIsVertical: Boolean): TdxBarItemControlClass; override; + + procedure KeyPress(var Key: Char); override; + + procedure DoEnter; override; + procedure DoExit; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property Follower: TBoldFollower read GetFollower; + published + property BoldHandle: TBoldElementHandle read GetBoldHandle write SetBoldHandle; + property BoldProperties: TBoldVariantFollowerController read fBoldProperties write SetBoldProperties; + property CanSelect; +// property EditValue; + property Height; + property Properties; + property RepositoryItem; + property StyleEdit; +// property TextHint; + end; + + TcxBarBoldEditItemControl = class(TcxBarEditItemControl) + private + protected +// procedure DoPostEditValue(Sender: TObject); override; +// procedure DoValidate(Sender: TObject; var DisplayValue: TcxEditValue; +// var ErrorText: TCaption; var Error: Boolean); override; + procedure RestoreDisplayValue; override; + procedure StoreDisplayValue; override; +// procedure DoPaint(ARect: TRect; PaintType: TdxBarPaintType); override; + public + end; + +{$IFDEF DevExScheduler} + TcxBoldDateNavigator = class(TcxCustomDateNavigator, IBoldValidateableComponent) + private + fInternalChange: integer; + fBoldStartHandleFollower: TBoldElementHandleFollower; + fBoldEndHandleFollower: TBoldElementHandleFollower; + fBoldStartProperties: TBoldVariantFollowerController; + fBoldEndProperties: TBoldVariantFollowerController; +// fValueOrDefinitionInvalid: boolean; + function GetStartFollower: TBoldFollower; + function GetEndFollower: TBoldFollower; + procedure SetBoldStartProperties(const Value: TBoldVariantFollowerController); + procedure SetBoldEndProperties(const Value: TBoldVariantFollowerController); + function GetBoldEndHandle: TBoldElementHandle; + function GetBoldStartHandle: TBoldElementHandle; + procedure SetBoldEndHandle(const Value: TBoldElementHandle); + procedure SetBoldStartHandle(const Value: TBoldElementHandle); + procedure _AfterMakeUptoDate(Follower: TBoldFollower); + + procedure ValidateSelf; + + // IBoldValidateableComponent + function ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: string): Boolean; + protected + function GetStartContextType: TBoldElementTypeInfo; + function GetEndContextType: TBoldElementTypeInfo; +// function CanSelectPeriod: Boolean; // overriden to return false, as we don't support range + procedure DateNavigatorSelectionChanged; override; +// procedure DoSelectionChangedEvent; override; + procedure Loaded; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property StartFollower: TBoldFollower read GetStartFollower; + property EndFollower: TBoldFollower read GetEndFollower; + published + property BoldStartHandle: TBoldElementHandle read GetBoldStartHandle write SetBoldStartHandle; + property BoldStartProperties: TBoldVariantFollowerController read fBoldStartProperties write SetBoldStartProperties; + property BoldEndHandle: TBoldElementHandle read GetBoldEndHandle write SetBoldEndHandle; + property BoldEndProperties: TBoldVariantFollowerController read fBoldEndProperties write SetBoldEndProperties; + property Align; + property Anchors; + property BorderStyle; + property Constraints; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property FirstWeekOfYear; + property Font; + property HolidayColor; + property LookAndFeel; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property Scheduler; + property SelectPeriod; + property ShowDatesContainingEventsInBold; + property ShowDatesContainingHolidaysInColor; + property ShowWeekNumbers; + property StartOfWeek; + property Storage; + property Styles; + property TabOrder; + property TabStop; + property UnlimitedSelection; + property Visible; + + property OnClick; + {$IFDEF DELPHI5} + property OnContextPopup; + {$ENDIF} + property OnCustomDrawBackground; + property OnCustomDrawContent; + property OnCustomDrawDayCaption; + property OnCustomDrawDayNumber; + property OnCustomDrawHeader; + property OnPeriodChanged; + property OnSelectionChanged; + property OnShowDateHint; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseEnter; + property OnMouseLeave; + property OnMouseMove; + property OnMouseUp; + property OnMouseWheel; + property OnMouseWheelDown; + property OnMouseWheelUp; + property OnResize; + property OnStartDock; + property OnStartDrag; + end; +{$ENDIF} + + { TcxBoldLabel } + + TcxBoldLabel = class(TcxCustomLabel, IBoldValidateableComponent, IBoldOCLComponent) + private + function GetActiveProperties: TcxLabelProperties; + function GetDataBinding: TcxBoldTextEditDataBinding; + function GetProperties: TcxLabelProperties; + procedure SetDataBinding(Value: TcxBoldTextEditDataBinding); + procedure SetProperties(Value: TcxLabelProperties); + protected + class function GetDataBindingClass: TcxEditDataBindingClass; override; + procedure Initialize; override; + procedure SetEditAutoSize(Value: Boolean); override; + procedure Paint; override; + public + class function GetPropertiesClass: TcxCustomEditPropertiesClass; override; + property ActiveProperties: TcxLabelProperties read GetActiveProperties; + published + property Align; + property Anchors; + property AutoSize {default False}; + property Constraints; + property DataBinding: TcxBoldTextEditDataBinding read GetDataBinding write SetDataBinding implements IBoldValidateableComponent, IBoldOCLComponent; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property ImeMode; + property ImeName; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property Properties: TcxLabelProperties read GetProperties + write SetProperties; + property ShowHint; + property Style; + property StyleDisabled; + property StyleFocused; + property StyleHot; + property TabOrder; + property TabStop; + property Transparent; + property Visible; + property OnClick; + property OnContextPopup; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseEnter; + property OnMouseLeave; + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + end; + + TcxBoldImage = class(TcxCustomImage, IBoldValidateableComponent, IBoldOCLComponent) + private + function GetActiveProperties: TcxImageProperties; + function GetDataBinding: TcxBoldBlobEditDataBinding; + function GetProperties: TcxImageProperties; + procedure SetDataBinding(Value: TcxBoldBlobEditDataBinding); + procedure SetProperties(Value: TcxImageProperties); +// function GetViewer: TBoldAbstractViewAdapter; +// procedure SetViewer(Value: TBoldAbstractViewAdapter); + protected + class function GetDataBindingClass: TcxEditDataBindingClass; override; + procedure Initialize; override; + procedure Paint; override; + public + class function GetPropertiesClass: TcxCustomEditPropertiesClass; override; + property ActiveProperties: TcxImageProperties read GetActiveProperties; +// property Viewer: TBoldAbstractViewAdapter read GetViewer write SetViewer; + published + property Align; + property Anchors; + property AutoSize; + property Constraints; + property DataBinding: TcxBoldBlobEditDataBinding read GetDataBinding write SetDataBinding implements IBoldValidateableComponent, IBoldOCLComponent; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property ParentColor; + property PopupMenu; + property Properties: TcxImageProperties read GetProperties write SetProperties; + property ShowHint; + property Style; + property StyleDisabled; + property StyleFocused; + property StyleHot; + property TabOrder; + property TabStop; + property Visible; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEditing; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnGetGraphicClass; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + end; + + TcxBoldRichEdit = class(TcxCustomRichEdit, IBoldValidateableComponent, IBoldOCLComponent) + private + function GetActiveProperties: TcxRichEditProperties; + function GetDataBinding: TcxBoldTextEditDataBinding; + function GetProperties: TcxRichEditProperties; + procedure SetDataBinding(Value: TcxBoldTextEditDataBinding); + procedure SetProperties(Value: TcxRichEditProperties); + protected + procedure EditingChanged; override; + class function GetDataBindingClass: TcxEditDataBindingClass; override; + procedure DoValidateDisplayValue(var ADisplayValue: TcxEditValue; var AErrorText: TCaption; var AError: Boolean); override; + function RealReadOnly: Boolean; override; + procedure Paint; override; + public + class function GetPropertiesClass: TcxCustomEditPropertiesClass; override; + property ActiveProperties: TcxRichEditProperties read GetActiveProperties; + published + property Align; + property Anchors; + property Constraints; + property DataBinding: TcxBoldTextEditDataBinding read GetDataBinding write SetDataBinding implements IBoldValidateableComponent, IBoldOCLComponent; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property ImeMode; + property ImeName; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property Properties: TcxRichEditProperties read GetProperties + write SetProperties; + property ShowHint; + property Style; + property StyleDisabled; + property StyleFocused; + property StyleHot; + property TabOrder; + property TabStop; + property Visible; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEditing; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseEnter; + property OnMouseLeave; + property OnMouseMove; + property OnMouseUp; + property OnMouseWheel; + property OnMouseWheelDown; + property OnMouseWheelUp; + property OnStartDock; + property OnStartDrag; + end; + + TcxBoldListBox = class(TcxListBox, IBoldValidateableComponent) + private + fInternalUpdate: boolean; + fListHandleFollower: TBoldListHandleFollower; + fBoldListProperties: TBoldListAsFollowerListController; + fBoldRowProperties: TBoldVariantFollowerController; + function GetBoldListHandle: TBoldAbstractListHandle; + procedure SetBoldListHandle(const Value: TBoldAbstractListHandle); + procedure SetBoldListProperties( + const Value: TBoldListAsFollowerListController); + procedure SetRowProperties( + const Value: TBoldVariantFollowerController); + function GetBoldHandleIndexLock: Boolean; + procedure SetBoldHandleIndexLock(const Value: Boolean); + function GetFollower: TBoldFollower; + function GetMutableList: TBoldList; + procedure SyncSelection; + // IBoldValidateableComponent + function ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: string): Boolean; + protected + procedure WndProc(var Message: TMessage); override; + procedure DblClick; override; + procedure Loaded; override; + procedure _InsertItem(Index: Integer; Follower: TBoldFollower); + procedure _ReplaceItem(Index: Integer; Follower: TBoldFollower); + procedure _DeleteItem(Index: Integer; OwningFollower: TBoldFollower); + procedure _RowAfterMakeUptoDate(Follower: TBoldFollower); + procedure _BeforeMakeUptoDate(Follower: TBoldFollower); + procedure _AfterMakeUptoDate(Follower: TBoldFollower); + + function DrawItem(ACanvas: TcxCanvas; AIndex: Integer; const ARect: TRect; + AState: TOwnerDrawState): Boolean; override; + procedure DefaultSetFontAndColor(Index: integer); virtual; + + procedure DoStartDrag(var DragObject: TDragObject); override; + procedure DoEndDrag(Target: TObject; X, Y: Integer); override; + procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); override; + + function GetListFollower: TBoldFollower; + function GetContextForBoldRowProperties: TBoldElementTypeInfo; + property Follower: TBoldFollower read GetFollower; + property MutableList: TBoldList read GetMutableList; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure DefaultDrawItem(Index: integer; aRect: TRect); virtual; + procedure DragDrop(Source: TObject; X, Y: Integer); override; + published +// property DataBinding: TcxBoldDataBinding read GetDataBinding write SetDataBinding implements IBoldValidateableComponent, IBoldOCLComponent; + property BoldListHandle: TBoldAbstractListHandle read GetBoldListHandle write SetBoldListHandle; + property BoldListProperties: TBoldListAsFollowerListController read fBoldListProperties write SetBoldListProperties; + property BoldRowProperties: TBoldVariantFollowerController read fBoldRowProperties write SetRowProperties; + property BoldHandleIndexLock: Boolean read GetBoldHandleIndexLock write SetBoldHandleIndexLock default true; + end; + + + TcxBoldCustomCheckListBox = class(TcxCustomCheckListBox, IBoldValidateableComponent) + private + fInternalUpdate: boolean; + fListHandleFollower: TBoldListHandleFollower; + fBoldListProperties: TBoldAbstractListAsFollowerListController; + fBoldRowProperties: TBoldVariantFollowerController; + FUpdateCount: Integer; // for Items + fBoldRowCheckBoxProperties: TBoldCheckBoxStateFollowerController; + fControllerList: TBoldControllerList; + + function GetBoldListHandle: TBoldAbstractListHandle; + procedure SetBoldListHandle(const Value: TBoldAbstractListHandle); + procedure SetBoldListProperties( + const Value: TBoldAbstractListAsFollowerListController); + procedure SetRowProperties( + const Value: TBoldVariantFollowerController); + function GetBoldHandleIndexLock: Boolean; + procedure SetBoldHandleIndexLock(const Value: Boolean); + function GetFollower: TBoldFollower; + procedure SetBoldRowCheckBoxProperties(const Value: TBoldCheckBoxStateFollowerController); + // IBoldValidateableComponent + function ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: string): Boolean; virtual; abstract; + protected + procedure WndProc(var Message: TMessage); override; + procedure SyncSelection; + function GetInnerCheckListBoxClass: TcxCustomInnerCheckListBoxClass; override; + + procedure Loaded; override; + + function GetContextType: TBoldElementTypeInfo; + procedure _DisplayCheckBox(Follower: TBoldFollower); + procedure _DisplayString(Follower: TBoldFollower); + procedure _ListInsertItem(Index: integer; Follower: TBoldFollower); + procedure _ReplaceItem(Index: Integer; Follower: TBoldFollower); + procedure _ListDeleteItem(Index: integer; Follower: TBoldFollower); + procedure _ListBeforeMakeUpToDate(Follower: TBoldFollower); + procedure _ListAfterMakeUpToDate(Follower: TBoldFollower); + property BoldRowCheckBoxProperties: TBoldCheckBoxStateFollowerController read fBoldRowCheckBoxProperties write SetBoldRowCheckBoxProperties; + property Follower: TBoldFollower read GetFollower; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; +// procedure DefaultDrawItem(Index: integer; aRect: TRect); virtual; +// procedure DragDrop(Source: TObject; X, Y: Integer); override; + published + property BoldListHandle: TBoldAbstractListHandle read GetBoldListHandle write SetBoldListHandle; + property BoldListProperties: TBoldAbstractListAsFollowerListController read fBoldListProperties write SetBoldListProperties; + property BoldRowProperties: TBoldVariantFollowerController read fBoldRowProperties write SetRowProperties; + property BoldHandleIndexLock: Boolean read GetBoldHandleIndexLock write SetBoldHandleIndexLock default true; + + property Align; + property AllowDblClickToggle; + property AllowGrayed; + property Anchors; + property AutoComplete; + property AutoCompleteDelay; + property BiDiMode; + property Columns; + property Constraints; + property DragCursor; + property DragKind; + property DragMode; + property EditValueFormat; + property Enabled; + property Glyph; + property GlyphCount; + property Images; + property ImageLayout; + property ImeMode; + property ImeName; + property IntegralHeight; +// property Items; + property ParentBiDiMode; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ReadOnly; + property ScrollWidth; + property ShowChecks; + property ShowHint; + property Sorted; + property Style; + property StyleDisabled; + property StyleFocused; + property StyleHot; + property TabOrder; + property TabStop; + property TabWidth; + property Visible; + property OnCheckStatesToEditValue; + property OnClick; + property OnClickCheck; + property OnCompare; + property OnContextPopup; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnDrawItem; + property OnEditValueToCheckStates; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMeasureItem; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + end; + + TcxBoldCheckListBox = class(TcxBoldCustomCheckListBox{, IBoldValidateableComponent, IBoldOCLComponent}) + private + // IBoldValidateableComponent + function ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: string): Boolean; override; + published + property BoldRowCheckBoxProperties; + end; + + +const + beSelectionHandleChanged = 400; + +type + TcxBoldSelectionCheckListBox = class(TcxBoldCustomCheckListBox{, IBoldValidateableComponent, IBoldOCLComponent}) + private + fCheckBoxRenderer: TBoldAsCheckBoxStateRenderer; + fPublisher: TBoldPublisher; + fBoldSelectionHandle: TBoldAbstractListHandle; + function GetAsCheckBoxState(aFollower: TBoldFollower): TCheckBoxState; + procedure SetAsCheckBoxState(aFollower: TBoldFollower; newValue: TCheckBoxState); + procedure OnSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); + procedure SetSelectionHandle(const Value: TBoldAbstractListHandle); + // IBoldValidateableComponent + function ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: string): Boolean; override; + protected + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + published + property BoldSelectionHandle: TBoldAbstractListHandle read fBoldSelectionHandle write SetSelectionHandle; + end; + + TcxBoldListView = class(TcxCustomListView{, IBoldValidateableComponent, IBoldOCLComponent}) + private + fListHandleFollower: TBoldListHandleFollower; + fBoldProperties: TBoldAbstractListAsFollowerListController; + fBoldRowProperties: TBoldVariantFollowerController; + FUpdateCount: Integer; + function GetContextType: TBoldElementTypeInfo; + function GetBoldHandle: TBoldAbstractListHandle; + procedure SetBoldHandle(value: TBoldAbstractListHandle); + function GetFollower: TBoldFollower; + procedure SetBoldProperties(Value: TBoldAbstractListAsFollowerListController); + procedure SetRowProperties(const Value: TBoldVariantFollowerController); + function GetBoldHandleIndexLock: Boolean; + procedure SetBoldHandleIndexLock(Value: Boolean); + function GetBoldList: TBoldList; + function GetCurrentBoldElement: TBoldElement; + function GetCurrentBoldObject: TBoldObject; + protected + procedure _BeforeMakeUptoDate(Follower: TBoldFollower); + procedure _AfterMakeUptoDate(Follower: TBoldFollower); + procedure _InsertItem(Index: Integer; Follower: TBoldFollower); + procedure _ReplaceItem(Index: Integer; Follower: TBoldFollower); + procedure _DeleteItem(index: Integer; OwningFollower: TBoldFollower); + procedure _RowAfterMakeUptoDate(Follower: TBoldFollower); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property Follower: TBoldFollower read GetFollower; + property ListViewCanvas; + property BoldList: TBoldList read GetBoldList; + property CurrentBoldObject: TBoldObject read GetCurrentBoldObject; + property CurrentBoldElement: TBoldElement read GetCurrentBoldElement; + published + property BoldHandle: TBoldAbstractListHandle read GetBoldHandle write SetBoldHandle; + property BoldHandleIndexLock: Boolean read GetBoldHandleIndexLock write SetBoldHandleIndexLock default true; + property BoldProperties: TBoldAbstractListAsFollowerListController read fBoldProperties write SetBoldProperties; + property BoldRowProperties: TBoldVariantFollowerController read fBoldRowProperties write SetRowProperties; + + property Align; + property AllocBy default 0; + property Anchors; + property BiDiMode; + property Checkboxes; + property ColumnClick default True; + property Columns; + property Constraints; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property HideSelection default True; + property HotTrack default False; + property HoverTime default -1; + property IconOptions; + {$IFDEF DELPHI6} + property ItemIndex; + {$ENDIF} +// property Items; + property LargeImages; + property MultiSelect default False; + property OwnerData default False; + property OwnerDraw default False; + property ParentBiDiMode; + property ParentColor default False; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ReadOnly default False; + property RowSelect default False; + property ShowColumnHeaders default True; + property ShowHint; + property ShowWorkAreas default False; + property SmallImages; + property SortType default stNone; + property StateImages; + property Style; + property StyleDisabled; + property StyleFocused; + property StyleHot; + property TabOrder; + property TabStop; + property ViewStyle default vsIcon; + property Visible; + property OnAdvancedCustomDraw; + property OnAdvancedCustomDrawItem; + property OnAdvancedCustomDrawSubItem; + property OnCancelEdit; + property OnChange; + property OnChanging; + property OnClick; + property OnColumnClick; + property OnColumnDragged; + property OnColumnRightClick; + property OnCompare; + property OnContextPopup; + {$IFDEF DELPHI6} + property OnCreateItemClass; + {$ENDIF} + property OnCustomDraw; + property OnCustomDrawItem; + property OnCustomDrawSubItem; + property OnData; + property OnDataFind; + property OnDataHint; + property OnDataStateChange; + property OnDblClick; + property OnDeletion; + property OnDragDrop; + property OnDragOver; + property OnDrawItem; + property OnEdited; + property OnEditing; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnGetImageIndex; + property OnGetSubItemImage; + property OnInfoTip; + property OnInsert; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnSelectItem; + property OnStartDock; + property OnStartDrag; + end; + +{$IFDEF BoldDevExLog} + TcxBoldEditorsLogProc = procedure(aMessage: string; aCategory: string = '') of object; +{$ENDIF} + +{$IFDEF BoldDevExLog} +var + cxBoldEditorsLogProc: TcxBoldEditorsLogProc; +{$ENDIF} + +procedure InternalComboSetValue( + aBoldHandle: TBoldElementHandle; + aFollower: TBoldFollower; + aSelectedElement: TBoldElement; + aBoldSelectChangeAction: TBoldComboSelectChangeAction; + aBoldSetValueExpression: TBoldExpression; + aListHandle: TBoldAbstractListHandle; + aValue: Variant); + +procedure _ValidateEdit(aEdit: TcxCustomEdit); + +implementation + +uses + Types, +{$IFDEF BOLD_DELPHI16_OR_LATER}UiTypes,{$ENDIF} + BoldAttributes, + BoldBase, + Variants, + Graphics, + BoldQueue, + BoldEnvironment, + cxFilterControlUtils, + cxBoldEditConsts, + BoldReferenceHandle, + BoldValueInterfaces, + cxDateUtils, + {$IFDEF DevExScheduler} + cxSchedulerDateNavigator, + {$ENDIF} + BoldLogHandler, + BoldCoreConsts, + BoldDomainElement, + BoldOCL, + BoldGuard, + BoldAFP, + BoldGUI, + BoldGuiResourceStrings, + BoldMetaElementList, + BoldHashIndexes, + BoldIndex, + BoldIndexableList, + Forms, dxMessages; + +type + TcxCustomEditAccess = class(TcxCustomEdit); + TBoldFollowerControllerAccess = class(TBoldFollowerController); + TBoldElementHandleAccess = class(TBoldElementHandle); + TcxEditValidateInfoAccess = class(TcxEditValidateInfo); + +{$IFDEF BoldDevExLog} +procedure _Log(aMessage: string; aCategory: string = ''); +begin + if Assigned(cxBoldEditorsLogProc) then + cxBoldEditorsLogProc(aMessage, aCategory); +end; +{$ENDIF} + +procedure _ValidateEdit(aEdit: TcxCustomEdit); +var + lBoldValidateableComponent: IBoldValidateableComponent; + + procedure InternalValidate; + var + lBoldComponentValidator: TBoldComponentValidator; + begin + lBoldComponentValidator := TBoldComponentValidator.Create; + try + lBoldValidateableComponent.ValidateComponent(lBoldComponentValidator, aEdit.Name); + finally + lBoldComponentValidator.free; + end; + end; + +var + lcxBoldEditDataBinding: TcxBoldEditDataBinding; + lValue: Variant; + lFollower: TBoldFollower; + s: string; + lContext: TBoldElementTypeInfo; + lEvaluator: TBoldOCL; + lBoldMemberRTInfo: TBoldMemberRTInfo; + lExpression: string; +begin + if Supports(aEdit, IBoldValidateableComponent, lBoldValidateableComponent) then + begin + InternalValidate; + + lcxBoldEditDataBinding := TcxCustomEditAccess(aEdit).DataBinding as TcxBoldEditDataBinding; + lContext := lcxBoldEditDataBinding.GetContextType; + if not Assigned(lcxBoldEditDataBinding.BoldHandle) then + lValue := '< no handle >' + else + if (lContext = nil) then + lValue := '< no context >' + else + if Assigned(lcxBoldEditDataBinding.Follower) then + begin + lFollower := lcxBoldEditDataBinding.Follower; + lEvaluator := lContext.Evaluator as TBoldOCL; + lExpression := TBoldFollowerControllerAccess(lFollower.Controller).Expression; + lBoldMemberRTInfo := lEvaluator.RTInfo(lExpression, lContext, false, lFollower.Controller.VariableList); + if Assigned(lBoldMemberRTInfo) then + lValue := lBoldMemberRTInfo.AsString + else + begin + lContext := lEvaluator.ExpressionType(lExpression, lContext, false, lFollower.Controller.VariableList); + if Assigned(lContext) then + lValue := lContext.AsString; + end; + end; + if VarIsNull(lValue) or (lValue = '') then + lValue := TBoldFollowerControllerAccess(lcxBoldEditDataBinding.BoldFollowerController).Expression; + +// TcxCustomEditAccess(aEdit).SetInternalEditValue(lValue); + TcxCustomEditAccess(aEdit).SetInternalDisplayValue(lValue); + + if aEdit.name <> '' then + s := '_ValidateEdit ' + aEdit.name + ':' + lValue + else + s := '_ValidateEdit ' + aEdit.ClassName + ':' + lValue; + + OutPutDebugString(PChar(S)); + end + else + if Supports(aEdit.ActiveProperties, IBoldValidateableComponent, lBoldValidateableComponent) then + InternalValidate; +end; + +procedure InternalComboSetValue( + aBoldHandle: TBoldElementHandle; + aFollower: TBoldFollower; + aSelectedElement: TBoldElement; + aBoldSelectChangeAction: TBoldComboSelectChangeAction; + aBoldSetValueExpression: TBoldExpression; + aListHandle: TBoldAbstractListHandle; + aValue: Variant); + +var + ElementToAssignTo: TBoldElement; + lValue: Variant; + lOldValue: IBoldValue; + lHasOldValue: boolean; + + procedure InternalSetValue(); + begin + if not ElementToAssignTo.Mutable then + begin + SetBoldLastFailureReason(TBoldFailureReason.CreateFmt('Element %s is immutable', [ElementToAssignTo.displayName], ElementToAssignTo)); + exit; + end + else + if (elementToAssignTo is TBoldMember) then + begin + if not TBoldMember(ElementToAssignTo).CanModify then + begin + exit; + end; + if elementToAssignTo is TBoldObjectReference then + begin + if not ElementToAssignTo.IsEqual(aSelectedElement) then + begin + ElementToAssignTo.Assign(aSelectedElement); + end; + end + else + // if elementToAssignTo is TBoldAttribute then + begin + lValue := Null; + if Assigned(aSelectedElement) then + lValue := aSelectedElement.AsVariant; + ElementToAssignTo.AsVariant := lValue; + // (aFollower.Controller as TBoldVariantFollowerController).MayHaveChanged(lValue, aFollower); + end; + end; + end; + +var + FailureReason: TBoldFailureReason; + Discard: Boolean; + Handled: Boolean; +begin + try + BoldClearLastFailure; + try + case aBoldSelectChangeAction of + bdcsNone:; + bdscSetText: + (aFollower.Controller as TBoldVariantFollowerController).MayHaveChanged(aValue, aFollower); + bdcsSetReference: + if Assigned(aBoldHandle) and aBoldHandle.CanSetValue then + TBoldElementHandleAccess(aBoldHandle).SetValue(aSelectedElement); + bdcsSetListIndex: + begin + aFollower.DiscardChange; + if assigned(aListHandle) then + aListHandle.CurrentIndex := aListHandle.List.IndexOf(aSelectedElement); + end; + bdcsSetValue: + begin + if not (Assigned(aFollower.Element)) then + exit; + if trim(aBoldSetValueExpression) <> '' then + ElementToAssignTo := aFollower.Element.EvaluateExpressionAsDirectElement(aBoldSetValueExpression, TBoldFollowerControllerAccess(aFollower.Controller).VariableList) + else + begin + ElementToAssignTo := aFollower.Value; + end; + if assigned(ElementToAssignTo) then + InternalSetValue(); + end; + end; + finally + FailureReason := GetBoldLastFailureReason; + if assigned(FailureReason) then + BoldRaiseLastFailure(nil, '', 'InternalComboSetValue failed.'); + end; + except + on E: Exception do + begin + Handled := assigned(aFollower.Controller) and TBoldFollowerControllerAccess(aFollower.Controller).DoApplyException(E, ElementToAssignTo, Discard); + if Discard then + aFollower.DiscardChange; + if not Handled then + raise; + end; + end; +end; + +{ TcxBoldTextEditProperties } + +procedure TcxCustomBoldTextEditProperties._DeleteItem(Index: Integer; + OwningFollower: TBoldFollower); +begin + if not LookupItems.Updating then + LookupItems.BeginUpdate; + LookupItems.Delete(index); +end; + +procedure TcxCustomBoldTextEditProperties._InsertItem(Index: Integer; Follower: TBoldFollower); +begin + Assert(Assigned(Follower)); + if not LookupItems.Updating then + LookupItems.BeginUpdate; + Follower.EnsureDisplayable; + LookupItems.Insert(Index, VarToStr(TBoldVariantFollowerController(Follower.Controller).GetAsVariant(Follower))); +end; + +procedure TcxCustomBoldTextEditProperties._ReplaceItem(Index: Integer; + Follower: TBoldFollower); +begin + if not LookupItems.Updating then + LookupItems.BeginUpdate; + Follower.EnsureDisplayable; + LookupItems.Strings[Index] := VarToStr(TBoldVariantFollowerController(Follower.Controller).GetAsVariant(Follower)); +end; + +procedure TcxCustomBoldTextEditProperties._RowAfterMakeUptoDate( + Follower: TBoldFollower); +var + index: Integer; + NewValue: String; +begin +{ OutputDebugString('TcxCustomBoldTextEditProperties._RowAfterMakeUptoDate'); + if (Owner is TcxCustomEdit) and TcxCustomEdit(Owner).IsDesigning then + begin + ValidateEdit(TcxCustomEdit(Owner)); + end; +} + index := Follower.index; + if (index > -1) and (index < LookupItems.Count) then + begin + NewValue := VarToStr(TBoldVariantFollowerController(Follower.Controller).GetAsVariant(Follower)); + if LookupItems[index] <> NewValue then + LookupItems[index] := NewValue; + end; +// LookupDataChanged(self); + // forces a redisplay of the edit-area, the windows component might go blank if the active row is removed and then reinserted +// fBoldHandleFollower.Follower.MarkValueOutOfDate; // do we really need this here ? Danny +end; + +function TcxCustomBoldTextEditProperties.GetBoldListHandle: TBoldAbstractListHandle; +begin + Result := fListHandleFollower.BoldHandle; +end; + +function TcxCustomBoldTextEditProperties.GetContextForBoldRowProperties: TBoldElementTypeInfo; +begin + if assigned(BoldLookupListHandle) then + result := BoldLookupListHandle.StaticBoldType + else + result := nil; +end; + +function TcxCustomBoldTextEditProperties.GetListFollower: TBoldFollower; +begin + Result := fListHandleFollower.Follower; +end; + +function TcxCustomBoldTextEditProperties.IsEditValueValid( + var EditValue: TcxEditValue; AEditFocused: Boolean): Boolean; +begin + result := inherited IsEditValueValid(EditValue, AEditFocused) or IsNilRepresentation(EditValue); +end; + +function TcxCustomBoldTextEditProperties.IsNilRepresentation( + AValue: Variant): boolean; +begin + result := UseLookupData and cxEditVarEquals(AValue, BoldRowProperties.NilRepresentation); +end; + +procedure TcxCustomBoldTextEditProperties.SetBoldListHandle( + const Value: TBoldAbstractListHandle); +begin + fListHandleFollower.BoldHandle := value; +end; + +procedure TcxCustomBoldTextEditProperties.SetBoldListProperties( + const Value: TBoldAbstractListAsFollowerListController); +begin + fBoldListProperties.Assign(Value); +end; +{ +procedure TcxCustomBoldTextEditProperties.SetBoldSelectChangeAction( + const Value: TBoldComboSelectChangeAction); +begin + fBoldSelectChangeAction := Value; +end; +} +procedure TcxCustomBoldTextEditProperties.SetRowProperties( + const Value: TBoldVariantFollowerController); +begin + fBoldRowProperties.Assign(Value); +end; + +constructor TcxCustomBoldTextEditProperties.Create(AOwner: TPersistent); + +begin + inherited; + fBoldRowProperties := TBoldVariantFollowerController.Create(Owner as TComponent); + fBoldRowProperties.AfterMakeUptoDate := _RowAfterMakeUptoDate; + fBoldRowProperties.OnGetContextType := GetContextForBoldRowProperties; + fBoldListProperties := TBoldAbstractListAsFollowerListController.Create((Owner as TComponent), fBoldRowProperties); + with fBoldListProperties do + begin + OnAfterInsertItem := _InsertItem; + OnAfterDeleteItem := _DeleteItem; + OnReplaceitem := _ReplaceItem; + BeforeMakeUptoDate := _BeforeMakeUptoDate; + AfterMakeUptoDate := _AfterMakeUptoDate; + end; + fListHandleFollower := TBoldListHandleFollower.Create((Owner as TComponent).owner , fBoldListProperties); + BoldSelectChangeAction := bdcsSetValue; +end; + +destructor TcxCustomBoldTextEditProperties.Destroy; +begin + FreeAndNil(fListHandleFollower); + FreeAndNil(fBoldListProperties); + FreeAndNil(fBoldRowProperties); + inherited; +end; + +procedure TcxCustomBoldTextEditProperties._AfterMakeUptoDate( + Follower: TBoldFollower); +begin + fBoldRowProperties.AfterMakeUptoDate := _RowAfterMakeUptoDate; + if LookupItems.Updating then + LookupItems.EndUpdate; +end; + +procedure TcxCustomBoldTextEditProperties._BeforeMakeUptoDate( + Follower: TBoldFollower); +begin + fBoldRowProperties.AfterMakeUptoDate := nil; +end; + + +{ TcxBoldEditDataBinding } + +constructor TcxBoldEditDataBinding.Create(AEdit: TcxCustomEdit); +begin + inherited Create(AEdit); +// DefaultValuesProvider.fcxBoldEditDataBinding := self; + fBoldFollowerController:= TBoldVariantFollowerController.Create(AEdit); +// fBoldProperties := TBoldVariantFollowerController.Create(AEdit); + BoldFollowerController.AfterMakeUptoDate := _AfterMakeUptoDate; + BoldFollowerController.OnGetContextType := GetContextType; + BoldFollowerController.OnApplyException := HandleApplyException; + fBoldHandleFollower := TBoldElementHandleFollower.Create(AEdit.Owner, BoldFollowerController); + + DefaultValuesProvider.BoldProperties := BoldFollowerController; + DefaultValuesProvider.BoldHandleFollower := fBoldHandleFollower; +{ if AEdit.InnerControl <> nil then + FDataLink.Control := AEdit.InnerControl + else + FDataLink.Control := AEdit; +} +end; + +destructor TcxBoldEditDataBinding.Destroy; +begin + case BoldFollowerController.ApplyPolicy of + bapChange, bapExit: try + Follower.Apply; + except + Follower.DiscardChange; + end; + bapDemand: Follower.DiscardChange; + end; + FreeAndNil(fBrokenConstraints); + FreeAndNil(fBoldHandleFollower); + FreeAndNil(fBoldFollowerController); + Edit.ViewInfo.OnPaint := nil; + inherited Destroy; +end; + +function TcxBoldEditDataBinding.GetBoldHandle: TBoldElementHandle; +begin + Result := fBoldHandleFollower.BoldHandle +end; + +function TcxBoldEditDataBinding.GetFollower: TBoldFollower; +begin + Result := fBoldHandleFollower.Follower +end; + +function TcxBoldEditDataBinding.GetHasBrokenConstraints: boolean; +begin + result := Assigned(fBrokenConstraints) and (BrokenConstraints.Count > 0); +end; + +function TcxBoldEditDataBinding.GetIsInInternalChange: boolean; +begin + result := fInternalChange > 0; +end; + +procedure TcxBoldEditDataBinding.SetBoldHandle( + const Value: TBoldElementHandle); +begin +// if not (Edit.IsLoading) then + begin + fBoldHandleFollower.BoldHandle := value; + DefaultValuesProvider.fBoldHandleFollower := fBoldHandleFollower; + if (Edit.IsDesigning) and not (Edit.IsLoading) then + begin + _ValidateEdit(Edit); + end; +// DefaultValuesProvider.BoldHandle := value; +// DefaultValuesProvider.BoldProperties := BoldProperties; + end; +end; + +procedure TcxBoldEditDataBinding.Assign(Source: TPersistent); +begin + if Source is TcxBoldEditDataBinding then + begin + // TODO: what about HandleFollower ? + BoldHandle := TcxBoldEditDataBinding(Source).BoldHandle; + fBoldFollowerController := TcxBoldEditDataBinding(Source).BoldFollowerController; + DataChanged; // ? + end; + inherited Assign(Source); +end; + +function TcxBoldEditDataBinding.ImmediatePost: boolean; +begin + result := BoldFollowerController.ApplyPolicy = bapChange; +end; + +function TcxBoldEditDataBinding.CanCheckEditorValue: Boolean; +begin + result := inherited CanCheckEditorValue; +end; + +function TcxBoldEditDataBinding.CanPostEditorValue: Boolean; +begin + Result := IsDataAvailable and (fInternalChange = 0) and not FEdit.ActiveProperties.ReadOnly and Modified; +// Result := Editing and Edit.IsFocused; //or (BoldProperties.ApplyPolicy = bapExit); +// result := false; // inherited CanPostEditorValue; +// Result := Editing and DataLink.FModified; +end; + +procedure TcxBoldEditDataBinding.DataChanged; +begin + inherited; +end; + +procedure TcxBoldEditDataBinding.DataSetChange; +begin + inherited; +end; + +procedure TcxBoldEditDataBinding.DefaultValuesChanged; +begin + inherited DefaultValuesChanged; +end; + +procedure TcxBoldEditDataBinding.EditingChanged; +begin + TcxCustomEditAccess(Edit).EditingChanged; +end; + +function TcxBoldEditDataBinding.ExecuteAction( + Action: TBasicAction): Boolean; +begin + result := inherited ExecuteAction(Action); +end; + +function TcxBoldEditDataBinding.GetDefaultValuesProvider: TcxCustomBoldEditDefaultValuesProvider; +begin + Result := TcxCustomBoldEditDefaultValuesProvider(IDefaultValuesProvider.GetInstance); +end; + +class function TcxBoldEditDataBinding.GetDefaultValuesProviderClass: TcxCustomEditDefaultValuesProviderClass; +begin + result := TcxCustomBoldEditDefaultValuesProvider; +end; + +type + TcxCustomTextEditAccess = class(TcxTextEdit); + +function TcxBoldEditDataBinding.GetModified: Boolean; +var + lcxBoldEditProperties: IcxBoldEditProperties; + lValue: Variant; + lEditValue: variant; +// lElement: TBoldElement; +begin + if not IsDataAvailable or FEdit.ActiveProperties.ReadOnly then + begin + result := false; + end + else + begin + if Supports(Edit.ActiveProperties, IcxBoldEditProperties, lcxBoldEditProperties) then + begin + if Edit is TcxCustomComboBox then + lEditValue := TcxCustomComboBox(Edit).ILookupData.CurrentKey + else + lEditValue := Edit.EditValue; + lValue := lcxBoldEditProperties.BoldElementToEditValue(Follower, Follower.Element, Edit); +// result := (Follower.AssertedController.EffectiveRenderer as TBoldAsVariantRenderer).IsChanged(Follower, lValue); + result := not cxEditVarEquals(lEditValue, lValue); + end + else + begin + result := (TBoldFollowerControllerAccess(Follower.AssertedController).EffectiveRenderer as TBoldAsVariantRenderer).IsChanged(Follower, Edit.EditValue); + end; + end; +end; + +function TcxBoldEditDataBinding.GetStoredValue: TcxEditValue; +begin + Assert(assigned(Follower)); + result := ((Follower.Controller) as TBoldVariantFollowerController).GetAsVariant(Follower); +end; + +function TcxBoldEditDataBinding.IsLookupControl: Boolean; +begin + result := false; // inherited IsLookupControl; +end; + +function TcxBoldEditDataBinding.IsRefreshDisabled: Boolean; +begin + result := false; // inherited IsRefreshDisabled; +end; + +procedure TcxBoldEditDataBinding.Reset; +begin + inc(fInternalChange); + try + case BoldFollowerController.ApplyPolicy of + bapChange : + begin +// Follower.UndoChange; + end; + bapExit, bapDemand: Follower.DiscardChange; + end; + inherited; +// Follower.Display; +// TBoldQueueable.DisplayAll; + finally + dec(fInternalChange); + Edit.LockClick(False); + end; +end; + +procedure TcxBoldEditDataBinding.SetModified; +begin + if (fInternalChange = 0) and Editing then + begin + inherited; + end; +end; + +procedure TcxBoldEditDataBinding.SetStoredValue(const Value: TcxEditValue); +var + lIcxBoldEditProperties: IcxBoldEditProperties; + lDone: Boolean; +begin + lDone := false; + if Supports(Edit.ActiveProperties, IcxBoldEditProperties, lIcxBoldEditProperties) then + begin + lIcxBoldEditProperties.SetStoredValue(Value, BoldHandle, Edit, Follower, lDone); + end; + if not lDone then + begin + InternalSetValue(Value); + end; + TBoldQueueable.DisplayAll; +// Follower.Apply; + inherited; +end; + +function TcxBoldEditDataBinding.UpdateAction( + Action: TBasicAction): Boolean; +begin + result := inherited UpdateAction(Action); +end; + +procedure TcxBoldEditDataBinding.UpdateData; +begin + inherited; +end; + +procedure TcxBoldEditDataBinding.UpdateDisplayValue; +begin + Edit.LockClick(True); + inc(fInternalChange); + try + inherited UpdateDisplayValue; + finally + dec(fInternalChange); + Edit.LockClick(False); + end; + if Edit.IsDesigning and not Edit.IsLoading then + begin + _ValidateEdit(Edit); + end; +end; + +type + TcxCustomTextEditPropertiesAccess = class(TcxCustomTextEditProperties) + end; + +procedure TcxBoldEditDataBinding._AfterMakeUptoDate( + Follower: TBoldFollower); +var + lValue: Variant; +// lcxBoldComboBoxProperties: TcxBoldComboBoxProperties; + lElement: TBoldElement; +// WasModified: boolean; + ASize: TSize; + AViewData: TcxCustomEditViewData; + AEditSizeProperties: TcxEditSizeProperties; +begin + if fInternalChange > 0 then + begin + {$IFDEF BoldDevExLog} + Assert(assigned(self)); + _Log('TcxBoldEditDataBinding._AfterMakeUptoDate: fInternalChange ' + Edit.Name, className); + {$ENDIF} + {$IFDEF Constraints} + SubscribeToConstraints(Follower.Value); + {$ENDIF} + exit; + end; +// WasModified := Edit.ModifiedAfterEnter or Edit.EditModified; + Edit.LockClick(True); + inc(fInternalChange); + try + // this is not really the perfect place for setting ImmediatePost + Edit.ActiveProperties.ImmediatePost := ImmediatePost; + lValue := null; + if Edit.IsDesigning then + begin + _ValidateEdit(Edit); + end + else + begin + TypeMayHaveChanged; + {$IFDEF Constraints} + lElement := Follower.Value; + SubscribeToConstraints(lElement); + {$ENDIF} + lValue := InternalGetValue(Follower); + if Edit.ModifiedAfterEnter and not Edit.IsPosting then + Edit.Reset; + if not cxEditVarEquals(Edit.EditValue, lValue) then + begin + TcxCustomEditAccess(Edit).SetInternalEditValue(lValue); + end; + if ShowHintIfCaptionDoesntFit then + begin + AViewData := TcxCustomEditViewData(TcxCustomEditAccess(Edit).CreateViewData); + try + TcxCustomEditAccess(Edit).PopulateSizeProperties(AEditSizeProperties); + ASize := AViewData.GetEditSize(cxScreenCanvas, lValue, AEditSizeProperties, edit.ViewInfo); + if ASize.cx > Edit.Width then + begin + Edit.Hint := VarToStr(lValue); + Edit.ShowHint := true; + end + else + begin + Edit.Hint := ''; + Edit.ShowHint := false; + end; + finally + FreeAndNil(AViewData); + end; + end; + end; + finally + ValueOrDefinitionInvalid := false; + try + if Assigned(Edit.ViewInfo) and Assigned(Edit.ViewInfo.ErrorData) and TcxEditValidateInfoAccess(Edit.ViewInfo.ErrorData).IsError then + begin + ValueOrDefinitionInvalid := not Edit.ValidateEdit(false); + end; + finally +// TcxCustomTextEditAccess(Edit).ResetEditValue; + Edit.LockClick(False); + dec(fInternalChange); + if Edit.IsFocused and not Edit.EditModified then + Edit.SelectAll + end; + end; +end; + +function TcxBoldEditDataBinding.InternalGetValue(Follower: TBoldFollower): Variant; +var + lElement: TBoldElement; + lIcxBoldEditProperties: IcxBoldEditProperties; +begin + result := Null; + lElement := Follower.Value; +{ if (Edit.ActiveProperties is TcxBoldComboBoxProperties) then + begin + lcxBoldComboBoxProperties := (Edit.ActiveProperties as TcxBoldComboBoxProperties); + if (Edit is TcxCustomComboBox) and Assigned(TcxCustomComboBox(Edit).ILookupData.ActiveControl) then + begin + TcxCustomEditListBox(TcxCustomComboBox(Edit).ILookupData.ActiveControl).ItemIndex := lcxBoldComboBoxProperties.LookupListFollower.CurrentIndex; + end; + end; +} + if Supports(Edit.ActiveProperties, IcxBoldEditProperties, lIcxBoldEditProperties) then + result := lIcxBoldEditProperties.BoldElementToEditValue(Follower, lElement, Edit) + else + result := TBoldVariantFollowerController(Follower.Controller).GetAsVariant(Follower); + if VarIsEmpty(result) then + result := Null; +end; + +function TcxBoldEditDataBinding.GetBrokenConstraints: TStringList; +begin + if not Assigned(fBrokenConstraints) then + fBrokenConstraints := TStringList.Create; + result := fBrokenConstraints; +end; + +function TcxBoldEditDataBinding.GetContextType: TBoldElementTypeInfo; +begin + if assigned(BoldHandle) then + result := BoldHandle.StaticBoldType + else + result := nil; +end; + +function TcxBoldEditDataBinding.CanModify: Boolean; +begin + result := inherited CanModify and MayModify; +end; + +procedure TcxBoldEditDataBinding.TypeMayHaveChanged; +begin +// Edit.IsDesigning +// BoldEffectiveEnvironment.RunningInIDE or + if not Assigned(BoldHandle) or not Assigned(BoldHandle.Value) then + Exit; // only update at runtime if there are values, avoids update on every UML model change. + if fCurrentElementType <> BoldHandle.BoldType then + begin + fCurrentElementType := BoldHandle.BoldType; + if Edit is TcxCustomTextEdit then + TcxCustomTextEditAccess(Edit).LockLookupDataTextChanged; + try + TcxCustomEditAccess(Edit).PropertiesChanged(nil); + finally + if Edit is TcxCustomTextEdit then + TcxCustomTextEditAccess(Edit).UnlockLookupDataTextChanged; + end; + end; +end; + +function TcxBoldEditDataBinding.MayModify: boolean; +var + lcxBoldEditProperties: IcxBoldEditProperties; +begin + result := BoldFollowerController.MayModify(Follower); + if result and Supports(Edit.ActiveProperties, IcxBoldEditProperties, lcxBoldEditProperties) then + begin + result := lcxBoldEditProperties.CanEdit(BoldHandle, Follower); + end; +end; + +procedure TcxBoldEditDataBinding.DoChanged; +begin + if Editing and (fInternalChange = 0) then + begin + inc(fInternalChange); + try + InternalSetValue(Edit.EditingValue); + if ImmediatePost then + Follower.Apply; + Follower.EnsureDisplayable; + finally + dec(fInternalChange); + end; + end; +end; + +procedure TcxBoldEditDataBinding.DoEnter; +begin + if (Follower.State = bfsDirty) then + Edit.ModifiedAfterEnter := true; +end; + +procedure TcxBoldEditDataBinding.DoExit; +begin + if (Follower.State = bfsDirty) and (Follower.Controller.ApplyPolicy <> bapDemand) then + try + Follower.Apply; + except + Follower.DiscardChange; + end; +end; + +{$IFDEF Constraints} +procedure TcxBoldEditDataBinding.SubscribeToConstraints( + aElement: TBoldElement); +var + s: string; + lIE: TBoldIndirectElement; + lConstraintList: TBoldList; +const + ECM_FIRST = $1500; + EM_SETCUEBANNER = ECM_FIRST + 1; + + procedure EvaluateConstraints(AElement: TBoldElement); + var + i: integer; + begin + lIE := TBoldIndirectElement.Create; + try + aElement.EvaluateAndSubscribeToExpression('constraints->select(c|not c)', Follower.Subscriber, lIe); + lConstraintList := lIE.Value as TBoldList; + for i := 0 to lConstraintList.Count - 1 do + BrokenConstraints.AddObject(lConstraintList[i].StringRepresentation[11], lConstraintList[i]); + if HasBrokenConstraints then + if Assigned(Edit) and Assigned(TcxCustomEditAccess(Edit).InnerEdit) then + begin + s := BrokenConstraints.Text; + SendMessage(TcxCustomEditAccess(Edit).InnerEdit.Control.Handle, EM_SETCUEBANNER, 1, LParam(PWideChar(WideString(s)))); + end; + finally + lIE.free; + end; + end; + +begin + FreeAndNil(fBrokenConstraints); + if not Assigned(aElement) then + exit; + if ((aElement is TBoldMember) and (Assigned(TBoldMember(aElement).BoldMemberRTinfo)) and + ((TBoldMember(aElement).BoldMemberRTinfo.ConstraintCount > 0) +// or (TBoldMember(aElement).OwningObject.BoldClassTypeInfo.ConstraintCount > 0) + )) or + (aElement is TBoldObject) and (TBoldObject(aElement).BoldClassTypeInfo.ConstraintCount > 0) or + (aElement is TBoldSystem) and (TBoldSystem(aElement).BoldSystemTypeInfo.ConstraintCount > 0 ) then + begin + EvaluateConstraints(AElement); + end; +end; +{$ENDIF} + +function TcxBoldEditDataBinding.ValidateComponent( + ComponentValidator: TBoldComponentValidator; + NamePrefix: string): Boolean; +var + lContext: TBoldElementTypeInfo; + lExpressionType: TBoldElementTypeInfo; + lBoldValidateableComponent: IBoldValidateableComponent; + s: string; +begin + lContext := GetContextType; + result := Assigned(lContext); + if not result then + begin + BoldLog.LogFmt(sNoContext, [Edit.Name]) + end + else + begin + result := ComponentValidator.ValidateExpressionInContext( + TBoldFollowerControllerAccess(BoldFollowerController).Expression, + lContext, + format('%s %s.Expression', [NamePrefix, Edit.Name]), TBoldFollowerControllerAccess(BoldFollowerController).VariableList) and result; // do not localize + + if result then + begin + lExpressionType := lContext.Evaluator.ExpressionType(TBoldFollowerControllerAccess(BoldFollowerController).Expression, lContext, false, TBoldFollowerControllerAccess(BoldFollowerController).VariableList); + if Assigned(lExpressionType) then + begin + s := ValidateTypeConforms(lExpressionType); + if s <> '' then + begin + result := false; + BoldLog.Log('*** ' + s + ' in ' + Edit.Name); + end; + end; + end; + end; + if Supports(Edit.ActiveProperties, IBoldValidateableComponent, lBoldValidateableComponent) then + begin + result := lBoldValidateableComponent.ValidateComponent(ComponentValidator, NamePrefix) and result; + end; + ValueOrDefinitionInvalid := not result; +end; + +function TcxBoldEditDataBinding.ValidateTypeConforms( + aExpressionType: TBoldElementTypeInfo): string; +begin + result := ''; +end; + +function TcxBoldEditDataBinding.GetValueOrDefinitionInvalid: boolean; +begin + result := fValueOrDefinitionInvalid; +end; + +procedure TcxBoldEditDataBinding.SetValueOrDefinitionInvalid( + const Value: boolean); +begin + if fValueOrDefinitionInvalid <> Value then + begin + fValueOrDefinitionInvalid := Value; +// Edit.Refresh; +// Edit.Invalidate; + Edit.Repaint; + end; +end; + +function TcxBoldEditDataBinding.GetBoldProperties: TBoldVariantFollowerController; +begin + result := BoldFollowerController as TBoldVariantFollowerController; +end; + +procedure TcxBoldEditDataBinding.InternalSetValue( + const aValue: TcxEditValue); +begin + {$IFDEF BoldDevExLog} + if Follower.State = bfsSubscriptionOutOfDate then + begin + _Log('TcxBoldEditDataBinding.InternalSetValue, Follower.State = bfsSubscriptionOutOfDate', 'Follower debug'); + end; + {$ENDIF} + BoldProperties.MayHaveChanged(aValue, Follower); +end; + +procedure TcxBoldEditDataBinding.SetBoldProperties( + const Value: TBoldVariantFollowerController); +begin + BoldFollowerController.Assign(Value); +end; + +function TcxBoldEditDataBinding.GetExpression: TBoldExpression; +begin + result := BoldProperties.Expression; +end; + +function TcxBoldEditDataBinding.GetVariableList: TBoldExternalVariableList; +begin + result := BoldProperties.VariableList; +end; + +function TcxBoldEditDataBinding.HandleApplyException(E: Exception; + Elem: TBoldElement; var Discard: Boolean): Boolean; +begin + result := false; + if Edit.IsDestroying then + exit; + if Assigned(Edit.ActiveProperties) then + result := not (evoRaiseException in Edit.ActiveProperties.ValidationOptions); + if not TcxCustomEditAccess(Edit).IsEditValidated then + Edit.ValidateEdit(false); +end; + +procedure TcxBoldEditDataBinding.SetExpression(const Value: TBoldExpression); +begin + BoldProperties.Expression := Value; +end; + +procedure TcxBoldEditDataBinding.ValidateDisplayValue(var ADisplayValue: TcxEditValue; var AErrorText: TCaption; var AError: Boolean); + + procedure AddMessage(const s: string); + begin + if AErrorText <> '' then + AErrorText := AErrorText + BOLDCRLF + s + else + AErrorText := s; + end; +begin + if not AError then + AErrorText := ''; + BoldClearLastFailure; + if not BoldProperties.ValidateVariant(ADisplayValue, Follower) then + begin + AError := true; + if (BoldSystem.GetBoldLastFailureReason <> nil) then + AddMessage(BoldSystem.GetBoldLastFailureReason.Reason); + end; + if HasBrokenConstraints then + begin + AError := true; + AddMessage(BrokenConstraints.text); + end; + ValueOrDefinitionInvalid := AError; +end; + +{ TcxBoldTextEdit } + +class function TcxBoldTextEdit.GetPropertiesClass: TcxCustomEditPropertiesClass; +begin + Result := TcxBoldTextEditProperties; +end; + +function TcxBoldTextEdit.GetActiveProperties: TcxBoldTextEditProperties; +begin + Result := TcxBoldTextEditProperties(InternalGetActiveProperties); +// FProperties.ValidateOnEnter := true; +end; + +function TcxBoldTextEdit.GetProperties: TcxBoldTextEditProperties; +begin + Result := TcxBoldTextEditProperties(FProperties); +// FProperties.ImmediatePost := true; +// FProperties.ValidateOnEnter := true; +end; + +procedure TcxBoldTextEdit.SetProperties( + Value: TcxBoldTextEditProperties); +begin + FProperties.Assign(Value); +end; + +class function TcxBoldTextEdit.GetDataBindingClass: TcxEditDataBindingClass; +begin + Result := TcxBoldTextEditDataBinding; +end; + +function TcxBoldTextEdit.GetDataBinding: TcxBoldTextEditDataBinding; +begin + Result := FDataBinding as TcxBoldTextEditDataBinding; +end; + +procedure TcxBoldTextEdit.SetDataBinding( + Value: TcxBoldTextEditDataBinding); +begin + FDataBinding.Assign(Value); +end; + +function TcxBoldTextEdit.ValidateKeyDown(var Key: Word; + Shift: TShiftState): Boolean; +begin + result := DataBinding.IsDataAvailable and inherited ValidateKeyDown(Key, Shift); +end; + +function TcxBoldTextEdit.ValidateKeyPress(var Key: Char): Boolean; +begin + result := DataBinding.MayModify and inherited ValidateKeyPress(Key); + if not result then + Key := #0 + else + begin + if (Key = #13) and (DataBinding.Follower.Controller.ApplyPolicy <> bapDemand) then + begin + DataBinding.Follower.Apply; + SelectAll; + end; + end; +end; + +procedure TcxBoldTextEdit.DoOnChange; +begin + inherited; + PostEditValue; +end; + +procedure TcxBoldTextEdit.DoValidateDisplayValue( + var ADisplayValue: TcxEditValue; var AErrorText: TCaption; + var AError: Boolean); +begin + inherited; + if Assigned(DataBinding) then + DataBinding.ValidateDisplayValue(ADisplayValue, AErrorText, AError); +end; + +procedure TcxBoldTextEdit.DoChange; +begin + inherited; + DataBinding.DoChanged; +end; + +procedure TcxBoldTextEdit.DoEnter; +begin + inherited; + DataBinding.DoEnter; +end; + +procedure TcxBoldTextEdit.DoExit; +begin + inherited; + DataBinding.DoExit; +end; +{ +function TcxBoldTextEdit.ValidateComponent( + ComponentValidator: TBoldComponentValidator; + NamePrefix: string): Boolean; +begin + result := DataBinding.ValidateComponent(ComponentValidator, NamePrefix); + result := GetActiveProperties.ValidateComponent(ComponentValidator, NamePrefix) and result; +end; +} +procedure TcxBoldTextEdit.Paint; +begin + inherited Paint; + if DataBinding.ValueOrDefinitionInvalid then + Canvas.FrameRect(Bounds, clRed, 2 - Ord(IsNativeStyle)); +end; + +{ TcxCustomBoldEditDefaultValuesProvider } + +function TcxCustomBoldEditDefaultValuesProvider.GetBoldElementTypeInfo: TBoldElementTypeInfo; +begin + if Assigned({DataBinding.}BoldHandle)then + result := {DataBinding.}BoldHandle.StaticBoldType + else + result := nil; +end; + +function TcxCustomBoldEditDefaultValuesProvider.IsDataAvailable: Boolean; +begin + Result := ({DataBinding.}BoldHandle <> nil) {and (DataBinding.BoldHandle.Value <> nil)}; +end; + +function TcxCustomBoldEditDefaultValuesProvider.DefaultAlignment: TAlignment; +var + lElement: TBoldElement; +begin + Result := taLeftJustify; + if IsDataAvailable then + begin + lElement := Follower.Value; + if (lElement is TBAMoment) or (lElement is TBANumeric) then + result := taRightJustify; + end; +end; + +function TcxCustomBoldEditDefaultValuesProvider.DefaultBlobKind: TcxBlobKind; +var + lElement: TBoldElement; +begin + Result := cxEdit.bkNone; + lElement := Follower.Value; + if (lElement is TBABlob) then + begin + if (lElement is TBABlobImageBMP) or (lElement is TBABlobImageJPEG) then + Result := bkGraphic + else + if (lElement is TBATypedBlob) then + begin + Result := bkBlob; +// TcxBlobKind = (bkNone, bkBlob, bkGraphic, bkMemo, bkOle); +{ + MIME decode to see what type it is + (Follower.Value as TBATypedBlob).ContentType +} + end + else + end; +end; + +function TcxCustomBoldEditDefaultValuesProvider.DefaultCanModify: Boolean; +begin +// TODO: 'not Assigned(Follower.Element)' is a temp workaround for cases where Value is nil and hence not allowed to be modified as per TBoldRenderer.DefaultMayModify +// Follower here can be list(lookup) follower instead of single editing follower, so we can't use it for MayModify + Result := not DefaultReadOnly and IsDataAvailable {and (Follower.Controller.MayModify(Follower) or not Assigned(Follower.Element))} {DataBinding.MayModify}; +end; + +function TcxCustomBoldEditDefaultValuesProvider.DefaultIsFloatValue: Boolean; +var + lElement: TBoldElement; +begin + lElement := nil; + if Assigned(Follower) then + lElement := Follower.Value; + result := (lElement is TBAFloat) or (lElement is TBACurrency); +end; + +function TcxCustomBoldEditDefaultValuesProvider.DefaultMaxLength: Integer; +var + lElement: TBoldElement; +begin + result := 0; + if not Assigned(fBoldHandleFollower) then + exit; + lElement := Follower.Value; + if (lElement is TBAString) and Assigned(TBAString(lElement).BoldAttributeRTInfo) then + begin + result := TBAString(lElement).BoldAttributeRTInfo.Length; + if result < 1 then + Result := inherited DefaultMaxLength; + end + else + Result := inherited DefaultMaxLength; +end; + +function TcxCustomBoldEditDefaultValuesProvider.IsBlob: Boolean; +var + lElement: TBoldElement; +begin + result := IsDataAvailable; + if result then + begin + lElement := Follower.Value; + result := (lElement is TBABlob); + end; +end; + +function TcxCustomBoldEditDefaultValuesProvider.IsCurrency: Boolean; +var + lElement: TBoldElement; +begin + result := IsDataAvailable; + if result then + begin + lElement := Follower.Value; + result := (lElement is TBACurrency); + end; +end; + +function TcxCustomBoldEditDefaultValuesProvider.IsValidChar( + AChar: Char): Boolean; +begin + result := inherited IsValidChar(AChar); + if result and (BoldProperties is TBoldVariantFollowerController) then + result := TBoldVariantFollowerController(BoldProperties).ValidateCharacter(AChar, Follower); +end; + +{function TcxCustomBoldEditDefaultValuesProvider.GetFollower: TBoldFollower; +begin + Result := DataBinding.Follower; +end;} + +function TcxCustomBoldEditDefaultValuesProvider.GetFollower: TBoldFollower; +begin + if Assigned(BoldHandleFollower) then + result := BoldHandleFollower.Follower + else + result := nil; +end; +(* +procedure TcxCustomBoldEditDefaultValuesProvider.SetBoldHandle( + const Value: TBoldElementHandle); +begin + self.BoldHandleFollower.BoldHandle := Value; +// TODO: Place subscriptions instead of free notifications +{ + if BoldHandle <> Value then + begin + if BoldHandle <> nil then + FFreeNotifier.RemoveSender(BoldHandle); + BoldHandle := Value; + if BoldHandle <> nil then + FFreeNotifier.AddSender(BoldHandle); + end; +} +end; +*) +procedure TcxCustomBoldEditDefaultValuesProvider.SetBoldProperties( + const Value: TBoldFollowerController); +begin + fBoldProperties := Value; +// TODO: Place subscriptions instead of free notifications +{ + if fBoldProperties <> Value then + begin + if fBoldProperties <> nil then + FFreeNotifier.RemoveSender(fBoldProperties); + fBoldProperties := Value; + if fBoldProperties <> nil then + FFreeNotifier.AddSender(fBoldProperties); + end; +} +end; + +procedure TcxCustomBoldEditDefaultValuesProvider.SetHandleFollower( + const Value: TBoldAbstractHandleFollower); +begin + fBoldHandleFollower := Value; +// TODO: Place subscriptions instead of free notifications +{ + if fBoldHandleFollower <> Value then + begin + if fBoldHandleFollower <> nil then + FFreeNotifier.RemoveSender(fBoldHandleFollower); + fBoldHandleFollower := Value; + if fBoldHandleFollower <> nil then + FFreeNotifier.AddSender(fBoldHandleFollower); + end; +} +end; + +function TcxCustomBoldEditDefaultValuesProvider.GetBoldHandle: TBoldElementHandle; +begin + if Assigned(BoldHandleFollower) then + result := BoldHandleFollower.BoldHandle + else + result := nil; +end; + +constructor TcxCustomBoldEditDefaultValuesProvider.Create( + AOwner: TPersistent); +begin + inherited; + +end; + +destructor TcxCustomBoldEditDefaultValuesProvider.Destroy; +begin + + inherited; +end; + +{ TcxBoldFloatEditDataBinding } + +function TcxBoldFloatEditDataBinding.ValidateTypeConforms( + aExpressionType: TBoldElementTypeInfo): string; +var + lFloatTypeInfo: TBoldAttributeTypeInfo; + lCurrencyTypeInfo: TBoldAttributeTypeInfo; +begin + result := ''; + with (aExpressionType.SystemTypeInfo as TBoldSystemTypeInfo) do + begin + lCurrencyTypeInfo := AttributeTypeInfoByExpressionName['Currency']; // do not localize + lFloatTypeInfo := AttributeTypeInfoByExpressionName['Float']; // do not localize + end; + if not aExpressionType.ConformsTo(lCurrencyTypeInfo) and not aExpressionType.ConformsTo(lFloatTypeInfo) then + result := Format(sPossiblyBadConformance, [aExpressionType.ModelName , lFloatTypeInfo.ModelName]); +end; + +{ TcxBoldDateTimeEditDataBinding } + +function TcxBoldDateTimeEditDataBinding.ValidateTypeConforms( + aExpressionType: TBoldElementTypeInfo): string; +var + lDateTimeTypeInfo: TBoldAttributeTypeInfo; + lDateTypeInfo: TBoldAttributeTypeInfo; +begin + result := ''; + with (aExpressionType.SystemTypeInfo as TBoldSystemTypeInfo) do + begin + lDateTimeTypeInfo := AttributeTypeInfoByExpressionName['DateTime']; // do not localize + lDateTypeInfo := AttributeTypeInfoByExpressionName['Date']; // do not localize + end; + if not (aExpressionType.ConformsTo(lDateTimeTypeInfo) or aExpressionType.ConformsTo(lDateTypeInfo)) then + result := Format(sPossiblyBadConformance, [aExpressionType.ModelName , lDateTimeTypeInfo.ModelName + ' nor ' + lDateTypeInfo.ModelName]); +end; + +{ TcxBoldDateEdit } + +function TcxBoldDateEdit.CanDropDown: Boolean; +begin + result := inherited CanDropDown and DataBinding.IsDataAvailable; +end; + +procedure TcxBoldDateEdit.DoChange; +begin + inherited; + DataBinding.DoChanged; +end; + +procedure TcxBoldDateEdit.DoEnter; +begin + inherited; + DataBinding.DoEnter; +end; + +procedure TcxBoldDateEdit.DoExit; +begin + inherited; + DataBinding.DoExit; +end; + +procedure TcxBoldDateEdit.DoOnChange; +begin + inherited; + if not DataBinding.IsInInternalChange then + PostEditValue; +end; + +procedure TcxBoldDateEdit.DoValidateDisplayValue( + var ADisplayValue: TcxEditValue; var AErrorText: TCaption; + var AError: Boolean); +begin + inherited; + if Assigned(DataBinding) then + DataBinding.ValidateDisplayValue(ADisplayValue, AErrorText, AError); +end; + +{ TcxBoldDateEdit } + +function TcxBoldDateEdit.GetActiveProperties: TcxDateEditProperties; +begin + Result := TcxDateEditProperties(InternalGetActiveProperties); +end; + +function TcxBoldDateEdit.GetDataBinding: TcxBoldDateTimeEditDataBinding; +begin + Result := TcxBoldDateTimeEditDataBinding(FDataBinding); +end; + +class function TcxBoldDateEdit.GetDataBindingClass: TcxEditDataBindingClass; +begin + Result := TcxBoldDateTimeEditDataBinding; +end; + +function TcxBoldDateEdit.GetProperties: TcxDateEditProperties; +begin + Result := TcxDateEditProperties(FProperties); +end; + +class function TcxBoldDateEdit.GetPropertiesClass: TcxCustomEditPropertiesClass; +begin + Result := TcxDateEditProperties; +end; + +procedure TcxBoldDateEdit.HidePopup(Sender: TcxControl; + AReason: TcxEditCloseUpReason); +begin + inherited; +// this will post the value when the calednar popup is closed with ok or enter +// the idea being to post the value even if using bapExit + if AReason = crEnter then + begin + DataBinding.InternalSetValue(EditingValue); + if (DataBinding.BoldFollowerController.ApplyPolicy <> bapDemand) and (DataBinding.Follower.State = bfsDirty) then + DataBinding.Follower.Apply; + end; +end; + +procedure TcxBoldDateEdit.Paint; +begin + inherited Paint; + if DataBinding.ValueOrDefinitionInvalid then + Canvas.FrameRect(Bounds, clRed, 2 - Ord(IsNativeStyle)); +end; + +procedure TcxBoldDateEdit.SetDataBinding( + Value: TcxBoldDateTimeEditDataBinding); +begin + FDataBinding.Assign(Value); +end; + +procedure TcxBoldDateEdit.SetProperties( + Value: TcxDateEditProperties); +begin + FProperties.Assign(Value); +end; + +function TcxBoldDateEdit.ValidateKeyDown(var Key: Word; + Shift: TShiftState): Boolean; +begin + result := DataBinding.IsDataAvailable and inherited ValidateKeyDown(Key, Shift); +end; + +function TcxBoldDateEdit.ValidateKeyPress(var Key: Char): Boolean; +begin + result := DataBinding.MayModify and inherited ValidateKeyPress(Key); + if not result then + Key := #0 + else + begin + if (Key = #13) and (DataBinding.Follower.Controller.ApplyPolicy <> bapDemand) then + begin + DataBinding.Follower.Apply; + SelectAll; + end; + end; +end; + +{ TcxBoldMemo } + +procedure TcxBoldMemo.DoChange; +begin + inherited; + DataBinding.DoChanged; +end; + +procedure TcxBoldMemo.DoEnter; +begin + inherited; + DataBinding.DoEnter; +end; + +procedure TcxBoldMemo.DoExit; +begin + inherited; + DataBinding.DoExit; +end; + +procedure TcxBoldMemo.DoValidateDisplayValue(var ADisplayValue: TcxEditValue; + var AErrorText: TCaption; var AError: Boolean); +begin + inherited; + if Assigned(DataBinding) then + DataBinding.ValidateDisplayValue(ADisplayValue, AErrorText, AError); +end; + +function TcxBoldMemo.GetActiveProperties: TcxMemoProperties; +begin + Result := TcxMemoProperties(InternalGetActiveProperties); +end; + +function TcxBoldMemo.GetDataBinding: TcxBoldTextEditDataBinding; +begin + Result := TcxBoldTextEditDataBinding(FDataBinding); +end; + +class function TcxBoldMemo.GetDataBindingClass: TcxEditDataBindingClass; +begin + result := TcxBoldTextEditDataBinding; +end; + +function TcxBoldMemo.GetProperties: TcxMemoProperties; +begin + Result := TcxMemoProperties(FProperties); +end; + +class function TcxBoldMemo.GetPropertiesClass: TcxCustomEditPropertiesClass; +begin + Result := TcxMemoProperties; +end; + +procedure TcxBoldMemo.Paint; +begin + inherited Paint; + if DataBinding.ValueOrDefinitionInvalid then + Canvas.FrameRect(Bounds, clRed, 2 - Ord(IsNativeStyle)); +end; + +procedure TcxBoldMemo.SetDataBinding(Value: TcxBoldTextEditDataBinding); +begin + FDataBinding.Assign(Value); +end; + +procedure TcxBoldMemo.SetProperties(Value: TcxMemoProperties); +begin + FProperties.Assign(Value); +end; + +{ TcxBoldTimeEdit } + +procedure TcxBoldTimeEdit.DoChange; +begin + inherited; + DataBinding.DoChanged; +end; + +procedure TcxBoldTimeEdit.DoEnter; +begin + inherited; + DataBinding.DoEnter; +end; + +procedure TcxBoldTimeEdit.DoExit; +begin + inherited; + DataBinding.DoExit; +end; + +procedure TcxBoldTimeEdit.DoValidateDisplayValue( + var ADisplayValue: TcxEditValue; var AErrorText: TCaption; + var AError: Boolean); +begin + inherited; + if Assigned(DataBinding) then + DataBinding.ValidateDisplayValue(ADisplayValue, AErrorText, AError); +end; + +function TcxBoldTimeEdit.GetActiveProperties: TcxTimeEditProperties; +begin + Result := TcxTimeEditProperties(InternalGetActiveProperties); +end; + +function TcxBoldTimeEdit.GetDataBinding: TcxBoldTimeEditDataBinding; +begin + Result := TcxBoldTimeEditDataBinding(FDataBinding); +end; + +class function TcxBoldTimeEdit.GetDataBindingClass: TcxEditDataBindingClass; +begin + result := TcxBoldTimeEditDataBinding; +end; + +function TcxBoldTimeEdit.GetProperties: TcxTimeEditProperties; +begin + Result := TcxTimeEditProperties(FProperties); +end; + +class function TcxBoldTimeEdit.GetPropertiesClass: TcxCustomEditPropertiesClass; +begin + Result := TcxTimeEditProperties; +end; + +procedure TcxBoldTimeEdit.Paint; +begin + inherited Paint; + if DataBinding.ValueOrDefinitionInvalid then + Canvas.FrameRect(Bounds, clRed, 2 - Ord(IsNativeStyle)); +end; + +procedure TcxBoldTimeEdit.SetDataBinding( + Value: TcxBoldTimeEditDataBinding); +begin + FDataBinding.Assign(Value); +end; + +procedure TcxBoldTimeEdit.SetProperties(Value: TcxTimeEditProperties); +begin + FProperties.Assign(Value); +end; + +function TcxBoldTimeEdit.ValidateKeyDown(var Key: Word; + Shift: TShiftState): Boolean; +begin + result := DataBinding.IsDataAvailable and inherited ValidateKeyDown(Key, Shift); +end; + +function TcxBoldTimeEdit.ValidateKeyPress(var Key: Char): Boolean; +begin + result := DataBinding.MayModify and inherited ValidateKeyPress(Key); + if not result then + Key := #0 + else + begin + if (Key = #13) and (DataBinding.Follower.Controller.ApplyPolicy <> bapDemand) then + begin + DataBinding.Follower.Apply; + SelectAll; + end; + end; +end; + +{ TcxBoldCurrencyEdit } + +procedure TcxBoldCurrencyEdit.DoEnter; +begin + inherited; + DataBinding.DoEnter; +end; + +procedure TcxBoldCurrencyEdit.DoExit; +begin + inherited; + DataBinding.DoExit; +end; + +procedure TcxBoldCurrencyEdit.DoValidateDisplayValue( + var ADisplayValue: TcxEditValue; var AErrorText: TCaption; + var AError: Boolean); +begin + inherited; + if Assigned(DataBinding) then + DataBinding.ValidateDisplayValue(ADisplayValue, AErrorText, AError); +end; + +function TcxBoldCurrencyEdit.GetActiveProperties: TcxCurrencyEditProperties; +begin + Result := TcxCurrencyEditProperties(InternalGetActiveProperties); +end; + +function TcxBoldCurrencyEdit.GetDataBinding: TcxBoldCurrencyEditDataBinding; +begin + Result := TcxBoldCurrencyEditDataBinding(FDataBinding); +end; + +class function TcxBoldCurrencyEdit.GetDataBindingClass: TcxEditDataBindingClass; +begin + Result := TcxBoldCurrencyEditDataBinding; +end; + +function TcxBoldCurrencyEdit.GetProperties: TcxCurrencyEditProperties; +begin + Result := TcxCurrencyEditProperties(FProperties); +end; + +class function TcxBoldCurrencyEdit.GetPropertiesClass: TcxCustomEditPropertiesClass; +begin + Result := TcxCurrencyEditProperties; +end; + +procedure TcxBoldCurrencyEdit.Paint; +begin + inherited Paint; + if DataBinding.ValueOrDefinitionInvalid then + Canvas.FrameRect(Bounds, clRed, 2 - Ord(IsNativeStyle)); +end; + +procedure TcxBoldCurrencyEdit.SetDataBinding( + Value: TcxBoldCurrencyEditDataBinding); +begin + FDataBinding.Assign(Value); +end; + +procedure TcxBoldCurrencyEdit.SetProperties( + Value: TcxCurrencyEditProperties); +begin + FProperties.Assign(Value); +end; + +procedure TcxBoldCurrencyEdit.DoChange; +begin + inherited; + DataBinding.DoChanged; +end; + +{ TcxBoldTextEditDataBinding } +{ +procedure TcxBoldTextEditDataBinding.InternalSetValue( + const aValue: TcxEditValue); +begin + if VarIsNull(aValue) then + BoldProperties.MayHaveChanged('', Follower) + else + BoldProperties.MayHaveChanged(aValue, Follower); +end; +} +{ TcxBoldMaskEdit } + +procedure TcxBoldMaskEdit.DoEnter; +begin + inherited; + DataBinding.DoEnter; +end; + +procedure TcxBoldMaskEdit.DoExit; +begin + inherited; + DataBinding.DoExit; +end; + +procedure TcxBoldMaskEdit.DoValidateDisplayValue( + var ADisplayValue: TcxEditValue; var AErrorText: TCaption; + var AError: Boolean); +begin + inherited; + if Assigned(DataBinding) then + DataBinding.ValidateDisplayValue(ADisplayValue, AErrorText, AError); +end; + +function TcxBoldMaskEdit.GetActiveProperties: TcxMaskEditProperties; +begin + Result := TcxMaskEditProperties(InternalGetActiveProperties); +end; + +function TcxBoldMaskEdit.GetDataBinding: TcxBoldTextEditDataBinding; +begin + Result := TcxBoldTextEditDataBinding(FDataBinding); +end; + +class function TcxBoldMaskEdit.GetDataBindingClass: TcxEditDataBindingClass; +begin + Result := TcxBoldTextEditDataBinding; +end; + +function TcxBoldMaskEdit.GetProperties: TcxMaskEditProperties; +begin + Result := TcxMaskEditProperties(FProperties); +end; + +class function TcxBoldMaskEdit.GetPropertiesClass: TcxCustomEditPropertiesClass; +begin + Result := TcxMaskEditProperties; +end; + +procedure TcxBoldMaskEdit.Paint; +begin + inherited Paint; + if DataBinding.ValueOrDefinitionInvalid then + Canvas.FrameRect(Bounds, clRed, 2 - Ord(IsNativeStyle)); +end; + +procedure TcxBoldMaskEdit.SetDataBinding( + Value: TcxBoldTextEditDataBinding); +begin + FDataBinding.Assign(Value); +end; + +procedure TcxBoldMaskEdit.SetProperties(Value: TcxMaskEditProperties); +begin + FProperties.Assign(Value); +end; + +function TcxBoldMaskEdit.SupportsSpelling: Boolean; +begin + Result := IsTextInputMode; +end; + +{ TcxBoldCheckBoxEditDataBinding } + + +function TcxBoldCheckBoxEditDataBinding.MayModify: boolean; +begin + result := inherited MayModify; //and (fCurrentElementType is TBoldAttributeTypeInfo) and TBoldAttributeTypeInfo(fCurrentElementType).AttributeClass.InheritsFrom(TBABoolean); +end; + + +function TcxBoldCheckBoxEditDataBinding.ValidateTypeConforms( + aExpressionType: TBoldElementTypeInfo): string; +var + lBooleanTypeInfo: TBoldAttributeTypeInfo; +begin + result := ''; + with (aExpressionType.SystemTypeInfo as TBoldSystemTypeInfo) do + begin + lBooleanTypeInfo := AttributeTypeInfoByExpressionName['Boolean']; // do not localize + end; + if not aExpressionType.ConformsTo(lBooleanTypeInfo) then + result := Format(sPossiblyBadConformance, [aExpressionType.ModelName , lBooleanTypeInfo.ModelName]); +end; + +function TcxBoldCheckBoxEditDataBinding.ImmediatePost: boolean; +begin + result := true; +end; + +{ TcxBoldCheckBox } + +procedure TcxBoldCheckBox.DoChange; +begin + inherited; + DataBinding.DoChanged; +end; + +procedure TcxBoldCheckBox.DoEnter; +begin + inherited; + DataBinding.DoEnter; +end; + +procedure TcxBoldCheckBox.DoExit; +begin + inherited; + DataBinding.DoExit; +end; + +procedure TcxBoldCheckBox.DoValidateDisplayValue( + var ADisplayValue: TcxEditValue; var AErrorText: TCaption; + var AError: Boolean); +begin + inherited; + ADisplayValue := EditingValue; + if Assigned(DataBinding) then + DataBinding.ValidateDisplayValue(ADisplayValue, AErrorText, AError); +end; + +function TcxBoldCheckBox.GetActiveProperties: TcxCheckBoxProperties; +begin + Result := TcxCheckBoxProperties(InternalGetActiveProperties); +end; + +function TcxBoldCheckBox.GetDataBinding: TcxBoldCheckBoxEditDataBinding; +begin + Result := FDataBinding as TcxBoldCheckBoxEditDataBinding; +end; + +class function TcxBoldCheckBox.GetDataBindingClass: TcxEditDataBindingClass; +begin + result := TcxBoldCheckBoxEditDataBinding; +end; + +function TcxBoldCheckBox.GetProperties: TcxCheckBoxProperties; +begin + Result := TcxCheckBoxProperties(FProperties); +end; + +class function TcxBoldCheckBox.GetPropertiesClass: TcxCustomEditPropertiesClass; +begin + Result := TcxCheckBoxProperties; +end; + +procedure TcxBoldCheckBox.Initialize; +begin + inherited; + if IsDesigning and not IsLoading then + begin + _ValidateEdit(self); + end; +end; + +procedure TcxBoldCheckBox.Paint; +begin + inherited; + if DataBinding.ValueOrDefinitionInvalid then + Canvas.FrameRect(Bounds, clRed, 3); +end; + +procedure TcxBoldCheckBox.SetDataBinding( + Value: TcxBoldCheckBoxEditDataBinding); +begin + FDataBinding.Assign(Value); +end; + +procedure TcxBoldCheckBox.SetProperties(Value: TcxCheckBoxProperties); +begin + FProperties.Assign(Value); +end; + +procedure TcxBoldCheckBox.Toggle; +begin + // this is a bit hacky, would be better if we can set it somewhere once + FProperties.ImmediatePost := DataBinding.ImmediatePost; + if CanModify and (DataBinding.MayModify) and Assigned(DataBinding.Follower.Element) then + begin + inherited Toggle; + DataBinding.Follower.Apply; + end; +end; + +{ TcxBoldComboBoxProperties } + +procedure TcxBoldComboBoxProperties._DeleteItem(Index: Integer; + OwningFollower: TBoldFollower); +begin + if not Items.Updating then + Items.BeginUpdate; + Items.Delete(index); +end; + +procedure TcxBoldComboBoxProperties._InsertItem(Index: Integer; Follower: TBoldFollower); +begin + if not Items.Updating then + Items.BeginUpdate; + if Assigned(Follower) then + begin + Follower.EnsureDisplayable; + Items.Insert(Follower.Index, VarToStr(TBoldVariantFollowerController(Follower.Controller).GetAsVariant(Follower))); + end + else + begin + Items.Insert(Index, VarToStr(BoldRowProperties.NilRepresentation)); + end; +end; + +procedure TcxBoldComboBoxProperties._ReplaceItem(Index: Integer; + Follower: TBoldFollower); +begin + if not Items.Updating then + Items.BeginUpdate; + Follower.EnsureDisplayable; + Items.Strings[Index] := VarToStr(TBoldVariantFollowerController(Follower.Controller).GetAsVariant(Follower)); +end; + +procedure TcxBoldComboBoxProperties._RowAfterMakeUptoDate( + Follower: TBoldFollower); +var + index: Integer; + NewValue: String; +begin + index := Follower.index; + if (index > -1) and (index < Items.Count) then + begin + NewValue := VarToStr(TBoldVariantFollowerController(Follower.Controller).GetAsVariant(Follower)); + if NewValue <> Items[index] then + Items[index] := NewValue; + end; +// LookupDataChanged(self); + // forces a redisplay of the edit-area, the windows component might go blank if the active row is removed and then reinserted +// fBoldHandleFollower.Follower.MarkValueOutOfDate; // do we really need this here ? Danny +end; + +procedure TcxBoldComboBoxProperties._AfterMakeUptoDate( + Follower: TBoldFollower); +begin + fBoldRowProperties.AfterMakeUptoDate := _RowAfterMakeUptoDate; + if Items.Updating then + Items.EndUpdate; +end; + +procedure TcxBoldComboBoxProperties._BeforeMakeUptoDate( + Follower: TBoldFollower); +begin + fBoldRowProperties.AfterMakeUptoDate := nil; +end; + +constructor TcxBoldComboBoxProperties.Create(AOwner: TPersistent); +var + lMatchObject: TComponent; +// lBoldAwareViewItem: IBoldAwareViewItem; +begin + inherited; + if aOwner is TComponent then + lMatchObject := aOwner as TComponent + else + lMatchObject := nil; + fBoldRowProperties := TBoldVariantFollowerController.Create(lMatchObject); + fBoldRowProperties.AfterMakeUptoDate := _RowAfterMakeUptoDate; + fBoldRowProperties.OnGetContextType := GetContextForBoldRowProperties; + fBoldListProperties := TBoldComboListController.Create(lMatchObject, fBoldRowProperties); + with fBoldListProperties do + begin + OnAfterInsertItem := _InsertItem; + OnAfterDeleteItem := _DeleteItem; + OnReplaceitem := _ReplaceItem; + BeforeMakeUptoDate := _BeforeMakeUptoDate; + AfterMakeUptoDate := _AfterMakeUptoDate; + end; + fListHandleFollower := TBoldListHandleFollower.Create(Owner, fBoldListProperties); + ImmediatePost := false; + BoldSelectChangeAction := bdcsSetValue; +// if aOwner.GetInterface(IBoldAwareViewItem, lBoldAwareViewItem) then +// BoldSetValueExpression := lBoldAwareViewItem.DataBinding.BoldProperties.Expression; +end; + +destructor TcxBoldComboBoxProperties.Destroy; +begin + FreeAndNil(fListHandleFollower); + FreeAndNil(fBoldListProperties); + FreeAndNil(fBoldRowProperties); + inherited; +end; + +function TcxBoldComboBoxProperties.GetBoldListHandle: TBoldAbstractListHandle; +begin + Result := fListHandleFollower.BoldHandle; +end; + +function TcxBoldComboBoxProperties.GetContextForBoldRowProperties: TBoldElementTypeInfo; +begin + if assigned(BoldLookupListHandle) then + result := BoldLookupListHandle.StaticBoldType + else + result := nil; +end; + +function TcxBoldComboBoxProperties.GetListFollower: TBoldFollower; +begin + Result := fListHandleFollower.Follower; +end; + +function TcxBoldComboBoxProperties.IsDisplayValueValid( + var DisplayValue: TcxEditValue; AEditFocused: Boolean): Boolean; +begin +// result := cxEditVarEquals(DisplayValue, BoldRowProperties.NilRepresentation) or inherited IsDisplayValueValid(DisplayValue, AEditFocused) + if not VarIsNull(BoldRowProperties.NilRepresentation) and cxEditVarEquals(DisplayValue, BoldRowProperties.NilRepresentation) then + result := true + else + result := inherited IsDisplayValueValid(DisplayValue, AEditFocused); +end; + +function TcxBoldComboBoxProperties.IsEditValueValid(var EditValue: TcxEditValue; + AEditFocused: Boolean): Boolean; +begin +// result := inherited IsEditValueValid(EditValue, AEditFocused) or cxEditVarEquals(EditValue, BoldRowProperties.NilRepresentation); + result := inherited IsEditValueValid(EditValue, AEditFocused); + if not result then + result := cxEditVarEquals(EditValue, BoldRowProperties.NilRepresentation); +end; + +procedure TcxBoldComboBoxProperties.SetBoldListHandle( + const Value: TBoldAbstractListHandle); +begin + fListHandleFollower.BoldHandle := value; +end; + +procedure TcxBoldComboBoxProperties.SetBoldListProperties( + const Value: TBoldComboListController); +begin + fBoldListProperties.Assign(Value); +end; + +procedure TcxBoldComboBoxProperties.SetRowProperties( + const Value: TBoldVariantFollowerController); +begin + fBoldRowProperties.Assign(Value); +end; + +procedure TcxBoldComboBoxProperties.SetBoldSelectChangeAction( + Value: TBoldComboSelectChangeAction); +begin +// if (Value = bdcsSetReference) and assigned(BoldHandle) and not BoldHandle.CanSetValue then +// raise EBold.Create(sChangeActionCannotBeSetReference); + fBoldSelectChangeAction := Value; +end; + +procedure TcxBoldComboBoxProperties.SetStoredValue( + aValue: Variant; + aBoldHandle: TBoldElementHandle; + aEdit: TcxCustomEdit; + aFollower: TBoldFollower; + var aDone: boolean); +var + LocalSelectedElement: TBoldElement; + lItemIndex: Integer; +begin + Assert(aEdit is TcxCustomComboBox); + lItemIndex := (aEdit as TcxCustomComboBox).ItemIndex; + if lItemIndex = -1 then + begin + // if DropDownListStyle = lsEditList then we might want to let default handling make modifications + // on other cases we set aDone := true as we're sure that with a fixed list item that isn't in the list won't make changes. + if DropDownListStyle <> lsEditList then + aDone := true; + exit; + end + else + begin + if ((lItemIndex = LookupListFollower.SubFollowerCount-1) and (BoldLookupListProperties.NilElementMode = neAddLast)) + or ((lItemIndex = 0) and (BoldLookupListProperties.NilElementMode = neInsertFirst)) then + begin + LocalSelectedElement := nil + end + else + begin + if (BoldLookupListProperties.NilElementMode = neInsertFirst) then + dec(lItemIndex); + LocalSelectedElement := BoldLookupListHandle.List[lItemIndex]; + end; + end; + InternalComboSetValue(aBoldHandle, aFollower, LocalSelectedElement, BoldSelectChangeAction, BoldSetValueExpression, BoldLookupListHandle, aValue); + aDone := true; +end; + +class function TcxBoldComboBoxProperties.GetContainerClass: TcxContainerClass; +begin + result := inherited GetContainerClass; +// result := TcxBoldComboBox; +end; + +function TcxBoldComboBoxProperties.GetAlwaysPostEditValue: Boolean; +begin + result := false; +end; + +function TcxBoldComboBoxProperties.ValidateComponent( + ComponentValidator: TBoldComponentValidator; + NamePrefix: string): Boolean; +var + lContext: TBoldElementTypeInfo; + lName: string; + lcxBoldEditDataBinding: TcxBoldEditDataBinding; +begin + result := true; + if (Owner is TComponent) and (TComponent(Owner).Name <> '') then + lName := TComponent(Owner).Name + else + if Assigned(Owner) then + lName := Owner.ClassName + else + lName := ClassName; + +// OutPutDebugString(PChar(lName)); + + lContext := GetContextForBoldRowProperties; + if assigned(lContext) then + begin + result := ComponentValidator.ValidateExpressionInContext( + BoldRowProperties.Expression, + lContext, + format('%s %s.BoldRowProperties.Expression', [NamePrefix, lName]), BoldRowProperties.VariableList) and result; // do not localize + + if (BoldSelectChangeAction = bdcsSetValue) and (Owner is TcxCustomEdit) then + begin + lcxBoldEditDataBinding := TcxCustomEditAccess(TcxCustomEdit(Owner)).DataBinding as TcxBoldEditDataBinding; + lContext := lcxBoldEditDataBinding.GetContextType; + result := ComponentValidator.ValidateExpressionInContext( + BoldSetValueExpression, + lContext, + format('%s %s.BoldSetValueExpression', [NamePrefix, lName]), + lcxBoldEditDataBinding.BoldProperties.VariableList) and result; // do not localize + end; + end; +end; + +function TcxBoldComboBoxProperties.BoldElementToEditValue( + aFollower: TBoldFollower; aElement: TBoldElement; aEdit: TcxCustomEdit): variant; +begin + result := BoldRowProperties.GetAsVariant(aFollower); +end; + +procedure TcxBoldComboBoxProperties.Assign(Source: TPersistent); +begin + if Source is TcxBoldComboBoxProperties then + begin + BeginUpdate; + try + BoldLookupListHandle := TcxBoldComboBoxProperties(Source).BoldLookupListHandle; + BoldLookupListProperties := TcxBoldComboBoxProperties(Source).BoldLookupListProperties; + BoldRowProperties := TcxBoldComboBoxProperties(Source).BoldRowProperties; + BoldSetValueExpression := TcxBoldComboBoxProperties(Source).BoldSetValueExpression; + BoldSelectChangeAction := TcxBoldComboBoxProperties(Source).BoldSelectChangeAction; + inherited Assign(Source); + + +// (FIDefaultValuesProvider.GetInstance as TcxCustomBoldEditDefaultValuesProvider).BoldHandleFollower := (TcxBoldComboBoxProperties(Source).FIDefaultValuesProvider.GetInstance as TcxCustomBoldEditDefaultValuesProvider).BoldHandleFollower; +// (FIDefaultValuesProvider.GetInstance as TcxCustomBoldEditDefaultValuesProvider).BoldProperties := (TcxBoldComboBoxProperties(Source).FIDefaultValuesProvider.GetInstance as TcxCustomBoldEditDefaultValuesProvider).BoldProperties; + + TBoldQueueable.DisplayAll; + finally + EndUpdate; + end + end + else + inherited Assign(Source); +end; + +function TcxBoldComboBoxProperties.CanEdit(aBoldHandle: TBoldElementHandle; + aFollower: TBoldFollower): boolean; +begin + result := (LookupListFollower.SubFollowerCount > 0) or (DropDownListStyle = lsEditList); +end; + +procedure TcxBoldComboBoxProperties.SetBoldSetValueExpression( + const Value: TBoldExpression); +begin + fBoldSetValueExpression := Value; + if Owner is TcxCustomEdit and (TcxCustomEdit(Owner).IsDesigning) and not (TcxCustomEdit(Owner).IsLoading) then + begin + _ValidateEdit(TcxCustomEdit(Owner)); + end; +end; + +{ TcxBoldComboBox } + +function TcxBoldComboBox.CanDropDown: Boolean; +var + lElementToAssignTo: TBoldElement; +begin + result := inherited CanDropDown and DataBinding.IsDataAvailable; + if result then + begin + case ActiveProperties.BoldSelectChangeAction of + bdcsSetValue: + begin + if (Assigned(DataBinding.Follower.Element)) then + begin + if trim(ActiveProperties.BoldSetValueExpression) <> '' then + begin + lElementToAssignTo := DataBinding.Follower.Element.EvaluateExpressionAsDirectElement(ActiveProperties.BoldSetValueExpression, TBoldFollowerControllerAccess(DataBinding.Follower.Controller).VariableList); + result := assigned(lElementToAssignTo) and lElementToAssignTo.Mutable; + end; + end + else + result := false; + end; + end; + end; +end; + +procedure TcxBoldComboBox.DoEnter; +begin + inherited; + DataBinding.DoEnter; +end; + +procedure TcxBoldComboBox.DoExit; +begin + inherited; + DataBinding.DoExit; +end; + +procedure TcxBoldComboBox.DoValidateDisplayValue( + var ADisplayValue: TcxEditValue; var AErrorText: TCaption; + var AError: Boolean); +begin + inherited; + if Assigned(DataBinding) then + DataBinding.ValidateDisplayValue(ADisplayValue, AErrorText, AError); +end; + +function TcxBoldComboBox.GetActiveProperties: TcxBoldComboBoxProperties; +begin + Result := TcxBoldComboBoxProperties(InternalGetActiveProperties); +end; + +function TcxBoldComboBox.GetDataBinding: TcxBoldComboBoxEditDataBinding; +begin + Result := TcxBoldComboBoxEditDataBinding(FDataBinding); +end; + +class function TcxBoldComboBox.GetDataBindingClass: TcxEditDataBindingClass; +begin + result := TcxBoldComboBoxEditDataBinding; //TcxBoldTextEditDataBinding; +end; + +function TcxBoldComboBox.GetProperties: TcxBoldComboBoxProperties; +begin + Result := TcxBoldComboBoxProperties(FProperties); +end; + +class function TcxBoldComboBox.GetPropertiesClass: TcxCustomEditPropertiesClass; +begin + result := TcxBoldComboBoxProperties; +end; + +procedure TcxBoldComboBox.Paint; +begin + inherited Paint; + if DataBinding.ValueOrDefinitionInvalid then + Canvas.FrameRect(Bounds, clRed, 2 - Ord(IsNativeStyle)); +end; + +procedure TcxBoldComboBox.SetDataBinding( + Value: TcxBoldComboBoxEditDataBinding); +begin + FDataBinding.Assign(Value); +end; + +procedure TcxBoldComboBox.SetProperties(Value: TcxBoldComboBoxProperties); +begin + FProperties.Assign(Value); +end; + +function TcxBoldComboBox.SupportsSpelling: Boolean; +begin + Result := IsTextInputMode; +end; +{ +function TcxBoldComboBox.ValidateComponent( + ComponentValidator: TBoldComponentValidator; + NamePrefix: string): Boolean; +begin + result := DataBinding.ValidateComponent(ComponentValidator, NamePrefix); + result := GetActiveProperties.ValidateComponent(ComponentValidator, NamePrefix) and result; +end; +} +{ TcxBoldSpinEdit } + +procedure TcxBoldSpinEdit.DoEnter; +begin + inherited; + DataBinding.DoEnter; +end; + +procedure TcxBoldSpinEdit.DoExit; +begin + inherited; + DataBinding.DoExit; +end; + +procedure TcxBoldSpinEdit.DoValidateDisplayValue( + var ADisplayValue: TcxEditValue; var AErrorText: TCaption; + var AError: Boolean); +begin + inherited; + if Assigned(DataBinding) then + DataBinding.ValidateDisplayValue(ADisplayValue, AErrorText, AError); +end; + +function TcxBoldSpinEdit.GetActiveProperties: TcxSpinEditProperties; +begin + Result := TcxSpinEditProperties(InternalGetActiveProperties); +end; + +function TcxBoldSpinEdit.GetDataBinding: TcxBoldNumericEditDataBinding; +begin + Result := TcxBoldNumericEditDataBinding(FDataBinding); +end; + +class function TcxBoldSpinEdit.GetDataBindingClass: TcxEditDataBindingClass; +begin + Result := TcxBoldNumericEditDataBinding; +end; + +function TcxBoldSpinEdit.GetProperties: TcxSpinEditProperties; +begin + Result := TcxSpinEditProperties(FProperties); +end; + +class function TcxBoldSpinEdit.GetPropertiesClass: TcxCustomEditPropertiesClass; +begin + Result := TcxSpinEditProperties; +end; + +procedure TcxBoldSpinEdit.Paint; +begin + inherited Paint; + if DataBinding.ValueOrDefinitionInvalid then + Canvas.FrameRect(Bounds, clRed, 2 - Ord(IsNativeStyle)); +end; + +procedure TcxBoldSpinEdit.SetDataBinding( + Value: TcxBoldNumericEditDataBinding); +begin + FDataBinding.Assign(Value); +end; + +procedure TcxBoldSpinEdit.SetProperties(Value: TcxSpinEditProperties); +begin + FProperties.Assign(Value); +end; + +{ TcxBoldButtonEdit } + +procedure TcxBoldButtonEdit.DoEnter; +begin + inherited; + DataBinding.DoEnter; +end; + +procedure TcxBoldButtonEdit.DoExit; +begin + inherited; + DataBinding.DoExit; +end; + +procedure TcxBoldButtonEdit.DoValidateDisplayValue( + var ADisplayValue: TcxEditValue; var AErrorText: TCaption; + var AError: Boolean); +begin + inherited; + if Assigned(DataBinding) then + DataBinding.ValidateDisplayValue(ADisplayValue, AErrorText, AError); +end; + +function TcxBoldButtonEdit.GetActiveProperties: TcxButtonEditProperties; +begin + Result := TcxButtonEditProperties(InternalGetActiveProperties); +end; + +function TcxBoldButtonEdit.GetDataBinding: TcxBoldTextEditDataBinding; +begin + Result := TcxBoldTextEditDataBinding(FDataBinding); +end; + +class function TcxBoldButtonEdit.GetDataBindingClass: TcxEditDataBindingClass; +begin + Result := TcxBoldTextEditDataBinding; +end; + +function TcxBoldButtonEdit.GetProperties: TcxButtonEditProperties; +begin + Result := TcxButtonEditProperties(FProperties); +end; + +class function TcxBoldButtonEdit.GetPropertiesClass: TcxCustomEditPropertiesClass; +begin + Result := TcxButtonEditProperties; +end; + +procedure TcxBoldButtonEdit.Paint; +begin + inherited Paint; + if DataBinding.ValueOrDefinitionInvalid then + Canvas.FrameRect(Bounds, clRed, 2 - Ord(IsNativeStyle)); +end; + +procedure TcxBoldButtonEdit.SetDataBinding( + Value: TcxBoldTextEditDataBinding); +begin + FDataBinding.Assign(Value); +end; + +procedure TcxBoldButtonEdit.SetProperties(Value: TcxButtonEditProperties); +begin + FProperties.Assign(Value); +end; + +{ TcxBoldHyperLinkEdit } + +procedure TcxBoldHyperLinkEdit.DoEnter; +begin + inherited; + DataBinding.DoEnter; +end; + +procedure TcxBoldHyperLinkEdit.DoExit; +begin + inherited; + DataBinding.DoExit; +end; + +procedure TcxBoldHyperLinkEdit.DoValidateDisplayValue( + var ADisplayValue: TcxEditValue; var AErrorText: TCaption; + var AError: Boolean); +begin + inherited; + if Assigned(DataBinding) then + DataBinding.ValidateDisplayValue(ADisplayValue, AErrorText, AError); +end; + +function TcxBoldHyperLinkEdit.GetActiveProperties: TcxHyperLinkEditProperties; +begin + Result := TcxHyperLinkEditProperties(InternalGetActiveProperties); +end; + +function TcxBoldHyperLinkEdit.GetDataBinding: TcxBoldTextEditDataBinding; +begin + Result := TcxBoldTextEditDataBinding(FDataBinding); +end; + +class function TcxBoldHyperLinkEdit.GetDataBindingClass: TcxEditDataBindingClass; +begin + Result := TcxBoldTextEditDataBinding; +end; + +function TcxBoldHyperLinkEdit.GetProperties: TcxHyperLinkEditProperties; +begin + Result := TcxHyperLinkEditProperties(FProperties); +end; + +class function TcxBoldHyperLinkEdit.GetPropertiesClass: TcxCustomEditPropertiesClass; +begin + Result := TcxHyperLinkEditProperties; +end; + +procedure TcxBoldHyperLinkEdit.Paint; +begin + inherited Paint; + if DataBinding.ValueOrDefinitionInvalid then + Canvas.FrameRect(Bounds, clRed, 2 - Ord(IsNativeStyle)); +end; + +procedure TcxBoldHyperLinkEdit.SetDataBinding( + Value: TcxBoldTextEditDataBinding); +begin + FDataBinding.Assign(Value); +end; + +procedure TcxBoldHyperLinkEdit.SetProperties( + Value: TcxHyperLinkEditProperties); +begin + FProperties.Assign(Value); +end; + +{ TcxBoldProgressBar } + +function TcxBoldProgressBar.GetActiveProperties: TcxProgressBarProperties; +begin + Result := TcxProgressBarProperties(InternalGetActiveProperties); +end; + +function TcxBoldProgressBar.GetDataBinding: TcxBoldNumericEditDataBinding; +begin + Result := TcxBoldNumericEditDataBinding(FDataBinding); +end; + +class function TcxBoldProgressBar.GetDataBindingClass: TcxEditDataBindingClass; +begin + Result := TcxBoldNumericEditDataBinding; +end; + +function TcxBoldProgressBar.GetProperties: TcxProgressBarProperties; +begin + Result := TcxProgressBarProperties(FProperties); +end; + +class function TcxBoldProgressBar.GetPropertiesClass: TcxCustomEditPropertiesClass; +begin + Result := TcxProgressBarProperties; +end; + +procedure TcxBoldProgressBar.Initialize; +begin + inherited; + if IsDesigning and not IsLoading then + begin + _ValidateEdit(self); + end; +end; + +procedure TcxBoldProgressBar.Paint; +begin + inherited Paint; + if DataBinding.ValueOrDefinitionInvalid then + Canvas.FrameRect(Bounds, clRed, 2 - Ord(IsNativeStyle)); +end; + +procedure TcxBoldProgressBar.SetDataBinding( + Value: TcxBoldNumericEditDataBinding); +begin + FDataBinding.Assign(Value); +end; + +procedure TcxBoldProgressBar.SetProperties( + Value: TcxProgressBarProperties); +begin + FProperties.Assign(Value); +end; + +{ TcxBarBoldEditItem } + +procedure TcxBarBoldEditItem._AfterMakeUptoDate(Follower: TBoldFollower); +var + lValue: variant;//string; + lElement: TBoldElement; + lIcxBoldEditProperties: IcxBoldEditProperties; +begin +// lValue := BoldProperties.GetAsVariant(Follower); + if fInternalChange = 0 then + begin + lElement := Follower.Value; + if Supports(Properties, IcxBoldEditProperties, lIcxBoldEditProperties) then + begin +// if Assigned(lElement) then + lValue := lIcxBoldEditProperties.BoldElementToEditValue(Follower, lElement, nil); + end + else + begin + lValue := TBoldVariantFollowerController(Follower.Controller).GetAsVariant(Follower); + if VarIsEmpty(lValue) then + lValue := Null; + end; + + inc(fInternalChange); + try + if not cxEditVarEquals(EditValue, lValue) then + EditValue := lValue; + finally + dec(fInternalChange); + end; + end; +end; + +{ +function TcxBarBoldEditItem.CanEdit: Boolean; +begin + result := inherited CanEdit; +end; +} +{ +procedure TcxBarBoldEditItem.DoEditValueChanged(Sender: TObject); +begin + inherited; + +end; +} +constructor TcxBarBoldEditItem.Create(AOwner: TComponent); +begin + inherited; + fBoldProperties := TBoldVariantFollowerController.Create(Self); + fBoldProperties.AfterMakeUptoDate := _AfterMakeUptoDate; + fBoldProperties.OnGetContextType := GetContextType; + fBoldHandleFollower := TBoldElementHandleFollower.Create(Owner, fBoldProperties); +// self.OnChange := EditValueChanged; +// self.OnEnter := EditEnter; + self.OnExit := EditExit; +end; + +destructor TcxBarBoldEditItem.Destroy; +begin + case BoldProperties.ApplyPolicy of + bapChange, bapExit: try + Follower.Apply; + except + Follower.DiscardChange; + end; + bapDemand: Follower.DiscardChange; + end; + FreeAndNil(fBoldHandleFollower); + FreeAndNil(fBoldProperties); + inherited; +end; + +function TcxBarBoldEditItem.GetBoldHandle: TBoldElementHandle; +begin + Result := fBoldHandleFollower.BoldHandle; +end; + +function TcxBarBoldEditItem.GetContextType: TBoldElementTypeInfo; +begin + if assigned(BoldHandle) then + result := BoldHandle.StaticBoldType + else + result := nil; +end; + +function TcxBarBoldEditItem.GetFollower: TBoldFollower; +begin + Result := fBoldHandleFollower.Follower; +end; + +procedure TcxBarBoldEditItem.SetBoldHandle( + const Value: TBoldElementHandle); +begin + fBoldHandleFollower.BoldHandle := value; +end; + +procedure TcxBarBoldEditItem.SetBoldProperties( + const Value: TBoldVariantFollowerController); +begin + fBoldProperties.Assign(Value); +end; + +procedure TcxBarBoldEditItem.EditValueChanged(Sender: TObject); +var + lIcxBoldEditProperties: IcxBoldEditProperties; + lDone: Boolean; + lEdit: TcxCustomEdit; +begin + if fInternalChange = 0 then + begin + lDone := false; + lEdit := Sender as TcxCustomEdit; + if Supports(Properties, IcxBoldEditProperties, lIcxBoldEditProperties) then + begin + lIcxBoldEditProperties.SetStoredValue(Null, BoldHandle, lEdit, Follower, lDone); + end; + if not lDone then + begin + if VarIsNull(EditValue) then + BoldProperties.MayHaveChanged('', Follower) + else + BoldProperties.MayHaveChanged(EditValue, Follower); + end; + TBoldQueueable.DisplayAll; + end; +end; + +procedure TcxBarBoldEditItem.EditExit(Sender: TObject); +begin + if (Follower.Controller.ApplyPolicy <> bapDemand) then + Follower.Apply; +end; + +class function TcxCustomBoldTextEditProperties.GetContainerClass: TcxContainerClass; +begin + result := inherited GetContainerClass; +// result := TcxBoldTextEdit; +end; + +procedure TcxBarBoldEditItem.DoEnter; +begin + inherited; + +end; + +procedure TcxBarBoldEditItem.DoExit; +begin + inherited; +end; + +function TcxBarBoldEditItem.GetControlClass( + AIsVertical: Boolean): TdxBarItemControlClass; +begin + if AIsVertical then + Result := inherited GetControlClass(AIsVertical) + else + Result := TcxBarBoldEditItemControl; +end; + +procedure TcxBarBoldEditItem.KeyPress(var Key: Char); +begin + inherited; + if (not Follower.Controller.MayModify(Follower)) or (not BoldProperties.ValidateCharacter(Key, Follower)) then + Key := #0; +end; + +{ TcxBarBoldEditItemControl } +{ +procedure TcxBarBoldEditItemControl.DoPostEditValue(Sender: TObject); +begin + inherited; + +end; + +procedure TcxBarBoldEditItemControl.DoValidate(Sender: TObject; + var DisplayValue: TcxEditValue; var ErrorText: TCaption; + var Error: Boolean); +begin + inherited; +// Error := Error or not (Item as TcxBarBoldEditItem).BoldProperties.ValidateString(DisplayValue, (Item as TcxBarBoldEditItem).Follower); +// if Error then +// Errortext := '+' + Errortext; +// (Item as TcxBarBoldEditItem).EditValueChanged(sender as TcxCustomEdit); +end; +} +//type +// TcxCustomDropDownEditPropertiesAccess = Class(TcxCustomDropDownEditProperties); + +procedure TcxBarBoldEditItemControl.RestoreDisplayValue; +begin + inherited; +// if Properties is TcxCustomDropDownEditProperties then +// TcxCustomDropDownEditPropertiesAccess(Properties).AlwaysPostEditValue := true; + Properties.ImmediatePost := true; +end; + +procedure TcxBarBoldEditItemControl.StoreDisplayValue; +begin + inherited; + (Item as TcxBarBoldEditItem).EditValueChanged(Edit); +// if Edit is TcxCustomComboBox then +end; + +function TcxCustomBoldTextEditProperties.ValidateComponent( + ComponentValidator: TBoldComponentValidator; + NamePrefix: string): Boolean; +var + lContext: TBoldElementTypeInfo; + lName: string; +begin + result := true; + if (Owner is TComponent) and (TComponent(Owner).Name <> '') then + lName := TComponent(Owner).Name + else + lName := ClassName; + if Assigned(BoldLookupListHandle) then + begin + lContext := GetContextForBoldRowProperties; + if not Assigned(lContext) then + BoldLog.LogFmt(sNoContext, [lName]) + else + begin + result := ComponentValidator.ValidateExpressionInContext( + BoldRowProperties.Expression, + lContext, + format('%s %s.BoldRowProperties.Expression', [NamePrefix, lName]), + BoldRowProperties.VariableList ) and result; // do not localize + end; + end; +end; + +{ TcxBoldDateNavigator } + +{$IFDEF DevExScheduler} + +procedure TcxBoldDateNavigator._AfterMakeUptoDate(Follower: TBoldFollower); +var + lValue: variant;//string; + lElement: TBoldElement; + i,j: integer; + lBoldComponentValidator: TBoldComponentValidator; +begin + if IsDesigning then + begin + lBoldComponentValidator := TBoldComponentValidator.Create; + try + ValidateComponent(lBoldComponentValidator, Name); + finally + lBoldComponentValidator.free; + end; + exit; + end; + lElement := Follower.Value; + if Assigned(lElement) then + lValue := lElement.AsVariant + else + lValue := Null; + InnerDateNavigator.EventOperations.ReadOnly := not Assigned(lElement); + inc(fInternalChange); + try + if Follower = StartFollower then + begin + if VarIsNull(lValue) or (lValue = 0) then + begin + if (self.Date <> NullDate) then + begin + SelectedDays.Clear; + DateNavigator.Refresh; + end + end + else + begin + if lValue <> self.Date then + self.Date := lValue; + end; + end + else + begin + if not VarIsNull(lValue) and (lValue <> 0) and (lValue <> RealLastDate) and (self.date <> NullDate) then + begin + j := Trunc(self.date); + SelectedDays.Clear; + for i := j to lValue do + SelectedDays.Add(i); + DateNavigator.Refresh; + end; + end; + finally + dec(fInternalChange); + end; +end; + +constructor TcxBoldDateNavigator.Create(AOwner: TComponent); +begin + inherited; +// fBoldProperties := TBoldVariantFollowerController.Create(Self); +// fBoldProperties.AfterMakeUptoDate := _AfterMakeUptoDate; +// fBoldProperties.OnGetContextType := GetContextType; + + fBoldStartProperties := TBoldVariantFollowerController.Create(Self); + fBoldStartProperties.AfterMakeUptoDate := _AfterMakeUptoDate; + fBoldStartProperties.OnGetContextType := GetStartContextType; + + fBoldEndProperties := TBoldVariantFollowerController.Create(Self); + fBoldEndProperties.AfterMakeUptoDate := _AfterMakeUptoDate; + fBoldEndProperties.OnGetContextType := GetEndContextType; + + fBoldStartHandleFollower := TBoldElementHandleFollower.Create(AOwner, fBoldStartProperties); + fBoldEndHandleFollower := TBoldElementHandleFollower.Create(AOwner, fBoldEndProperties); + + if IsDesigning and not isLoading then + ValidateSelf; +end; + +procedure TcxBoldDateNavigator.DateNavigatorSelectionChanged; +begin + inherited; + if (fInternalChange = 0) {and Assigned(Follower) and Follower.Controller.MayModify(Follower)} then + begin + if Assigned(StartFollower) and StartFollower.Controller.MayModify(StartFollower) then + BoldStartProperties.MayHaveChanged(self.date, StartFollower); + if Assigned(EndFollower) and EndFollower.Controller.MayModify(EndFollower) then + BoldEndProperties.MayHaveChanged(self.RealLastDate, EndFollower); + end; +end; +{ +procedure TcxBoldDateNavigator.DoSelectionChangedEvent; +begin + inherited; + BoldProperties.MayHaveChanged(DateToStr(self.date), Follower); +end; +} +destructor TcxBoldDateNavigator.Destroy; +begin + case BoldStartProperties.ApplyPolicy of + bapChange, bapExit: try + StartFollower.Apply; + except + StartFollower.DiscardChange; + end; + bapDemand: StartFollower.DiscardChange; + end; + case BoldEndProperties.ApplyPolicy of + bapChange, bapExit: try + EndFollower.Apply; + except + EndFollower.DiscardChange; + end; + bapDemand: EndFollower.DiscardChange; + end; + FreeAndNil(fBoldStartHandleFollower); + FreeAndNil(fBoldEndHandleFollower); + FreeAndNil(fBoldStartProperties); + FreeAndNil(fBoldEndProperties); + inherited; +end; + + +function TcxBoldDateNavigator.GetBoldEndHandle: TBoldElementHandle; +begin + Result := fBoldEndHandleFollower.BoldHandle; +end; + +function TcxBoldDateNavigator.GetEndContextType: TBoldElementTypeInfo; +begin + if assigned(BoldEndHandle) then + result := BoldEndHandle.StaticBoldType + else + result := nil; +end; + +function TcxBoldDateNavigator.GetEndFollower: TBoldFollower; +begin + result := fBoldEndHandleFollower.Follower; +end; + +function TcxBoldDateNavigator.GetBoldStartHandle: TBoldElementHandle; +begin + Result := fBoldStartHandleFollower.BoldHandle; +end; + +function TcxBoldDateNavigator.GetStartContextType: TBoldElementTypeInfo; +begin + if assigned(BoldStartHandle) then + result := BoldStartHandle.StaticBoldType + else + result := nil; +end; + +function TcxBoldDateNavigator.GetStartFollower: TBoldFollower; +begin + result := fBoldStartHandleFollower.Follower; +end; + +{procedure TcxBoldDateNavigator.SetBoldProperties( + const Value: TBoldVariantFollowerController); +begin + fBoldProperties.Assign(Value); +end;} + +procedure TcxBoldDateNavigator.SetBoldEndHandle( + const Value: TBoldElementHandle); +begin + fBoldEndHandleFollower.BoldHandle := value; +end; + +procedure TcxBoldDateNavigator.SetBoldEndProperties( + const Value: TBoldVariantFollowerController); +begin + fBoldEndProperties.Assign(Value); +end; + +procedure TcxBoldDateNavigator.SetBoldStartHandle( + const Value: TBoldElementHandle); +begin + fBoldStartHandleFollower.BoldHandle := value; +end; + +procedure TcxBoldDateNavigator.SetBoldStartProperties( + const Value: TBoldVariantFollowerController); +begin + fBoldStartProperties.Assign(Value); +end; + +type TcxInnerDateNavigatorAccess = class(TcxInnerDateNavigator); + +function TcxBoldDateNavigator.ValidateComponent( + ComponentValidator: TBoldComponentValidator; + NamePrefix: string): Boolean; +var + lContext: TBoldElementTypeInfo; + lExpressionType: TBoldElementTypeInfo; + lDateTimeTypeInfo: TBoldAttributeTypeInfo; + lDateTypeInfo: TBoldAttributeTypeInfo; +// s: string; +begin +// OutPutDebugString(PChar('TcxBoldDateNavigator.ValidateComponent start')); + lContext := GetStartContextType; + result := Assigned(lContext); + if not result then + begin + BoldLog.LogFmt(sNoContext, [Name]) + end + else + begin + with (lContext.SystemTypeInfo as TBoldSystemTypeInfo) do + begin + lDateTimeTypeInfo := AttributeTypeInfoByExpressionName['DateTime']; // do not localize + lDateTypeInfo := AttributeTypeInfoByExpressionName['Date']; // do not localize + end; + result := ComponentValidator.ValidateExpressionInContext( + TBoldFollowerControllerAccess(BoldStartProperties).Expression, + lContext, + format('%s %s.Expression', [NamePrefix, Name]), + BoldStartProperties.VariableList); // do not localize + + if result then + begin + lExpressionType := lContext.Evaluator.ExpressionType(TBoldFollowerControllerAccess(BoldStartProperties).Expression, lContext, false, TBoldFollowerControllerAccess(BoldStartProperties).VariableList); + if not (lExpressionType.ConformsTo(lDateTimeTypeInfo) or lExpressionType.ConformsTo(lDateTypeInfo)) then + begin + result := false; + BoldLog.LogFmt(sPossiblyBadConformance, [lExpressionType.ModelName , lDateTimeTypeInfo.ModelName + ' nor ' + lDateTypeInfo.ModelName]); + end; + end; + + lContext := GetEndContextType; + if Assigned(lContext) then + begin + result := ComponentValidator.ValidateExpressionInContext( + TBoldFollowerControllerAccess(BoldEndProperties).Expression, + lContext, + format('%s %s.Expression', [NamePrefix, Name]), + BoldEndProperties.VariableList) and result; // do not localize + + if result then + begin + lExpressionType := lContext.Evaluator.ExpressionType(TBoldFollowerControllerAccess(BoldEndProperties).Expression, lContext, false, TBoldFollowerControllerAccess(BoldEndProperties).VariableList); + if not (lExpressionType.ConformsTo(lDateTimeTypeInfo) or lExpressionType.ConformsTo(lDateTypeInfo)) then + begin + result := false; + BoldLog.LogFmt(sPossiblyBadConformance, [lExpressionType.ModelName , lDateTimeTypeInfo.ModelName + ' nor ' + lDateTypeInfo.ModelName]); + end; + end; + end; + end; +// fValueOrDefinitionInvalid := not result; +// s := 'TcxBoldDateNavigator.ValidateComponent:' + BoolToStr(result, true); +// OutPutDebugString(PChar(S)); +end; + +procedure TcxBoldDateNavigator.Loaded; +begin + inherited; + if IsDesigning then + ValidateSelf; +end; + +procedure TcxBoldDateNavigator.ValidateSelf; +var + lBoldComponentValidator: TBoldComponentValidator; +begin + if IsDesigning then + begin + lBoldComponentValidator := TBoldComponentValidator.Create; + try + ValidateComponent(lBoldComponentValidator, Name); + finally + lBoldComponentValidator.free; + end; + end; +end; + +{$ENDIF} + +{ TcxBoldLabel } + +function TcxBoldLabel.GetActiveProperties: TcxLabelProperties; +begin + Result := TcxLabelProperties(InternalGetActiveProperties); +end; + +function TcxBoldLabel.GetDataBinding: TcxBoldTextEditDataBinding; +begin + Result := FDataBinding as TcxBoldTextEditDataBinding; +end; + +class function TcxBoldLabel.GetDataBindingClass: TcxEditDataBindingClass; +begin + Result := TcxBoldTextEditDataBinding; +end; + +function TcxBoldLabel.GetProperties: TcxLabelProperties; +begin + Result := TcxLabelProperties(FProperties); +end; + +class function TcxBoldLabel.GetPropertiesClass: TcxCustomEditPropertiesClass; +begin + Result := TcxLabelProperties; +end; + +procedure TcxBoldLabel.Initialize; +begin + inherited Initialize; +// AutoSize := False; + if IsDesigning and not IsLoading then + begin + _ValidateEdit(self); + end; +end; + +procedure TcxBoldLabel.Paint; +begin + inherited; + if DataBinding.ValueOrDefinitionInvalid then +// ViewInfo.TextColor := clRed; + Canvas.FrameRect(Bounds, clRed, 3); +end; + +procedure TcxBoldLabel.SetDataBinding(Value: TcxBoldTextEditDataBinding); +begin + FDataBinding.Assign(Value); +end; + +procedure TcxBoldLabel.SetEditAutoSize(Value: Boolean); +begin + inherited; + +end; + +procedure TcxBoldLabel.SetProperties(Value: TcxLabelProperties); +begin + FProperties.Assign(Value); +end; + +{ TcxBoldImage } + +function TcxBoldImage.GetActiveProperties: TcxImageProperties; +begin + Result := TcxImageProperties(InternalGetActiveProperties); +end; + +function TcxBoldImage.GetDataBinding: TcxBoldBlobEditDataBinding; +begin + Result := FDataBinding as TcxBoldBlobEditDataBinding; +end; + +class function TcxBoldImage.GetDataBindingClass: TcxEditDataBindingClass; +begin + result := TcxBoldBlobEditDataBinding; +end; + +function TcxBoldImage.GetProperties: TcxImageProperties; +begin + Result := TcxImageProperties(FProperties); +end; + +class function TcxBoldImage.GetPropertiesClass: TcxCustomEditPropertiesClass; +begin + Result := TcxImageProperties; +end; + +procedure TcxBoldImage.Initialize; +begin + inherited; + if IsDesigning and not IsLoading then + begin + _ValidateEdit(self); + end; +end; + +procedure TcxBoldImage.Paint; +begin + inherited Paint; + if DataBinding.ValueOrDefinitionInvalid then + Canvas.FrameRect(Bounds, clRed, 2 - Ord(IsNativeStyle)); +end; + +procedure TcxBoldImage.SetDataBinding(Value: TcxBoldBlobEditDataBinding); +begin + FDataBinding.Assign(Value); +end; + +procedure TcxBoldImage.SetProperties(Value: TcxImageProperties); +begin + FProperties.Assign(Value); +end; + +{ TcxBoldRichEdit } + +procedure TcxBoldRichEdit.DoValidateDisplayValue( + var ADisplayValue: TcxEditValue; var AErrorText: TCaption; + var AError: Boolean); +begin + inherited; + if Assigned(DataBinding) then + DataBinding.ValidateDisplayValue(ADisplayValue, AErrorText, AError); +end; + +procedure TcxBoldRichEdit.EditingChanged; +begin + inherited; + +end; + +function TcxBoldRichEdit.GetActiveProperties: TcxRichEditProperties; +begin + Result := TcxRichEditProperties(InternalGetActiveProperties); +end; + +function TcxBoldRichEdit.GetDataBinding: TcxBoldTextEditDataBinding; +begin + Result := FDataBinding as TcxBoldTextEditDataBinding; +end; + +class function TcxBoldRichEdit.GetDataBindingClass: TcxEditDataBindingClass; +begin + Result := TcxBoldTextEditDataBinding; +end; + +function TcxBoldRichEdit.GetProperties: TcxRichEditProperties; +begin + Result := TcxRichEditProperties(FProperties); +end; + +class function TcxBoldRichEdit.GetPropertiesClass: TcxCustomEditPropertiesClass; +begin + Result := TcxRichEditProperties; +end; + +procedure TcxBoldRichEdit.Paint; +begin + inherited Paint; + if DataBinding.ValueOrDefinitionInvalid then + Canvas.FrameRect(Bounds, clRed, 2 - Ord(IsNativeStyle)); +end; + +function TcxBoldRichEdit.RealReadOnly: Boolean; +begin + Result := inherited RealReadOnly or not DataBinding.Editing; +end; + +procedure TcxBoldRichEdit.SetDataBinding( + Value: TcxBoldTextEditDataBinding); +begin + FDataBinding.Assign(Value); +end; + +procedure TcxBoldRichEdit.SetProperties(Value: TcxRichEditProperties); +begin + FProperties.Assign(Value); +end; + +{ TcxBoldComboBoxEditDataBinding } + +constructor TcxBoldComboBoxEditDataBinding.Create(AEdit: TcxCustomEdit); +begin + inherited; + Assert(TcxCustomEditAccess(AEdit).Properties is TcxBoldComboBoxProperties); + fBoldHandleFollower.PrioritizedQueuable := TcxBoldComboBoxProperties(TcxCustomEditAccess(AEdit).Properties).fListHandleFollower; + fBoldHandleFollower.StronglyDependedOfPrioritized := true; +end; + +function TcxBoldComboBoxEditDataBinding.GetModified: Boolean; +var +// lcxCustomTextEditAccess: TcxCustomTextEditAccess; + lItemIndex: integer; + lCount: integer; + lOriginalElement, lNewElement: TBoldElement; + lcxBoldComboBox: TcxBoldComboBox; +begin + if not IsDataAvailable or FEdit.ActiveProperties.ReadOnly or (TcxCustomTextEditAccess(Edit).ILookupData.ActiveControl = nil) then + begin + result := false; + exit; + end; + result := not cxEditVarEquals(Edit.EditValue, StoredValue); //not ((VarType(Edit.EditValue) = VarType(StoredValue)) and VarSameValue(StoredValue, Edit.EditValue)); + if result and ((VarIsNull(Edit.EditValue) and VarIsStr(StoredValue) and (StoredValue = '')) + or (VarIsNull(StoredValue) and VarIsStr(Edit.EditValue) and (Edit.EditValue = ''))) then + result := false; +// if not result then + begin + lcxBoldComboBox := Edit as TcxBoldComboBox; + lOriginalElement := lcxBoldComboBox.DataBinding.Follower.Value; + if lOriginalElement is TBoldObjectReference then + lOriginalElement := TBoldObjectReference(lOriginalElement).BoldObject; +// lItemIndex := TcxCustomTextEditAccess(Edit).ItemIndex; + lCount := lcxBoldComboBox.ActiveProperties.LookupListFollower.SubFollowerCount-1; + lItemIndex := TcxCustomEditListBox(TcxCustomTextEditAccess(Edit).ILookupData.ActiveControl).itemIndex; + + if ((lItemIndex = lCount) and (lcxBoldComboBox.ActiveProperties.BoldLookupListProperties.NilElementMode = neAddLast)) + or ((lItemIndex = 0) and (lcxBoldComboBox.ActiveProperties.BoldLookupListProperties.NilElementMode = neInsertFirst)) + then + begin + Result := lOriginalElement <> nil; + exit; + end; + if lItemIndex <> -1 then + begin + // lcxBoldComboBox.ActiveProperties.BoldLookupListProperties.ListIndexToIndex(lItemIndex); + if (lcxBoldComboBox.ActiveProperties.BoldLookupListProperties.NilElementMode = neInsertFirst) then + Dec(lItemIndex); + lNewElement := lcxBoldComboBox.ActiveProperties.BoldLookupListHandle.List[lItemIndex]; + Result := lOriginalElement <> lNewElement; + end + else + begin + if not ((lcxBoldComboBox.Properties.BoldSelectChangeAction in [bdcsSetValue,bdscSetText]) and (lOriginalElement is TBoldAttribute)) then + result := false; + end; + end; +end; + +function TcxBoldComboBoxEditDataBinding.ImmediatePost: boolean; +begin + result := true; +end; + +{ TcxBoldIntegerEditDataBinding } + +function TcxBoldNumericEditDataBinding.ValidateTypeConforms( + aExpressionType: TBoldElementTypeInfo): string; +var + lNumericTypeInfo: TBoldAttributeTypeInfo; +begin + result := ''; + with (aExpressionType.SystemTypeInfo as TBoldSystemTypeInfo) do + begin + lNumericTypeInfo := AttributeTypeInfoByExpressionName['Numeric']; // do not localize + end; + if not aExpressionType.ConformsTo(lNumericTypeInfo) then + result := Format(sPossiblyBadConformance, [aExpressionType.ModelName , lNumericTypeInfo.ModelName]); +end; + +{ TcxBoldBlobEditDataBinding } + +function TcxBoldBlobEditDataBinding.ValidateTypeConforms( + aExpressionType: TBoldElementTypeInfo): string; +var + lBlobTypeInfo: TBoldAttributeTypeInfo; +begin + result := ''; + with (aExpressionType.SystemTypeInfo as TBoldSystemTypeInfo) do + begin + lBlobTypeInfo := AttributeTypeInfoByExpressionName['Blob']; // do not localize + end; + if not aExpressionType.ConformsTo(lBlobTypeInfo) then + result := Format(sPossiblyBadConformance, [aExpressionType.ModelName , lBlobTypeInfo.ModelName]); +end; + +{ TcxBoldTimeEditDataBinding } + +function TcxBoldTimeEditDataBinding.ValidateTypeConforms( + aExpressionType: TBoldElementTypeInfo): string; +var + lDateTimeTypeInfo: TBoldAttributeTypeInfo; + lTimeTypeInfo: TBoldAttributeTypeInfo; +begin + result := ''; + with (aExpressionType.SystemTypeInfo as TBoldSystemTypeInfo) do + begin + lDateTimeTypeInfo := AttributeTypeInfoByExpressionName['DateTime']; // do not localize + lTimeTypeInfo := AttributeTypeInfoByExpressionName['Time']; // do not localize + end; + if not (aExpressionType.ConformsTo(lDateTimeTypeInfo) or aExpressionType.ConformsTo(lTimeTypeInfo)) then + result := Format(sPossiblyBadConformance, [aExpressionType.ModelName , lDateTimeTypeInfo.ModelName + ' nor ' + lTimeTypeInfo.ModelName]); +end; + +function TcxCustomBoldTextEditProperties.BoldElementToEditValue( + aFollower: TBoldFollower; aElement: TBoldElement; + aEdit: TcxCustomEdit): variant; +begin + result := BoldRowProperties.GetAsVariant(aFollower); +end; + +procedure TcxCustomBoldTextEditProperties.SetBoldSelectChangeAction( + Value: TBoldComboSelectChangeAction); +begin + fBoldSelectChangeAction := Value; +end; + +procedure TcxCustomBoldTextEditProperties.SetStoredValue(aValue: Variant; + aBoldHandle: TBoldElementHandle; aEdit: TcxCustomEdit; + aFollower: TBoldFollower; var aDone: boolean); +var + LocalSelectedElement: TBoldElement; + lItemIndex: Integer; +begin + lItemIndex := -1; + if Assigned(TcxTextEdit(aEdit).ILookupData) then + lItemIndex := TcxTextEdit(aEdit).ILookupData.CurrentKey; + if lItemIndex = -1 then + begin + aDone := false; + exit; + end + else + begin +{ if ((lItemIndex = LookupListFollower.SubFollowerCount-1) and (BoldLookupListProperties.NilElementMode = neAddLast)) + or ((lItemIndex = 0) and (BoldLookupListProperties.NilElementMode = neInsertFirst)) then + begin + LocalSelectedElement := nil + end + else + begin + if (BoldLookupListProperties.NilElementMode = neInsertFirst) then + dec(lItemIndex); +} + LocalSelectedElement := BoldLookupListHandle.List[lItemIndex]; +// end; + end; + InternalComboSetValue(aBoldHandle, aFollower, LocalSelectedElement, BoldSelectChangeAction, BoldSetValueExpression, BoldLookupListHandle, aValue); + aDone := true; +end; + +function TcxCustomBoldTextEditProperties.CanEdit( + aBoldHandle: TBoldElementHandle; aFollower: TBoldFollower): boolean; +begin + result := true; +end; + +procedure TcxCustomBoldTextEditProperties.SetBoldSetValueExpression( + const Value: TBoldExpression); +begin + fBoldSetValueExpression := Value; + if Owner is TcxCustomEdit and (TcxCustomEdit(Owner).IsDesigning) and not (TcxCustomEdit(Owner).IsLoading) then + begin + _ValidateEdit(TcxCustomEdit(Owner)); + end; +end; + +{ TcxBoldCurrencyEditDataBinding } + +function TcxBoldCurrencyEditDataBinding.ValidateTypeConforms( + aExpressionType: TBoldElementTypeInfo): string; +var + lCurrencyTypeInfo: TBoldAttributeTypeInfo; + lFloatTypeInfo: TBoldAttributeTypeInfo; +begin + result := ''; + with (aExpressionType.SystemTypeInfo as TBoldSystemTypeInfo) do + begin + lCurrencyTypeInfo := AttributeTypeInfoByExpressionName['Currency']; // do not localize + lFloatTypeInfo := AttributeTypeInfoByExpressionName['Float']; // do not localize + end; + if not aExpressionType.ConformsTo(lCurrencyTypeInfo) and not aExpressionType.ConformsTo(lFloatTypeInfo) then + result := Format(sPossiblyBadConformance, [aExpressionType.ModelName , lCurrencyTypeInfo.ModelName]); +end; + +{ TcxBoldListBox } + +procedure TcxBoldListBox._DeleteItem(Index: Integer; + OwningFollower: TBoldFollower); +begin + if not (ListStyle in [lbVirtual, lbVirtualOwnerDraw]) then + begin + if not Items.Updating then + Items.BeginUpdate; + Items.Delete(index); + end; +end; + +procedure TcxBoldListBox._InsertItem(Index: Integer; Follower: TBoldFollower); +begin + Assert(Assigned(Follower)); + if not Items.Updating then + Items.BeginUpdate; + Follower.EnsureDisplayable; + if not (ListStyle in [lbVirtual, lbVirtualOwnerDraw]) then + Items.Insert(Follower.Index, VarToStr(TBoldVariantFollowerController(Follower.Controller).GetAsVariant(Follower))) +end; + +procedure TcxBoldListBox._ReplaceItem(Index: Integer; Follower: TBoldFollower); +begin + if not Items.Updating then + Items.BeginUpdate; + Follower.EnsureDisplayable; + if not (ListStyle in [lbVirtual, lbVirtualOwnerDraw]) then + Items.Strings[Index] := VarToStr(TBoldVariantFollowerController(Follower.Controller).GetAsVariant(Follower)); +end; + +procedure TcxBoldListBox._RowAfterMakeUptoDate(Follower: TBoldFollower); +var + index: Integer; + s: string; +begin + index := Follower.index; + if (index > -1) and (index < Items.Count) then + begin + s := VarToStr(TBoldVariantFollowerController(Follower.Controller).GetAsVariant(Follower)); + if s <> Items[index] then + Items[index] := s; + end; +end; + +procedure TcxBoldListBox._AfterMakeUptoDate(Follower: TBoldFollower); +begin + fBoldRowProperties.AfterMakeUptoDate := _RowAfterMakeUptoDate; + if not fInternalUpdate then + begin + if ListStyle in [lbVirtual, lbVirtualOwnerDraw] then + Count := self.Follower.SubFollowerCount; + ItemIndex := Follower.CurrentIndex; + if MultiSelect then + ClearSelection; + if ItemIndex <> -1 then + Selected[ItemIndex] := true; + end; + SyncSelection; + if Items.Updating then + Items.EndUpdate; +end; + +procedure TcxBoldListBox._BeforeMakeUptoDate(Follower: TBoldFollower); +begin + fBoldRowProperties.AfterMakeUptoDate := nil; + if assigned(BoldListHandle) and assigned(BoldListHandle.list) then + BoldListHandle.list.EnsureRange(0, BoldListHandle.list.Count-1); +end; + +function TcxBoldListBox.GetBoldListHandle: TBoldAbstractListHandle; +begin + Result := fListHandleFollower.BoldHandle; +end; + +procedure TcxBoldListBox.SetBoldListHandle( + const Value: TBoldAbstractListHandle); +begin + fListHandleFollower.BoldHandle := value; +end; + +procedure TcxBoldListBox.SetBoldListProperties( + const Value: TBoldListAsFollowerListController); +begin + fBoldListProperties.Assign(Value); +end; + +procedure TcxBoldListBox.SetRowProperties( + const Value: TBoldVariantFollowerController); +begin + fBoldRowProperties.Assign(Value); +end; + +function TcxBoldListBox.GetListFollower: TBoldFollower; +begin + Result := fListHandleFollower.Follower; +end; + +constructor TcxBoldListBox.Create(AOwner: TComponent); +begin + inherited; + fBoldRowProperties := TBoldVariantFollowerController.Create(AOwner); + fBoldRowProperties.AfterMakeUptoDate := _RowAfterMakeUptoDate; + fBoldRowProperties.OnGetContextType := GetContextForBoldRowProperties; + fBoldListProperties := TBoldListAsFollowerListController.Create(AOwner, fBoldRowProperties); + with fBoldListProperties do + begin + OnAfterInsertItem := _InsertItem; + OnAfterDeleteItem := _DeleteItem; + OnReplaceitem := _ReplaceItem; + BeforeMakeUptoDate := _BeforeMakeUptoDate; + AfterMakeUptoDate := _AfterMakeUptoDate; + end; + fListHandleFollower := TBoldListHandleFollower.Create(Owner, fBoldListProperties); +end; + +destructor TcxBoldListBox.Destroy; +begin + FreeAndNil(fListHandleFollower); + FreeAndNil(fBoldListProperties); + FreeAndNil(fBoldRowProperties); + inherited; +end; + +function TcxBoldListBox.GetContextForBoldRowProperties: TBoldElementTypeInfo; +begin + if assigned(BoldListHandle) then + result := BoldListHandle.StaticBoldType + else + result := nil; +end; + +function TcxBoldListBox.GetBoldHandleIndexLock: Boolean; +begin + Result := fListHandleFollower.HandleIndexLock; +end; + +procedure TcxBoldListBox.SetBoldHandleIndexLock(const Value: Boolean); +begin + fListHandleFollower.HandleIndexLock := Value; +end; + +procedure TcxBoldListBox.WndProc(var Message: TMessage); +begin + inherited; + if (InnerListBox <> nil) and not IsDestroying and + ((Message.Msg = WM_CTLCOLORLISTBOX) or (Message.Msg = WM_COMMAND) and (Message.WParamHi = LBN_SELCHANGE)) and (Follower.CurrentIndex <> ItemIndex) then + begin + fListHandleFollower.SetFollowerIndex(ItemIndex); + fInternalUpdate := true; + try + TBoldQueueable.DisplayAll; + finally + fInternalUpdate := false; + end; + end; +end; + +procedure TcxBoldListBox.DblClick; +var + lAutoForm: TForm; + lElement: TBoldElement; +begin + inherited; + if fBoldListProperties.DefaultDblClick and Assigned(Follower.CurrentSubFollower) and Assigned(Follower.CurrentSubFollower.Element) then + begin + lElement := Follower.CurrentSubFollower.Element; + lAutoForm := AutoFormProviderRegistry.FormForElement(lElement); + if assigned(lAutoForm) then + begin + lAutoForm.Show; + end + end; +end; + +function TcxBoldListBox.GetFollower: TBoldFollower; +begin + if Assigned(fListHandleFollower) then + result := fListHandleFollower.Follower + else + result := nil; +end; + +procedure TcxBoldListBox.Loaded; +begin + inherited; + Items.Clear; + DragMode := dmAutomatic; +end; + +procedure TcxBoldListBox.DoEndDrag(Target: TObject; X, Y: Integer); +begin + BoldListProperties.EndDrag; + inherited DoEndDrag(Target, X, Y); +end; + +procedure TcxBoldListBox.DoStartDrag(var DragObject: TDragObject); +begin + SyncSelection; + BoldListProperties.StartDrag(Follower); + inherited DoStartDrag(DragObject); +end; + +procedure TcxBoldListBox.DragOver(Source: TObject; X, Y: Integer; + State: TDragState; var Accept: Boolean); +begin + if Assigned(OnDragOver) + or (BoldListProperties.DropMode = bdpNone) + or ((Source = Self) and (not BoldListProperties.InternalDrag)) then + inherited DragOver(Source, X, Y, State, Accept) + else + Accept := BoldListProperties.DragOver(Follower, MutableList, ItemAtPos(Point(X, Y), False)); +end; + +procedure TcxBoldListBox.DragDrop(Source: TObject; X, Y: Integer); +begin + if Assigned(OnDragDrop) then + begin + if BoldGuiHandler.ActivateTargetFormOnDrop then + BoldGUIHandler.TryToFocusHostingForm(self); + inherited DragDrop(Source, X, Y); + end + else + BoldListProperties.DragDrop(Follower, MutableList, ItemAtPos(Point(X, Y), False)); +end; + +function TcxBoldListBox.DrawItem(ACanvas: TcxCanvas; AIndex: Integer; + const ARect: TRect; AState: TOwnerDrawState): Boolean; +begin + DefaultSetFontAndColor(AIndex); + Result := inherited DrawItem(ACanvas, AIndex, ARect, AState); +end; + +procedure TcxBoldListBox.DefaultDrawItem(Index: integer; aRect: TRect); +begin + BoldRowProperties.DrawOnCanvas(Follower.SubFollowers[index], Canvas.Canvas, aRect, taLeftJustify, Point(2,0)); +end; + +procedure TcxBoldListBox.DefaultSetFontAndColor(Index: integer); +var + ec: tColor; + SubFollower: TBoldFollower; +begin + BoldRowProperties.SetFont(InnerListBox.Canvas.Font, InnerListBox.Canvas.Font, Follower.SubFollowers[index]); + BoldRowProperties.SetColor(ec, InnerListBox.Canvas.Brush.Color, Follower.SubFollowers[index]); + InnerListBox.Canvas.Brush.Color := ec; + SubFollower := Follower.SubFollowers[index]; + if assigned(Subfollower) and Subfollower.Selected then + with InnerListBox.Canvas do + begin + Brush.Color := clHighlight; + Font.Color := clHighlightText; + end; +end; + +function TcxBoldListBox.GetMutableList: TBoldList; +begin + if assigned(BoldListHandle) then + result := BoldListHandle.MutableList + else + result := nil; +end; + +procedure TcxBoldListBox.SyncSelection; +var + i: integer; +begin + BoldListProperties.SelectAll(Follower, False); + if multiselect then + begin + if SelCount > 0 then + begin + for i := 0 to Count - 1 do + begin + BoldListProperties.SetSelected(Follower, i, Selected[i]); + end; + end; + end + else + begin + if ItemIndex <> -1 then + BoldListProperties.SetSelected(Follower, ItemIndex, true); + end; + if Assigned(BoldListHandle) and (BoldListHandle.CurrentIndex <> ItemIndex) then + begin + BoldListHandle.CurrentIndex := ItemIndex; + TBoldQueueable.DisplayAll; + end; +end; + +function TcxBoldListBox.ValidateComponent( + ComponentValidator: TBoldComponentValidator; + NamePrefix: string): Boolean; +var + lContext: TBoldElementTypeInfo; +begin + result := false; + lContext := GetContextForBoldRowProperties; + if assigned(lContext) then + begin + result := ComponentValidator.ValidateExpressionInContext( + BoldRowProperties.Expression, + lContext, + format('%s %s.BoldRowProperties.Expression', [NamePrefix, Name]), BoldRowProperties.VariableList); // do not localize + end; +end; + +{ TcxBoldListView } + +procedure TcxBoldListView._BeforeMakeUptoDate(Follower: TBoldFollower); +begin + // Will fetch all + if assigned(BoldHandle) and assigned(Boldhandle.list) then + BoldHandle.list.EnsureRange(0, BoldHandle.list.Count-1); +end; + +procedure TcxBoldListView._AfterMakeUptoDate(Follower: TBoldFollower); +begin + ItemIndex := Follower.CurrentIndex; + if ItemIndex = -1 then + fBoldProperties.SelectAll(Follower, False) + else + ; + if FUpdateCount > 0 then + begin + dec(FUpdateCount); + Items.EndUpdate; + end; +end; + +procedure TcxBoldListView._InsertItem(Index: Integer; Follower: TBoldFollower); +var + lItem: TListItem; +begin + Assert(Assigned(Follower)); + if FUpdateCount = 0 then + begin + inc(FUpdateCount); + Items.BeginUpdate; + end; + Follower.EnsureDisplayable; + lItem := Items.Insert(Follower.Index); + lItem.Caption := VarToStr(TBoldVariantFollowerController(Follower.Controller).GetAsVariant(Follower)); + lItem.ImageIndex := 0; +end; + +procedure TcxBoldListView._DeleteItem(index: Integer; + OwningFollower: TBoldFollower); +begin + if FUpdateCount = 0 then + begin + inc(FUpdateCount); + Items.BeginUpdate; + end; + Items.Delete(index); +end; + +procedure TcxBoldListView._ReplaceItem(Index: Integer; Follower: TBoldFollower); +begin + if FUpdateCount = 0 then + begin + inc(FUpdateCount); + Items.BeginUpdate; + end; + Follower.EnsureDisplayable; + items[Index].Caption := VarToStr(TBoldVariantFollowerController(Follower.Controller).GetAsVariant(Follower)); +end; + +procedure TcxBoldListView._RowAfterMakeUptoDate(Follower: TBoldFollower); +var + NewValue: string; +begin + NewValue := VarToStr(TBoldVariantFollowerController(Follower.Controller).GetAsVariant(Follower)); + if Items[Follower.index].Caption <> NewValue then + Items[Follower.index].Caption := NewValue; +end; + +function TcxBoldListView.GetBoldHandle: TBoldAbstractListHandle; +begin + Result := fListHandleFollower.BoldHandle; +end; + +function TcxBoldListView.GetBoldHandleIndexLock: Boolean; +begin + Result := fListHandleFollower.HandleIndexLock; +end; + +function TcxBoldListView.GetBoldList: TBoldList; +begin + //CHECKME We may have to remove this because the list is not necessarily equal with the rendered list!!! /FH + if Assigned(BoldHandle) then + Result := BoldHandle.List + else + Result := nil; +end; + +function TcxBoldListView.GetContextType: TBoldElementTypeInfo; +begin + if assigned(BoldHandle) then + result := BoldHandle.StaticBoldType + else + result := nil; +end; + +function TcxBoldListView.GetCurrentBoldElement: TBoldElement; +var + Subfollower: TBoldFollower; +begin + Result := nil; + if ItemIndex <> -1 then + begin + SubFollower := Follower.SubFollowers[ItemIndex]; + if assigned(SubFollower) then + Result := Subfollower.Element; + end; +end; + +function TcxBoldListView.GetCurrentBoldObject: TBoldObject; +begin + if CurrentBoldElement is TBoldObject then + Result := CurrentBoldElement as TBoldObject + else + Result := nil; +end; + +function TcxBoldListView.GetFollower: TBoldFollower; +begin + Result := fListHandleFollower.Follower; +end; + +procedure TcxBoldListView.SetBoldHandle(value: TBoldAbstractListHandle); +begin + fListHandleFollower.BoldHandle := value; +end; + +procedure TcxBoldListView.SetBoldHandleIndexLock(Value: Boolean); +begin + fListHandleFollower.HandleIndexLock := Value; +end; + +procedure TcxBoldListView.SetBoldProperties( + Value: TBoldAbstractListAsFollowerListController); +begin + fBoldProperties.Assign(Value); +end; + +procedure TcxBoldListView.SetRowProperties( + const Value: TBoldVariantFollowerController); +begin + fBoldRowProperties.Assign(Value); +end; + +constructor TcxBoldListView.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + fBoldRowProperties := TBoldVariantFollowerController.Create(Self); + fBoldRowProperties.AfterMakeUptoDate := _RowAfterMakeUptoDate; + fBoldRowProperties.OnGetContextType := GetContextType; + fBoldProperties := TBoldAbstractListAsFollowerListController.Create(Self, fBoldRowProperties); + with fBoldProperties do + begin + OnAfterInsertItem := _InsertItem; + OnAfterDeleteItem := _DeleteItem; + OnReplaceitem := _ReplaceItem; + BeforeMakeUptoDate := _BeforeMakeUptoDate; + AfterMakeUptoDate := _AfterMakeUptoDate; + end; + fListHandleFollower := TBoldListHandleFollower.Create(Owner, fBoldProperties); + DragMode := dmAutomatic; + ViewStyle := vsIcon; +end; + +destructor TcxBoldListView.Destroy; +begin + FreeAndNil(fListHandleFollower); + FreeAndNil(fBoldProperties); + FreeAndNil(fBoldRowProperties); + inherited Destroy; +end; +(* +{ TcxBoldListBox } + +function TcxBoldListBox.GetDataBinding: TcxBoldDataBinding; +begin + Result := TcxBoldDataBinding(FDataBinding); +end; + +function TcxBoldListBox.GetDataBindingClass: TcxCustomDataBindingClass; +begin + result := TcxBoldDataBinding; +end; + +procedure TcxBoldListBox.SetDataBinding(Value: TcxBoldDataBinding); +begin + FDataBinding.Assign(Value); +end; +*) + +{ TcxBoldCustomCheckListBox } + +constructor TcxBoldCustomCheckListBox.Create(AOwner: TComponent); +begin + inherited; + fBoldRowProperties := TBoldVariantFollowerController.Create(self); + fBoldRowProperties.OnGetContextType := GetContextType; + fBoldRowCheckBoxProperties := TBoldCheckBoxStateFollowerController.Create(self); + fBoldRowCheckBoxProperties.OnGetContextType := GetContextType; + + fControllerList := TBoldControllerList.Create(self); + fControllerList.Add(fBoldRowCheckBoxProperties); + fControllerLIst.Add(fBoldRowProperties); + + fBoldRowProperties.AfterMakeUptoDate := _DisplayString; + fBoldRowCheckBoxProperties.AfterMakeUpToDate := _DisplayCheckBox; + + fBoldListProperties := TBoldAbstractListAsFollowerListController.Create(self, fControllerList); + fBoldListProperties.OnGetContextType := GetContextType; + fBoldListProperties.AfterMakeUptoDate := _ListAfterMakeUpToDate; + fBoldListProperties.BeforeMakeUptoDate := _ListBeforeMakeUpToDate; + fBoldlistProperties.OnAfterInsertItem := _ListInsertItem; + fBoldListProperties.OnAfterDeleteItem := _ListDeleteItem; + fBoldListProperties.OnReplaceitem := _ReplaceItem; +// fBoldListProperties.DefaultDblClick := false; + fListHandleFollower := TBoldListHandleFollower.Create(AOwner, fBoldListProperties); +end; + +destructor TcxBoldCustomCheckListBox.Destroy; +begin + FreeAndNil(fListHandleFollower); + FreeAndNil(fBoldListProperties); + FreeAndNil(fControllerList); + inherited; +end; + +function TcxBoldCustomCheckListBox.GetBoldHandleIndexLock: Boolean; +begin + Result := fListHandleFollower.HandleIndexLock; +end; + +function TcxBoldCustomCheckListBox.GetBoldListHandle: TBoldAbstractListHandle; +begin + Result := fListHandleFollower.BoldHandle; +end; + +function TcxBoldCustomCheckListBox.GetContextType: TBoldElementTypeInfo; +begin + if Assigned(BoldListHandle) then + result := BoldListHandle.StaticBoldType + else + result := nil; +end; + +function TcxBoldCustomCheckListBox.GetFollower: TBoldFollower; +begin + result := fListHandleFollower.Follower; +end; + +type + TcxBoldCustomInnerCheckListBox = class(TcxCustomInnerCheckListBox) + protected + procedure DoClickCheck(const AIndex: Integer; const OldState, NewState: TcxCheckBoxState); override; + end; + +{ TcxBoldCustomInnerCheckListBox } + +const + CHECKBOXFOLLOWER_INDEX = 0; + STRINGFOLLOWER_INDEX = 1; + +procedure TcxBoldCustomInnerCheckListBox.DoClickCheck( + const AIndex: Integer; const OldState, NewState: TcxCheckBoxState); +var + CheckBoxFollower: TBoldFollower; + lOwningCheckListBox: TcxBoldCustomCheckListBox; +begin + lOwningCheckListBox := (fContainer as TcxBoldCustomCheckListBox); + if not (csDesigning in ComponentState) and (ItemIndex <> - 1) then + begin + CheckBoxFollower := lOwningCheckListBox.fListHandleFollower.Follower.SubFollowers[AIndex].SubFollowers[CHECKBOXFOLLOWER_INDEX]; + TBoldCheckBoxStateFollowerController(CheckBoxFollower.Controller).SetAsCheckBoxState(TCheckBoxState(NewState), CheckBoxFollower); + lOwningCheckListBox.fListHandleFollower.SetFollowerIndex(AIndex); + end; + inherited; +end; + +function TcxBoldCustomCheckListBox.GetInnerCheckListBoxClass: TcxCustomInnerCheckListBoxClass; +begin + result := TcxBoldCustomInnerCheckListBox; +end; + +procedure TcxBoldCustomCheckListBox.Loaded; +begin + inherited; + Items.Clear; + DragMode := dmAutomatic; +end; + +procedure TcxBoldCustomCheckListBox.SetBoldHandleIndexLock( + const Value: Boolean); +begin + fListHandleFollower.HandleIndexLock := Value; +end; + +procedure TcxBoldCustomCheckListBox.SetBoldListHandle( + const Value: TBoldAbstractListHandle); +begin + fListHandleFollower.BoldHandle := value; +end; + +procedure TcxBoldCustomCheckListBox.SetBoldListProperties( + const Value: TBoldAbstractListAsFollowerListController); +begin + FBoldListProperties.Assign(Value); +end; + +procedure TcxBoldCustomCheckListBox.SetBoldRowCheckBoxProperties( + const Value: TBoldCheckBoxStateFollowerController); +begin + fBoldRowCheckBoxProperties.Assign(Value); +end; + +procedure TcxBoldCustomCheckListBox.SetRowProperties( + const Value: TBoldVariantFollowerController); +begin + fBoldRowProperties.Assign(Value); +end; + +procedure TcxBoldCustomCheckListBox.SyncSelection; +var + i: integer; +begin + BoldListProperties.SelectAll(Follower, False); + if InnerCheckListBox.multiselect then + begin + if InnerCheckListBox.SelCount > 0 then + begin + for i := 0 to Count - 1 do + begin + BoldListProperties.SetSelected(Follower, i, Selected[i]); + end; + end + end + else + begin + if ItemIndex <> -1 then + BoldListProperties.SetSelected(Follower, ItemIndex, true) + end; +end; + +procedure TcxBoldCustomCheckListBox.WndProc(var Message: TMessage); +begin + inherited; + if (InnerCheckListBox <> nil) and (Message.Msg = WM_COMMAND) and (Message.WParamHi = LBN_SELCHANGE) then + begin + fListHandleFollower.SetFollowerIndex(ItemIndex); + fInternalUpdate := true; + try + TBoldQueueable.DisplayAll; + finally + fInternalUpdate := false; + end; + end; +end; + +procedure TcxBoldCustomCheckListBox._DisplayCheckBox( + Follower: TBoldFollower); +var + index: integer; +begin + index := Follower.OwningFollower.index; + if (index > -1) and (index < Items.Count) then + begin + Items[Index].State := TcxCheckBoxState(TBoldCheckBoxStateFollowerController(Follower.Controller).GetCurrentAsCheckBoxState(Follower)); + end; +end; + +procedure TcxBoldCustomCheckListBox._DisplayString( + Follower: TBoldFollower); +var + index: integer; +begin + index := Follower.OwningFollower.index; + if (index > -1) and (index < Items.Count) then + begin + Items[Index].Text := VarToStr(TBoldVariantFollowerController(Follower.Controller).GetAsVariant(Follower)); + end; +end; + +procedure TcxBoldCustomCheckListBox._ListAfterMakeUpToDate( + Follower: TBoldFollower); +var + lIndex: integer; +begin +// fBoldRowProperties.AfterMakeUptoDate := _RowAfterMakeUptoDate; + if FUpdateCount > 0 then + begin + dec(FUpdateCount); + Items.EndUpdate; + end; + if not fInternalUpdate then + begin + lIndex := Follower.CurrentIndex; + ItemIndex := lIndex; + if self.InnerCheckListBox.MultiSelect then + InnerCheckListBox.ClearSelection; + if lIndex <> -1 then + Selected[lIndex] := true; + end; + SyncSelection; +end; + +procedure TcxBoldCustomCheckListBox._ListBeforeMakeUpToDate( + Follower: TBoldFollower); +begin + // will fetch all + if Assigned(BoldListHandle) and Assigned(BoldListHandle.List) then + BoldListHandle.List.EnsureRange(0, BoldListHandle.List.Count - 1); +end; + +procedure TcxBoldCustomCheckListBox._ListDeleteItem(Index: integer; + Follower: TBoldFollower); +begin + if FUpdateCount = 0 then + begin + inc(FUpdateCount); + Items.BeginUpdate; + end; + Items.Delete(Index); +end; + +procedure TcxBoldCustomCheckListBox._ListInsertItem(Index: Integer; Follower: TBoldFollower); +var + lCheckListBoxItem: TcxCheckListBoxItem; +begin + if FUpdateCount = 0 then + begin + inc(FUpdateCount); + Items.BeginUpdate; + end; + Assert(Assigned(Follower)); + lCheckListBoxItem := Items.Insert(Follower.Index) as TcxCheckListBoxItem; + if Assigned(Follower) then + begin + Follower.EnsureDisplayable; + if Assigned(Follower.Value) then + lCheckListBoxItem.Text := VarToStr(TBoldVariantFollowerController(Follower.Controller).GetAsVariant(Follower)); + end; +end; + +procedure TcxBoldCustomCheckListBox._ReplaceItem(Index: Integer; + Follower: TBoldFollower); +begin + if FUpdateCount = 0 then + begin + inc(FUpdateCount); + Items.BeginUpdate; + end; + Follower.EnsureDisplayable; + Items[Index].Text := VarToStr(TBoldVariantFollowerController(Follower.Controller).GetAsVariant(Follower)); +end; + +{ TcxBoldSelectionCheckListBox } + +constructor TcxBoldSelectionCheckListBox.Create(AOwner: TComponent); +begin + inherited; + fPublisher := TBoldPublisher.Create; +{ + TBoldGetAsCheckBoxState = function (Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression): TCheckBoxState of object; + TBoldSetAsCheckBoxState = procedure (Element: TBoldElement; newValue: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression) of object; +} + fCheckBoxRenderer := TBoldAsCheckBoxStateRenderer.Create(self); + fCheckBoxRenderer.OnGetAsCheckBoxState := GetAsCheckBoxState; + fCheckBoxRenderer.OnSetAsCheckBoxState := SetAsCheckBoxState; + fCheckBoxRenderer.OnSubscribe := OnSubscribe; + BoldRowCheckBoxProperties.Renderer := fCheckBoxRenderer; +end; + +destructor TcxBoldSelectionCheckListBox.Destroy; +begin + fPublisher.NotifySubscribersAndClearSubscriptions(self); + FreeAndNil(fPublisher); + inherited; +end; + +function TcxBoldSelectionCheckListBox.GetAsCheckBoxState( + aFollower: TBoldFollower + ): TCheckBoxState; +begin + if Assigned(BoldSelectionHandle) then + begin + if (BoldSelectionHandle.List.IndexOf(aFollower.Element) <> -1 ) then + Result := cbChecked + else + Result := cbUnChecked; + end + else + Result := cbGrayed; +end; + +procedure TcxBoldSelectionCheckListBox.SetAsCheckBoxState( + aFollower: TBoldFollower; newValue: TCheckBoxState); +var + lElement: TBoldElement; +begin + lElement := aFollower.Element; + if Assigned(BoldSelectionHandle) then + begin + case newValue of + cbChecked: BoldSelectionHandle.MutableList.Add(lElement); + cbUnChecked: if (BoldSelectionHandle.List.IndexOf(lElement) <> -1) then BoldSelectionHandle.MutableList.Remove(lElement); + cbGrayed: ; + end; + end; +end; + +procedure TcxBoldSelectionCheckListBox.Notification(AComponent: TComponent; + Operation: TOperation); +begin + inherited; + if (AComponent = BoldSelectionHandle) and (Operation = opRemove) then + BoldSelectionHandle := nil; +end; + +procedure TcxBoldSelectionCheckListBox.OnSubscribe( + aFollower: TBoldFollower; Subscriber: TBoldSubscriber); +begin + if Assigned(BoldSelectionHandle) then + begin + BoldSelectionHandle.AddSmallSubscription(Subscriber, [beValueIdentityChanged, beDestroying], breReSubscribe); + if Assigned(BoldSelectionHandle.List) then + BoldSelectionHandle.List.DefaultSubscribe(Subscriber); + end; + fPublisher.AddSubscription(Subscriber, beSelectionHandleChanged, breReSubscribe); +end; + +procedure TcxBoldSelectionCheckListBox.SetSelectionHandle( + const Value: TBoldAbstractListHandle); +begin + if (fBoldSelectionHandle <> Value) then + begin + fBoldSelectionHandle := Value; + fPublisher.SendExtendedEvent(self, beSelectionHandleChanged, []); + end; +end; + +function TcxBoldSelectionCheckListBox.ValidateComponent( + ComponentValidator: TBoldComponentValidator; + NamePrefix: string): Boolean; +var + lContext: TBoldElementTypeInfo; +begin + result := false; + lContext := GetContextType; + if assigned(lContext) then + begin + result := ComponentValidator.ValidateExpressionInContext( + BoldRowProperties.Expression, + lContext, + format('%s %s.BoldRowProperties.Expression', [NamePrefix, Name]), BoldRowProperties.VariableList); // do not localize + end; +end; + +{ TcxBoldCheckListBox } + +function TcxBoldCheckListBox.ValidateComponent( + ComponentValidator: TBoldComponentValidator; + NamePrefix: string): Boolean; +var + lContext: TBoldElementTypeInfo; +begin + result := false; + lContext := GetContextType; + if assigned(lContext) then + begin + result := ComponentValidator.ValidateExpressionInContext( + BoldRowProperties.Expression, + lContext, + format('%s %s.BoldRowProperties.Expression', [NamePrefix, Name]), BoldRowProperties.VariableList); // do not localize + result := ComponentValidator.ValidateExpressionInContext( + BoldRowCheckBoxProperties.Expression, + lContext, + format('%s %s.BoldRowProperties.Expression', [NamePrefix, Name]), BoldRowCheckBoxProperties.VariableList) and result; // do not localize + end; +end; + +initialization + GetRegisteredEditProperties.Register(TcxBoldTextEditProperties, scxSBoldEditRepositoryTextItem); + GetRegisteredEditProperties.Register(TcxBoldComboBoxProperties, scxSBoldComboBoxRepositoryTextItem); + FilterEditsController.Register(TcxBoldTextEditProperties, TcxFilterTextEditHelper); + FilterEditsController.Register(TcxBoldComboBoxProperties, TcxFilterComboBoxHelper); + dxBarRegisterItem(TcxBarBoldEditItem, TcxBarEditItemControl, True); +// BarDesignController.RegisterBarControlEditor(TcxItemsEditorEx); + + +finalization + dxBarUnregisterItem(TcxBarBoldEditItem); + FilterEditsController.Unregister(TcxBoldTextEditProperties, TcxFilterTextEditHelper); + FilterEditsController.Unregister(TcxBoldComboBoxProperties, TcxFilterComboBoxHelper); + GetRegisteredEditProperties.UnRegister(TcxBoldTextEditProperties); + GetRegisteredEditProperties.UnRegister(TcxBoldComboBoxProperties); +// BarDesignController.UnregisterBarControlEditor(TcxItemsEditorEx); + +end. diff --git a/Source/BoldAwareGUI/BoldDevex/cxBoldExtLookupComboBox.pas b/Source/BoldAwareGUI/BoldDevex/cxBoldExtLookupComboBox.pas new file mode 100644 index 00000000..f8fc6ca6 --- /dev/null +++ b/Source/BoldAwareGUI/BoldDevex/cxBoldExtLookupComboBox.pas @@ -0,0 +1,1042 @@ +unit cxBoldExtLookupComboBox; + +{$I cxVer.inc} + +// v2.03 - 25 Jan 2011 2007-2011 Daniel Mauric + +interface + +uses +{$IFDEF DELPHI6} + Variants, +{$ENDIF} + Windows, Classes, Controls, + Graphics, Messages, SysUtils, cxClasses, + cxContainer, cxControls, cxCustomData, + cxBoldLookupEdit, + cxEditConsts, cxGrid, cxGridCustomTableView, cxEdit, + cxGridCustomView, cxGridStrs, cxGridTableView, cxLookAndFeels, cxLookupEdit, + + BoldElements, + cxBoldEditors, + cxGridBoldSupportUnit, + BoldControlPack, + BoldHandles, + BoldComponentValidator; + +type + { TcxBoldExtLookupGrid } + + TcxBoldExtLookupGrid = class(TcxGrid) + private + FEditable: Boolean; + FMousePos: TPoint; + FPopupMouseMoveLocked: Boolean; + FPrevOnKeyDown: TKeyEvent; + FPrevOnMouseDown: TMouseEvent; + FPrevOnMouseMove: TMouseMoveEvent; + FPrevOnMouseUp: TMouseEvent; + FRowPressed: Boolean; + FOnCloseUp: TcxLookupGridCloseUpEvent; + function GetView: TcxCustomGridTableView; + procedure ViewKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); + procedure ViewMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); + procedure ViewMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); + procedure ViewMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); + protected + procedure DoCancelMode; override; + procedure DoCloseUp(AAccept: Boolean); virtual; + function IsDataRow(AHitTest: TcxCustomGridHitTest): Boolean; + property Editable: Boolean read FEditable write FEditable; + property PopupMouseMoveLocked: Boolean read FPopupMouseMoveLocked write FPopupMouseMoveLocked; + property OnCloseUp: TcxLookupGridCloseUpEvent read FOnCloseUp write FOnCloseUp; + public + property View: TcxCustomGridTableView read GetView; + end; + + { TcxCustomBoldExtLookupComboBoxProperties } + + TcxCustomBoldExtLookupComboBoxProperties = class(TcxCustomBoldLookupEditProperties); + + { TcxBoldExtLookupComboBoxProperties } + + TcxBoldExtLookupComboBoxProperties = class(TcxCustomBoldExtLookupComboBoxProperties) + private + FAutoSearchOnPopup: Boolean; + FDestroying: Boolean; + FFocusPopup: Boolean; + FGrid: TcxBoldExtLookupGrid; + FInCheckListFieldItem: Boolean; + FListFieldItem: TcxCustomGridTableItem; + FPrevColumnFiltering: Boolean; + FPrevColumnsQuickCustomization: Boolean; + FPrevPullFocusing: Boolean; + FPrevImmediateEditor: Boolean; + FPrevIncSearch: Boolean; + FPrevMultiSelect: Boolean; + FView: TcxCustomGridTableView; + function GetGrid: TcxBoldExtLookupGrid; +// function GetGridMode: Boolean; + function GetListFieldIndex: Integer; + function GetListFieldItem: TcxCustomGridTableItem; +// procedure SetGridMode(Value: Boolean); + procedure SetListFieldItem(Value: TcxCustomGridTableItem); + procedure SetView(Value: TcxCustomGridTableView); + protected + // IcxBoldEditProperties + procedure SetStoredValue(aValue: Variant; aBoldHandle: TBoldElementHandle; aEdit: TcxCustomEdit; aFollower: TBoldFollower; var aDone: boolean); override; + function CanEdit(aBoldHandle: TBoldElementHandle; aFollower: TBoldFollower): boolean; override; + + procedure CheckListFieldItem; + procedure DeinitializeDataController; override; + procedure FreeNotification(Sender: TComponent); override; + function GetIncrementalFiltering: Boolean; override; + function GetListIndex: Integer; override; + procedure InitializeDataController; override; + procedure LinkView(AView: TcxCustomGridTableView); + function PopupWindowCapturesFocus: Boolean; override; + procedure UnlinkView(AView: TcxCustomGridTableView); + // LookupGrid methods + function GetLookupGridActiveControl: TWinControl; override; + function GetLookupGridCanResize: Boolean; override; + function GetLookupGridColumnCount: Integer; override; + function GetLookupGridControl: TWinControl; override; + function GetLookupGridDataController: TcxCustomDataController; override; + function GetLookupGridVisualAreaPreferredWidth: Integer; override; + function GetLookupGridNearestPopupHeight(AHeight: Integer): Integer; override; + function GetLookupGridPopupHeight(ADropDownRowCount: Integer): Integer; override; + function IsLookupGridMouseOverList(const P: TPoint): Boolean; override; + procedure LookupGridDeinitialize; override; + procedure LookupGridDroppedDown(const AFindStr: string); override; + procedure LookupGridInitEvents(AOnClick, AOnFocusedRowChanged: TNotifyEvent; + AOnCloseUp: TcxLookupGridCloseUpEvent); override; + procedure LookupGridInitialize; override; + procedure LookupGridInitLookAndFeel(ALookAndFeel: TcxLookAndFeel; + AColor: TColor; AFont: TFont); override; + procedure LookupGridLockMouseMove; override; + procedure LookupGridMakeFocusedRowVisible; override; + procedure LookupGridUnlockMouseMove; override; + + procedure BoldLookupGridBeginUpdate; override; + procedure BoldLookupGridEndUpdate; override; + + // DBLookupGrid methods +{ + procedure DBLookupGridBeginUpdate; override; + procedure DBLookupGridCheckColumnByFieldName(const AFieldName: string); override; + procedure DBLookupGridCreateColumnsByFieldNames(const AFieldNames: string); override; + procedure DBLookupGridEndUpdate; override; + function GetDBLookupGridColumnField(AIndex: Integer): TField; override; + function GetDBLookupGridColumnFieldName(AIndex: Integer): string; override; + function GetDBLookupGridColumnIndexByFieldName(const AFieldName: string): Integer; override; +} + function GetBoldLookupGridDataController: TcxBoldDataController; override; + public + constructor Create(AOwner: TPersistent); override; + destructor Destroy; override; + procedure Assign(Source: TPersistent); override; + class function GetContainerClass: TcxContainerClass; override; + class function IsViewSupported(Value: TcxCustomGridTableView): Boolean; + property Grid: TcxBoldExtLookupGrid read GetGrid; + property ListFieldIndex: Integer read GetListFieldIndex; + published + property BoldSelectChangeAction; + property BoldSetValueExpression; + + property Alignment; + property AssignedValues; + property AutoSearchOnPopup: Boolean read FAutoSearchOnPopup write FAutoSearchOnPopup default True; + property AutoSelect; + property ButtonGlyph; + property CaseSensitiveSearch; + property CharCase; + property ClearKey; + property DropDownAutoSize; + property DropDownHeight; + property DropDownListStyle; + property DropDownRows; + property DropDownSizeable; + property DropDownWidth; + property FocusPopup: Boolean read FFocusPopup write FFocusPopup default False; +// property GridMode: Boolean read GetGridMode write SetGridMode default False; + property HideSelection; + property ImeMode; + property ImeName; + property ImmediateDropDown; +// property ImmediatePost; + property IncrementalFiltering; + property IncrementalFilteringOptions; + property View: TcxCustomGridTableView read FView write SetView; // before +// property KeyFieldNames; + property ListFieldItem: TcxCustomGridTableItem read GetListFieldItem write SetListFieldItem; + property MaxLength; + property OEMConvert; + property PopupAlignment; + property PostPopupValueOnTab; + property ReadOnly; + property Revertable; + property UseLeftAlignmentOnEditing; + property ValidateOnEnter; + property OnChange; + property OnCloseUp; + property OnEditValueChanged; + property OnInitPopup; + property OnNewLookupDisplayText; + property OnPopup; + property OnValidate; + end; + + { TcxCustomBoldExtLookupComboBox } + + TcxCustomBoldExtLookupComboBox = class(TcxCustomBoldLookupEdit) + private + function GetActiveProperties: TcxBoldExtLookupComboBoxProperties; + function GetProperties: TcxBoldExtLookupComboBoxProperties; + procedure SetProperties(Value: TcxBoldExtLookupComboBoxProperties); + protected + function CanDropDown: Boolean; override; + public + class function GetPropertiesClass: TcxCustomEditPropertiesClass; override; + property ActiveProperties: TcxBoldExtLookupComboBoxProperties + read GetActiveProperties; + property EditValue; + property Properties: TcxBoldExtLookupComboBoxProperties read GetProperties + write SetProperties; + property Text; + end; + + { TcxBoldNBExtLookupComboBox } + + TcxBoldNBExtLookupComboBox = class(TcxCustomBoldExtLookupComboBox) + published + property Anchors; + property AutoSize; + property BeepOnEnter; + property Constraints; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property ImeMode; + property ImeName; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property Properties; + property EditValue; + property ShowHint; + property Style; + property StyleDisabled; + property StyleFocused; + property StyleHot; + property TabOrder; + property TabStop; + property Visible; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnEditing; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + end; + + { TcxBoldExtLookupComboBox } + + TcxBoldExtLookupComboBox = class(TcxCustomBoldExtLookupComboBox, IBoldValidateableComponent, IBoldOCLComponent) + private + function GetDataBinding: TcxBoldTextEditDataBinding; + procedure SetDataBinding(Value: TcxBoldTextEditDataBinding); +// procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK; + protected + class function GetDataBindingClass: TcxEditDataBindingClass; override; + procedure Initialize; override; + procedure Paint; override; + published + property Anchors; + property AutoSize; + property BeepOnEnter; + property Constraints; + property DragCursor; + property DragKind; + property DataBinding: TcxBoldTextEditDataBinding read GetDataBinding write SetDataBinding implements IBoldValidateableComponent, IBoldOCLComponent; + property DragMode; + property Enabled; + property ImeMode; + property ImeName; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property Properties; + property ShowHint; + property Style; + property StyleDisabled; + property StyleFocused; + property StyleHot; + property TabOrder; + property TabStop; + property Visible; + property OnClick; + property OnContextPopup; + property OnDblClick; + property OnEditing; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + end; + + { TcxEditRepositoryExtLookupComboBoxItem } + + TcxEditRepositoryExtLookupComboBoxItem = class(TcxEditRepositoryItem) + private + function GetProperties: TcxBoldExtLookupComboBoxProperties; + procedure SetProperties(Value: TcxBoldExtLookupComboBoxProperties); + public + class function GetEditPropertiesClass: TcxCustomEditPropertiesClass; override; + published + property Properties: TcxBoldExtLookupComboBoxProperties read GetProperties write SetProperties; + end; + +implementation + +uses + Types, + cxGridFilterHelpers, + BoldSystem, + cxDropDownEdit; + +type + TcxCustomGridTableOptionsBehaviorAccess = class(TcxCustomGridTableOptionsBehavior); + TcxCustomGridTableOptionsViewAccess = class(TcxCustomGridTableOptionsView); + +{ TcxBoldExtLookupGrid } + +procedure TcxBoldExtLookupGrid.DoCancelMode; +begin + FRowPressed := False; + inherited; +end; + +procedure TcxBoldExtLookupGrid.DoCloseUp(AAccept: Boolean); +begin + if AAccept then + View.DataController.SyncSelected(True); + if Assigned(FOnCloseUp) then FOnCloseUp(Self, AAccept); +end; + +function TcxBoldExtLookupGrid.IsDataRow(AHitTest: TcxCustomGridHitTest): Boolean; +begin + Result := (AHitTest is TcxGridRecordHitTest) and + TcxGridRecordHitTest(AHitTest).GridRecord.IsData; +end; + +function TcxBoldExtLookupGrid.GetView: TcxCustomGridTableView; +begin + Result := Levels[0].GridView as TcxCustomGridTableView; +end; + +procedure TcxBoldExtLookupGrid.ViewKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); +begin + if Assigned(FPrevOnKeyDown) then + FPrevOnKeyDown(Self, Key, Shift); + if (View = nil) then Exit; + case Key of + VK_RETURN: + if not Editable or not View.OptionsData.Editing or (ssCtrl in Shift) then + begin + if View.DataController.IsEditing then + View.DataController.Post; + DoCloseUp(View.DataController.FocusedRowIndex <> -1); + end; + VK_ESCAPE: + if Editable and not View.DataController.IsEditing then + DoCloseUp(False); + end; +end; + +procedure TcxBoldExtLookupGrid.ViewMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +var + AHitTest: TcxCustomGridHitTest; +begin + if Assigned(FPrevOnMouseDown) then + FPrevOnMouseDown(Sender, Button, Shift, X, Y); + AHitTest := View.ViewInfo.GetHitTest(X, Y); + if (Button = mbLeft) and IsDataRow(AHitTest) then + begin + if Editable then + begin + if ssDouble in Shift then + DoCloseUp(True); + end + else + FRowPressed := True; + end; +end; + +procedure TcxBoldExtLookupGrid.ViewMouseMove(Sender: TObject; Shift: TShiftState; + X, Y: Integer); +var + AHitTest: TcxCustomGridHitTest; +begin + if Assigned(FPrevOnMouseMove) then + FPrevOnMouseMove(Sender, Shift, X, Y); + if not MouseCapture and PopupMouseMoveLocked then + begin + PopupMouseMoveLocked := False; + Exit; + end; + // Hot Track + if (View = nil) or Editable then Exit; + AHitTest := View.ViewInfo.GetHitTest(X, Y); + if IsDataRow(AHitTest) and ((FMousePos.X <> X) or (FMousePos.Y <> Y)) then + begin + FMousePos.X := X; + FMousePos.Y := Y; + TcxGridRecordHitTest(AHitTest).GridRecord.Focused := True; + end; +end; + +procedure TcxBoldExtLookupGrid.ViewMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +var + AHitTest: TcxCustomGridHitTest; +begin + if Assigned(FPrevOnMouseUp) then + FPrevOnMouseUp(Sender, Button, Shift, X, Y); + AHitTest := View.ViewInfo.GetHitTest(X, Y); + if (Button = mbLeft) and FRowPressed then + DoCloseUp(IsDataRow(AHitTest)); + FRowPressed := False; +end; + +{ TcxBoldExtLookupComboBoxProperties } + +constructor TcxBoldExtLookupComboBoxProperties.Create(AOwner: TPersistent); +begin + inherited Create(AOwner); + FAutoSearchOnPopup := True; +end; + +destructor TcxBoldExtLookupComboBoxProperties.Destroy; +begin + FDestroying := True; + ListFieldItem := nil; + View := nil; + FreeAndNil(FGrid); + inherited Destroy; +end; + +procedure TcxBoldExtLookupComboBoxProperties.Assign(Source: TPersistent); +begin + if Source is TcxBoldExtLookupComboBoxProperties then + begin + BeginUpdate; + try + AutoSearchOnPopup := TcxBoldExtLookupComboBoxProperties(Source).AutoSearchOnPopup; + FocusPopup := TcxBoldExtLookupComboBoxProperties(Source).FocusPopup; + View := nil; //? +// GridMode := TcxBoldExtLookupComboBoxProperties(Source).GridMode; + View := TcxBoldExtLookupComboBoxProperties(Source).View; + inherited Assign(Source); + ListFieldItem := TcxBoldExtLookupComboBoxProperties(Source).ListFieldItem; + finally + EndUpdate; + end + end + else + inherited Assign(Source); +end; + +class function TcxBoldExtLookupComboBoxProperties.GetContainerClass: TcxContainerClass; +begin + Result := TcxBoldNBExtLookupComboBox; +end; + +class function TcxBoldExtLookupComboBoxProperties.IsViewSupported(Value: TcxCustomGridTableView): Boolean; +begin + Result := Value.CanBeLookupList and + (TcxCustomGridView(Value).DataController is TcxBoldDataController); +end; + +procedure TcxBoldExtLookupComboBoxProperties.CheckListFieldItem; +begin + FInCheckListFieldItem := True; + try + if (View <> nil) and (ListFieldItem <> nil) and + (View.IndexOfItem(ListFieldItem) = -1) then + ListFieldItem := nil; + finally + FInCheckListFieldItem := False; + end; +end; + +procedure TcxBoldExtLookupComboBoxProperties.DeinitializeDataController; +begin + inherited DeinitializeDataController; + if DataController <> nil then + DataController.RemoveDataChangeRefCount; +end; + +procedure TcxBoldExtLookupComboBoxProperties.FreeNotification(Sender: TComponent); +begin + inherited FreeNotification(Sender); + if Sender = ListFieldItem then + ListFieldItem := nil; + if Sender = View then + View := nil; +end; + +function TcxBoldExtLookupComboBoxProperties.GetIncrementalFiltering: Boolean; +begin + if FocusPopup then + Result := False + else + Result := inherited GetIncrementalFiltering; +end; + +function TcxBoldExtLookupComboBoxProperties.GetListIndex: Integer; +begin + Result := Self.ListFieldIndex; +end; + +procedure TcxBoldExtLookupComboBoxProperties.InitializeDataController; +begin + inherited InitializeDataController; + if DataController <> nil then + DataController.AddDataChangeRefCount; +end; + +procedure TcxBoldExtLookupComboBoxProperties.LinkView(AView: TcxCustomGridTableView); +begin + CheckListFieldItem; + FreeNotificator.AddSender(AView); + InitializeDataController; +end; + +function TcxBoldExtLookupComboBoxProperties.PopupWindowCapturesFocus: Boolean; +begin + Result := FocusPopup; +end; + +procedure TcxBoldExtLookupComboBoxProperties.UnlinkView(AView: TcxCustomGridTableView); +begin + DeinitializeDataController; + FreeNotificator.RemoveSender(AView); +end; + +// LookupGrid methods + +function TcxBoldExtLookupComboBoxProperties.GetLookupGridActiveControl: TWinControl; +begin + if View <> nil then + Result := View.Site + else + Result := inherited GetLookupGridActiveControl; +end; + +function TcxBoldExtLookupComboBoxProperties.GetLookupGridCanResize: Boolean; +begin + if View <> nil then + Result := not TcxCustomGridTableOptionsViewAccess(View.OptionsView).CellAutoHeight + else + Result := False; +end; + +function TcxBoldExtLookupComboBoxProperties.GetLookupGridColumnCount: Integer; +begin + if View <> nil then + Result := View.ItemCount + else + Result := 0; +end; + +function TcxBoldExtLookupComboBoxProperties.GetLookupGridControl: TWinControl; +begin + Result := Grid; +end; + +function TcxBoldExtLookupComboBoxProperties.GetLookupGridDataController: TcxCustomDataController; +begin + if View <> nil then + Result := View.DataController + else + Result := nil; +end; + +function TcxBoldExtLookupComboBoxProperties.GetLookupGridVisualAreaPreferredWidth: Integer; +begin + Result := 0; + if View <> nil then + View.ViewInfo.GetWidth(Point(MaxInt, MaxInt), Result); +end; + +function TcxBoldExtLookupComboBoxProperties.GetLookupGridNearestPopupHeight(AHeight: Integer): Integer; +begin + if View <> nil then + Result := View.ViewInfo.GetNearestPopupHeight(AHeight, FocusPopup) + else + Result := AHeight; +end; + +function TcxBoldExtLookupComboBoxProperties.GetLookupGridPopupHeight(ADropDownRowCount: Integer): Integer; +begin + if View <> nil then + begin + if FocusPopup and (ADropDownRowCount < 2) then // TODO: Check New Item Row + ADropDownRowCount := 2; + Result := View.ViewInfo.GetPopupHeight(ADropDownRowCount); + end + else + Result := 0; +end; + +function TcxBoldExtLookupComboBoxProperties.IsLookupGridMouseOverList(const P: TPoint): Boolean; +var + AHitTest: TcxCustomGridHitTest; +begin + Result := False; + if View <> nil then + begin + AHitTest := View.ViewInfo.GetHitTest(P); + Result := AHitTest is TcxGridRecordHitTest; + end; +end; + +procedure TcxBoldExtLookupComboBoxProperties.LookupGridDeinitialize; +begin + Grid.Levels[0].GridView := nil; + // restore options + if (View <> nil) and not (csDestroying in View.ComponentState) then + begin + TcxCustomGridTableOptionsBehaviorAccess(View.OptionsBehavior).PullFocusing := FPrevPullFocusing; + View.OptionsSelection.MultiSelect := FPrevMultiSelect; + View.OptionsBehavior.ImmediateEditor := FPrevImmediateEditor; + if View is TcxGridTableView then + begin + TcxGridTableView(View).OptionsCustomize.ColumnFiltering := FPrevColumnFiltering; + TcxGridTableView(View).OptionsCustomize.ColumnsQuickCustomization := FPrevColumnsQuickCustomization; + end; + View.OptionsBehavior.IncSearch := FPrevIncSearch; + View.OnKeyDown := Grid.FPrevOnKeyDown; + View.OnMouseDown := Grid.FPrevOnMouseDown; + View.OnMouseMove := Grid.FPrevOnMouseMove; + View.OnMouseUp := Grid.FPrevOnMouseUp; + end; +end; + +procedure TcxBoldExtLookupComboBoxProperties.LookupGridDroppedDown(const AFindStr: string); +begin + // Init Inc Search + // TODO: !!! + if FocusPopup and AutoSearchOnPopup and (ListFieldItem <> nil) then + begin + ListFieldItem.Focused := True; + View.DataController.Search.Locate(ListFieldItem.Index, AFindStr); + end; +end; + +procedure TcxBoldExtLookupComboBoxProperties.LookupGridInitEvents(AOnClick, AOnFocusedRowChanged: TNotifyEvent; + AOnCloseUp: cxLookupEdit.TcxLookupGridCloseUpEvent); +begin + Grid.OnClick := AOnClick; // not impl + if View <> nil then + begin +// View.OnFocusedRecordChanged := AOnFocusedRowChanged; + Grid.OnCloseUp := AOnCloseUp; + end; +end; + +procedure TcxBoldExtLookupComboBoxProperties.LookupGridInitialize; +begin + if View = nil then + Exit; + // save options + FPrevPullFocusing := TcxCustomGridTableOptionsBehaviorAccess(View.OptionsBehavior).PullFocusing; + TcxCustomGridTableOptionsBehaviorAccess(View.OptionsBehavior).PullFocusing := True; + FPrevMultiSelect := View.OptionsSelection.MultiSelect; + View.OptionsSelection.MultiSelect := False; + FPrevImmediateEditor := View.OptionsBehavior.ImmediateEditor; + View.OptionsBehavior.ImmediateEditor := False; + if View is TcxGridTableView then + begin + FPrevColumnFiltering := TcxGridTableView(View).OptionsCustomize.ColumnFiltering; + FPrevColumnsQuickCustomization := TcxGridTableView(View).OptionsCustomize.ColumnsQuickCustomization; + if not FocusPopup then + begin + TcxGridTableView(View).OptionsCustomize.ColumnFiltering := False; + TcxGridTableView(View).OptionsCustomize.ColumnsQuickCustomization := False; + end; + end; + + Grid.FPrevOnKeyDown := View.OnKeyDown; + View.OnKeyDown := Grid.ViewKeyDown; + + Grid.FPrevOnMouseDown := View.OnMouseDown; + View.OnMouseDown := Grid.ViewMouseDown; + + Grid.FMousePos := Point(-1, -1); + Grid.FPrevOnMouseMove := View.OnMouseMove; + View.OnMouseMove := Grid.ViewMouseMove; + + Grid.FPrevOnMouseUp := View.OnMouseUp; + View.OnMouseUp := Grid.ViewMouseUp; + + Grid.Editable := FocusPopup; + Grid.Levels[0].GridView := View; + + FPrevIncSearch := View.OptionsBehavior.IncSearch; + if FocusPopup and AutoSearchOnPopup then + View.OptionsBehavior.IncSearch := True; + View.DataController.Search.Cancel; +end; + +procedure TcxBoldExtLookupComboBoxProperties.LookupGridInitLookAndFeel(ALookAndFeel: TcxLookAndFeel; + AColor: TColor; AFont: TFont); +begin + Grid.LookAndFeel.MasterLookAndFeel := ALookAndFeel; + Grid.Color := AColor; + Grid.Font := AFont; +end; + +procedure TcxBoldExtLookupComboBoxProperties.LookupGridLockMouseMove; +begin + Grid.PopupMouseMoveLocked := True; +end; + +procedure TcxBoldExtLookupComboBoxProperties.LookupGridMakeFocusedRowVisible; +begin + if View <> nil then + View.Controller.MakeFocusedRecordVisible; +end; + +procedure TcxBoldExtLookupComboBoxProperties.LookupGridUnlockMouseMove; +begin + Grid.MouseCapture := False; + Grid.PopupMouseMoveLocked := False; +end; + +// DBLookupGrid methods +{ +procedure TcxBoldExtLookupComboBoxProperties.DBLookupGridBeginUpdate; +begin + if View <> nil then View.BeginUpdate; +end; + +procedure TcxBoldExtLookupComboBoxProperties.DBLookupGridCheckColumnByFieldName(const AFieldName: string); +begin + if (View <> nil) and (DataController <> nil) then + begin + if (AFieldName <> '') and (DataController.GetItemByFieldName(AFieldName) = nil) then + with View.CreateItem do + begin + Index := 0; + DataController.ChangeFieldName(Index, AFieldName); + end; + end; +end; + +procedure TcxBoldExtLookupComboBoxProperties.DBLookupGridCreateColumnsByFieldNames(const AFieldNames: string); +var + I: Integer; + AFieldNamesList: TStrings; +begin + if View <> nil then + begin + View.ClearItems; + AFieldNamesList := TStringList.Create; + try + GetFieldNames(AFieldNames, AFieldNamesList); + View.BeginUpdate; + try + for I := 0 to AFieldNamesList.Count - 1 do + DataController.ChangeFieldName(View.CreateItem.Index, AFieldNamesList[I]); + finally + View.EndUpdate; + end; + finally + AFieldNamesList.Free; + end; + end; +end; + +procedure TcxBoldExtLookupComboBoxProperties.DBLookupGridEndUpdate; +begin + if View <> nil then View.EndUpdate; +end; + +function TcxBoldExtLookupComboBoxProperties.GetDBLookupGridColumnField(AIndex: Integer): TField; +begin + if DataController <> nil then + Result := DataController.GetItemField(AIndex) + else + Result := nil; +end; + +function TcxBoldExtLookupComboBoxProperties.GetDBLookupGridColumnFieldName(AIndex: Integer): string; +begin + if DataController <> nil then + Result := DataController.GetItemFieldName(AIndex) + else + Result := ''; +end; + +function TcxBoldExtLookupComboBoxProperties.GetDBLookupGridColumnIndexByFieldName(const AFieldName: string): Integer; +var + AItem: TcxCustomGridTableItem; +begin + if DataController <> nil then + begin + AItem := TcxCustomGridTableItem(DataController.GetItemByFieldName(AFieldName)); + Result := AItem.Index; + end + else + Result := -1; +end; + +function TcxBoldExtLookupComboBoxProperties.GetDBLookupGridDataController: TcxDBDataController; +begin + Result := TcxDBDataController(GetLookupGridDataController); +end; +} +function TcxBoldExtLookupComboBoxProperties.GetGrid: TcxBoldExtLookupGrid; + + procedure CreateGrid; + begin + FGrid := TcxBoldExtLookupGrid.Create(nil); + FGrid.IsPopupControl := True; + FGrid.BorderStyle := cxcbsNone; + FGrid.Levels.Add; + end; + +begin + if (FGrid = nil) and not FDestroying then + CreateGrid; + Result := FGrid; +end; + +{function TcxBoldExtLookupComboBoxProperties.GetGridMode: Boolean; +begin + Result := inherited IsUseLookupList; +end;} + +function TcxBoldExtLookupComboBoxProperties.GetListFieldIndex: Integer; +var + AItem: TcxCustomGridTableItem; +begin + if IsDefinedByLookup then + Result := GetDisplayColumnIndex + else + begin + AItem := ListFieldItem; + if AItem <> nil then + Result := AItem.Index + else + Result := -1; + end; +end; + +function TcxBoldExtLookupComboBoxProperties.GetListFieldItem: TcxCustomGridTableItem; +begin + if IsDefinedByLookup then + Result := nil + else + Result := FListFieldItem; +end; + +{procedure TcxBoldExtLookupComboBoxProperties.SetGridMode(Value: Boolean); +begin + inherited IsUseLookupList := Value; +end;} + +procedure TcxBoldExtLookupComboBoxProperties.SetListFieldItem(Value: TcxCustomGridTableItem); +begin + if (View <> nil) and (View.IndexOfItem(Value) = -1) then + Value := nil; + if FListFieldItem <> Value then + begin + if FListFieldItem <> nil then + FreeNotificator.RemoveSender(FListFieldItem); + FListFieldItem := Value; + if FListFieldItem <> nil then + FreeNotificator.AddSender(FListFieldItem); + if not FInCheckListFieldItem then + Changed; + end; +end; + +procedure TcxBoldExtLookupComboBoxProperties.SetView(Value: TcxCustomGridTableView); +begin + if (Value <> nil) and not IsViewSupported(Value) then Exit; + if FView <> Value then + begin + if FView <> nil then + UnlinkView(FView); + FView := Value; + if FView <> nil then + LinkView(FView); + Changed; + end; +end; + +function TcxBoldExtLookupComboBoxProperties.GetBoldLookupGridDataController: TcxBoldDataController; +begin + Result := TcxBoldDataController(GetLookupGridDataController); +end; + +procedure TcxBoldExtLookupComboBoxProperties.SetStoredValue( + aValue: Variant; aBoldHandle: TBoldElementHandle; aEdit: TcxCustomEdit; aFollower: TBoldFollower; var aDone: boolean); +var + lItemIndex: Integer; + lSelectedElement: TBoldElement; +begin +// inherited; +// Assert(aEdit is TcxCustomComboBox, 'TcxBoldLookupComboBoxProperties.SetStoredValue: aEdit is not TcxCustomComboBox;' + aEdit.classname); + +// lItemIndex := (aEdit as TcxCustomComboBox).ItemIndex; +// if TcxCustomComboBox(aEdit).ILookupData.CurrentKey <> null then + if (not VarIsNull(aValue)) and (aValue <> -1) then + begin + lItemIndex := aValue; //TcxCustomComboBox(aEdit).ILookupData.CurrentKey; + + lSelectedElement := GetBoldLookupGridDataController.BoldHandle.List[lItemIndex]; + InternalComboSetValue(aBoldHandle, aFollower, lSelectedElement, BoldSelectChangeAction, BoldSetValueExpression, DataController.BoldHandle, aValue); +{ + Assert(aEdit.EditingValue = aEdit.EditValue); + i := aEdit.EditingValue; + Assert(DataController.CurrentIndex = i); +// (DataController.Follower.Element as TBoldList)[i]. + aFollower.Element.Assign(DataController.CurrentBoldObject); +} + end; + aDone := true; +end; + +procedure TcxBoldExtLookupComboBoxProperties.BoldLookupGridBeginUpdate; +begin + if View <> nil then View.BeginUpdate; +end; + +procedure TcxBoldExtLookupComboBoxProperties.BoldLookupGridEndUpdate; +begin + if View <> nil then View.EndUpdate; +end; + +function TcxBoldExtLookupComboBoxProperties.CanEdit( + aBoldHandle: TBoldElementHandle; aFollower: TBoldFollower): boolean; +begin + result := GetBoldLookupGridDataController.RecordCount > 0; +end; + +{ TcxCustomBoldExtLookupComboBox } + +class function TcxCustomBoldExtLookupComboBox.GetPropertiesClass: TcxCustomEditPropertiesClass; +begin + Result := TcxBoldExtLookupComboBoxProperties; +end; + +function TcxCustomBoldExtLookupComboBox.CanDropDown: Boolean; +begin + if ActiveProperties.FocusPopup then + Result := True + else + Result := inherited CanDropDown; +end; + +function TcxCustomBoldExtLookupComboBox.GetActiveProperties: TcxBoldExtLookupComboBoxProperties; +begin + Result := TcxBoldExtLookupComboBoxProperties(InternalGetActiveProperties); +end; + +function TcxCustomBoldExtLookupComboBox.GetProperties: TcxBoldExtLookupComboBoxProperties; +begin + Result := TcxBoldExtLookupComboBoxProperties(FProperties); +end; + +procedure TcxCustomBoldExtLookupComboBox.SetProperties(Value: TcxBoldExtLookupComboBoxProperties); +begin + FProperties.Assign(Value); +end; + +{ TcxBoldExtLookupComboBox } + +class function TcxBoldExtLookupComboBox.GetDataBindingClass: TcxEditDataBindingClass; +begin + Result := TcxBoldLookupEditDataBinding; +end; + +function TcxBoldExtLookupComboBox.GetDataBinding: TcxBoldTextEditDataBinding; +begin + Result := TcxBoldTextEditDataBinding(FDataBinding); +end; + +procedure TcxBoldExtLookupComboBox.SetDataBinding(Value: TcxBoldTextEditDataBinding); +begin + FDataBinding.Assign(Value); +end; +{ +procedure TcxBoldExtLookupComboBox.CMGetDataLink(var Message: TMessage); +begin + Message.Result := Integer(GetcxDBEditDataLink(Self)); +end; +} + +type + TcxBoldTextEditDataBindingAccess = class(TcxBoldTextEditDataBinding); + +procedure TcxBoldExtLookupComboBox.Paint; +begin + inherited Paint; + if TcxBoldTextEditDataBindingAccess(DataBinding).ValueOrDefinitionInvalid then + Canvas.FrameRect(Bounds, clRed, 2 - Ord(IsNativeStyle)); +end; + +procedure TcxBoldExtLookupComboBox.Initialize; +begin + inherited; + if IsDesigning and not IsLoading then + begin + _ValidateEdit(self); + end; +end; + +{ TcxEditRepositoryExtLookupComboBoxItem } + +class function TcxEditRepositoryExtLookupComboBoxItem.GetEditPropertiesClass: TcxCustomEditPropertiesClass; +begin + Result := TcxBoldExtLookupComboBoxProperties; +end; + +function TcxEditRepositoryExtLookupComboBoxItem.GetProperties: TcxBoldExtLookupComboBoxProperties; +begin + Result := inherited Properties as TcxBoldExtLookupComboBoxProperties; +end; + +procedure TcxEditRepositoryExtLookupComboBoxItem.SetProperties(Value: TcxBoldExtLookupComboBoxProperties); +begin + inherited Properties := Value; +end; + +// TODO: rename TcxEditRepositoryExtLookupComboBoxItem to something unique +{ +initialization + RegisterClasses([TcxEditRepositoryExtLookupComboBoxItem]); + GetRegisteredEditProperties.Register(TcxBoldExtLookupComboBoxProperties, + cxSEditRepositoryExtLookupComboBoxItem); + +finalization + GetRegisteredEditProperties.Unregister(TcxBoldExtLookupComboBoxProperties); +} +end. diff --git a/Source/BoldAwareGUI/BoldDevex/cxBoldLookupComboBox.pas b/Source/BoldAwareGUI/BoldDevex/cxBoldLookupComboBox.pas new file mode 100644 index 00000000..6cff4b4c --- /dev/null +++ b/Source/BoldAwareGUI/BoldDevex/cxBoldLookupComboBox.pas @@ -0,0 +1,655 @@ +unit cxBoldLookupComboBox; + +{$I cxVer.inc} + +// v2.03 - 25 Jan 2011 2007-2011 Daniel Mauric + +interface + +uses +{$IFDEF DELPHI6} + Variants, +{$ENDIF} + Windows, Messages, SysUtils, Classes, Controls, Graphics, + cxClasses, cxContainer, cxCustomData, cxDataStorage, + cxLookAndFeels, cxEdit, + cxEditConsts, cxDropDownEdit, + cxLookupEdit, + cxBoldLookupEdit, + cxLookupGrid, + cxLookupBoldGrid, + cxFilterControlUtils, + + cxGridBoldSupportUnit, + cxBoldEditors, + + BoldListHandleFollower, + BoldComboBox, // TODO: it's only neede for TBoldComboListController, perhaps we can replace it + BoldControlPack, +// BoldStringControlPack, + BoldAbstractListHandle, + BoldElements, + BoldHandles, + BoldComponentValidator; + +type + { TcxBoldLookupComboBoxProperties } + + TcxBoldLookupComboBoxProperties = class(TcxCustomBoldLookupEditProperties) + private + FGrid: TcxCustomLookupBoldGrid; + function GetBoldListHandle: TBoldAbstractListHandle; + function GetGrid: TcxCustomLookupBoldGrid; +// function GetGridMode: Boolean; + function GetListColumns: TcxLookupBoldGridColumns; + function GetListOptions: TcxLookupBoldGridOptions; +// function GetListSource: TDataSource; + function GetOnSortingChanged: TNotifyEvent; +// procedure SetGridMode(Value: Boolean); + procedure SetListColumns(Value: TcxLookupBoldGridColumns); + procedure SetListOptions(Value: TcxLookupBoldGridOptions); +// procedure SetListSource(Value: TDataSource); + procedure SetOnSortingChanged(Value: TNotifyEvent); + procedure SetBoldListHandle(const Value: TBoldAbstractListHandle); + protected + function GetLookupGridClass: TcxCustomLookupBoldGridClass; virtual; + procedure ListOptionsChanged(Sender: TObject); virtual; + // LookupGrid methods + function GetLookupGridColumnCount: Integer; override; + function GetLookupGridControl: TWinControl; override; + function GetLookupGridDataController: TcxCustomDataController; override; + function GetLookupGridVisualAreaPreferredWidth: Integer; override; + function GetLookupGridNearestPopupHeight(AHeight: Integer): Integer; override; + function GetLookupGridPopupHeight(ADropDownRowCount: Integer): Integer; override; + function IsLookupGridMouseOverList(const P: TPoint): Boolean; override; + procedure LookupGridInitEvents(AOnClick, AOnFocusedRowChanged: TNotifyEvent; + AOnCloseUp: cxLookupEdit.TcxLookupGridCloseUpEvent); override; + procedure LookupGridInitLookAndFeel(ALookAndFeel: TcxLookAndFeel; AColor: TColor; AFont: TFont); override; + procedure LookupGridLockMouseMove; override; + procedure LookupGridMakeFocusedRowVisible; override; + procedure LookupGridUnlockMouseMove; override; + // BoldLookupGrid methods + procedure BoldLookupGridBeginUpdate; override; +// procedure BoldLookupGridCheckColumnByFieldName(const AFieldName: string); override; +// procedure BoldLookupGridCreateColumnsByFieldNames(const AFieldNames: string); override; + procedure BoldLookupGridEndUpdate; override; +// function GetBoldLookupGridColumnField(AIndex: Integer): TField; override; +// function GetBoldLookupGridColumnFieldName(AIndex: Integer): string; override; +// function GetBoldLookupGridColumnIndexByFieldName(const AFieldName: string): Integer; override; + function GetBoldLookupGridDataController: TcxBoldDataController; override; + procedure SetStoredValue(aValue: Variant; aBoldHandle: TBoldElementHandle; aEdit: TcxCustomEdit; aFollower: TBoldFollower; var aDone: boolean); override; + function CanEdit(aBoldHandle: TBoldElementHandle; aFollower: TBoldFollower): boolean; override; + public + constructor Create(AOwner: TPersistent); override; + destructor Destroy; override; + procedure Assign(Source: TPersistent); override; + class function GetContainerClass: TcxContainerClass; override; + property Grid: TcxCustomLookupBoldGrid read GetGrid; +// property LookupListFollower: TBoldFollower read GetListFollower; + published + property BoldLookupListHandle: TBoldAbstractListHandle read GetBoldListHandle write SetBoldListHandle; +// property BoldLookupListProperties: TBoldComboListController read fBoldListProperties write SetBoldListProperties; +// property BoldRowProperties: TBoldStringFollowerController read fBoldRowProperties write SetRowProperties; + + property BoldSelectChangeAction; + property BoldSetValueExpression; + + property Alignment; + property AutoSelect; + property AssignedValues; + property ButtonGlyph; + property CaseSensitiveSearch; + property CharCase; + property ClearKey; + property DropDownAutoSize; + property DropDownHeight; + property DropDownListStyle; + property DropDownRows; + property DropDownSizeable; + property DropDownWidth; +// property GridMode: Boolean read GetGridMode write SetGridMode default False; + property HideSelection; + property ImeMode; + property ImeName; + property ImmediateDropDown; +// property ImmediatePost; + property IncrementalFiltering; + property IncrementalFilteringOptions; +// property KeyFieldNames; + property ListColumns: TcxLookupBoldGridColumns read GetListColumns write SetListColumns; +// property ListFieldNames; + property ListFieldIndex; + property ListOptions: TcxLookupBoldGridOptions read GetListOptions write SetListOptions; +// property ListSource: TDataSource read GetListSource write SetListSource; + property MaxLength; + property OEMConvert; + property PopupAlignment; + property PostPopupValueOnTab; + property ReadOnly; + property Revertable; + property UseLeftAlignmentOnEditing; + property ValidateOnEnter; + property OnChange; + property OnCloseUp; + property OnEditValueChanged; + property OnInitPopup; + property OnNewLookupDisplayText; + property OnPopup; + property OnSortingChanged: TNotifyEvent read GetOnSortingChanged write SetOnSortingChanged; + property OnValidate; + end; + + { TcxCustomBoldLookupComboBox } + + TcxCustomBoldLookupComboBox = class(TcxCustomBoldLookupEdit) + private + function GetProperties: TcxBoldLookupComboBoxProperties; + function GetActiveProperties: TcxBoldLookupComboBoxProperties; + procedure SetProperties(Value: TcxBoldLookupComboBoxProperties); + public + class function GetPropertiesClass: TcxCustomEditPropertiesClass; override; + property ActiveProperties: TcxBoldLookupComboBoxProperties + read GetActiveProperties; + property EditValue; + property Properties: TcxBoldLookupComboBoxProperties read GetProperties + write SetProperties; + property Text; + end; + + { TcxBoldLookupComboBox } + + TcxBoldNBLookupComboBox = class(TcxCustomBoldLookupComboBox) + published + property Anchors; + property AutoSize; + property BeepOnEnter; + property Constraints; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property ImeMode; + property ImeName; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property Properties; + property EditValue; + property ShowHint; + property Style; + property StyleDisabled; + property StyleFocused; + property StyleHot; + property TabOrder; + property TabStop; + property Visible; + property OnClick; +{$IFDEF DELPHI5} + property OnContextPopup; +{$ENDIF} + property OnDblClick; + property OnEditing; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + end; + + { TcxBoldLookupComboBox } + + TcxBoldLookupComboBox = class(TcxCustomBoldLookupComboBox, IBoldValidateableComponent, IBoldOCLComponent) + private + function GetDataBinding: TcxBoldTextEditDataBinding; + procedure SetDataBinding(Value: TcxBoldTextEditDataBinding); +// procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK; + protected + class function GetDataBindingClass: TcxEditDataBindingClass; override; + procedure Initialize; override; + procedure Paint; override; + published + property Anchors; + property AutoSize; + property BeepOnEnter; + property Constraints; + property DragCursor; + property DragKind; + property DataBinding: TcxBoldTextEditDataBinding read GetDataBinding write SetDataBinding implements IBoldValidateableComponent, IBoldOCLComponent; + property DragMode; + property Enabled; + property ImeMode; + property ImeName; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property Properties; + property ShowHint; + property Style; + property StyleDisabled; + property StyleFocused; + property StyleHot; + property TabOrder; + property TabStop; + property Visible; + property OnClick; +{$IFDEF DELPHI5} + property OnContextPopup; +{$ENDIF} + property OnDblClick; + property OnEditing; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + end; + + { TcxBoldFilterLookupComboBoxHelper } + + TcxBoldFilterLookupComboBoxHelper = class(TcxFilterComboBoxHelper) + protected + class function IsIDefaultValuesProviderNeeded( + AEditProperties: TcxCustomEditProperties): Boolean; override; + public + class function GetFilterEditClass: TcxCustomEditClass; override; + class procedure GetFilterValue(AEdit: TcxCustomEdit; AEditProperties: TcxCustomEditProperties; + var V: Variant; var S: TCaption); override; + class function GetSupportedFilterOperators( + AProperties: TcxCustomEditProperties; + AValueTypeClass: TcxValueTypeClass; + AExtendedSet: Boolean = False): TcxFilterControlOperators; override; + class procedure InitializeProperties(AProperties, + AEditProperties: TcxCustomEditProperties; AHasButtons: Boolean); override; + class function IsValueValid(AValueTypeClass: TcxValueTypeClass; + var Value: Variant): Boolean; override; + end; + +implementation + +uses + cxTextEdit, + + BoldSystem, + BoldQueue; + +type + TControlAccess = class(TControl); + +{ TcxBoldLookupComboBoxProperties } + +constructor TcxBoldLookupComboBoxProperties.Create(AOwner: TPersistent); +//var +// lMatchObject: TComponent; +begin + inherited Create(AOwner); +{ if aOwner is TComponent then + lMatchObject := aOwner as TComponent + else + lMatchObject := nil; +} + FGrid := GetLookupGridClass.Create(nil); + FGrid.IsPopupControl := True; + FGrid.Options.OnChanged := ListOptionsChanged; + InitializeDataController; +end; + +destructor TcxBoldLookupComboBoxProperties.Destroy; +begin + DeinitializeDataController; + FGrid.Free; + FGrid := nil; + inherited Destroy; +end; + +procedure TcxBoldLookupComboBoxProperties.Assign(Source: TPersistent); +begin + if Source is TcxBoldLookupComboBoxProperties then + begin + BeginUpdate; + try +// GridMode := TcxBoldLookupComboBoxProperties(Source).GridMode; + ListOptions := TcxBoldLookupComboBoxProperties(Source).ListOptions; + if not IsDefinedByLookup then + begin + BoldSetValueExpression := TcxBoldLookupComboBoxProperties(Source).BoldSetValueExpression; + BoldSelectChangeAction := TcxBoldLookupComboBoxProperties(Source).BoldSelectChangeAction; + BoldLookupListHandle := TcxBoldLookupComboBoxProperties(Source).BoldLookupListHandle; +// ListSource := TcxBoldLookupComboBoxProperties(Source).ListSource; + ListColumns := TcxBoldLookupComboBoxProperties(Source).ListColumns; + end; + OnSortingChanged := TcxBoldLookupComboBoxProperties(Source).OnSortingChanged; + inherited Assign(Source); + if IsDefinedByLookup then + ListColumns := TcxBoldLookupComboBoxProperties(Source).ListColumns; + // DisplayAll is needed to make sure DataController is up to date, + // otherwise it will get updated in next onIdle and by then it will be too late and it will be interpreted as a modification + TBoldQueueable.DisplayAll; + finally + EndUpdate; + end + end + else + inherited Assign(Source); +end; + +class function TcxBoldLookupComboBoxProperties.GetContainerClass: TcxContainerClass; +begin + Result := TcxBoldLookupComboBox; +end; + +function TcxBoldLookupComboBoxProperties.GetLookupGridClass: TcxCustomLookupBoldGridClass; +begin + Result := TcxCustomLookupBoldGrid; +end; + +procedure TcxBoldLookupComboBoxProperties.ListOptionsChanged(Sender: TObject); +begin + Changed; +end; + +// LookupGrid + +function TcxBoldLookupComboBoxProperties.GetLookupGridColumnCount: Integer; +begin + Result := ListColumns.Count; +end; + +function TcxBoldLookupComboBoxProperties.GetLookupGridControl: TWinControl; +begin + Result := Grid; +end; + +function TcxBoldLookupComboBoxProperties.GetLookupGridDataController: TcxCustomDataController; +begin + Result := Grid.DataController; +end; + +function TcxBoldLookupComboBoxProperties.GetLookupGridVisualAreaPreferredWidth: Integer; +var + I: Integer; +begin + Result := 0; + for I := 0 to ListColumns.Count - 1 do + Inc(Result, ListColumns[I].Width); +end; + +function TcxBoldLookupComboBoxProperties.GetLookupGridNearestPopupHeight( + AHeight: Integer): Integer; +begin + Result := Grid.GetNearestPopupHeight(AHeight); +end; + +function TcxBoldLookupComboBoxProperties.GetLookupGridPopupHeight(ADropDownRowCount: Integer): Integer; +begin + Result := Grid.GetPopupHeight(ADropDownRowCount); +end; + +function TcxBoldLookupComboBoxProperties.IsLookupGridMouseOverList(const P: TPoint): Boolean; +begin + Result := Grid.IsMouseOverList(P); +end; + +procedure TcxBoldLookupComboBoxProperties.LookupGridInitEvents(AOnClick, AOnFocusedRowChanged: TNotifyEvent; + AOnCloseUp: cxLookupEdit.TcxLookupGridCloseUpEvent); +begin + Grid.OnClick := AOnClick; + Grid.OnFocusedRowChanged := AOnFocusedRowChanged; + Grid.OnCloseUp := AOnCloseUp; +end; + +procedure TcxBoldLookupComboBoxProperties.LookupGridInitLookAndFeel(ALookAndFeel: TcxLookAndFeel; + AColor: TColor; AFont: TFont); +begin + Grid.LookAndFeel.MasterLookAndFeel := ALookAndFeel; + Grid.Color := AColor; + Grid.Font := AFont; +end; + +procedure TcxBoldLookupComboBoxProperties.LookupGridLockMouseMove; +begin + Grid.LockPopupMouseMove; +end; + +procedure TcxBoldLookupComboBoxProperties.LookupGridMakeFocusedRowVisible; +begin + Grid.MakeFocusedRowVisible; +end; + +procedure TcxBoldLookupComboBoxProperties.LookupGridUnlockMouseMove; +begin + TControlAccess(Grid).MouseCapture := False; +end; + +// BoldLookupGrid + +procedure TcxBoldLookupComboBoxProperties.BoldLookupGridBeginUpdate; +begin + Grid.BeginUpdate; +end; + +procedure TcxBoldLookupComboBoxProperties.BoldLookupGridEndUpdate; +begin + Grid.EndUpdate; +end; + +function TcxBoldLookupComboBoxProperties.GetBoldLookupGridDataController: TcxBoldDataController; +begin + if Grid <> nil then + Result := Grid.DataController + else + Result := nil; +end; + +function TcxBoldLookupComboBoxProperties.GetGrid: TcxCustomLookupBoldGrid; +begin + Result := FGrid; +end; + +{function TcxBoldLookupComboBoxProperties.GetGridMode: Boolean; +begin + Result := inherited IsUseLookupList; +end;} + +function TcxBoldLookupComboBoxProperties.GetListColumns: TcxLookupBoldGridColumns; +begin + Result := Grid.Columns; +end; + +function TcxBoldLookupComboBoxProperties.GetListOptions: TcxLookupBoldGridOptions; +begin + Result := Grid.Options; +end; + +function TcxBoldLookupComboBoxProperties.GetOnSortingChanged: TNotifyEvent; +begin + Result := Grid.DataController.OnSortingChanged; +end; + +{procedure TcxBoldLookupComboBoxProperties.SetGridMode(Value: Boolean); +begin + inherited IsUseLookupList := Value; +end;} + +procedure TcxBoldLookupComboBoxProperties.SetListColumns(Value: TcxLookupBoldGridColumns); +begin + Grid.Columns := Value; // TODO: recreate? + CheckLookupColumn; + CheckDisplayColumnIndex; +end; + +procedure TcxBoldLookupComboBoxProperties.SetListOptions(Value: TcxLookupBoldGridOptions); +begin + Grid.Options := Value; +end; + +procedure TcxBoldLookupComboBoxProperties.SetOnSortingChanged(Value: TNotifyEvent); +begin + Grid.DataController.OnSortingChanged := Value; +end; + +function TcxBoldLookupComboBoxProperties.GetBoldListHandle: TBoldAbstractListHandle; +begin + result := DataController.BoldHandle; +end; + +procedure TcxBoldLookupComboBoxProperties.SetBoldListHandle( + const Value: TBoldAbstractListHandle); +begin + DataController.BoldHandle := Value; +end; + +procedure TcxBoldLookupComboBoxProperties.SetStoredValue( + aValue: Variant; aBoldHandle: TBoldElementHandle; aEdit: TcxCustomEdit; aFollower: TBoldFollower; var aDone: boolean); +var + lItemIndex: Integer; + lSelectedElement: TBoldElement; +begin +// inherited; + +// if TcxCustomComboBox(aEdit).ILookupData.CurrentKey <> null then + if (not VarIsNull(aValue)) and (aValue <> -1) then + begin + lItemIndex := aValue; //(aEdit as TcxCustomComboBox).ItemIndex; + lSelectedElement := DataController.BoldHandle.List[lItemIndex]; //(DataController.Follower.Element as TBoldList)[lItemIndex]; + + InternalComboSetValue(aBoldHandle, aFollower, lSelectedElement, BoldSelectChangeAction, BoldSetValueExpression, BoldLookupListHandle, AValue); + // aEdit.EditModified := false + end; + aDone := true; +end; + +function TcxBoldLookupComboBoxProperties.CanEdit( + aBoldHandle: TBoldElementHandle; aFollower: TBoldFollower): boolean; +begin + result := Assigned(BoldLookupListHandle) and (BoldLookupListHandle.Count > 0); +end; + +{ TcxCustomBoldLookupComboBox } + +class function TcxCustomBoldLookupComboBox.GetPropertiesClass: TcxCustomEditPropertiesClass; +begin + Result := TcxBoldLookupComboBoxProperties; +end; + +function TcxCustomBoldLookupComboBox.GetProperties: TcxBoldLookupComboBoxProperties; +begin + Result := TcxBoldLookupComboBoxProperties(FProperties); +end; + +function TcxCustomBoldLookupComboBox.GetActiveProperties: TcxBoldLookupComboBoxProperties; +begin + Result := TcxBoldLookupComboBoxProperties(InternalGetActiveProperties); +end; + +procedure TcxCustomBoldLookupComboBox.SetProperties(Value: TcxBoldLookupComboBoxProperties); +begin + FProperties.Assign(Value); +end; + +{ TcxBoldLookupComboBox } + +class function TcxBoldLookupComboBox.GetDataBindingClass: TcxEditDataBindingClass; +begin + Result := TcxBoldLookupEditDataBinding; +end; + +function TcxBoldLookupComboBox.GetDataBinding: TcxBoldTextEditDataBinding; +begin + Result := TcxBoldTextEditDataBinding(FDataBinding); +end; + +procedure TcxBoldLookupComboBox.SetDataBinding(Value: TcxBoldTextEditDataBinding); +begin + FDataBinding.Assign(Value); +end; + +{procedure TcxBoldLookupComboBox.CMGetDataLink(var Message: TMessage); +begin + Message.Result := Integer(GetcxDBEditDataLink(Self)); +end;} + +type + TcxBoldTextEditDataBindingAccess = class(TcxBoldTextEditDataBinding); + +procedure TcxBoldLookupComboBox.Paint; +begin + inherited Paint; + if TcxBoldTextEditDataBindingAccess(DataBinding).ValueOrDefinitionInvalid then + Canvas.FrameRect(Bounds, clRed, 2 - Ord(IsNativeStyle)); +end; + +procedure TcxBoldLookupComboBox.Initialize; +begin + inherited; + if IsDesigning and not IsLoading then + begin + _ValidateEdit(self); + end; +end; + +{ TcxBoldFilterLookupComboBoxHelper } + +class function TcxBoldFilterLookupComboBoxHelper.GetFilterEditClass: TcxCustomEditClass; +begin + Result := TcxBoldLookupComboBox; +end; + +class procedure TcxBoldFilterLookupComboBoxHelper.GetFilterValue(AEdit: TcxCustomEdit; + AEditProperties: TcxCustomEditProperties; var V: Variant; var S: TCaption); +begin + V := AEdit.EditValue; + S := TcxCustomTextEdit(AEdit).ILookupData.GetDisplayText(V); +end; + +class function TcxBoldFilterLookupComboBoxHelper.GetSupportedFilterOperators( + AProperties: TcxCustomEditProperties; + AValueTypeClass: TcxValueTypeClass; + AExtendedSet: Boolean = False): TcxFilterControlOperators; +begin + Result := [fcoEqual, fcoNotEqual, fcoBlanks, fcoNonBlanks]; +end; + +class procedure TcxBoldFilterLookupComboBoxHelper.InitializeProperties(AProperties, + AEditProperties: TcxCustomEditProperties; AHasButtons: Boolean); +begin + inherited InitializeProperties(AProperties, AEditProperties, AHasButtons); + with TcxCustomLookupEditProperties(AProperties) do + begin + DropDownAutoSize := True; + DropDownListStyle := lsFixedList; + DropDownSizeable := True; + IncrementalFiltering := True; + end; +end; + +class function TcxBoldFilterLookupComboBoxHelper.IsValueValid(AValueTypeClass: TcxValueTypeClass; + var Value: Variant): Boolean; +begin + Result := True; +end; + +class function TcxBoldFilterLookupComboBoxHelper.IsIDefaultValuesProviderNeeded( + AEditProperties: TcxCustomEditProperties): Boolean; +begin + Result := TcxCustomBoldLookupEditProperties(AEditProperties).IsDefinedByLookup; +end; + +initialization +// scxSEditRepositoryLookupComboBoxItem = 'LookupComboBox|Represents a lookup combo box control'; +// InternalAdd('scxSEditRepositoryLookupComboBoxItem', @scxSEditRepositoryLookupComboBoxItem); +// TODO: extract sting to a resourcestring like above + GetRegisteredEditProperties.Register(TcxBoldLookupComboBoxProperties, 'BoldLookupComboBox|Represents a bold aware lookup combo box control'); + FilterEditsController.Register(TcxBoldLookupComboBoxProperties, TcxBoldFilterLookupComboBoxHelper); + +finalization + FilterEditsController.Unregister(TcxBoldLookupComboBoxProperties, TcxBoldFilterLookupComboBoxHelper); + +end. diff --git a/Source/BoldAwareGUI/BoldDevex/cxBoldLookupEdit.pas b/Source/BoldAwareGUI/BoldDevex/cxBoldLookupEdit.pas new file mode 100644 index 00000000..549049c2 --- /dev/null +++ b/Source/BoldAwareGUI/BoldDevex/cxBoldLookupEdit.pas @@ -0,0 +1,804 @@ +unit cxBoldLookupEdit; + +interface + +// v2.03 - 25 Jan 2011 2007-2011 Daniel Mauric + +uses + classes, + cxLookupEdit, + cxDataStorage, + cxClasses, + cxEdit, + cxContainer, + cxBoldEditors, + cxGridBoldSupportUnit, + dxCoreClasses, + + BoldElements, + BoldControlPack, + BoldControlsDefs, + BoldDefs, + BoldHandles, + BoldComponentValidator; + +type + TcxCustomBoldLookupEditProperties = class; + + { TcxCustomBoldLookupEditLookupData } + + TcxCustomBoldLookupEditLookupData = class(TcxCustomLookupEditLookupData) + private +// fCurrentElement: TBoldElement; // ? + function GetDataController: TcxBoldDataController; + function GetProperties: TcxCustomBoldLookupEditProperties; + protected + procedure DoSetCurrentKey(ARecordIndex: Integer); override; + procedure DoSyncGrid; override; + property DataController: TcxBoldDataController read GetDataController; + property Properties: TcxCustomBoldLookupEditProperties read GetProperties; + end; + + { TcxCustomBoldLookupEditProperties } + + TcxCustomBoldLookupEditProperties = class(TcxCustomLookupEditProperties, IcxBoldEditProperties, IBoldValidateableComponent) + private +// FCachedLookupSource: TDataSource; + FCaseSensitiveSearch: Boolean; + FLockGridModeCount: Integer; +// FLookupField: TField; +// FLookupList: TcxLookupList; +// FLookupSource: TDataSource; +// FSyncLookup: Boolean; + fBoldSelectChangeAction: TBoldComboSelectChangeAction; + fBoldSetValueExpression: TBoldExpression; +// function GetIsUseLookupList: Boolean; +// function GetKeyFieldNames: string; +// function GetListField: TField; + function GetListFieldIndex: Integer; +// function GetListFieldNames: string; +// procedure SetIsUseLookupList(Value: Boolean); + procedure SetBoldSelectChangeAction( + const Value: TBoldComboSelectChangeAction); +// procedure SetKeyFieldNames(const Value: string); + procedure SetListFieldIndex(Value: Integer); + procedure SetBoldSetValueExpression(const Value: TBoldExpression); +// procedure SetListFieldNames(const Value: string); + protected + // IcxBoldEditProperties + procedure SetStoredValue(aValue: Variant; aBoldHandle: TBoldElementHandle; aEdit: TcxCustomEdit; aFollower: TBoldFollower; var aDone: boolean); virtual; + function BoldElementToEditValue(aFollower: TBoldFollower; aElement: TBoldElement; aEdit: TcxCustomEdit): variant; + function CanEdit(aBoldHandle: TBoldElementHandle; aFollower: TBoldFollower): boolean; virtual; + // IBoldValidateableComponent + function ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: string): Boolean; + // BoldLookupGrid methods + procedure BoldLookupGridBeginUpdate; virtual; +// procedure BoldLookupGridCheckColumnByFieldName(const AFieldName: string); virtual; // if a column does not exist, then create it with zero index +// procedure BoldLookupGridCreateColumnsByFieldNames(const AFieldNames: string); virtual; + procedure BoldLookupGridEndUpdate; virtual; +// function GetBoldLookupGridColumnField(AIndex: Integer): TField; virtual; +// function GetBoldLookupGridColumnFieldName(AIndex: Integer): string; virtual; +// function GetBoldLookupGridColumnIndexByFieldName(const AFieldName: string): Integer; virtual; + function GetBoldLookupGridDataController: TcxBoldDataController; virtual; + + function CanDisplayArbitraryEditValue: Boolean; + procedure CheckLookup; virtual; + procedure CheckLookupColumn; virtual; +// procedure CheckLookupList; + procedure DefaultValuesProviderDestroyed; override; + procedure DefineByLookupError; + procedure DoChanged; override; + function GetAlwaysPostEditValue: Boolean; override; + function FindByText(AItemIndex: Integer; const AText: string; APartialCompare: Boolean): Integer; override; + function GetDisplayColumnIndex: Integer; override; + function GetDisplayLookupText(const AKey: TcxEditValue): string; override; + function GetDefaultHorzAlignment: TAlignment; override; + function GetDefaultMaxLength: Integer; override; + function GetIncrementalFiltering: Boolean; override; + function GetKeyByRecordIndex(ARecordIndex: Integer): Variant; + class function GetLookupDataClass: TcxInterfacedPersistentClass; override; +// function GetLookupResultFieldName: string; + function GetNullKey: Variant; override; + function GetRecordIndexByKey(const AKey: Variant): Integer; + function IsPickMode: Boolean; override; + procedure LockDataChanged; override; + procedure LookupSourceFreeNotification(Sender: TComponent); virtual; + procedure SetDisplayColumnIndex(Value: Integer); override; +// procedure SetLookupField(ALookupField: TField); + procedure UnlockDataChanged; override; +// property InSyncLookup: Boolean read FSyncLookup; +// property IsUseLookupList: Boolean read GetIsUseLookupList write SetIsUseLookupList; + public + constructor Create(AOwner: TPersistent); override; + destructor Destroy; override; + procedure Assign(Source: TPersistent); override; + class function GetContainerClass: TcxContainerClass; override; +// function GetDataField: TField; +// function GetEditValueSource(AEditFocused: Boolean): TcxDataEditValueSource; override; +// function GetLookupField: TField; +// function IsLookupField: Boolean; override; + procedure PrepareDisplayValue(const AEditValue: TcxEditValue; + var DisplayValue: TcxEditValue; AEditFocused: Boolean); override; + property CaseSensitiveSearch: Boolean read FCaseSensitiveSearch + write FCaseSensitiveSearch default False; + property DataController: TcxBoldDataController read GetBoldLookupGridDataController; +// property KeyFieldNames: string read GetKeyFieldNames write SetKeyFieldNames; +// property ListField: TField read GetListField; +// property ListFieldNames: string read GetListFieldNames write SetListFieldNames stored False; + property ListFieldIndex: Integer read GetListFieldIndex write SetListFieldIndex default 0; + +// property BoldRowProperties: TBoldStringFollowerController read fBoldRowProperties write SetRowProperties; + property BoldSelectChangeAction: TBoldComboSelectChangeAction read fBoldSelectChangeAction write SetBoldSelectChangeAction default bdcsSetValue; + property BoldSetValueExpression: TBoldExpression read fBoldSetValueExpression write SetBoldSetValueExpression; + end; + + { TcxCustomBoldLookupEdit } + + TcxCustomBoldLookupEdit = class(TcxCustomLookupEdit) + private + function GetProperties: TcxCustomBoldLookupEditProperties; + function GetActiveProperties: TcxCustomBoldLookupEditProperties; + procedure SetProperties(Value: TcxCustomBoldLookupEditProperties); + protected + function GetClearValue: TcxEditValue; override; + function IsValidChar(AChar: Char): Boolean; override; + function ItemIndexToLookupKey(AItemIndex: Integer): TcxEditValue; override; + function LookupKeyToEditValue(const AKey: TcxEditValue): TcxEditValue; override; +// function LookupKeyToItemIndex(const AKey: TcxEditValue): Integer; override; + procedure PopupWindowClosed(Sender: TObject); override; + procedure PrepareDisplayValue(const AEditValue: TcxEditValue; + var DisplayValue: TcxEditValue; AEditFocused: Boolean); override; + public + class function GetPropertiesClass: TcxCustomEditPropertiesClass; override; + property ActiveProperties: TcxCustomBoldLookupEditProperties + read GetActiveProperties; + property Properties: TcxCustomBoldLookupEditProperties read GetProperties + write SetProperties; + end; + + { TcxBoldLookupEditDataBinding } + + TcxBoldLookupEditDataBinding = class(TcxBoldTextEditDataBinding) + protected + function IsLookupControl: Boolean; override; + end; + +implementation + +uses +{$IFDEF DELPHI6} + VDBConsts, +{$ENDIF} + Contnrs, + cxDropDownEdit, + Variants, + SysUtils, + + BoldSystem; + +{ TcxCustomBoldLookupEditLookupData } + +procedure TcxCustomBoldLookupEditLookupData.DoSetCurrentKey(ARecordIndex: Integer); +begin + FCurrentKey := Properties.GetKeyByRecordIndex(ARecordIndex); +end; + +type + TcxCustomEditAccess = Class(TcxCustomEdit) + end; + +procedure TcxCustomBoldLookupEditLookupData.DoSyncGrid; +var + lcxBoldEditDataBinding: TcxBoldEditDataBinding; + lBoldElement: TBoldElement; +begin + if Edit is TcxCustomEdit and (TcxCustomEditAccess(Edit).DataBinding is TcxBoldEditDataBinding) then + begin + lcxBoldEditDataBinding := TcxCustomEditAccess(Edit).DataBinding as TcxBoldEditDataBinding; + lBoldElement := lcxBoldEditDataBinding.Follower.Element; + if Assigned(DataController) and Assigned(lBoldElement) and (DataController.Follower.Element is TBoldList) then + begin + Properties.LockDataChanged; + try + DataController.RecNo := (DataController.Follower.Element as TBoldList).IndexOf(lBoldElement); + finally + Properties.UnlockDataChanged; + end; + end; + end; +// DataController.Follower.Element. +{ if DataController <> nil then + try + Properties.LockDataChanged; + try + DataController.LocateByKey(GetCurrentKey); + finally + Properties.UnlockDataChanged; + end; + except + on EVariantError do; + on EDatabaseError do; + end; +} +end; + +function TcxCustomBoldLookupEditLookupData.GetDataController: TcxBoldDataController; +begin + Result := Properties.DataController; +end; + +function TcxCustomBoldLookupEditLookupData.GetProperties: TcxCustomBoldLookupEditProperties; +begin + Result := TcxCustomBoldLookupEditProperties(inherited Properties); +end; + +{ TcxCustomBoldLookupEditProperties } + +constructor TcxCustomBoldLookupEditProperties.Create(AOwner: TPersistent); +begin + inherited; + BoldSelectChangeAction := bdcsSetValue; +end; + +destructor TcxCustomBoldLookupEditProperties.Destroy; +begin +// SetLookupField(nil); +// FLookupList.Free; +// FLookupList := nil; +// FreeAndNil(FCachedLookupSource); + inherited Destroy; +end; + +procedure TcxCustomBoldLookupEditProperties.Assign(Source: TPersistent); +begin + if Source is TcxCustomBoldLookupEditProperties then + begin + BeginUpdate; + try + inherited Assign(Source); + CaseSensitiveSearch := TcxCustomBoldLookupEditProperties(Source).CaseSensitiveSearch; +// if not IsDefinedByLookup then +// KeyFieldNames := TcxCustomBoldLookupEditProperties(Source).KeyFieldNames; + finally + EndUpdate; + end + end + else + inherited Assign(Source); +end; + +class function TcxCustomBoldLookupEditProperties.GetContainerClass: TcxContainerClass; +begin +// result := inherited GetContainerClass; + Result := TcxCustomBoldLookupEdit; +end; +{ +function TcxCustomBoldLookupEditProperties.GetDataField: TField; +var + ADefaultValuesProvider: TcxCustomEditDefaultValuesProvider; +begin + Result := nil; + if IDefaultValuesProvider <> nil then + begin + ADefaultValuesProvider := TcxCustomEditDefaultValuesProvider(IDefaultValuesProvider.GetInstance); + if ADefaultValuesProvider is TcxCustomDBEditDefaultValuesProvider then + Result := TcxCustomDBEditDefaultValuesProvider(ADefaultValuesProvider).Field; + end; +end; +} +{ +function TcxCustomBoldLookupEditProperties.GetEditValueSource(AEditFocused: Boolean): TcxDataEditValueSource; +begin + if GetLookupField <> nil then + begin + if AEditFocused then + Result := evsKey + else + Result := evsText; + end + else + Result := inherited GetEditValueSource(AEditFocused); +end; +} +{ +function TcxCustomBoldLookupEditProperties.GetLookupField: TField; +begin + Result := GetDataField; + if (Result <> nil) and (not Result.Lookup or (csDestroying in Result.ComponentState)) then + Result := nil; +end; + +function TcxCustomBoldLookupEditProperties.IsLookupField: Boolean; +begin + Result := GetLookupField <> nil; +end; +} +procedure TcxCustomBoldLookupEditProperties.PrepareDisplayValue( + const AEditValue: TcxEditValue; var DisplayValue: TcxEditValue; + AEditFocused: Boolean); +var + lRecordIndex, lItemIndex: integer; +begin + lRecordIndex := GetRecordIndexByKey(AEditValue); + lItemIndex := GetListIndex; + if (lItemIndex <> -1) and (lRecordIndex <> -1) then + begin + DisplayValue := DataController.Values[lRecordIndex, lItemIndex]; + if VarIsNull(DisplayValue) then + begin + DisplayValue := DataController.Values[lRecordIndex, lItemIndex]; + if VarIsNull(DisplayValue) then + DisplayValue := ''; + end; + end + else + inherited PrepareDisplayValue(AEditValue, DisplayValue, AEditFocused); +end; + +procedure TcxCustomBoldLookupEditProperties.BoldLookupGridBeginUpdate; +begin +end; +{ +procedure TcxCustomBoldLookupEditProperties.BoldLookupGridCheckColumnByFieldName(const AFieldName: string); +begin +end; + +procedure TcxCustomBoldLookupEditProperties.BoldLookupGridCreateColumnsByFieldNames(const AFieldNames: string); +begin +end; +} +procedure TcxCustomBoldLookupEditProperties.BoldLookupGridEndUpdate; +begin +end; +{ +function TcxCustomBoldLookupEditProperties.GetBoldLookupGridColumnField(AIndex: Integer): TField; +begin + Result := nil; +end; +} +{ +function TcxCustomBoldLookupEditProperties.GetBoldLookupGridColumnFieldName(AIndex: Integer): string; +begin + Result := ''; +end; + +function TcxCustomBoldLookupEditProperties.GetBoldLookupGridColumnIndexByFieldName(const AFieldName: string): Integer; +begin + Result := -1; +end; +} +function TcxCustomBoldLookupEditProperties.GetAlwaysPostEditValue: Boolean; +begin + result := true; +end; + +function TcxCustomBoldLookupEditProperties.GetBoldLookupGridDataController: TcxBoldDataController; +begin + Result := nil; +end; + +function TcxCustomBoldLookupEditProperties.CanDisplayArbitraryEditValue: Boolean; +//var +// AKeyField: TField; +begin + Result := DropDownListStyle = lsEditList; +{ + Result := False; // TODO: method in DataController? + if (KeyFieldNames <> '') and not IsMultipleFieldNames(KeyFieldNames) and + (DataController <> nil) and (DataController.DataSet <> nil) then + begin + AKeyField := DataController.DataSet.FindField(KeyFieldNames); + if AKeyField <> nil then + Result := (AKeyField = GetListField) and + ((DropDownListStyle = lsEditList) or (AKeyField is TStringField)); + end; +} +end; + +procedure TcxCustomBoldLookupEditProperties.CheckLookup; +begin +// Assert(false); +// SetLookupField(GetLookupField); +// CheckListSource; +end; + +procedure TcxCustomBoldLookupEditProperties.CheckLookupColumn; +//var +// AFieldName: string; +begin +// Assert(false); +// AFieldName := GetLookupResultFieldName; +// if AFieldName <> '' then +// BoldLookupGridCheckColumnByFieldName(AFieldName); +end; + +{procedure TcxCustomBoldLookupEditProperties.CheckLookupList; +begin + if FLookupList <> nil then + FLookupList.Clear; +// if (DataController <> nil) then +// DataController.DataModeController.GridMode := IsUseLookupList; +end;} + +procedure TcxCustomBoldLookupEditProperties.DefaultValuesProviderDestroyed; +begin + inherited DefaultValuesProviderDestroyed; + BeginUpdate; + try + Changed; + finally + EndUpdate(False); + end; +end; + +procedure TcxCustomBoldLookupEditProperties.DefineByLookupError; +begin + Assert(false); +// DatabaseError(SPropDefByLookup); +end; + +procedure TcxCustomBoldLookupEditProperties.DoChanged; +begin +// CheckLookupList; + CheckLookup; + CheckLookupColumn; + inherited; + + if (owner is TcxCustomEdit) and TcxCustomEdit(owner).IsDesigning and not TcxCustomEdit(owner).IsLoading and Assigned(TcxCustomEditAccess(owner).FDataBinding) then + begin + _ValidateEdit(TcxCustomEdit(owner)); + end; +end; + +function TcxCustomBoldLookupEditProperties.IsPickMode: Boolean; +begin + Result := (DropDownListStyle = lsEditList) and CanDisplayArbitraryEditValue; +end; + +procedure TcxCustomBoldLookupEditProperties.LockDataChanged; +begin + inherited LockDataChanged; + // TODO: if GridMode + if (DataController <> nil) and DataController.IsGridMode then + Inc(FLockGridModeCount); + if FLockGridModeCount <> 0 then + DataController.LockGridModeNotify; +end; + +procedure TcxCustomBoldLookupEditProperties.LookupSourceFreeNotification(Sender: TComponent); +begin + CheckLookup; +end; + +procedure TcxCustomBoldLookupEditProperties.SetDisplayColumnIndex(Value: Integer); +begin + if IsDefinedByLookup then + DefineByLookupError; + inherited SetDisplayColumnIndex(Value); +end; + +procedure TcxCustomBoldLookupEditProperties.UnlockDataChanged; +begin + if FLockGridModeCount <> 0 then + begin + if DataController <> nil then + DataController.UnlockGridModeNotify; + Dec(FLockGridModeCount); + end; + inherited UnlockDataChanged; +end; + +function TcxCustomBoldLookupEditProperties.FindByText(AItemIndex: Integer; + const AText: string; APartialCompare: Boolean): Integer; + +{ function GetLocateOptions: TLocateOptions; + begin + Result := []; + if not CaseSensitiveSearch then + Include(Result, loCaseInsensitive); + if APartialCompare then + Result := Result + [loPartialKey]; + end; + + function GetLocateValue: Variant; + begin + Result := AText; + // TDataSet.Locate does not work with empty strings passed as key values for numeric fields + if (AText = '') and not (DataController.GetItemField(AItemIndex) is TStringField) then + Result := Null; + end; +} +//var +// ADataSet: TDataSet; +// AListFieldName: string; +begin +// if not IsUseLookupList then + begin + Result := inherited FindByText(AItemIndex, AText, APartialCompare); + Exit; + end; + Result := DataController.GetFocusedRecordIndex; +{ + Result := -1; + LockDataChanged; + try +// ADataSet := DataController.DataSet; + AListFieldName := DataController.GetItemFieldName(AItemIndex); + try +// if (ADataSet <> nil) and ADataSet.Active and (AItemIndex <> -1) and +// ADataSet.Locate(AListFieldName, GetLocateValue, GetLocateOptions) then + Result := DataController.GetFocusedRecordIndex; + except + on EDatabaseError do; + on EVariantError do; + end; + finally + UnlockDataChanged; + end; +} +end; + +function TcxCustomBoldLookupEditProperties.GetDisplayColumnIndex: Integer; +begin + Result := inherited GetDisplayColumnIndex; +end; + +function TcxCustomBoldLookupEditProperties.GetDisplayLookupText(const AKey: TcxEditValue): string; +var + ARecordIndex: Integer; + AItemIndex: Integer; +begin + Result := ''; + AItemIndex := GetListIndex; + if (AItemIndex <> -1) and (DataController <> nil) then + begin + ARecordIndex := GetRecordIndexByKey(AKey); + if (ARecordIndex <> -1) then + Result := DataController.DisplayTexts[ARecordIndex, AItemIndex] + end + else + begin + if VarIsStr(AKey) then + Result := AKey + else + Result := inherited GetDisplayLookupText(AKey); + end; +end; + +function TcxCustomBoldLookupEditProperties.GetDefaultHorzAlignment: TAlignment; +begin + Result := inherited GetDefaultHorzAlignment; +end; + +function TcxCustomBoldLookupEditProperties.GetDefaultMaxLength: Integer; +begin + Result := inherited GetDefaultMaxLength; +end; + +function TcxCustomBoldLookupEditProperties.GetIncrementalFiltering: Boolean; +begin + Result := inherited GetIncrementalFiltering; +end; + +class function TcxCustomBoldLookupEditProperties.GetLookupDataClass: TcxInterfacedPersistentClass; +begin + Result := TcxCustomBoldLookupEditLookupData; +end; + +function TcxCustomBoldLookupEditProperties.GetNullKey: Variant; +begin + Result := Null; +end; + +function TcxCustomBoldLookupEditProperties.GetRecordIndexByKey(const AKey: Variant): Integer; +begin + if VarIsNull(AKey) or VarIsEmpty(AKey) or not VarIsType(AKey, varInteger) or (AKey >= DataController.RecordCount) then +// or VarIsType(AKey, varSmallint) or VarIsType(AKey, varShortInt) or VarIsType(AKey, varInt64)) then + result := -1 + else + Result := AKey; +end; + +{function TcxCustomBoldLookupEditProperties.GetIsUseLookupList: Boolean; +begin + Result := FLookupList <> nil; +end;} + +{procedure TcxCustomBoldLookupEditProperties.SetIsUseLookupList(Value: Boolean); +begin + if (FLookupList <> nil) <> Value then + begin + if Value then + begin + FLookupList := TcxLookupList.Create; + end + else + begin + FLookupList.Free; + FLookupList := nil; + end; + Changed; + end; +end;} + +function TcxCustomBoldLookupEditProperties.GetKeyByRecordIndex( + ARecordIndex: Integer): Variant; +begin + if (ARecordIndex <> -1) and (DataController <> nil) then + Result := DataController.GetRecordId(ARecordIndex) + else + Result := Null; +end; + +procedure TcxCustomBoldLookupEditProperties.SetStoredValue( + aValue: Variant; aBoldHandle: TBoldElementHandle; aEdit: TcxCustomEdit; aFollower: TBoldFollower; var aDone: boolean); +begin +// TODO: nothing to do here, subclasse will override, perhaps even make this abstract ? +end; + +procedure TcxCustomBoldLookupEditProperties.SetBoldSelectChangeAction( + const Value: TBoldComboSelectChangeAction); +begin + fBoldSelectChangeAction := Value; +end; + +function TcxCustomBoldLookupEditProperties.GetListFieldIndex: Integer; +begin + Result := inherited DisplayColumnIndex; +end; + +procedure TcxCustomBoldLookupEditProperties.SetListFieldIndex( + Value: Integer); +begin + inherited DisplayColumnIndex := Value; +end; + +function TcxCustomBoldLookupEditProperties.BoldElementToEditValue( + aFollower: TBoldFollower; aElement: TBoldElement; aEdit: TcxCustomEdit): variant; +var + lBoldList: TBoldList; +begin + result := Null; // used to be -1 + if Assigned(DataController) and Assigned(DataController.BoldHandle) and Assigned(aElement) then + begin + lBoldList := DataController.BoldHandle.List; + if Assigned(lBoldList) then + begin + if aElement is TBoldObjectReference then + result := lBoldList.IndexOf( TBoldObjectReference(aElement).BoldObject ) + else + result := lBoldList.IndexOf(aElement); + end; + end; +end; + +type + TcxBoldEditDataBindingAccess = class(TcxBoldEditDataBinding); + TBoldFollowerControllerAccess = class(TBoldFollowerController); + +function TcxCustomBoldLookupEditProperties.ValidateComponent( + ComponentValidator: TBoldComponentValidator; + NamePrefix: string): Boolean; +var + lContext: TBoldElementTypeInfo; + lName: string; + lcxBoldEditDataBinding: TcxBoldEditDataBinding; +begin + if (Owner is TComponent) and (TComponent(Owner).Name <> '') then + lName := TComponent(Owner).Name + else + lName := ClassName; + + result := Assigned(DataController); + if Assigned(DataController) then + begin + lContext := DataController.GetHandleStaticType; + if assigned(lContext) then + begin + result := ComponentValidator.ValidateExpressionInContext( + TBoldFollowerControllerAccess(DataController.BoldProperties).Expression, + lContext, + format('%s %s.BoldProperties.Expression', [NamePrefix, lName]), DataController.BoldProperties.VariableList) and result; // do not localize + if (BoldSelectChangeAction = bdcsSetValue) and (Owner is TcxCustomEdit) then + begin + lcxBoldEditDataBinding := TcxCustomEditAccess(TcxCustomEdit(Owner)).DataBinding as TcxBoldEditDataBinding; + lContext := TcxBoldEditDataBindingAccess(lcxBoldEditDataBinding).GetContextType; + result := ComponentValidator.ValidateExpressionInContext( + BoldSetValueExpression, + lContext, + format('%s %s.BoldSetValueExpression', [NamePrefix, lName]), + lcxBoldEditDataBinding.BoldProperties.VariableList) and result; // do not localize + end; + end; + end; +end; + +function TcxCustomBoldLookupEditProperties.CanEdit( + aBoldHandle: TBoldElementHandle; aFollower: TBoldFollower): boolean; +begin + result := false; +end; + +procedure TcxCustomBoldLookupEditProperties.SetBoldSetValueExpression( + const Value: TBoldExpression); +begin + fBoldSetValueExpression := Value; + if Owner is TcxCustomEdit and (TcxCustomEdit(Owner).IsDesigning) and not (TcxCustomEdit(Owner).IsLoading) then + begin + _ValidateEdit(TcxCustomEdit(Owner)); + end; +end; + +{ TcxCustomBoldLookupEdit } + +class function TcxCustomBoldLookupEdit.GetPropertiesClass: TcxCustomEditPropertiesClass; +begin + Result := TcxCustomBoldLookupEditProperties; +end; + +function TcxCustomBoldLookupEdit.GetClearValue: TcxEditValue; +begin + Result := inherited GetClearValue; +end; + +function TcxCustomBoldLookupEdit.IsValidChar(AChar: Char): Boolean; +begin + Result := True; +end; + +function TcxCustomBoldLookupEdit.ItemIndexToLookupKey(AItemIndex: Integer): TcxEditValue; +begin + Assert(false); +end; + +function TcxCustomBoldLookupEdit.LookupKeyToEditValue(const AKey: TcxEditValue): TcxEditValue; +begin + Result := AKey; +end; + +{function TcxCustomBoldLookupEdit.LookupKeyToItemIndex(const AKey: TcxEditValue): Integer; +begin + Assert(false); +end;} + +procedure TcxCustomBoldLookupEdit.PopupWindowClosed(Sender: TObject); +begin +// if ActiveProperties.DataController.DataModeController.SyncMode then + ILookupData.CurrentKey := EditValue; + inherited PopupWindowClosed(Sender); +end; + +procedure TcxCustomBoldLookupEdit.PrepareDisplayValue( + const AEditValue: TcxEditValue; var DisplayValue: TcxEditValue; + AEditFocused: Boolean); +begin + if (ActiveProperties.DropDownListStyle <> lsEditList) and not Focused and + ActiveProperties.CanDisplayArbitraryEditValue then + DisplayValue := VarToStr(AEditValue) + else + ActiveProperties.PrepareDisplayValue(AEditValue, DisplayValue, AEditFocused); +end; + +function TcxCustomBoldLookupEdit.GetProperties: TcxCustomBoldLookupEditProperties; +begin + Result := TcxCustomBoldLookupEditProperties(FProperties); +end; + +function TcxCustomBoldLookupEdit.GetActiveProperties: TcxCustomBoldLookupEditProperties; +begin + Result := TcxCustomBoldLookupEditProperties(InternalGetActiveProperties); +end; + +procedure TcxCustomBoldLookupEdit.SetProperties(Value: TcxCustomBoldLookupEditProperties); +begin + FProperties.Assign(Value); +end; + +{ TcxBoldLookupEditDataBinding } + +function TcxBoldLookupEditDataBinding.IsLookupControl: Boolean; +begin + Result := True; +end; + +end. diff --git a/Source/BoldAwareGUI/BoldDevex/cxBoldRegUnit.dcr b/Source/BoldAwareGUI/BoldDevex/cxBoldRegUnit.dcr new file mode 100644 index 00000000..665ec51c Binary files /dev/null and b/Source/BoldAwareGUI/BoldDevex/cxBoldRegUnit.dcr differ diff --git a/Source/BoldAwareGUI/BoldDevex/cxBoldRegUnit.pas b/Source/BoldAwareGUI/BoldDevex/cxBoldRegUnit.pas new file mode 100644 index 00000000..532b4eff --- /dev/null +++ b/Source/BoldAwareGUI/BoldDevex/cxBoldRegUnit.pas @@ -0,0 +1,344 @@ +unit cxBoldRegUnit; + +{$I cxVer.inc} + +// v2.03 - 25 Jan 2011 2007-2011 Daniel Mauric + +{$ASSERTIONS ON} + +interface + +procedure Register; + +implementation + +uses + Classes, SysUtils,{$IFDEF DELPHI6} DesignIntf, DesignEditors,{$ELSE} DsgnIntf,{$ENDIF} + cxEditRepositoryEditor, + cxEditRepositoryItems, +// cxEditConsts, + cxEdit, + cxBoldEditors, + dxBarBoldNav, + cxBoldEditConsts, + cxBoldEditRepositoryItems, + dxBar, + BoldPropertyEditors, + BoldElements, + BoldDefs, + BoldHandles, +// BoldDataBindingUnit, +// BoldDataBindingTestUnit, + BoldAbstractPropertyEditors, + + Dialogs, + cxDropDownEdit, + cxGridBoldSupportUnit, + + cxGridCustomView, + cxGridCustomTableView, + + cxBoldExtLookupComboBox, + cxBoldLookupComboBox, + cxBoldLookupEdit, + BoldToCxConverterUnit; + +type + TcxCustomEditAccess = class(TcxCustomEdit); + TcxCustomBoldLookupEditAccess = class(TcxCustomBoldLookupEdit); + +type + TBoldOCLExpressionForCxBoldPropertiesSetValueExpression = class(TBoldOCLExpressionProperty) + protected + function GetContextType(Component: TPersistent): TBoldElementTypeInfo; override; + end; + +type + TdxBoldItemEditor = class(TdxAddSubItemEditor) + protected + class function GetAddedItemClass(const AAddedItemName: string): TdxBarItemClass; override; + class function GetPopupItemCaption: string; override; + end; + +{ TcxCustomGridTableItemProperty } + +type + TcxCustomGridTableItemProperty = class(TComponentProperty) + protected + function GetGridView: TcxCustomGridView; + procedure GetGridViewItemNames(AGridView: TcxCustomGridView; Proc: TGetStrProc); virtual; + function InternalGetGridView(APersistent: TPersistent): TcxCustomGridView; virtual; abstract; + public + procedure GetValues(Proc: TGetStrProc); override; + end; + +procedure TcxCustomGridTableItemProperty.GetValues(Proc: TGetStrProc); +var + AGridView: TcxCustomGridView; +begin + AGridView := GetGridView; + if AGridView <> nil then + GetGridViewItemNames(AGridView, Proc); +end; + +function TcxCustomGridTableItemProperty.GetGridView: TcxCustomGridView; +var + I: Integer; +begin + Result := InternalGetGridView(GetComponent(0)); + for I := 1 to PropCount - 1 do + if InternalGetGridView(GetComponent(I)) <> Result then + begin + Result := nil; + Break; + end; +end; + +procedure TcxCustomGridTableItemProperty.GetGridViewItemNames(AGridView: TcxCustomGridView; + Proc: TGetStrProc); +var + I: Integer; +begin + if AGridView is TcxCustomGridTableView then + with AGridView as TcxCustomGridTableView do + for I := 0 to ItemCount - 1 do + Proc(Designer.GetComponentName(Items[I])); +end; + +type + TcxExtLookupComboBoxPropertiesItemColumnProperty = class(TcxCustomGridTableItemProperty) + protected + function InternalGetGridView(APersistent: TPersistent): TcxCustomGridView; override; + end; + + TcxExtLookupComboBoxPropertiesViewProperty = class(TComponentProperty) + private + FProc: TGetStrProc; + procedure CheckComponent(const Value: string); + public + procedure GetValues(Proc: TGetStrProc); override; + end; + +(* + TBoldOCLExpressionForSetValueExpression = class(TBoldOCLExpressionProperty) + protected + function GetContextType(Component: TPersistent): TBoldElementTypeInfo; override; + end; + +{ TBoldOCLExpressionForSetValueExpression } + + +function TBoldOCLExpressionForSetValueExpression.GetContextType( + Component: TPersistent): TBoldElementTypeInfo; +var + lBoldElementHandle: TBoldElementHandle; +begin + if Component is TcxBarBoldEditItem then + lBoldElementHandle := (Component as TcxBarBoldEditItem).BoldHandle + else + if component is TcxCustomEdit and (TcxCustomEditAccess(component).DataBinding is TcxBoldEditDataBinding) then + lBoldElementHandle := (TcxCustomEditAccess(component).DataBinding as TcxBoldEditDataBinding).BoldHandle + else + if component is TcxBoldComboBoxProperties then + begin + raise EBold.CreateFmt('Unsuported component %s.', [(component as TcxBoldComboBoxProperties).Owner.Classname]); + end + else + raise EBold.CreateFmt('Unsuported component %s.', [Component.ClassName]); + + if Assigned(lBoldElementHandle) then + Result := lBoldElementHandle.StaticBoldType + else + Result := nil +end; +*) +{ TdxBoldItemEditor } + +class function TdxBoldItemEditor.GetAddedItemClass( + const AAddedItemName: string): TdxBarItemClass; +begin + Result := TcxBarBoldEditItem; +end; + +class function TdxBoldItemEditor.GetPopupItemCaption: string; +begin + Result := 'Add BoldItem';//dxSBAR_CP_ADDBUTTON; +end; + + +procedure RegisterEditRepositoryItems; +begin + RegisterEditRepositoryItem(TcxEditRepositoryBoldStringItem, scxSBoldEditRepositoryTextItem); + RegisterEditRepositoryItem(TcxEditRepositoryBoldComboBoxItem, scxSBoldComboBoxRepositoryTextItem); + RegisterEditRepositoryItem(TcxEditRepositoryBoldLookupComboBoxItem, scxSBoldLookupComboBoxRepositoryTextItem); + RegisterEditRepositoryItem(TcxEditRepositoryBoldExtLookupComboBoxItem, scxSBoldExtLookupComboBoxRepositoryTextItem); +end; + +{type + TBoldOCLExpressionForDataBindingDefinitionProperty = class(TBoldOCLExpressionProperty) + protected + function GetContextType(Component: TPersistent): TBoldElementTypeInfo; override; + function GetVariableList(Component: TPersistent): TBoldExternalVariableList; override; + end;} + +procedure Register; +begin +{$IFDEF DELPHI9} + ForceDemandLoadState(dlDisable); +{$ENDIF} + RegisterNoIcon([TcxBarBoldEditItem]); + + RegisterComponents('Express BoldEditors', [TdxBarBoldNavigator, TcxBoldTextEdit, TcxBoldDateEdit, + TcxBoldTimeEdit, TcxBoldMemo, TcxBoldCurrencyEdit, TcxBoldMaskEdit, TcxBoldCheckBox, TcxBoldComboBox, + TcxBoldSpinEdit, TcxBoldButtonEdit, TcxBoldHyperLinkEdit, TcxBoldProgressBar, + {$IFDEF DevExScheduler} + TcxBoldDateNavigator, + {$ENDIF} + TcxBoldLabel, TcxBoldImage, TcxBoldRichEdit, + TcxBoldListBox, TcxBoldCheckListBox, TcxBoldSelectionCheckListBox, TcxBoldListView, + TcxBoldExtLookupComboBox, TcxBoldLookupComboBox, TcxBoldNBLookupComboBox, TcxBoldNBExtLookupComboBox, + TBoldToCxConverter]); + + RegisterNoIcon([TdxBarBoldNavButton]); + + RegisterPropertyEditor(TypeInfo(TdxBarBoldNavigator), TdxBarBoldNavButton, 'BarBoldNavigator', nil); +// RegisterPropertyEditor(TypeInfo(String), TcxBoldComboBoxProperties, 'BoldSetValueExpression', TBoldOCLExpressionForSetValueExpression); + + BarDesignController.RegisterBarControlEditor(TdxBoldItemEditor); + RegisterEditRepositoryItems; + + RegisterPropertyEditor(TypeInfo(TBoldElementHandle), TPersistent, 'BoldHandle', TBoldComponentPropertyIndicateMissing); + RegisterPropertyEditor(TypeInfo(TBoldExpression), TcxBoldComboBoxProperties, 'BoldSetValueExpression', TBoldOCLExpressionForCxBoldPropertiesSetValueExpression); + RegisterPropertyEditor(TypeInfo(TBoldExpression), TcxCustomBoldLookupEditProperties, 'BoldSetValueExpression', TBoldOCLExpressionForCxBoldPropertiesSetValueExpression); + RegisterPropertyEditor(TypeInfo(TcxCustomGridTableItem), TcxBoldExtLookupComboBoxProperties, 'ListFieldItem', TcxExtLookupComboBoxPropertiesItemColumnProperty); + RegisterPropertyEditor(TypeInfo(TcxCustomGridTableView), TcxBoldExtLookupComboBoxProperties, 'View', TcxExtLookupComboBoxPropertiesViewProperty); + + {GUI Component editors} + RegisterComponentEditor(TcxBoldTextEdit, TBoldOCLComponentEditor); + RegisterComponentEditor(TcxBoldDateEdit, TBoldOCLComponentEditor); + RegisterComponentEditor(TcxBoldTimeEdit, TBoldOCLComponentEditor); + RegisterComponentEditor(TcxBoldMemo, TBoldOCLComponentEditor); + RegisterComponentEditor(TcxBoldCurrencyEdit, TBoldOCLComponentEditor); + RegisterComponentEditor(TcxBoldMaskEdit, TBoldOCLComponentEditor); + RegisterComponentEditor(TcxBoldCheckBox, TBoldOCLComponentEditor); + RegisterComponentEditor(TcxBoldComboBox, TBoldOCLComponentEditor); + RegisterComponentEditor(TcxBoldSpinEdit, TBoldOCLComponentEditor); + RegisterComponentEditor(TcxBoldButtonEdit, TBoldOCLComponentEditor); + RegisterComponentEditor(TcxBoldHyperLinkEdit, TBoldOCLComponentEditor); + RegisterComponentEditor(TcxBoldProgressBar, TBoldOCLComponentEditor); + RegisterComponentEditor(TcxBoldLabel, TBoldOCLComponentEditor); + RegisterComponentEditor(TcxBoldImage, TBoldOCLComponentEditor); + RegisterComponentEditor(TcxBoldRichEdit, TBoldOCLComponentEditor); + RegisterComponentEditor(TcxBoldExtLookupComboBox, TBoldOCLComponentEditor); + RegisterComponentEditor(TcxBoldLookupComboBox, TBoldOCLComponentEditor); +end; + + +{ TBoldOCLExpressionForDataBindingDefinitionProperty } +{ +function TBoldOCLExpressionForDataBindingDefinitionProperty.GetContextType( + Component: TPersistent): TBoldElementTypeInfo; +begin + EnsureComponentType(Component, TBoldDataBindingDefinition); + Result := (Component as TBoldDataBindingDefinition).ContextType; +end; + +function TBoldOCLExpressionForDataBindingDefinitionProperty.GetVariableList( + Component: TPersistent): TBoldExternalVariableList; +begin + EnsureComponentType(Component, TBoldDataBindingDefinition); + Result := (Component as TBoldDataBindingDefinition).VariableList; +end; +} + +{ TBoldOCLExpressionForCxBoldPropertiesSetValueExpression } + +function TBoldOCLExpressionForCxBoldPropertiesSetValueExpression.GetContextType( + Component: TPersistent): TBoldElementTypeInfo; +var + lcxBoldComboBoxProperties: TcxBoldComboBoxProperties; + lBoldAwareViewItem: IBoldAwareViewItem; + lcxBoldComboBox: TcxBoldComboBox; + lcxBoldDataController: TcxBoldDataController; + lcxCustomBoldLookupEditProperties: TcxCustomBoldLookupEditProperties; + lcxBoldEditDataBinding: TcxBoldEditDataBinding; +begin + result := nil; + if Component is TcxBoldComboBoxProperties then + begin +// ShowMessage(lcxBoldComboBoxProperties.GetContainerClass.ClassName); +// ShowMessage(lcxBoldComboBoxProperties.Owner.ClassName); + lcxBoldComboBoxProperties := Component as TcxBoldComboBoxProperties; + if (lcxBoldComboBoxProperties.Owner is TcxCustomGridTableItem) and lcxBoldComboBoxProperties.Owner.GetInterface(IBoldAwareViewItem, lBoldAwareViewItem) then + begin + lcxBoldDataController := (TcxCustomGridTableItem(lcxBoldComboBoxProperties.Owner).DataBinding.DataController as TcxBoldDataController); + if Assigned(lcxBoldDataController.BoldHandle) then + result := lcxBoldDataController.BoldHandle.StaticBoldType; + end + else + if lcxBoldComboBoxProperties.Owner is TcxBoldComboBox then + begin + lcxBoldComboBox := lcxBoldComboBoxProperties.Owner as TcxBoldComboBox; + if Assigned(lcxBoldComboBox.DataBinding.BoldHandle) then + result := lcxBoldComboBox.DataBinding.BoldHandle.StaticBoldType; + end + else + if lcxBoldComboBoxProperties.Owner is TcxEditRepositoryItem then + begin + raise Exception.Create('OCL Editor is not available, repository items do not have a context.'); + end + else + raise Exception.Create('Unknown context: ' + lcxBoldComboBoxProperties.Owner.ClassName ); +{ if Assigned(lcxBoldComboBoxProperties.BoldLookupListHandle) then + result := lcxBoldComboBoxProperties.BoldLookupListHandle.StaticBoldType; +} + end + else + if component is TcxCustomBoldLookupEditProperties then + begin + lcxCustomBoldLookupEditProperties := component as TcxCustomBoldLookupEditProperties; + if (lcxCustomBoldLookupEditProperties.Owner is TcxCustomBoldLookupEdit) and (TcxCustomBoldLookupEditAccess(lcxCustomBoldLookupEditProperties.Owner).DataBinding is TcxBoldEditDataBinding) then + begin + lcxBoldEditDataBinding := TcxBoldEditDataBinding(TcxCustomEditAccess(lcxCustomBoldLookupEditProperties.Owner).DataBinding); + if Assigned(lcxBoldEditDataBinding.BoldHandle) then + result := lcxBoldEditDataBinding.BoldHandle.StaticBoldType; + end + else + raise Exception.Create('Unknown context: ' + lcxCustomBoldLookupEditProperties.Owner.ClassName ); + end + else + Assert(false); +// raise EBold.CreateFmt(sComponentNotComboBox, [ClassName]); +end; + +{ TcxExtLookupComboBoxPropertiesItemColumnProperty } + +function TcxExtLookupComboBoxPropertiesItemColumnProperty.InternalGetGridView( + APersistent: TPersistent): TcxCustomGridView; +var + AProperties: TcxBoldExtLookupComboBoxProperties; +begin + AProperties := APersistent as TcxBoldExtLookupComboBoxProperties; + Result := AProperties.View; +end; + +{ TcxExtLookupComboBoxPropertiesViewProperty } + +procedure TcxExtLookupComboBoxPropertiesViewProperty.CheckComponent( + const Value: string); +var + AView: TcxCustomGridTableView; +begin + AView := TcxCustomGridTableView(Designer.GetComponent(Value)); + if (AView <> nil) and TcxBoldExtLookupComboBoxProperties.IsViewSupported(AView) then + FProc(Value); +end; + +procedure TcxExtLookupComboBoxPropertiesViewProperty.GetValues( + Proc: TGetStrProc); +begin + FProc := Proc; + inherited GetValues(CheckComponent); +end; + +end. diff --git a/Source/BoldAwareGUI/BoldDevex/cxGridBoldSupportUnit.pas b/Source/BoldAwareGUI/BoldDevex/cxGridBoldSupportUnit.pas new file mode 100644 index 00000000..321e6a5a --- /dev/null +++ b/Source/BoldAwareGUI/BoldDevex/cxGridBoldSupportUnit.pas @@ -0,0 +1,6292 @@ +unit cxGridBoldSupportUnit; + + +{$ASSERTIONS ON} +{$INCLUDE Bold.inc} + +{$DEFINE DelayOnFocusedRecordChange} + +{.$DEFINE IEJpegImage} +{.$DEFINE DefaultDragMode} +{.$DEFINE FireAfterLoadOnChangeOnly} +{$DEFINE CenterResultOnIncSearch} + +{.$DEFINE BoldDevExLog} + +(* + cxGrid Bold aware components v2.7 - Oct 2018 + for ExpressQuantumGrid 6 + + 2007-2018 Daniel Mauric + + features + - on demand fetching + - appropriate column properties for each BoldAttribute, including ComboBoxProperties with possible values for TBAValueSet + - smart drag & drop support, across views and within single view if list is ordered, etc... + - constraint column with hints that contain broken constraints messages + - implements IBoldValidateableComponent + - global var cxBoldDataSourceClass allows to plugin a custom TcxBoldDataSource subclass + + non bold related features + - ctrl+home and ctrl+end go to top and bottom of the list, respectively + - ctrl+numeric plus toggles ApplyBestFit for the visible range of records + + known issues + - Drag drop is currently not supported in the CardView + - Master detail views only supported when connected to BoldListHandles + +*) + +interface + +uses + Classes, + Controls, + Types, + Messages, + Contnrs, + + cxGridCustomTableView, + cxCustomData, + cxGridCustomView, + cxGridTableView, + cxStorage, + cxDataStorage, + cxData, + cxDataUtils, + cxEdit, + cxDropDownEdit, + cxGridCardView, +// cxGridChartView, + cxGridBandedTableView, + cxGridLayoutView, + cxFilter, + cxGraphics, + + BoldSystem, + BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after + BoldComponentvalidator, + BoldSystemRT, + BoldControlPack, +// BoldStringControlPack, + BoldVariantControlPack, + BoldListHandleFollower, + BoldListListControlPack, + BoldControllerListControlPack, + BoldAbstractListHandle, + BoldElements, + BoldSubscription, + + cxBoldEditors; // for IcxBoldEditProperties, perhaps extract that class to another unit later on and use that instead + +type + TcxGridBoldTableView = class; + TcxGridBoldColumn = class; + TcxGridItemBoldDataBinding = class; + TcxBoldDataController = class; + TcxGridBoldDataController = class; + TcxBoldDataSource = class; + TcxGridBoldTableController = class; + TcxGridBoldCardView = class; +(* + TcxBoldGridChartView = class; + TcxGridBoldChartDataController = class; + TcxGridBoldChartCategories = class; + TcxGridBoldChartDataGroup = class; + TcxGridBoldChartSeries = class; +*) + TcxGridBoldBandedTableView = class; + TcxGridBoldBandedColumn = class; + TcxGridBoldBandedTableController = class; + TcxBoldDataControllerSearch = class; + TcxBoldCustomDataProvider = class; + TcxGridBoldEditingController = class; + + TcxGridBoldLayoutView = class; + TcxGridBoldLayoutViewItem = class; + + TBoldCxGridVariantFollowerController = class; + + IBoldAwareViewItem = interface + ['{187C2B47-FD11-4A01-9340-6BC608B6FF38}'] + function GetBoldProperties: TBoldVariantFollowerController; + property BoldProperties: TBoldVariantFollowerController read GetBoldProperties; + end; + + IBoldAwareView = interface + ['{51A80761-FCA5-4D4E-8585-907B8C08C404}'] + function GetDataController: TcxGridBoldDataController; + procedure SetDataController(Value: TcxGridBoldDataController); + property DataController: TcxGridBoldDataController read GetDataController write SetDataController; + function GetItemCount: Integer; + property ItemCount: Integer read GetItemCount; + function GetItem(Index: Integer): IBoldAwareViewItem; + property Items[Index: Integer]: IBoldAwareViewItem read GetItem; default; + function GetSelection: TBoldList; + property Selection: TBoldList read GetSelection; + procedure DoSelectionChanged; + procedure ClearItems; + + function GetCurrentBoldObject: TBoldObject; + function GetCurrentIndex: integer; + function GetCurrentElement: TBoldElement; + + property CurrentBoldObject: TBoldObject read GetCurrentBoldObject; + property CurrentElement: TBoldElement read GetCurrentElement; + property CurrentIndex: integer read GetCurrentIndex; + end; + + TBoldCxGridVariantFollowerController = class(TBoldVariantFollowerController) + protected + fcxGridItemBoldDataBinding: TcxGridItemBoldDataBinding; + public + function SubFollowersActive: boolean; override; + constructor Create(aOwningComponent: TComponent); reintroduce; + end; + + TcxGridBoldDefaultValuesProvider = class(TcxCustomBoldEditDefaultValuesProvider) + public + function DefaultCanModify: Boolean; override; + function IsDisplayFormatDefined(AIsCurrencyValueAccepted: Boolean): Boolean; override; + end; + + + TcxBoldDataSource = class(TcxCustomDataSource) + private + fBoldDataController: TcxBoldDataController; + fIsBoldInitiatedChange: boolean; + protected + function GetRecordCount: Integer; override; + function GetValue(ARecordHandle: TcxDataRecordHandle; + AItemHandle: TcxDataItemHandle): Variant; override; + procedure SetValue(ARecordHandle: TcxDataRecordHandle; + AItemHandle: TcxDataItemHandle; const AValue: Variant); override; + function GetItemHandle(AItemIndex: Integer): TcxDataItemHandle; override; + function GetRecordHandle(ARecordIndex: Integer): TcxDataRecordHandle; override; + function IsRecordIdSupported: Boolean; override; + function GetRecordId(ARecordHandle: TcxDataRecordHandle): Variant; override; + function GetDetailHasChildren(ARecordIndex, ARelationIndex: Integer): Boolean; override; + procedure LoadRecordHandles; override; + procedure CustomSort; override; + function CustomSortElementCompare(Item1, Item2: TBoldElement): integer; + function IsCustomSorting: Boolean; override; + public + constructor Create(aBoldDataController: TcxBoldDataController); virtual; + destructor Destroy; override; + procedure DeleteRecord(ARecordHandle: TcxDataRecordHandle); override; + function GetRecordHandleByIndex(ARecordIndex: Integer): TcxDataRecordHandle; override; + end; + + TcxBoldCustomDataControllerInfo = class(TcxCustomDataControllerInfo) + protected + procedure DoSort; override; + procedure DoFilter; override; + end; + + TcxBoldDataSummary = class(TcxDataSummary) + protected +{$IFDEF BOLD_DELPHI16_OR_LATER} + procedure CalculateSummary(ASummaryItems: TcxDataSummaryItems; ABeginIndex, AEndIndex: Integer; + var ACountValues: TcxDataSummaryCountValues; var ASummaryValues: TcxDataSummaryValues); override; +{$ELSE} + procedure CalculateSummary(ASummaryItems: TcxDataSummaryItems; ABeginIndex, AEndIndex: Integer; + var ACountValues: TcxDataSummaryCountValues; var ASummaryValues: TcxDataSummaryValues; var SummaryValues: Variant); override; +{$ENDIF} + end; + + TcxGridUserQueryEvent = procedure (Sender: TObject; var Allow: boolean) of object; + + TcxBoldDataController = class(TcxCustomDataController) + private + fBoldHandleFollower: TBoldListHandleFollower; + fBoldProperties: TBoldListAsFollowerListController; + fBoldColumnsProperties: TBoldControllerList; + fSubscriber: TBoldPassthroughSubscriber; + FSkipMakeCellUptoDate: integer; + FSkipSyncFocusedRecord: integer; + fInDelayScrollUpdate: boolean; + fCurrentListElementType: TBoldElementTypeInfo; + fSelection: TBoldList; + fBoldAutoColumns: Boolean; + fDataChanged: boolean; + fInvalidating: boolean; + fFetchedAll: boolean; + fInternalLoading: boolean; +// fBeforeLoad: TNotifyEvent; + fAfterLoad: TNotifyEvent; + fLoadAll: boolean; + fSkipCancel: boolean; + fOnDelete: TNotifyEvent; + fOnInsert: TNotifyEvent; + fCanInsert: TcxGridUserQueryEvent; + fCanDelete: TcxGridUserQueryEvent; + FUseDelayedScrollUpdate: boolean; + fClearColumnsOnTypeChange: boolean; + fStoredRecordIndex: integer; + fRedrawGrid: boolean; + fRecalcSummary: boolean; +{$IFDEF DelayOnFocusedRecordChange} + fFocusChanged: boolean; + fPrevFocusedRecordIndex: integer; + fFocusedRecordIndex: integer; + fPrevFocusedDataRecordIndex: integer; + fFocusedDataRecordIndex: integer; + fNewItemRecordFocusingChanged: boolean; +{$ENDIF} + function GetRecNo: Integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetRecNo(const Value: Integer); + function GetBoldHandle: TBoldAbstractListHandle; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetBoldHandleIndexLock: Boolean; + procedure SetBoldHandle(const Value: TBoldAbstractListHandle); + procedure SetBoldHandleIndexLock(const Value: Boolean); + procedure SetController(const Value: TBoldListAsFollowerListController); + function GetRowFollower(DataRow: Integer): TBoldFollower; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetFollower: TBoldFollower; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetCellFollower(ARecordIndex, AItemIndex: Integer): TBoldFollower; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetSelection: TBoldList; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetBoldList: TBoldList; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetDataChanged(const Value: boolean); + procedure FindMinMaxIndex(ListA, ListB: TBoldList; var AFrom, ATo: integer); + procedure Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); + function GetHasCellFollower(ARecordIndex, AItemIndex: Integer): boolean; + procedure EnsureEventQueued; + protected + function GetDataProviderClass: TcxCustomDataProviderClass; override; + function GetSearchClass: TcxDataControllerSearchClass; override; + function CreateDataControllerInfo: TcxCustomDataControllerInfo; override; + function IsDataLinked: Boolean; + function IsSmartRefresh: Boolean; override; + function GetCurrentBoldObject: TBoldObject; + function GetCurrentIndex: integer; + function GetCurrentElement: TBoldElement; + procedure ProcessQueueEvent(Sender: TObject); virtual; + procedure BeforeSorting; override; + function BoldSetValue(AItemHandle: TcxDataItemHandle; ACellFollower: TBoldFollower; const AValue: variant): boolean; virtual; + function RequiresAllRecords: boolean; overload; virtual; + function RequiresAllRecords(AItem: TObject): boolean; overload; virtual; + procedure SelectionChanged; virtual; + procedure FilterChanged; override; + function FindItemByData(AData: Integer): TObject; + function GetItemData(AItem: TObject): Integer; virtual; abstract; + function BoldPropertiesFromItem(aIndex: integer): TBoldVariantFollowerController; + procedure _InsertRow(index: Integer; Follower: TBoldFollower); virtual; + procedure _DeleteRow(index: Integer; owningFollower: TBoldFollower); virtual; + procedure _ReplaceRow(index: Integer; AFollower: TBoldFollower); virtual; + procedure _BeforeMakeListUpToDate(Follower: TBoldFollower); virtual; + procedure _AfterMakeListUptoDate(Follower: TBoldFollower); virtual; + procedure _AfterMakeCellUptoDate(Follower: TBoldFollower); virtual; + function GetHandleListElementType: TBoldElementTypeInfo; + function TypeMayHaveChanged: boolean; + procedure TypeChanged(aNewType, aOldType: TBoldElementTypeInfo); virtual; + procedure BeginDelayScrollUpdate; + procedure EndDelayScrollUpdate; + procedure DisplayFollowers; virtual; + function MainFollowerNeedsDisplay: boolean; + function EnsureFollower(ARecordIndex, AItemIndex: integer): boolean; + property BoldHandleIndexLock: Boolean read GetBoldHandleIndexLock write SetBoldHandleIndexLock default true; + property HasCellFollower[ARecordIndex, AItemIndex: Integer]: boolean read GetHasCellFollower; + property BoldAutoColumns: Boolean read fBoldAutoColumns write fBoldAutoColumns default false; + property BoldColumnsProperties: TBoldControllerList read fBoldColumnsProperties; + property DataHasChanged: boolean read fDataChanged write SetDataChanged; + property SkipMakeCellUptoDate: integer read FSkipMakeCellUptoDate; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function InDelayScrollUpdate: boolean; + function IsProviderMode: Boolean; override; + function GetRecordCount: Integer; override; + procedure Cancel; override; + procedure AdjustActiveRange(aList: TBoldList = nil; aItem: integer = -1); overload; virtual; + procedure AdjustActiveRange(aRecordIndex: integer; aItem: integer = -1); overload; + procedure PreFetchColumns(aList: TBoldList = nil; aItem: integer = -1); virtual; + function GetHandleStaticType: TBoldElementTypeInfo; + function GetCurrentDetailDataController(ARelationIndex: integer = 0): TcxBoldDataController; + function CreateList: TBoldList; + property BoldProperties: TBoldListAsFollowerListController read fBoldProperties write SetController; + property BoldHandle: TBoldAbstractListHandle read GetBoldHandle write SetBoldHandle; + property BoldHandleFollower: TBoldListHandleFollower read fBoldHandleFollower; + property RecNo: Integer read GetRecNo write SetRecNo; // Sequenced + property Follower: TBoldFollower read GetFollower; + property CurrentBoldObject: TBoldObject read GetCurrentBoldObject; + property CurrentElement: TBoldElement read GetCurrentElement; + property CurrentIndex: integer read GetCurrentIndex; +// property OnBeforeLoad: TNotifyEvent read fBeforeLoad write fBeforeLoad; + property OnAfterLoad: TNotifyEvent read fAfterLoad write fAfterLoad; + property LoadAll: boolean read fLoadAll write fLoadAll default false; + property Selection: TBoldList read GetSelection; + property BoldList: TBoldList read GetBoldList; + property CellFollowers[ARecordIndex, AItemIndex: Integer]: TBoldFollower read GetCellFollower; + published + property OnInsert: TNotifyEvent read fOnInsert write fOnInsert; + property OnDelete: TNotifyEvent read fOnDelete write fOnDelete; + property CanInsert: TcxGridUserQueryEvent read fCanInsert write fCanInsert; + property CanDelete: TcxGridUserQueryEvent read fCanDelete write fCanDelete; + property UseDelayedScrollUpdate: boolean read FUseDelayedScrollUpdate write FUseDelayedScrollUpdate default true; + property ClearColumnsOnTypeChange: boolean read fClearColumnsOnTypeChange write fClearColumnsOnTypeChange default true; + end; + + TcxGridBoldDataController = class(TcxBoldDataController, IcxCustomGridDataController, IcxGridDataController) + private + FPrevScrollBarPos: Integer; + fCreatingColumns: boolean; + fInternalChange: boolean; + fTriggerAfterLoad: boolean; + function GetController: TcxCustomGridTableController; + function GetGridViewValue: TcxCustomGridTableView; + procedure ConstraintColumnCustomDrawCell(Sender: TcxCustomGridTableView; + ACanvas: TcxCanvas; AViewInfo: TcxGridTableDataCellViewInfo; var ADone: Boolean); + procedure ColumnCustomDrawCell(Sender: TcxCustomGridTableView; + ACanvas: TcxCanvas; AViewInfo: TcxGridTableDataCellViewInfo; var ADone: Boolean); + protected + function GetSummaryItemClass: TcxDataSummaryItemClass; override; + function GetSummaryGroupItemLinkClass: TcxDataSummaryGroupItemLinkClass; override; + + procedure CheckDataSetCurrent; override; // used to get CurrentIndex (ie. current record after change) + procedure GetCellHint(Sender: TcxCustomGridTableItem; ARecord: TcxCustomGridRecord; + ACellViewInfo: TcxGridTableDataCellViewInfo; const AMousePos: TPoint; + var AHintText: TCaption; var AIsHintMultiLine: Boolean; var AHintTextRect: TRect); + procedure SelectionChanged; override; + procedure ProcessQueueEvent(Sender: TObject); override; + procedure DisplayFollowers; override; + function DoEditing(AItem: TcxCustomGridTableItem): Boolean; + function BoldSetValue(AItemHandle: TcxDataItemHandle; ACellFollower: TBoldFollower; const AValue: variant): boolean; override; + + function GetOwnerOrView: TComponent; + { IcxCustomGridDataController } + procedure AssignData(ADataController: TcxCustomDataController); + procedure DeleteAllItems; + procedure GetFakeComponentLinks(AList: TList); + function GetGridView: TcxCustomGridView; + function HasAllItems: Boolean; + function IsDataChangeable: Boolean; + function IsDataLinked: Boolean; + function SupportsCreateAllItems: Boolean; + + { IcxGridDataController } + procedure CheckGridModeBufferCount; + function DoScroll(AForward: Boolean): Boolean; + function DoScrollPage(AForward: Boolean): Boolean; + //function GetFilterPropertyValue(const AName: string; var AValue: Variant): Boolean; + function GetItemDataBindingClass: TcxGridItemDataBindingClass; + function GetItemDefaultValuesProviderClass: TcxCustomEditDefaultValuesProviderClass; + function GetNavigatorIsBof: Boolean; + function GetNavigatorIsEof: Boolean; + function GetScrollBarPos: Integer; + function GetScrollBarRecordCount: Integer; + //function SetFilterPropertyValue(const AName: string; const AValue: Variant): Boolean; + function SetScrollBarPos(Value: Integer): Boolean; + function SupportsScrollBarParams: Boolean; virtual; + function GetItemData(AItem: TObject): Integer; override; + function RequiresAllRecords: boolean; overload; override; + function RequiresAllRecords(AItem: TObject): boolean; overload; override; + function CanSelectRow(ARowIndex: Integer): Boolean; override; + function CompareByField(ARecordIndex1, ARecordIndex2: Integer; + AField: TcxCustomDataField; AMode: TcxDataControllerComparisonMode): Integer; override; + procedure DoValueTypeClassChanged(AItemIndex: Integer); override; + procedure FilterChanged; override; + function GetDefaultActiveRelationIndex: Integer; override; + function GetFilterDisplayText(ARecordIndex, AItemIndex: Integer): string; override; + function GetItemID(AItem: TObject): Integer; override; +// function GetItemData(AItem: TObject): Integer; virtual; + function GetSortingBySummaryEngineClass: TcxSortingBySummaryEngineClass; override; + function GetSummaryClass: TcxDataSummaryClass; override; + { Bold methods } + procedure _BeforeMakeListUpToDate(Follower: TBoldFollower); override; + procedure _AfterMakeListUptoDate(Follower: TBoldFollower); override; + procedure _AfterMakeCellUptoDate(Follower: TBoldFollower); override; + procedure TypeChanged(aNewType, aOldType: TBoldElementTypeInfo); override; + procedure ConnectEvents(AConnect: boolean); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure CreateAllItems(AMissingItemsOnly: Boolean); + procedure EnsureConstraintColumn; + function GetItemByExpression(const AExpression: string): TObject; + function GetItem(Index: Integer): TObject; override; + procedure ChangeValueTypeClass(AItemIndex: Integer; AValueTypeClass: TcxValueTypeClass); override; + procedure DoStartDrag(Sender: TObject; var DragObject: TDragObject); + procedure DoDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); + procedure DoDragDrop(Sender, Source: TObject; X, Y: Integer); + procedure DoEndDrag(Sender, Target: TObject; X, Y: Integer); + function CreateItem(aGridView: TcxCustomGridTableView; const aExpression, aCaption, aValueType, aName: string): TcxCustomGridTableItem; + procedure BeginFullUpdate; override; + procedure EndFullUpdate; override; + function CreateDetailLinkObject(ARelation: TcxCustomDataRelation; + ARecordIndex: Integer): TObject; override; + procedure FocusControl(AItemIndex: Integer; var Done: Boolean); override; + function GetDetailDataControllerByLinkObject(ALinkObject: TObject): TcxCustomDataController; override; + function GetDisplayText(ARecordIndex, AItemIndex: Integer): string; override; + function GetFilterDataValue(ARecordIndex: Integer; AField: TcxCustomDataField): Variant; override; + function GetFilterItemFieldCaption(AItem: TObject): string; override; + function GetItemSortByDisplayText(AItemIndex: Integer; ASortByDisplayText: Boolean): Boolean; override; + function GetItemValueSource(AItemIndex: Integer): TcxDataEditValueSource; override; + procedure UpdateData; override; + procedure ReloadStorage; + procedure AdjustActiveRange(aList: TBoldList = nil; aItem: integer = -1); override; + procedure CollectVisibleRecords(var aList: TBoldList); + procedure PreFetchColumns(AList: TBoldList; AItem: integer = -1); override; +// procedure DoGroupingChanged; override; +// procedure DoSortingChanged; override; + // Master-Detail: Grid Notifications + procedure SetMasterRelation(AMasterRelation: TcxCustomDataRelation; AMasterRecordIndex: Integer); override; + procedure SetValueTypeAndProperties(aMember: TBoldMemberRtInfo; aItem: TcxCustomGridTableItem; aChangeProperties: boolean = true); overload; + procedure SetValueTypeAndProperties(aElementTypeInfo: TBoldElementTypeInfo; aItem: TcxCustomGridTableItem; aChangeProperties: boolean = true); overload; + procedure ForEachRow(ASelectedRows: Boolean; AProc: TcxDataControllerEachRowProc); override; + property GridView: TcxCustomGridTableView read GetGridViewValue; + property Controller: TcxCustomGridTableController read GetController; + published + property BoldProperties; + property BoldHandle; + property BoldHandleIndexLock; + property BoldAutoColumns; +// property OnBeforeLoad; + property OnAfterLoad; + property LoadAll; + + property Filter; + property Options; + property Summary; + property OnAfterCancel; + property OnAfterDelete; + property OnAfterInsert; + property OnAfterPost; + property OnBeforeCancel; + property OnBeforeDelete; + property OnBeforeInsert; + property OnBeforePost; + property OnNewRecord; + property OnCompare; + property OnDataChanged; + property OnDetailCollapsing; + property OnDetailCollapsed; + property OnDetailExpanding; + property OnDetailExpanded; + property OnFilterRecord; + property OnGroupingChanged; + property OnRecordChanged; + property OnSortingChanged; + end; + + TcxGridItemBoldDataBinding = class(TcxGridItemDataBinding) + private + fBoldProperties: TBoldVariantFollowerController; + fSubscriber: TBoldPassthroughSubscriber; + procedure Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); + function GetDataController: TcxGridBoldDataController; + function GetBoldProperties: TBoldVariantFollowerController; + procedure SetBoldProperties(Value: TBoldVariantFollowerController); + protected + function GetDefaultValueTypeClass: TcxValueTypeClass; override; + procedure Init; override; + procedure Remove; + public + constructor Create(AItem: TcxCustomGridTableItem); override; + destructor Destroy; override; + procedure Assign(Source: TPersistent); override; + property DataController: TcxGridBoldDataController read GetDataController; + published + property BoldProperties: TBoldVariantFollowerController read GetBoldProperties write SetBoldProperties; + end; + + TcxGridBoldColumn = class(TcxGridColumn, IBoldAwareViewItem, IcxStoredObject) + private + function GetDataBinding: TcxGridItemBoldDataBinding; + procedure SetDataBinding(Value: TcxGridItemBoldDataBinding); + protected + // IcxStoredObject + function GetProperties(AProperties: TStrings): Boolean; + procedure GetPropertyValue(const AName: string; var AValue: Variant); override; + procedure SetPropertyValue(const AName: string; const AValue: Variant); override; + function CalculateBestFitWidth: Integer; override; + procedure VisibleChanged; override; + public + destructor Destroy; override; + published + property DataBinding: TcxGridItemBoldDataBinding read GetDataBinding write SetDataBinding implements IBoldAwareViewItem; + end; + + TcxBoldDataControllerSearch = class(TcxDataControllerSearch) + public + // the sole purpose of these overrides is to ensure range (fetch in 1 pass) +{$IFDEF BOLD_DELPHI25_OR_LATER} + function Locate(AItemIndex: Integer; const ASubText: string; AIsAnywhere: Boolean = False; ASyncSelection: Boolean = True): Boolean; override; + function LocateNext(AForward: Boolean; AIsAnywhere: Boolean = False; ASyncSelection: Boolean = True): Boolean; override; +{$ELSE} + function Locate(AItemIndex: Integer; const ASubText: string; AIsAnywhere: Boolean = False): Boolean; override; + function LocateNext(AForward: Boolean; AIsAnywhere: Boolean = False): Boolean; override; +{$ENDIF} + end; + + TcxGridBoldCardsViewInfo = class(TcxGridCardsViewInfo) + protected + end; + + TcxGridBoldCardViewViewInfo = class(TcxGridCardViewViewInfo) + protected + function GetSiteClass: TcxGridSiteClass; override; + function GetRecordsViewInfoClass: TcxCustomGridRecordsViewInfoClass; override; + end; + + TcxGridBoldCardView = class(TcxGridCardView, IBoldAwareView, IBoldValidateableComponent) + private + function GetDataController: TcxGridBoldDataController; + procedure SetDataController(Value: TcxGridBoldDataController); + // IBoldValidateableComponent + function ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: string): Boolean; + // IBoldAwareView + function GetItemCount: Integer; + function GetItem(Index: Integer): IBoldAwareViewItem; + function GetSelection: TBoldList; + function GetCurrentBoldObject: TBoldObject; + function GetCurrentIndex: integer; + function GetCurrentElement: TBoldElement; + protected + function GetDataControllerClass: TcxCustomDataControllerClass; override; + function GetControllerClass: TcxCustomGridControllerClass; override; + function GetItemClass: TcxCustomGridTableItemClass; override; + function DoEditing(AItem: TcxCustomGridTableItem): Boolean; override; + function DoCellDblClick(ACellViewInfo: TcxGridTableDataCellViewInfo; + AButton: TMouseButton; AShift: TShiftState): Boolean; override; + procedure DoSelectionChanged; override; + function GetViewInfoClass: TcxCustomGridViewInfoClass; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property Items[Index: Integer]: IBoldAwareViewItem read GetItem; default; + property ItemCount: Integer read GetItemCount; + property Selection: TBoldList read GetSelection; + property CurrentBoldObject: TBoldObject read GetCurrentBoldObject; + property CurrentElement: TBoldElement read GetCurrentElement; + property CurrentIndex: integer read GetCurrentIndex; + published + property DataController: TcxGridBoldDataController read GetDataController write SetDataController; + end; + + TcxGridBoldCardViewRow = class(TcxGridCardViewRow, IBoldAwareViewItem) + private + function GetDataBinding: TcxGridItemBoldDataBinding; + procedure SetDataBinding(Value: TcxGridItemBoldDataBinding); + protected + // IcxStoredObject + {function GetStoredProperties(AProperties: TStrings): Boolean; override; + procedure GetPropertyValue(const AName: string; var AValue: Variant); override; + procedure SetPropertyValue(const AName: string; const AValue: Variant); override;} + function CalculateBestFitWidth: Integer; override; + procedure VisibleChanged; override; + public + destructor Destroy; override; + published + property DataBinding: TcxGridItemBoldDataBinding read GetDataBinding write SetDataBinding implements IBoldAwareViewItem; + end; +(* + TcxGridBoldChartDataController = class(TcxBoldDataController, {TcxGridBoldDataController} IcxCustomGridDataController, + IcxGridChartViewItemsProvider) + private + { IcxGridChartViewItemsProvider } + function IcxGridChartViewItemsProvider.GetItem = GetChartItem; + function GetChartItem(AItemClass: TcxGridChartItemClass; AIndex: Integer): TcxGridChartItem; + procedure GetItemCaptions(AItemClass: TcxGridChartItemClass; ACaptions: TStringList); + procedure InitItem(AItem: TcxGridChartItem; AIndex: Integer); + procedure GetValidValueFields(AItemClass: TcxGridChartItemClass; AFields: TList); + { IcxCustomGridDataController } + procedure AssignData(ADataController: TcxCustomDataController); + procedure CreateAllItems(AMissingItemsOnly: Boolean); + procedure DeleteAllItems; + procedure GetFakeComponentLinks(AList: TList); + function HasAllItems: Boolean; + function IsDataChangeable: Boolean; + function SupportsCreateAllItems: Boolean; + published + property Options; +// property OnAfterSummary: TcxAfterSummaryEvent read GetOnAfterSummary write SetOnAfterSummary; + property OnCompare; + property OnDataChanged; + property OnFilterRecord; +// property OnSummary: TcxSummaryEvent read GetOnSummary write SetOnSummary; + end; + + TcxGridBoldChartItemDataBinding = class(TcxGridChartItemDataBinding) + private + fBoldProperties: TBoldVariantFollowerController; + procedure SetBoldProperties(Value: TBoldVariantFollowerController); + function GetDataController: TcxGridBoldChartDataController; + public + constructor Create(AGridView: TcxGridChartView; AIsValue: Boolean; + ADefaultValueTypeClass: TcxValueTypeClass); override; + destructor Destroy; override; + procedure Assign(Source: TPersistent); override; + property DataController: TcxGridBoldChartDataController read GetDataController; + property BoldProperties: TBoldVariantFollowerController read fBoldProperties write SetBoldProperties; + end; + + TcxGridBoldChartCategories = class(TcxGridChartCategories) + private + function GetDataBinding: TcxGridBoldChartItemDataBinding; + procedure SetDataBinding(Value: TcxGridBoldChartItemDataBinding); + published + property DataBinding: TcxGridBoldChartItemDataBinding read GetDataBinding write SetDataBinding; + end; + + TcxGridBoldChartDataGroup = class(TcxGridChartDataGroup) + private + function GetDataBinding: TcxGridBoldChartItemDataBinding; + procedure SetDataBinding(Value: TcxGridBoldChartItemDataBinding); + published + property DataBinding: TcxGridBoldChartItemDataBinding read GetDataBinding write SetDataBinding; + end; + + TcxGridBoldChartSeries = class(TcxGridChartSeries) + private + function GetDataBinding: TcxGridBoldChartItemDataBinding; + procedure SetDataBinding(Value: TcxGridBoldChartItemDataBinding); + published + property DataBinding: TcxGridBoldChartItemDataBinding read GetDataBinding write SetDataBinding; + end; + + TcxBoldGridChartView = class(TcxGridChartView, IBoldAwareView, IBoldValidateableComponent) + private + function GetCategories: TcxGridBoldChartCategories; + function GetDataController: TcxGridBoldChartDataController; + function GetDataGroup(Index: Integer): TcxGridBoldChartDataGroup; + function GetSeries(Index: Integer): TcxGridBoldChartSeries; + procedure SetCategories(Value: TcxGridBoldChartCategories); + procedure SetDataController(Value: TcxGridBoldChartDataController); + procedure SetDataGroup(Index: Integer; Value: TcxGridBoldChartDataGroup); + procedure SetSeries(Index: Integer; Value: TcxGridBoldChartSeries); + procedure ClearItems; + // IBoldValidateableComponent + function ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: String): Boolean; + // IBoldAwareView + function GetItemCount: Integer; + function GetItem(Index: Integer): IBoldAwareViewItem; + function GetSelection: TBoldList; + property Selection: TBoldList read GetSelection; + protected + function GetCategoriesClass: TcxGridChartCategoriesClass; override; + function GetDataControllerClass: TcxCustomDataControllerClass; override; + function GetItemDataBindingClass: TcxGridChartItemDataBindingClass; override; + + function FindItemByFieldName(AItemClass: TcxGridChartItemClass; const AFieldName: string): TcxGridChartItem; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property Items[Index: Integer]: IBoldAwareViewItem read GetItem; default; + property ItemCount: Integer read GetItemCount; + + function CreateDataGroup: TcxGridBoldChartDataGroup; + function FindDataGroupByFieldName(const AFieldName: string): TcxGridBoldChartDataGroup; + function GetDataGroupClass: TcxGridChartDataGroupClass; override; + property DataGroups[Index: Integer]: TcxGridBoldChartDataGroup read GetDataGroup write SetDataGroup; + + function CreateSeries: TcxGridBoldChartSeries; + function FindSeriesByFieldName(const AFieldName: string): TcxGridBoldChartSeries; + function GetSeriesClass: TcxGridChartSeriesClass; override; + property Series[Index: Integer]: TcxGridBoldChartSeries read GetSeries write SetSeries; + published + property Categories: TcxGridBoldChartCategories read GetCategories write SetCategories; + property DataController: TcxGridBoldChartDataController read GetDataController write SetDataController; + end; +*) + + TcxGridBoldBandedColumn = class(TcxGridBandedColumn, IBoldAwareViewItem {,IcxStoredObject}) + private + function GetDataBinding: TcxGridItemBoldDataBinding; + procedure SetDataBinding(Value: TcxGridItemBoldDataBinding); +// procedure HyperLinkClick(Sender: TObject); + protected + // IcxStoredObject +// function GetProperties(AProperties: TStrings): Boolean; +// procedure GetPropertyValue(const AName: string; var AValue: Variant); override; +// procedure SetPropertyValue(const AName: string; const AValue: Variant); override; + function CalculateBestFitWidth: Integer; override; + procedure VisibleChanged; override; + public + destructor Destroy; override; + published + property DataBinding: TcxGridItemBoldDataBinding read GetDataBinding write SetDataBinding implements IBoldAwareViewItem; + end; + + TcxGridBoldBandedRowsViewInfo = class(TcxGridBandedRowsViewInfo) + protected + end; + + TcxGridBoldBandedTableViewInfo = class(TcxGridBandedTableViewInfo) + protected + function GetRecordsViewInfoClass: TcxCustomGridRecordsViewInfoClass; override; + function GetSiteClass: TcxGridSiteClass; override; + procedure Calculate; override; + end; + + TcxGridBoldBandedTableView = class(TcxGridBandedTableView, IBoldAwareView, IBoldValidateableComponent) + private + FPrevFocusedRecordIndex: integer; + FPrevFocusedDataRecordIndex: integer; + procedure HookDragDrop; + function GetDataController: TcxGridBoldDataController; + procedure SetDataController(Value: TcxGridBoldDataController); + // IBoldValidateableComponent + function ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: string): Boolean; + // IBoldAwareView + function GetItemCount: Integer; + function GetItem(Index: Integer): IBoldAwareViewItem; + function GetSelection: TBoldList; + function GetCurrentBoldObject: TBoldObject; + function GetCurrentIndex: integer; + function GetCurrentElement: TBoldElement; + protected + function GetDataControllerClass: TcxCustomDataControllerClass; override; + function GetControllerClass: TcxCustomGridControllerClass; override; + function GetItemClass: TcxCustomGridTableItemClass; override; + function DoCellDblClick(ACellViewInfo: TcxGridTableDataCellViewInfo; + AButton: TMouseButton; AShift: TShiftState): Boolean; override; + function DoEditing(AItem: TcxCustomGridTableItem): Boolean; override; + procedure DoSelectionChanged; override; + function GetViewInfoClass: TcxCustomGridViewInfoClass; override; + procedure DoChanged(AChangeKind: TcxGridViewChangeKind); override; + procedure DoFocusedRecordChanged(APrevFocusedRecordIndex, AFocusedRecordIndex, + APrevFocusedDataRecordIndex, AFocusedDataRecordIndex: Integer; + ANewItemRecordFocusingChanged: Boolean); override; +{$IFDEF DelayOnFocusedRecordChange} + procedure InheritedDoFocusedRecordChanged(APrevFocusedRecordIndex, AFocusedRecordIndex, // a bit ugly + APrevFocusedDataRecordIndex, AFocusedDataRecordIndex: Integer; + ANewItemRecordFocusingChanged: Boolean); +{$ENDIF} + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property Items[Index: Integer]: IBoldAwareViewItem read GetItem; default; + property ItemCount: Integer read GetItemCount; + property Selection: TBoldList read GetSelection; + property CurrentBoldObject: TBoldObject read GetCurrentBoldObject; + property CurrentElement: TBoldElement read GetCurrentElement; + property CurrentIndex: integer read GetCurrentIndex; + published + property DataController: TcxGridBoldDataController read GetDataController write SetDataController; + end; + + TcxBoldGridSite = class(TcxGridSite) + protected + procedure WndProc(var Message: TMessage); override; + end; + + TLinkClickEvent = procedure(Sender: TObject; aElement: TBoldElement) of object; + + TcxBoldGridRowsViewInfo = class(TcxGridRowsViewInfo) + protected + end; + + TcxGridBoldTableViewInfo = class(TcxGridTableViewInfo) + protected + function GetRecordsViewInfoClass: TcxCustomGridRecordsViewInfoClass; override; + function GetSiteClass: TcxGridSiteClass; override; + procedure Calculate; override; + end; + + TcxGridBoldTableView = class(TcxGridTableView, IBoldAwareView, IBoldValidateableComponent) + private + fOnLinkClick: TLinkClickEvent; + FPrevFocusedRecordIndex: integer; + FPrevFocusedDataRecordIndex: integer; + procedure HookDragDrop; + function GetDataController: TcxGridBoldDataController; + procedure SetDataController(Value: TcxGridBoldDataController); + function GetSelection: TBoldList; + function GetCurrentBoldObject: TBoldObject; + function GetCurrentIndex: integer; + function GetCurrentElement: TBoldElement; + // IBoldValidateableComponent + function ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: string): Boolean; + // IBoldAwareView + function GetItemCount: Integer; + function GetItem(Index: Integer): IBoldAwareViewItem; + function GetFake: TNotifyEvent; + procedure SetFake(const Value: TNotifyEvent); + protected + // IcxStoredObject + function GetProperties(AProperties: TStrings): Boolean; override; + procedure GetPropertyValue(const AName: string; var AValue: Variant); override; + procedure SetPropertyValue(const AName: string; const AValue: Variant); override; + + function GetDataControllerClass: TcxCustomDataControllerClass; override; + function GetControllerClass: TcxCustomGridControllerClass; override; + function GetItemClass: TcxCustomGridTableItemClass; override; + function DoEditing(AItem: TcxCustomGridTableItem): Boolean; override; + procedure DoEditKeyPress(AItem: TcxCustomGridTableItem; AEdit: TcxCustomEdit; + var Key: Char); override; + function DoCellDblClick(ACellViewInfo: TcxGridTableDataCellViewInfo; + AButton: TMouseButton; AShift: TShiftState): Boolean; override; + procedure DoSelectionChanged; override; + procedure DoChanged(AChangeKind: TcxGridViewChangeKind); override; + procedure DoFocusedRecordChanged(APrevFocusedRecordIndex, AFocusedRecordIndex, + APrevFocusedDataRecordIndex, AFocusedDataRecordIndex: Integer; + ANewItemRecordFocusingChanged: Boolean); override; +{$IFDEF DelayOnFocusedRecordChange} + procedure InheritedDoFocusedRecordChanged(APrevFocusedRecordIndex, AFocusedRecordIndex, // a bit ugly + APrevFocusedDataRecordIndex, AFocusedDataRecordIndex: Integer; + ANewItemRecordFocusingChanged: Boolean); +{$ENDIF} + procedure DoItemsAssigned; override; + function GetViewInfoClass: TcxCustomGridViewInfoClass; override; + procedure DoCustomDrawCell(ACanvas: TcxCanvas; AViewInfo: TcxGridTableDataCellViewInfo; + var ADone: Boolean); override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property Items[Index: Integer]: IBoldAwareViewItem read GetItem; default; + property ItemCount: Integer read GetItemCount; + property Selection: TBoldList read GetSelection; + property CurrentBoldObject: TBoldObject read GetCurrentBoldObject; + property CurrentElement: TBoldElement read GetCurrentElement; + property CurrentIndex: integer read GetCurrentIndex; + published + property DataController: TcxGridBoldDataController read GetDataController write SetDataController; + property DragMode; + property OnDelete: TNotifyEvent read GetFake write SetFake; + property OnInsert: TNotifyEvent read GetFake write SetFake; + + property OnLinkClick: TLinkClickEvent read fOnLinkClick write fOnLinkClick; + end; + + TcxGridBoldLayoutView = class(TcxGridLayoutView, IBoldAwareView, IBoldValidateableComponent) + private + function GetDataController: TcxGridBoldDataController; +// function GetItem(Index: Integer): TcxGridBoldLayoutViewItem; + procedure SetDataController(Value: TcxGridBoldDataController); +// procedure SetItem(Index: Integer; Value: TcxGridBoldLayoutViewItem); + // IBoldValidateableComponent + function ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: string): Boolean; + // IBoldAwareView + function GetItemCount: Integer; + function GetItem(Index: Integer): IBoldAwareViewItem; + function GetSelection: TBoldList; + function GetCurrentBoldObject: TBoldObject; + function GetCurrentIndex: integer; + function GetCurrentElement: TBoldElement; + protected + function GetDataControllerClass: TcxCustomDataControllerClass; override; + function GetItemClass: TcxCustomGridTableItemClass; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + function CreateItem: TcxGridBoldLayoutViewItem; +// property Items[Index: Integer]: TcxGridBoldLayoutViewItem read GetItem write SetItem; + property Items[Index: Integer]: IBoldAwareViewItem read GetItem; default; + property ItemCount: Integer read GetItemCount; + property Selection: TBoldList read GetSelection; + property CurrentBoldObject: TBoldObject read GetCurrentBoldObject; + property CurrentElement: TBoldElement read GetCurrentElement; + property CurrentIndex: integer read GetCurrentIndex; + published + property DataController: TcxGridBoldDataController read GetDataController write SetDataController; + end; + + TcxGridBoldLayoutViewItem = class(TcxGridLayoutViewItem, IBoldAwareViewItem) + private + function GetDataBinding: TcxGridItemBoldDataBinding; + procedure SetDataBinding(Value: TcxGridItemBoldDataBinding); + public + destructor Destroy; override; + published + property DataBinding: TcxGridItemBoldDataBinding read GetDataBinding write SetDataBinding implements IBoldAwareViewItem; + end; + + + TcxBoldCustomDataProvider = class(TcxCustomDataProvider) + protected + function GetValue(ARecordIndex: Integer; AField: TcxCustomDataField): Variant; override; + procedure SetValue(ARecordIndex: Integer; AField: TcxCustomDataField; const Value: Variant); override; + function CanInsert: Boolean; override; + function CanDelete: Boolean; override; + procedure DeleteRecords(AList: TList); override; + function SetEditValue(ARecordIndex: Integer; AField: TcxCustomDataField; const AValue: Variant; AEditValueSource: TcxDataEditValueSource): Boolean; override; + function IsActiveDataSet: Boolean; override; + end; + + TcxGridBoldTableController = class(TcxGridTableController) + protected +{ procedure FocusedRecordChanged(APrevFocusedRecordIndex, AFocusedRecordIndex, + APrevFocusedDataRecordIndex, AFocusedDataRecordIndex: Integer; + ANewItemRecordFocusingChanged: Boolean); override; +} + function GetEditingControllerClass: TcxGridEditingControllerClass; override; + public + procedure DoKeyDown(var Key: Word; Shift: TShiftState); override; + procedure KeyDown(var Key: Word; Shift: TShiftState); override; + procedure KeyUp(var Key: Word; Shift: TShiftState); override; + end; + + TcxGridBoldBandedTableController = class(TcxGridBandedTableController) + protected + function GetEditingControllerClass: TcxGridEditingControllerClass; override; + public + procedure DoKeyDown(var Key: Word; Shift: TShiftState); override; + procedure KeyDown(var Key: Word; Shift: TShiftState); override; + procedure KeyUp(var Key: Word; Shift: TShiftState); override; + end; + + TcxGridBoldEditingController = class(TcxGridTableEditingController) + protected + procedure DoEditKeyDown(var Key: Word; Shift: TShiftState); override; + procedure EditChanged(Sender: TObject); override; + procedure EditExit(Sender: TObject); override; + public + procedure HideEdit(Accept: Boolean); override; + end; + + TcxGridBoldCardViewController = class(TcxGridCardViewController) + protected + function GetEditingControllerClass: TcxGridEditingControllerClass; override; +// procedure DoEditKeyDown(var Key: Word; Shift: TShiftState); override; +// procedure EditChanged(Sender: TObject); override; + public + end; + + TcxGridBoldCardEditingController = class(TcxGridEditingController) + protected +// procedure DoEditKeyDown(var Key: Word; Shift: TShiftState); override; + procedure EditChanged(Sender: TObject); override; +// procedure EditExit(Sender: TObject); override; + public +// procedure HideEdit(Accept: Boolean); override; + end; + + + TcxBoldDataSourceClass = class of TcxBoldDataSource; +{$IFDEF BoldDevExLog} + TcxBoldGridLogProc = procedure(aMessage: string; aCategory: string = '') of object; +{$ENDIF} + +var + cxBoldDataSourceClass: TcxBoldDataSourceClass = TcxBoldDataSource; +{$IFDEF BoldDevExLog} + cxBoldGridLogProc: TcxBoldGridLogProc; +{$ENDIF} + +{$IFDEF BoldDevExLog} +procedure _Log(aMessage: string; aCategory: string = ''); +{$ENDIF} + +implementation + +uses + Dialogs, + Forms, + Graphics, + Math, + SysUtils, + Variants, + Windows, +{$IFDEF BOLD_DELPHI16_OR_LATER}UiTypes,{$ENDIF} + + BoldAFP, + BoldAttributes, + BoldBase, + BoldCommonBitmaps, + BoldControlPackDefs, + BoldDefs, + BoldDerivedValueSet, + BoldElementList, + BoldEnvironment, + BoldGui, + BoldId, + BoldListControlPack, + BoldListHandle, + BoldMLAttributes, + BoldOcl, + BoldQueue, + BoldReferenceHandle, + BoldSystemPersistenceHandler, + BoldValueSpaceInterfaces, + + cxCalendar, + cxCheckBox, + cxClasses, + cxControls, + cxCurrencyEdit, + cxFilterConsts, + cxFilterControlUtils, + cxGridCommon, + cxGridLevel, + cxGridRows, + cxHyperLinkEdit, + cxImage, + cxSpinEdit, + cxTextEdit, + cxTimeEdit, + +{$IFDEF SpanFetch} + AttracsSpanFetchManager, +{$ENDIF} + BoldGuard, TypInfo; + +const + cOCLConstraint = 'constraints->select(c|not c)->size = 0'; + beSystemDestroying = 100; + beSelectionDestroying = 101; + +type + EcxGridBoldSupport = class(Exception); + TcxCustomDataControllerAccess = class(TcxCustomDataController); + TcxGridTableControllerAccess = class(TcxGridTableController); + TBoldListHandleFollowerAccess = class(TBoldListHandleFollower); + TBoldFollowerAccess = class(TBoldFollower); + TBoldFollowerControllerAccess = class(TBoldFollowerController); + TcxCustomGridTableItemAccess = class(TcxCustomGridTableItem); + TcxGridLevelAccess = class(TcxGridLevel); + TcxCustomDataProviderAccess = class(TcxCustomDataProvider); + TcxCustomGridRecordAccess = class(TcxCustomGridRecord); + TcxCustomGridTableViewAccess = class(TcxCustomGridTableView); + TcxCustomDataControllerInfoAccess = class(TcxCustomDataControllerInfo); + TBoldQueueableAccess = class(TBoldQueueable); + +{$IFDEF BoldDevExLog} +procedure _Log(aMessage: string; aCategory: string = ''); +begin + if Assigned(cxBoldGridLogProc) then + cxBoldGridLogProc(aMessage, aCategory); +end; +{$ENDIF} + +function InternalSetValue(aFollower: TBoldFollower; const AValue: Variant): boolean; +var + lController: TBoldVariantFollowerController; +begin + result := false; + lController := aFollower.Controller as TBoldVariantFollowerController; + if VarIsNull(aValue) then + lController.MayHaveChanged('', aFollower) + else + lController.MayHaveChanged(aValue, aFollower); +end; + +{ TcxGridBoldDataController } + +procedure TcxGridBoldDataController.SetValueTypeAndProperties( + aElementTypeInfo: TBoldElementTypeInfo; aItem: TcxCustomGridTableItem; + aChangeProperties: boolean); +var + lAttributeClass: TClass; + lValueType: string; + lBAValueSet: TBAValueSet; + lBoldAttributeTypeInfo: TBoldAttributeTypeInfo; + i: integer; +begin + lValueType := 'String'; + if aElementTypeInfo is TBoldAttributeTypeInfo then + begin + lBoldAttributeTypeInfo := TBoldAttributeTypeInfo(aElementTypeInfo); + lAttributeClass := lBoldAttributeTypeInfo.AttributeClass; + if not Assigned(lAttributeClass) then + begin + raise EcxGridBoldSupport.Create('Custom attribute ' + aElementTypeInfo.ModelName + ' is not installed in IDE.'); + end; + // Blob, ValueSet and Associations map to string + if lAttributeClass.InheritsFrom(TBAString) then + begin + lValueType := 'String'; + if aChangeProperties then + aItem.PropertiesClass := TcxTextEditProperties; + end + else + if lAttributeClass.InheritsFrom(TBATime) then + begin + lValueType := 'DateTime'; + if aChangeProperties then + begin + aItem.PropertiesClass := TcxTimeEditProperties; + (aItem.Properties as TcxTimeEditProperties).Alignment.Horz := taRightJustify; + end; + end + else + if lAttributeClass.InheritsFrom(TBAMoment) then + begin + lValueType := 'DateTime'; + if aChangeProperties then + begin + aItem.PropertiesClass := TcxDateEditProperties; + (aItem.Properties as TcxDateEditProperties).Alignment.Horz := taRightJustify; + end; + end + else + if lAttributeClass.InheritsFrom(TBABoolean) then + begin + lValueType := 'Boolean'; + if aChangeProperties then + aItem.PropertiesClass := TcxCheckBoxProperties; + end + else + if lAttributeClass.InheritsFrom(TBACurrency) then + begin + lValueType := 'Currency'; + if aChangeProperties then + begin + aItem.PropertiesClass := TcxCurrencyEditProperties; + (aItem.Properties as TcxCurrencyEditProperties).Alignment.Horz := taRightJustify; + end; + end + else + if lAttributeClass.InheritsFrom(TBANumeric) then + begin + if aChangeProperties then + begin + aItem.PropertiesClass := TcxSpinEditProperties; + (aItem.properties as TcxSpinEditProperties).SpinButtons.Visible := false; + (aItem.Properties as TcxSpinEditProperties).Alignment.Horz := taRightJustify; + (aItem.Properties as TcxSpinEditProperties).Increment := 0; + (aItem.Properties as TcxSpinEditProperties).LargeIncrement := 0; + end; + if lAttributeClass.InheritsFrom(TBAFloat) then + begin + lValueType := 'Float'; + if aItem.properties is TcxSpinEditProperties then + (aItem.properties as TcxSpinEditProperties).ValueType := vtFloat; + end + else + if lAttributeClass.InheritsFrom(TBASMallInt) then + begin + lValueType := 'Smallint'; + if aItem.properties is TcxSpinEditProperties then + (aItem.properties as TcxSpinEditProperties).ValueType := vtInt; + end + else + if lAttributeClass.InheritsFrom(TBAWord) then + begin + lValueType := 'Word'; + if aItem.properties is TcxSpinEditProperties then + (aItem.properties as TcxSpinEditProperties).ValueType := vtInt; + end + else + if lAttributeClass.InheritsFrom(TBAInteger) then + begin + lValueType := 'Integer'; + if aItem.properties is TcxSpinEditProperties then + (aItem.properties as TcxSpinEditProperties).ValueType := vtInt; + end; + end + else + {$IFDEF IEJpegImage} + if lAttributeClass.InheritsFrom(TBABlobImageJPEG) then + begin + lValueType := ''; + if aChangeProperties then + begin + aItem.PropertiesClass := TcxImageProperties; + (aItem.properties as TcxImageProperties).GraphicClassName := 'TIEJpegImage'; + end; + end + else + {$ENDIF} + if lAttributeClass.InheritsFrom(TBABlobImageBMP) or lAttributeClass.InheritsFrom(TBABlobImageJPEG) then + begin + lValueType := ''; + if aChangeProperties then + aItem.PropertiesClass := TcxImageProperties; + end + else + if aChangeProperties and lAttributeClass.InheritsFrom(TBAValueSet) then + begin + if lAttributeClass.InheritsFrom(TBALanguage) or lAttributeClass.InheritsFrom(TBADerivedValueSetValueList) and GridView.IsDesigning then + begin + MessageDlg(Format('Combo values for ''%s'' can only be fetched at run time', [aElementTypeInfo.expressionName]), mtError, [mbOk], 0); + end + else + begin + lBAValueSet := TBoldMemberFactory.CreateMemberFromBoldType(aElementTypeInfo) as TBAValueSet; + try + aItem.PropertiesClass := TcxComboBoxProperties; + (aItem.Properties as TcxComboBoxProperties).Items.Clear; + for i := 0 to lBAValueSet.Values.Count - 1 do + begin + (aItem.Properties as TcxComboBoxProperties).Items.Add(lBAValueSet.Values[i].AsString); + end; + (aItem.Properties as TcxComboBoxProperties).DropDownListStyle := lsEditFixedList; + (aItem.Properties as TcxComboBoxProperties).DropDownRows := lBAValueSet.Values.Count; + finally + lBAValueSet.Free; + end; + end; + end; + end; + aItem.DataBinding.ValueType := lValueType; +end; + +procedure TcxGridBoldDataController.SetValueTypeAndProperties(aMember: TBoldMemberRtInfo; aItem: TcxCustomGridTableItem; aChangeProperties: boolean); +begin + SetValueTypeAndProperties(aMember.boldType, aItem); +end; + +procedure TcxGridBoldDataController.ChangeValueTypeClass(AItemIndex: Integer; + AValueTypeClass: TcxValueTypeClass); +begin + // this code is copied from inherited TcxCustomDataController.ChangeValueTypeClass and RestructData is commented out + // Commenting out RestructData causes other problems. + // Probably it has to be only called once, not for each item. That should be implemented + CheckItemRange(AItemIndex); + if GetItemValueTypeClass(AItemIndex) <> AValueTypeClass then + begin + Fields[AItemIndex].ValueTypeClass := AValueTypeClass; +// if {IsProviderMode and} not TcxCustomGridTableViewAccess(GridView).IsAssigningItems then +// RestructData; + DataControllerInfo.UpdateField(Fields[AItemIndex]); + DoValueTypeClassChanged(AItemIndex); + end; +end; + +procedure TcxGridBoldDataController.CheckDataSetCurrent; +var + i: integer; + lChanged: boolean; + lState : TKeyboardState; +begin + inherited; + if Assigned(BoldHandle) and Assigned(CustomDataSource) and (FSkipSyncFocusedRecord = 0) and not (csDestroying in GridView.ComponentState) then + begin + i := FocusedRecordIndex; + if (i >= RecordCount) then + begin + FocusedRecordIndex := -1; + i := -1; + end; + lChanged := (i <> Follower.CurrentIndex) {or (i <> BoldHandle.CurrentIndex)}; + if not lChanged and (i <> BoldHandle.CurrentIndex) then + lChanged := true; + + if lChanged then + begin + {$IFDEF BoldDevExLog} + if GridView <> nil then + _Log(GridView.Name + ':CheckDataSetCurrent', className) + else + _Log(':CheckDataSetCurrent', className); + {$ENDIF} + ConnectEvents(false); + inc(FSkipMakeCellUptoDate); + BeginUpdate; + try +// TBoldQueueable.DisplayAll; + fBoldHandleFollower.SetFollowerIndex(i); + GetKeyboardState(lState); + if i <> -1 then + begin + i := GetRowIndexByRecordIndex(i, false); + end; + if not (((lState[VK_CONTROL] and 128) <> 0) or ((lState[VK_SHIFT] and 128) <> 0)) and ((i = -1) or not IsRowSelected(i)) then + begin + Controller.ClearSelection; + if Assigned(Controller.FocusedRecord) and not MultiSelect then + Controller.FocusedRecord.Selected := true; + end; + finally + DisplayFollowers; + ConnectEvents(True); + dec(FSkipMakeCellUptoDate); + SelectionChanged; + EndUpdate; + end; + end; + end; +end; + +procedure TcxGridBoldDataController.ConnectEvents(AConnect: boolean); +var + i: integer; +begin + for i := 0 to ItemCount - 1 do + begin + if AConnect then + BoldPropertiesFromItem(i).AfterMakeUptoDate := _AfterMakeCellUptoDate + else + BoldPropertiesFromItem(i).AfterMakeUptoDate := nil; + end; + if AConnect then + begin + fBoldProperties.AfterMakeUptoDate := _AfterMakeListUptoDate; + fBoldProperties.BeforeMakeUptoDate := _BeforeMakeListUptoDate; + fBoldProperties.OnAfterInsertItem := _InsertRow; + fBoldProperties.OnAfterDeleteItem := _DeleteRow; + fBoldProperties.OnReplaceitem := _ReplaceRow + end + else + begin + fBoldProperties.AfterMakeUptoDate := nil; + fBoldProperties.BeforeMakeUptoDate := nil; + fBoldProperties.OnAfterInsertItem := nil; + fBoldProperties.OnAfterDeleteItem := nil; + fBoldProperties.OnReplaceitem := nil; + end; +end; + +procedure TcxGridBoldDataController.ConstraintColumnCustomDrawCell( + Sender: TcxCustomGridTableView; ACanvas: TcxCanvas; + AViewInfo: TcxGridTableDataCellViewInfo; var ADone: Boolean); +var + ARect: TRect; + lConstraintBitmap: Graphics.TBitmap; + lValue: Variant; +begin + if AViewInfo is TcxGridCardRowCaptionViewInfo then exit; + with AViewInfo do + begin + ARect := Bounds; +// ACanvas.Brush.Style := bsClear; + ACanvas.FillRect(ARect, ACanvas.Brush.Color); + if AViewInfo.RecordViewInfo.Index = -1 then + begin + // draw nothing + end + else + begin + lValue := Value; + if not VarIsNull(lValue) and lValue then + lConstraintBitmap := bmpBoldGridConstraint_true + else + lConstraintBitmap := bmpBoldGridConstraint_false; + lConstraintBitmap.Transparent := true; + ACanvas.Draw(ARect.Left + 4, ARect.Top + 4, lConstraintBitmap); + end; + end; + ADone := true; +end; + +procedure TcxGridBoldDataController.ColumnCustomDrawCell( + Sender: TcxCustomGridTableView; ACanvas: TcxCanvas; + AViewInfo: TcxGridTableDataCellViewInfo; var ADone: Boolean); +var + lBoldVariantFollowerController: TBoldVariantFollowerController; + lColor: TColor; + lCellFollower: TBoldFollower; +begin + inc(FSkipMakeCellUptoDate); + try + if not AViewInfo.RecordViewInfo.Focused then + begin + lCellFollower := CellFollowers[AViewInfo.RecordViewInfo.GridRecord.RecordIndex, AViewInfo.Item.Id]; + if Assigned(lCellFollower) then + begin + lBoldVariantFollowerController := lCellFollower.Controller as TBoldVariantFollowerController; + lBoldVariantFollowerController.SetColor(lColor, ACanvas.Brush.Color, lCellFollower); + lBoldVariantFollowerController.SetFont(ACanvas.Font, ACanvas.Font, lCellFollower); + if LColor > -1 then + ACanvas.Brush.Color := lColor; + end; + end; + finally + dec(FSkipMakeCellUptoDate); + end; +end; + +procedure TcxGridBoldDataController.GetCellHint(Sender: TcxCustomGridTableItem; ARecord: TcxCustomGridRecord; + ACellViewInfo: TcxGridTableDataCellViewInfo; const AMousePos: TPoint; + var AHintText: TCaption; var AIsHintMultiLine: Boolean; var AHintTextRect: TRect); +var + lIE: TBoldIndirectElement; +begin + if VarIsType(ACellViewInfo.Value, varBoolean) and (not ACellViewInfo.Value) then +// if (not VarIsNull(ACellViewInfo.Value)) and (not ACellViewInfo.Value) then + begin + lIE := TBoldIndirectElement.Create; + try + Follower.SubFollowers[ARecord.RecordIndex].Element.EvaluateExpression('constraints->select(c|not c)', lIE); + AHintText := (lIE.Value as TBoldList).AsCommaText(false, 11); + finally + lIE.free; + end; + end; +end; + +procedure TcxGridBoldDataController.CreateAllItems( + AMissingItemsOnly: Boolean); + +function ClassTypeHasConstraints(aBoldClassTypeInfo: TBoldClassTypeInfo): boolean; +var + lBoldClassTypeInfo: TBoldClassTypeInfo; +begin + lBoldClassTypeInfo := aBoldClassTypeInfo; + repeat + // BoldClassTypeInfo.ConstraintCount doesn't include inherited constraints so we have to iterate + result := lBoldClassTypeInfo.ConstraintCount > 0; + lBoldClassTypeInfo := lBoldClassTypeInfo.SuperClassTypeInfo; + until result or (lBoldClassTypeInfo = nil); +end; + +var + I: Integer; + lListElementType: TBoldElementTypeInfo; + lClasstypeInfo: TBoldClassTypeInfo; + lMember: TBoldMemberRtInfo; + lcxCustomGridTableItem: TcxCustomGridTableItem; +begin + if (BoldHandle = nil) or (BoldHandle.ListElementType = nil) then Exit; + ShowHourglassCursor; + fCreatingColumns := true; + try + GridView.BeginUpdate; + BeginUpdateFields; + try + lListElementType := BoldHandle.ListElementType; + if (lListElementType is TBoldClassTypeInfo) then + begin + lClassTypeInfo := lListElementType as TBoldClassTypeInfo; + if ClassTypeHasConstraints(lClassTypeInfo) and (not AMissingItemsOnly or (GetItemByExpression(cOCLConstraint) = nil)) then + begin + // create constraint column + EnsureConstraintColumn; + end; + if (lClassTypeInfo.DefaultStringRepresentation <> '') and (lClassTypeInfo.AllMembers.Count = 0) then + begin + if not AMissingItemsOnly or (GetItemByExpression('') = nil) then + begin + CreateItem(GridView, '', lClassTypeInfo.ModelName, 'String', 'DefaultStringRepresentation'); + end; + end; + for i := 0 to lClassTypeInfo.AllMembers.Count - 1 do + begin + lMember := lClassTypeInfo.AllMembers[I]; + if (lMember.IsAttribute or (lMember.IsSingleRole and TBoldRoleRTInfo(lMember).IsNavigable)) and not lMember.DelayedFetch then + begin + if not AMissingItemsOnly or (GetItemByExpression(lMember.ExpressionName) = nil) then + begin + lcxCustomGridTableItem := CreateItem(GridView, lMember.ExpressionName, lMember.ModelName, 'String', lMember.ModelName); + if lMember.IsSingleRole then + begin + lcxCustomGridTableItem.DataBinding.ValueType := 'String'; + end + else + begin + SetValueTypeAndProperties(lMember, lcxCustomGridTableItem); + end; + end; + end; + end; + end + else if (lListElementType is TBoldAttributeTypeInfo) then + begin + if not AMissingItemsOnly or (GetItemByExpression('') = nil) then + begin + CreateItem(GridView, '', TBoldAttributeTypeInfo(lListElementType).ModelName, 'String', TBoldAttributeTypeInfo(lListElementType).ModelName); + end; + end + else if (lListElementType is TBoldListTypeInfo) then + begin + if not AMissingItemsOnly or (GetItemByExpression('') = nil) then + begin + CreateItem(GridView, '', 'ClassName', 'String', 'ClassName'); + end; + end; + if (GridView.ItemCount = 0) or ((GridView.ItemCount = 1) and ((GridView.Items[0] as IBoldAwareViewItem).BoldProperties.expression = cOCLConstraint)) then + begin + CreateItem(GridView, '', lListElementType.asString, 'String', lListElementType.asString); + end; + finally + EndUpdateFields; + GridView.EndUpdate; + end; + finally + HideHourglassCursor; + fCreatingColumns := false; + end; +end; + +{ +procedure TcxGridBoldDataController.DoGroupingChanged; +begin + inherited; + +end; + +procedure TcxGridBoldDataController.DoSortingChanged; +begin + inherited; + +end; +} + +function TcxGridBoldDataController.GetController: TcxCustomGridTableController; +begin + Result := GridView.Controller; +end; + +function TcxGridBoldDataController.GetGridViewValue: TcxCustomGridTableView; +begin + result := TcxCustomGridTableView(GetGridView); +end; + +function TcxGridBoldDataController.GetItem(Index: Integer): TObject; +begin + Result := GridView.Items[Index]; +end; + +function TcxGridBoldDataController.GetItemByExpression( + const aExpression: string): TObject; +var + I: Integer; +begin + Result := nil; + for I := 0 to ItemCount - 1 do + begin + if AnsiCompareText(BoldPropertiesFromItem(i).Expression, aExpression) = 0 then + begin + Result := GetItem(I); + Break; + end; + end; +end; + +function TcxGridBoldDataController.GetItemData(AItem: TObject): Integer; +begin + if AItem is TcxCustomGridTableItem then + Result := Integer(TcxCustomGridTableItem(AItem).DataBinding.Data) + else + Result := -1; +end; + +function TcxGridBoldDataController.GetItemDataBindingClass: TcxGridItemDataBindingClass; +begin + Result := TcxGridItemBoldDataBinding; +end; + +function TcxGridBoldDataController.HasAllItems: Boolean; +begin + result := false; +end; + +function TcxGridBoldDataController.SupportsCreateAllItems: Boolean; +begin + result := true; +end; + +procedure TcxGridBoldDataController.ForEachRow(ASelectedRows: Boolean; + AProc: TcxDataControllerEachRowProc); +var + i: integer; + lList: TBoldList; + IsObjectList: boolean; + lWholeList: TBoldList; + lGuard: IBoldGuard; +begin + if ASelectedRows then + begin + if GetSelectedCount > 0 then + begin + lWholeList := BoldList; + lGuard := TBoldGuard.Create(lList); + lList := CreateList; + lList.DuplicateMode := bldmAllow; + lList.Capacity := GetSelectedCount; + IsObjectList := (lList is TBoldObjectList) and (lWholeList is TBoldObjectList); + for i := 0 to GetSelectedCount - 1 do // or Controller.SelectedRecordCount ? + begin + if IsObjectList then + TBoldObjectList(lList).AddLocator( TBoldObjectList(lWholeList).Locators[Controller.SelectedRecords[i].RecordIndex] ) + else + lList.Add(lWholeList[Controller.SelectedRecords[i].RecordIndex]); + end; + AdjustActiveRange(lList); + end; + end + else + begin + AdjustActiveRange; + end; + inherited; +end; + +procedure TcxGridBoldDataController.SetMasterRelation( + AMasterRelation: TcxCustomDataRelation; AMasterRecordIndex: Integer); +var + lReferenceHandle: TBoldReferenceHandle; + lListHandle: TBoldListHandle; + lGridLevel: TcxGridLevel; + lPatternView: IBoldAwareView; + lMasterElement: TBoldElement; + lBoldAwareView: IBoldAwareView; +begin + if Assigned(AMasterRelation) and (AMasterRelation.Item is TcxGridLevel) then + begin + lGridLevel := (AMasterRelation.Item as TcxGridLevel); + if lGridLevel.GridView.IsPattern and (lGridLevel.GridView <> GridView) then + begin + lBoldAwareView := lGridLevel.GridView.MasterGridView as IBoldAwareView; + Assert(lBoldAwareView.DataController.BoldHandle.List.count > AMasterRecordIndex); + lBoldAwareView.DataController.BoldHandle.CurrentIndex := AMasterRecordIndex; + lMasterElement := lBoldAwareView.DataController.BoldHandle.Value; + lPatternView := (lGridLevel.GridView as IBoldAwareView); + lReferenceHandle := TBoldReferenceHandle.Create(GetOwnerOrView); + lReferenceHandle.Value := lMasterElement; + lListHandle := TBoldListHandle.Create(GetOwnerOrView); + lListHandle.RootHandle := lReferenceHandle; + if Assigned(lPatternView.DataController.BoldHandle) and (lPatternView.DataController.BoldHandle is TBoldListHandle) then + begin + lListHandle.expression := (lPatternView.DataController.BoldHandle as TBoldListHandle).Expression; + lListHandle.mutableListexpression := (lPatternView.DataController.BoldHandle as TBoldListHandle).mutableListexpression; + lListHandle.name := CreateUniqueName(GetOwnerOrView, GridView, lListHandle, '', 'md_' + lPatternView.DataController.BoldHandle.name); + end; + BoldAutoColumns := false; // lPatternView.DataController.BoldAutoColumns; + BoldHandle := lListHandle; + GridView.Name := CreateUniqueName(GetOwnerOrView, GetOwnerOrView, GridView, '', lGridLevel.GridView.Name); + end; + end; + inherited; +end; + +type + TcxCustomGridTableControllerHack = class(TcxCustomGridTableController); + +procedure TcxGridBoldDataController.SelectionChanged; +var + i, j: integer; + lSelectedIndex: integer; + lFollower: TBoldFollower; + lCount: integer; + lList: TBoldList; + lIndex: integer; +// lBoldAwareView: IBoldAwareView; + lSelection: TBoldList; + lRecordCount: integer; +begin + {$IFDEF BoldDevExLog} + _Log(GridView.Name + ':DoSelectionChanged', className); + {$ENDIF} +// GridView.GetInterface(IBoldAwareView, lBoldAwareView); + lSelection := fSelection;// lBoldAwareView.Selection; + if Assigned(lSelection) then + lSelection.Clear; + lFollower := Follower; + j := Controller.SelectedRecordCount; + if Assigned(BoldHandle) and Assigned(Follower.Element) and (lFollower.Element is TBoldObjectList) then + begin + lList := BoldList; + if (j > 0) and (j >= lList.Count) then + begin + if Assigned(lSelection) then + lSelection.AddList(lList); + BoldProperties.SelectAll(lFollower, true); + end + else + begin + lCount := lList.count; + lRecordCount := TcxCustomGridTableControllerHack(GridView.Controller).ViewData.RecordCount; + BoldProperties.SelectAll(lFollower, false); + for i := 0 to j - 1 do + begin + lIndex := GetSelectedRowIndex(i); + if lIndex < lRecordCount then + begin + lSelectedIndex := Controller.SelectedRecords[i].RecordIndex; + if lSelectedIndex < lCount then + begin + if Assigned(lSelection) then + lSelection.Add(lList[lSelectedIndex]); + BoldProperties.SetSelected(lFollower, lSelectedIndex, true); + end; + end; + end; + end; + if not MultiSelect and (Follower.SubFollowerCount > 0) and (Follower.CurrentIndex <> -1) and (Follower.CurrentIndex < Follower.SubFollowerCount) then + begin + if Assigned(lSelection) and Assigned(Follower.CurrentSubFollower) then + lSelection.Add(Follower.CurrentSubFollower.Element); + BoldProperties.SetSelected(lFollower, Follower.CurrentIndex, true); + end; + end + else + begin + if Assigned(lSelection) then + lSelection.Clear; + BoldProperties.SelectAll(lFollower, false); + end; + {$IFDEF DisplayAll} +// TBoldQueueable.DisplayAll; + {$ENDIF} +end; + +function TcxGridBoldDataController.DoEditing(AItem: TcxCustomGridTableItem): Boolean; +var + lRecord: integer; + lFollower: TBoldFollower; + lIcxBoldEditProperties: IcxBoldEditProperties; +begin + lRecord := RecNo; + Assert(lRecord <> -1, 'lRecord <> -1'); + lFollower := CellFollowers[lRecord, AItem.ID]; + if not Assigned(lFollower) then + begin + TBoldQueueable.DisplayAll; + lFollower := CellFollowers[lRecord, AItem.ID]; +// Assert(Assigned(lFollower)); + end; + result := Assigned(lFollower); + if Assigned(lFollower) then + begin + lFollower.EnsureDisplayable; + result := lFollower.Controller.MayModify(lFollower); + Assert(AItem.GetProperties <> nil); + if Supports(AItem.GetProperties, IcxBoldEditProperties, lIcxBoldEditProperties) then + begin + result := lIcxBoldEditProperties.CanEdit(BoldHandle, lFollower); + end + end; +end; + +procedure TcxGridBoldDataController.AssignData( + ADataController: TcxCustomDataController); +begin +end; + +procedure TcxGridBoldDataController.CheckGridModeBufferCount; +begin +// UpdateGridModeBufferCount; +end; + +procedure TcxGridBoldDataController.DeleteAllItems; +begin + GridView.ClearItems; +end; + +function TcxGridBoldDataController.DoScroll(AForward: Boolean): Boolean; +begin + Result := SupportsScrollBarParams; + if Result then + if AForward then + Controller.GoToNext(False, False) + else + Controller.GoToPrev(False, False); +end; + +function TcxGridBoldDataController.DoScrollPage( + AForward: Boolean): Boolean; +begin + Result := SupportsScrollBarParams; + if Result then + if AForward then + TcxCustomGridTableControllerAccess.FocusNextPage(Controller, False) + else + TcxCustomGridTableControllerAccess.FocusPrevPage(Controller, False); +end; + +procedure TcxGridBoldDataController.GetFakeComponentLinks(AList: TList); +begin + if (BoldHandle <> nil) and (BoldHandle.Owner <> GetOwnerOrView) and + (AList.IndexOf(BoldHandle.Owner) = -1) then + AList.Add(BoldHandle.Owner); +end; + +function TcxGridBoldDataController.GetGridView: TcxCustomGridView; +begin + Result := TcxCustomGridView(GetOwner); +end; + +function TcxGridBoldDataController.GetItemDefaultValuesProviderClass: TcxCustomEditDefaultValuesProviderClass; +begin +// Result := TcxGridDefaultValuesProvider; + Result := TcxGridBoldDefaultValuesProvider; +end; + +function TcxGridBoldDataController.GetNavigatorIsBof: Boolean; +begin + Result := GridView.Controller.IsStart; +end; + +function TcxGridBoldDataController.GetNavigatorIsEof: Boolean; +begin + Result := GridView.Controller.IsFinish; +end; + +function TcxGridBoldDataController.GetScrollBarPos: Integer; +begin + if SupportsScrollBarParams then + if dceInsert in EditState then + Result := FPrevScrollBarPos + else + Result := RecNo - 1 + else + Result := -1; + FPrevScrollBarPos := Result; +end; + +function TcxGridBoldDataController.GetScrollBarRecordCount: Integer; +begin +// TODO see how to properly replace DataSetRecordCount, perhaps add BoldHandleRecordCount + if SupportsScrollBarParams then + Result := {DataSetRecordCount +} GridView.ViewInfo.VisibleRecordCount - 1 + else + Result := -1; +end; + +function TcxGridBoldDataController.CreateItem( + aGridView: TcxCustomGridTableView; const aExpression, aCaption, aValueType, + aName: string): TcxCustomGridTableItem; +begin + result := aGridView.CreateItem; + (result as IBoldAwareViewItem).BoldProperties.Expression := aExpression; + result.DataBinding.ValueType := aValueType; + result.Caption := aCaption; + result.Name := CreateUniqueName(GetOwnerOrView, GridView, result, ScxGridPrefixName, aName); +end; + +function TcxGridBoldDataController.IsDataChangeable: Boolean; +begin + Result := False; +end; + +function TcxGridBoldDataController.IsDataLinked: Boolean; +begin + Result := BoldHandle <> nil; +end; + +procedure TcxGridBoldDataController.PreFetchColumns(AList: TBoldList; aItem: integer); + + procedure Prefetch(FetchList: TBoldList; const AOcl: String; AVariableList: TBoldExternalVariableList); +{$IFNDEF SpanFetch} + var + IE: TBoldIndirectElement; + const + cCollectOcl = 'self->collect(%s)'; +{$ENDIF} + begin + try + {$IFDEF SpanFetch} + FetchOclSpan(FetchList, AOcl, AVariableList); + {$ELSE} + IE := TBoldIndirectElement.Create; + try + with BoldHandle.StaticSystemHandle.System.Evaluator do + begin + if Assigned(ExpressionType(AOCL, FetchList.BoldType, false, AVariableList)) then + Evaluate(AOcl, FetchList, nil, false, IE, false, AVariableList) + else + if Assigned(ExpressionType(Format(cCollectOcl, [AOcl]), FetchList.BoldType, false, AVariableList)) then + Evaluate(Format(cCollectOcl, [AOcl]), FetchList, nil, false, IE, false, AVariableList); + end; + finally + IE.free; + end; +{$ENDIF} + except + // ignore all exceptions during prefetch, otherwise the grid view infos will be messed up + end; + end; + +var + i,j: integer; + lOcl: string; + lBoldAwareViewItem: IBoldAwareViewItem; + lItem: TcxCustomGridTableItem; + FetchList: TBoldList; + lWholeList: TBoldList; + lMainFollower: TBoldFollower; + lRowFollower: TBoldFollower; + lCellFollower: TBoldFollower; + locator: TBoldObjectLocator; + IsObjectList: boolean; + lRowIndex: integer; + lSameCount: boolean; + lGuard: IBoldGuard; + lTableViewInfo: TcxGridTableViewInfo; + lRowsViewInfo: TcxGridRowsViewInfo; + lVisibleList: TBoldList; +const + cCollectOcl = 'self->collect(%s)'; +begin + lGuard := TBoldGuard.Create(FetchList, lVisibleList); + if not Assigned(AList) then + begin + lVisibleList := CreateList; + CollectVisibleRecords(lVisibleList); + AList := lVisibleList; +// lTableViewInfo := (Owner as TcxGridBoldTableView).ViewInfo; +// for := lTableViewInfo.FirstRecordIndex to lTableViewInfo.FirstRecordIndex + lTableViewInfo.VisibleColumnCount +// (Owner as TcxGridBoldTableView).ViewInfo.RecordsViewInfo[0]. VisibleColumnCount; +// (Owner as TcxGridBoldTableView).GridView.ViewInfo. + end; + + if AList.Empty then + exit; + lMainFollower := Follower; + lWholeList := BoldList; + + FetchList := CreateList; + FetchList.DuplicateMode := bldmAllow; + FetchList.Capacity := AList.Count; + IsObjectList := (AList is TBoldObjectList) and (lWholeList is TBoldObjectList); + lSameCount := AList.Count = lWholeList.Count; + Locator := nil; + for i := 0 to AList.Count - 1 do + begin +{ if lSameCount then + j := i + else} + if IsObjectList then + begin + locator := TBoldObjectList(aList).Locators[i]; + if TBoldObjectList(lWholeList).Locators[i] = locator then + j := i + else + j := TBoldObjectList(lWholeList).IndexOfLocator( locator ); + end + else + begin + if lWholeList[i] = aList[i] then + j := i + else + j := lWholeList.IndexOf(aList[i]); + end; + if j = -1 then + begin + FetchList.AddList(AList); + break; + end; + lRowFollower := lMainFollower.SubFollowers[j]; + if not Assigned(lRowFollower) or not lRowFollower.Displayable {or not Assigned(lRowFollower.Element)} then + begin + if IsObjectList then + TBoldObjectList(FetchList).AddLocator(locator) + else + FetchList.Add(aList[i]) + end + else + begin + for j := 0 to lRowFollower.SubFollowerCount - 1 do + begin + lItem := TcxCustomGridTableItem(FindItemByData(j)); + if (aItem = j) or ((AItem = -1) and lItem.ActuallyVisible) {or RequiresAllRecords(lItem)} then + if not lRowFollower.SubFollowerAssigned[j] then + begin + if IsObjectList then + TBoldObjectList(FetchList).AddLocator(locator) + else + FetchList.Add(aList[j]); + break; + end; + end; + end; + end; +// if FetchList.Empty then +// exit; + ConnectEvents(false); + inc(FSkipMakeCellUptoDate); + try + if not FetchList.Empty then + for I := 0 to ItemCount - 1 do + begin + lItem := TcxCustomGridTableItem(FindItemByData(i)); + if (aItem = i) or ((aItem = -1) and lItem.ActuallyVisible) {or RequiresAllRecords(lItem)} then + begin + lItem.GetInterface(IBoldAwareViewItem, lBoldAwareViewItem); + lOcl := lBoldAwareViewItem.BoldProperties.Expression; + Prefetch(FetchList, lOcl, lBoldAwareViewItem.BoldProperties.VariableList); + end; + end; + DisplayFollowers; + lSameCount := (AList.Count = lWholeList.Count) {or ((Assigned(Filter) and Filter.Active and (Filter.Root.Count > 0)))}; + if lSameCount then + begin + i := 0; + j := lWholeList.Count-1; + end + else + FindMinMaxIndex(AList, lWholeList, i, j); + with TBoldFollowerList(lMainFollower.RendererData) do + if (FirstActive <> i) or (LastActive <> j) then + BoldProperties.SetActiveRange(lMainFollower, i, j, 0); + + for i := 0 to AList.Count - 1 do + begin + if lSameCount and (lWholeList[i] = AList[i]) then + lRowIndex := i + else + if isObjectList then + lRowIndex := TBoldObjectList(lWholeList).IndexOfLocator(TBoldObjectList(AList).Locators[i]) + else + lRowIndex := lWholeList.IndexOf(AList[i]); + if lRowIndex <> -1 then + begin + lRowFollower := lMainFollower.EnsuredSubFollowers[lRowIndex]; + Assert(Assigned(lRowFollower)); + lRowFollower.SetElementAndMakeCurrent(AList[i], true); + for j := 0 to ItemCount - 1 do + begin + lItem := TcxCustomGridTableItem(FindItemByData(j)); + if (aItem = j) or ((aItem = -1) and lItem.ActuallyVisible) {or RequiresAllRecords(lItem)} then + begin + lCellFollower := lRowFollower.SubFollowers[j]; + Assert(Assigned(lCellFollower)); + lCellFollower.Active := true; + end; + end; + end; + end; + + finally + dec(FSkipMakeCellUptoDate); + ConnectEvents(true); + end; +end; + +procedure TcxGridBoldDataController.ProcessQueueEvent(Sender: TObject); +begin + if not IsDestroying then + if not GridView.IsDestroying then + begin + if fDataChanged then + begin + DataHasChanged := false; + AdjustActiveRange(); + DataChanged(dcTotal, -1, -1); + // Follower.MarkValueOutOfDate; + // self.Refresh; + CheckDataSetCurrent; + end; +{$IFDEF DelayOnFocusedRecordChange} + if fFocusChanged then + begin + if GridView is TcxGridBoldTableView then + (GridView as TcxGridBoldTableView).InheritedDoFocusedRecordChanged(FPrevFocusedRecordIndex, FFocusedRecordIndex, + FPrevFocusedDataRecordIndex, FFocusedDataRecordIndex, FNewItemRecordFocusingChanged) + else + if (GridView is TcxGridBoldBandedTableView) then + (GridView as TcxGridBoldBandedTableView).InheritedDoFocusedRecordChanged(FPrevFocusedRecordIndex, FFocusedRecordIndex, + FPrevFocusedDataRecordIndex, FFocusedDataRecordIndex, FNewItemRecordFocusingChanged) + else + Assert(false, 'Unsupported GridView: ' + GridView.ClassName); + fFocusChanged := false; + end; +{$ENDIF} + if fRedrawGrid then + begin + GridView.Invalidate(true); + if fRecalcSummary then + GridView.DataController.Summary.Recalculate; + fRedrawGrid := false; + fRecalcSummary := false; + end; + end; +end; + +function TcxGridBoldDataController.RequiresAllRecords(AItem: TObject): boolean; +var + lItem: TcxCustomGridTableItemAccess; +begin + result := false; + if (AItem is TcxCustomGridTableItem) then + begin + lItem := TcxCustomGridTableItemAccess(AItem); + result := (lItem.SortIndex <> -1) or (lItem.GroupIndex <> -1) or lItem.Filtered or + ((AItem is TcxGridColumn) and + ( + (TcxGridColumn(AItem).Summary.FooterKind <> skNone ) or + (TcxGridColumn(AItem).Summary.GroupFooterKind <> skNone ) or + (TcxGridColumn(AItem).Summary.GroupKind <> skNone ) + )); + end; +end; + +function TcxGridBoldDataController.RequiresAllRecords: boolean; +var + lcxCustomGridTableView: TcxCustomGridTableView; + i: integer; +begin + lcxCustomGridTableView := GridView as TcxCustomGridTableView; + result := (lcxCustomGridTableView.SortedItemCount > 0) + or (lcxCustomGridTableView.GroupedItemCount > 0) + or (Summary.FooterSummaryItems.Count > 0) + or (Assigned(Filter) and Filter.Active and (Filter.Root.Count > 0)); + if not result then + for I := 0 to lcxCustomGridTableView.ItemCount - 1 do + result := result or RequiresAllRecords(lcxCustomGridTableView.Items[i]); +end; + +function TcxGridBoldDataController.GetOwnerOrView: TComponent; +begin + if Assigned(GridView.Owner) then + result := GridView.Owner + else + result := GridView; +end; + +function TcxGridBoldDataController.SetScrollBarPos( + Value: Integer): Boolean; +begin + Result := SupportsScrollBarParams; + if Result then + RecNo := Value + 1; +end; + +function TcxGridBoldDataController.SupportsScrollBarParams: Boolean; +begin + Result := IsGridMode and TcxCustomGridTableViewAccess(GridView).IsEqualHeightRecords; +end; + +constructor TcxGridBoldDataController.Create(AOwner: TComponent); +begin + inherited; +end; + +destructor TcxGridBoldDataController.Destroy; +begin + BoldInstalledQueue.RemoveFromPostDisplayQueue(self); + inherited; +end; + +procedure TcxGridBoldDataController.DisplayFollowers; +var + Queueable: TBoldQueueable; +begin + if Assigned(Follower) and (Follower.IsInDisplayList {or not Follower.Displayable}) and not (GridView.IsLoading or GridView.IsDestroying) then + repeat + Queueable := TBoldFollowerAccess(Follower).MostPrioritizedQueuableOrSelf; + if Assigned(Queueable) then + TBoldQueueableAccess(Queueable).display; + until not Assigned(Queueable); +end; + +procedure TcxGridBoldDataController.CollectVisibleRecords(var aList: TBoldList); +var + i,j: integer; + lFollower: TBoldFollower; + lRecordIndex: integer; + lList: TBoldList; + lGuard: IBoldGuard; + lWholeList: TBoldList; + lRecord: TcxCustomGridRecord; + IsObjectList: boolean; +begin + lWholeList := BoldList; + IsObjectList := (lWholeList is TBoldObjectList); +// lGuard := TBoldGuard.Create(lList); +// lList := CreateList; + lList := AList; + i := GridView.Controller.TopRecordIndex; + if i = -1 then + exit; + if i <> -1 then + begin + j := i + GridView.ViewInfo.VisibleRecordCount+2; // there can be at most 2 partially visible records + i := (i div 10) * 10; + j := (j div 10 +1) * 10; + end + else + begin + i := 0; + j := 10; + end; + if j >= TcxCustomDataControllerInfoAccess(DataControllerInfo).RecordList.Count then + j := TcxCustomDataControllerInfoAccess(DataControllerInfo).RecordList.Count -1; + lList.Capacity := j-i+1; + lList.DuplicateMode := bldmAllow; + for i := i to j do + begin + lRecord := GridView.ViewData.GetRecordByIndex(i); + if Assigned(lRecord) then + begin + lRecordIndex := lRecord.RecordIndex; + if (lRecordIndex > -1) and (lRecordIndex < lWholeList.count) then + begin + if IsObjectList then + TBoldObjectList(lList).AddLocator(TBoldObjectList(lWholeList).Locators[lRecordIndex]) + else + lList.Add(lWholeList[lRecordIndex]); + end; + end; + end; +end; + +procedure TcxGridBoldDataController.AdjustActiveRange( + aList: TBoldList = nil; aItem: integer = -1); +var + i,j: integer; + lFollower: TBoldFollower; + lRecordIndex: integer; + lList: TBoldList; + lGuard: IBoldGuard; + lWholeList: TBoldList; + lRecord: TcxCustomGridRecord; + IsObjectList: boolean; +begin + lFollower := Follower; + lList := aList; + lWholeList := BoldList; + if not Assigned(lFollower) or not Assigned(lWholeList) then + exit; + i := GridView.Controller.TopRecordIndex; + if i = -1 then + exit; + if not Assigned(aList) and not LoadAll then + begin + IsObjectList := (lWholeList is TBoldObjectList); + lGuard := TBoldGuard.Create(lList); + lList := CreateList; + if i <> -1 then + begin + j := i + GridView.ViewInfo.VisibleRecordCount+2; // there can be at most 2 partially visible records + i := (i div 10) * 10; + j := (j div 10 +1) * 10; + end + else + begin + i := 0; + j := 10; + end; + if j >= TcxCustomDataControllerInfoAccess(DataControllerInfo).RecordList.Count then + j := TcxCustomDataControllerInfoAccess(DataControllerInfo).RecordList.Count -1; + lList.Capacity := j-i+1; + lList.DuplicateMode := bldmAllow; + for i := i to j do + begin + lRecord := GridView.ViewData.GetRecordByIndex(i); + if Assigned(lRecord) then + begin + lRecordIndex := lRecord.RecordIndex; + if (lRecordIndex > -1) and (lRecordIndex < lWholeList.count) then + begin + if IsObjectList then + TBoldObjectList(lList).AddLocator(TBoldObjectList(lWholeList).Locators[lRecordIndex]) + else + lList.Add(lWholeList[lRecordIndex]); + end; + end; + end; + end; + if LoadAll then + aItem := -1; + inherited AdjustActiveRange(lList, aItem); +end; + +procedure TcxGridBoldDataController._BeforeMakeListUpToDate( + Follower: TBoldFollower); +//var +// lFirstLoad: boolean; +begin +// lFirstLoad := CustomDataSource = nil; + if GridView.IsDestroying then + begin + Assert(Assigned(self)); + exit; + end; + inherited; +{ if lFirstLoad then + begin + if Assigned(OnBeforeLoad) then + OnBeforeLoad(GridView); + end; +} +end; + +procedure TcxGridBoldDataController.ReloadStorage; +begin + if not Assigned(CustomDataSource) then + exit; + if CustomDataSource.Provider = nil then + TcxBoldDataSource(CustomDataSource).CurrentProvider := Provider; + if MainFollowerNeedsDisplay then + DisplayFollowers; + DataStorage.BeginLoad; + fInternalLoading := true; + try + TcxBoldDataSource(CustomDataSource).LoadRecordHandles; + if DataControllerInfo.LockCount = 0 then + Refresh; + Assert(Follower.SubFollowerCount = DataStorage.RecordCount, 'Follower.SubFollowerCount = DataStorage.RecordCount' + IntToStr(Follower.SubFollowerCount) + ',' + IntToStr(DataStorage.RecordCount) ); + finally + fInternalLoading := false; + DataStorage.EndLoad; + end; +end; + +procedure TcxGridBoldDataController._AfterMakeListUptoDate( + Follower: TBoldFollower); +var + i: integer; + lcxBoldDataSource: TcxBoldDataSource; + lBoldAwareView: IBoldAwareView; + lFirstLoad: boolean; + lDataChanged: boolean; + lTypeChanged: boolean; +begin + if GridView.IsDestroying then + begin + Assert(Assigned(self)); + exit; + end; + {$IFDEF BoldDevExLog} + _Log((GetOwner as TComponent).Name + ':_AfterMakeListUpToDate:' +IntToStr(FSkipMakeCellUptoDate), className); + {$ENDIF} + + lTypeChanged := false; + lBoldAwareView := GridView as IBoldAwareView; + lFirstLoad := (CustomDataSource = nil); + if not lFirstLoad and (DataStorage.RecordCount <> Follower.SubfollowerCount) then + DataHasChanged := true; + try + if GridView.IsDesigning {or isPattern} then // isPattern needs to be tested for detail views + begin + exit; + end; +// TypeMayHaveChanged; + if lFirstLoad then + begin + fFetchedAll := false; + lcxBoldDataSource := cxBoldDataSourceClass.Create(self as TcxGridBoldDataController); + + if {BoldAutoColumns and} (GetHandleListElementType <> fCurrentListElementType) and Assigned(fCurrentListElementType) and (GetHandleListElementType <> nil) then + if ClearColumnsOnTypeChange and not GetHandleListElementType.ConformsTo(fCurrentListElementType) then + lBoldAwareView.ClearItems; + CustomDataSource := lcxBoldDataSource; + + if (Follower.Element = nil) or Follower.ElementValid then + begin + lTypeChanged := TypeMayHaveChanged; + end; + for i := 0 to ItemCount - 1 do + begin + BoldPropertiesFromItem(i).AfterMakeUptoDate := nil; + end; + end + else + begin + TypeMayHaveChanged; + // EndUpdate; + end; + finally + lDataChanged := DataHasChanged; +// if lDataChanged or lFirstLoad or lTypeChanged then +// AdjustActiveRange(); + if not lDataChanged then + dec(FSkipMakeCellUptoDate); + if lDataChanged and (FSkipMakeCellUptoDate = 1) and Assigned(CustomDataSource) then + begin + if CustomDataSource.Provider = nil then + TcxBoldDataSource(CustomDataSource).CurrentProvider := Provider; + CustomDataSource.DataChanged; + TcxBoldDataSource(CustomDataSource).DataController.DataControllerInfo.Refresh; + + DataHasChanged := false; + end; + if lDataChanged then + dec(FSkipMakeCellUptoDate); + ConnectEvents(true); + if {not lFirstLoad and not lDataChanged and} (Follower.SubFollowerCount <> DataStorage.RecordCount) then + ReloadStorage; + inc(FSkipSyncFocusedRecord); + try + if CustomDataSource.Provider = nil then + TcxBoldDataSource(CustomDataSource).CurrentProvider := Provider; + Assert(Assigned(CustomDataSource.Provider)); + EndFullUpdate; + finally + dec(FSkipSyncFocusedRecord); + end; + if not ((Follower.SubFollowerCount = DataStorage.RecordCount) or (DetailMode = dcdmPattern) or lFirstLoad) then + begin + if CustomDataSource.Provider = nil then + TcxBoldDataSource(CustomDataSource).CurrentProvider := Provider; + DataStorage.BeginLoad; + try + TcxBoldDataSource(CustomDataSource).LoadRecordHandles; + Assert(Follower.SubFollowerCount = DataStorage.RecordCount, 'Follower.SubFollowerCount = DataStorage.RecordCount' + IntToStr(Follower.SubFollowerCount) + ',' + IntToStr(DataStorage.RecordCount) ); + finally + DataStorage.EndLoad; + end; + end; + if (DetailMode <> dcdmPattern) and (Groups.GroupingItemCount = 0) and (not Filter.Active) and (GridView.ViewData.RecordCount <> {RowCount} Follower.SubFollowerCount) then + begin + TcxCustomGridTableViewAccess(GridView).ViewInfoCache.Count := Follower.SubFollowerCount; + TcxCustomDataControllerInfoAccess(DataControllerInfo).Update; + TcxCustomGridTableViewAccess(GridView).ViewData.Refresh(Follower.SubFollowerCount); + Assert(GridView.ViewData.RecordCount = Follower.SubFollowerCount); + end; + if Assigned(CustomDataSource) then + TcxBoldDataSource(CustomDataSource).fIsBoldInitiatedChange := false; + fBoldProperties.OnAfterInsertItem := _InsertRow; + fBoldProperties.OnAfterDeleteItem := _DeleteRow; + fBoldProperties.OnReplaceitem := _ReplaceRow; + + BeginUpdate; + try + FNearestRecordIndex := -1; + if (Follower.CurrentIndex <> FocusedRecordIndex) and (FSkipMakeCellUptoDate < 2) then + begin + Controller.ClearSelection; + if {(Follower.CurrentIndex <> -1) and} (Follower.CurrentIndex < RecordCount) then + FocusedRecordIndex := Follower.CurrentIndex + else + if RecordCount > 0 then + begin + Follower.CurrentIndex := 0; + FocusedRecordIndex := 0; + end; + if Assigned(Controller.FocusedRecord) then + Controller.FocusedRecord.Selected := true; + end; + Change([dccSelection]); + finally + EndUpdate; + end; + if (DataControllerInfo.LockCount = 0) and ((DataControllerInfo.DataRowCount <> RowCount) and ((DataControllerInfo.DataGroups.Count>0) and (RecordCount <> DataControllerInfo.DataRowCount))) then + begin + Refresh; + end; + if lTypeChanged and BoldAutoColumns {(GridView.OptionsView is TcxGridTableOptionsView) and TcxGridTableOptionsView(GridView.OptionsView).ColumnAutoWidth} then + begin +// TcxGridTableOptionsView(GridView.OptionsView).ColumnAutoWidth := false; + ShowHourglassCursor; + GridView.BeginUpdate; + try + GridView.ApplyBestFit(nil, true, false); + finally + GridView.EndUpdate; + HideHourglassCursor; +// TcxGridTableOptionsView(GridView.OptionsView).ColumnAutoWidth := true + end; + end; + ConnectEvents(True); + if lDataChanged or lFirstLoad or lTypeChanged then + begin + {$IFDEF FireAfterLoadOnChangeOnly} + if Assigned(OnAfterLoad) then + begin + if (DataControllerInfo.LockCount = 0) then + begin + fTriggerAfterLoad := false; + OnAfterLoad(GridView) + end + else + fTriggerAfterLoad := true; + end; + + {$ENDIF} + end; + {$IFNDEF FireAfterLoadOnChangeOnly} + if Assigned(OnAfterLoad) then + begin + if (DataControllerInfo.LockCount = 0) then + begin + fTriggerAfterLoad := false; + OnAfterLoad(GridView); + end + else + fTriggerAfterLoad := true; + end; + {$ENDIF} + end; +end; + + + +procedure TcxGridBoldDataController.TypeChanged(aNewType, aOldType: TBoldElementTypeInfo); +begin + inherited; + if not Assigned(fCurrentListElementType) then + begin + if BoldAutoColumns then + begin + TcxCustomGridTableView(GridView).ClearItems; + fFetchedAll := false; + end; + end + else + if Assigned(aOldType) and BoldAutoColumns or (TcxCustomGridTableView(GridView).ItemCount = 0) then + begin + TcxCustomGridTableView(GridView).ClearItems; + TcxGridBoldDataController(self).CreateAllItems(false); + fFetchedAll := false; + end; +end; + +function TcxGridBoldDataController.GetSummaryClass: TcxDataSummaryClass; +begin + Result := TcxBoldDataSummary; +end; + +function TcxGridBoldDataController.GetSummaryGroupItemLinkClass: TcxDataSummaryGroupItemLinkClass; +begin + Result := TcxGridTableSummaryGroupItemLink; +end; + +function TcxGridBoldDataController.GetSummaryItemClass: TcxDataSummaryItemClass; +begin + Result := TcxGridTableSummaryItem; +end; + +procedure TcxGridBoldDataController._AfterMakeCellUptoDate( + Follower: TBoldFollower); +var + lItem: TcxCustomGridTableItemAccess; +begin + if DataHasChanged then + exit; + lItem := TcxCustomGridTableItemAccess(GetItem(Follower.index)); + if (FSkipMakeCellUptoDate = 0) and not ((lItem.GroupIndex = -1) and (lItem.SortIndex = -1) and (not lItem.Filtered) and (Follower.OwningFollower.index <= RecordCount)) then + DataHasChanged := true + else + begin + EnsureEventQueued; + fRedrawGrid := true; + fRecalcSummary := fRecalcSummary or (Summary.FooterSummaryItems.IndexOfItemLink(lItem) <> -1) or (Assigned(Summary.SummaryGroups.FindByItemLink(lItem))); + end; +end; + +procedure TcxGridBoldDataController.BeginFullUpdate; +begin + GridView.BeginUpdate; + inherited; +end; + +procedure TcxGridBoldDataController.EndFullUpdate; +begin + inherited; + if not (IsDestroying or GridView.IsDestroying) then + begin + if DataHasChanged and (LockCount <= 1) then + begin + + //DataChangedEvent(nil); + DataHasChanged := false; + AdjustActiveRange(); + DataChanged(dcTotal, -1, -1); + // Follower.MarkValueOutOfDate; + // self.Refresh; + CheckDataSetCurrent; + + + end; + if ((LockCount <= 1)) and (Follower.SubFollowerCount <> DataStorage.RecordCount) then + ReloadStorage; + GridView.EndUpdate + end; + if fTriggerAfterLoad then + begin + fTriggerAfterLoad := false; + OnAfterLoad(GridView) + end; +end; + +function TcxGridBoldDataController.BoldSetValue(AItemHandle: TcxDataItemHandle; + ACellFollower: TBoldFollower; const AValue: variant): boolean; +var + lcxCustomGridTableItem: TcxCustomGridTableItem; + lcxBoldEditProperties: IcxBoldEditProperties; + lEdit: TcxCustomEdit; +begin + result := false; + lcxCustomGridTableItem := GetItem(Integer(AItemHandle)) as TcxCustomGridTableItem; + if Supports(lcxCustomGridTableItem.GetProperties, IcxBoldEditProperties, lcxBoldEditProperties) then + begin + lEdit := Controller.EditingController.Edit; + lcxBoldEditProperties.SetStoredValue(AValue, nil, lEdit, ACellFollower, result); + end; +end; + +procedure TcxGridBoldDataController.EnsureConstraintColumn; +var + lItem: TcxCustomGridTableItemAccess; +begin + lItem := TcxCustomGridTableItemAccess(GetItemByExpression(cOCLConstraint)); + if not Assigned(lItem) then + lItem := TcxCustomGridTableItemAccess(CreateItem(GridView, cOCLConstraint, '§', 'Boolean', 'Constraints')); + lItem.OnCustomDrawCell := ConstraintColumnCustomDrawCell; + lItem.Index := 0; + lItem.BestFitMaxWidth := 16; + lItem.Width := 16; + lItem.MinWidth := 16; + lItem.Options.Focusing := false; + lItem.Options.Editing := false; + lItem.Options.IncSearch := false; + if lItem.Options is TcxGridColumnOptions then + begin + TcxGridColumnOptions(lItem.Options).HorzSizing := false; + TcxGridColumnOptions(lItem.Options).Moving := false; + end; +end; + +function TcxGridBoldDataController.CanSelectRow( + ARowIndex: Integer): Boolean; +begin + Result := TcxCustomGridTableViewAccess(GridView).CanSelectRecord(ARowIndex); +end; + +function TcxGridBoldDataController.CompareByField(ARecordIndex1, + ARecordIndex2: Integer; AField: TcxCustomDataField; + AMode: TcxDataControllerComparisonMode): Integer; +begin + if GridView.ViewData.NeedsCustomDataComparison(AField, AMode) then + Result := GridView.ViewData.CustomCompareDataValues(AField, + GetComparedValue(ARecordIndex1, AField), GetComparedValue(ARecordIndex2, AField), AMode) + else + Result := inherited CompareByField(ARecordIndex1, ARecordIndex2, AField, AMode); +end; + +function TcxGridBoldDataController.CreateDetailLinkObject( + ARelation: TcxCustomDataRelation; ARecordIndex: Integer): TObject; +begin + Result := TcxGridLevelAccess(ARelation.Item).CreateLinkObject(ARelation, ARecordIndex); +end; + +procedure TcxGridBoldDataController.DoValueTypeClassChanged( + AItemIndex: Integer); +begin + inherited; + TcxCustomGridTableViewAccess(GridView).ItemValueTypeClassChanged(AItemIndex); +end; + +procedure TcxGridBoldDataController.FilterChanged; +begin + DataControllerInfo.BeginUpdate; + try + if MainFollowerNeedsDisplay then + DisplayFollowers; + inherited; + TcxCustomGridTableViewAccess(GridView).FilterChanged; + finally + TcxCustomDataControllerInfoAccess(DataControllerInfo).CorrectFocusedRow(FocusedRowIndex); + DataControllerInfo.EndUpdate; + end; +end; + +procedure TcxGridBoldDataController.FocusControl(AItemIndex: Integer; + var Done: Boolean); +begin + inherited; + TcxCustomGridTableViewAccess(GridView).FocusEdit(AItemIndex, Done); +end; + +function TcxGridBoldDataController.GetDefaultActiveRelationIndex: Integer; +begin + Result := TcxCustomGridTableViewAccess(GridView).GetDefaultActiveDetailIndex; +end; + +function TcxGridBoldDataController.GetDetailDataControllerByLinkObject( + ALinkObject: TObject): TcxCustomDataController; +begin + Result := TcxCustomGridView(ALinkObject).DataController; +end; + +function TcxGridBoldDataController.GetDisplayText(ARecordIndex, + AItemIndex: Integer): string; +var + lCellFollower: TBoldFollower; +begin +{ if not GridView.ViewData.GetDisplayText(ARecordIndex, AItemIndex, Result) then + Result := inherited GetDisplayText(ARecordIndex, AItemIndex); + TcxCustomGridTableItemAccess(GridView.Items[AItemIndex]).DoGetDataText(ARecordIndex, Result); +} + AItemIndex := GridView.Items[AItemIndex].ID; + EnsureFollower(ARecordIndex, AItemIndex); + lCellFollower := CellFollowers[ARecordIndex, AItemIndex]; + result := VarToStr((lCellFollower.Controller as TBoldVariantFollowerController).GetCurrentAsVariant(lCellFollower)); +end; + +function TcxGridBoldDataController.GetFilterDataValue( + ARecordIndex: Integer; AField: TcxCustomDataField): Variant; +begin + if Assigned(BoldList) and not HasCellFollower[ARecordIndex, GetItemData(aField.Item)] then + PreFetchColumns(BoldList, GetItemData(aField.Item)); + Result := inherited GetFilterDataValue(ARecordIndex, AField); + if GridView.ViewData.HasCustomDataHandling(AField, doFiltering) then + Result := GridView.ViewData.GetCustomDataValue(AField, Result, doFiltering); +end; + +function TcxGridBoldDataController.GetFilterDisplayText(ARecordIndex, + AItemIndex: Integer): string; +var + lCellFollower: TBoldFollower; +begin +{ if GridView.ViewData.HasCustomDataHandling(Fields[AItemIndex], doFiltering) then + Result := GridView.ViewData.GetCustomDataDisplayText(ARecordIndex, AItemIndex, doFiltering) + else + Result := inherited GetFilterDisplayText(ARecordIndex, AItemIndex); +} + AItemIndex := GridView.Items[AItemIndex].ID; + EnsureFollower(ARecordIndex, AItemIndex); + lCellFollower := CellFollowers[ARecordIndex, AItemIndex]; + result := VarToStr((lCellFollower.Controller as TBoldVariantFollowerController).GetCurrentAsVariant(lCellFollower)); +end; + +function TcxGridBoldDataController.GetFilterItemFieldCaption( + AItem: TObject): string; +begin + Result := TcxCustomGridTableItemAccess(AItem).FilterCaption; +end; + +function TcxGridBoldDataController.GetItemID(AItem: TObject): Integer; +begin + if AItem is TcxCustomGridTableItem then + Result := TcxCustomGridTableItem(AItem).ID + else + Result := -1; +end; + +function TcxGridBoldDataController.GetItemSortByDisplayText( + AItemIndex: Integer; ASortByDisplayText: Boolean): Boolean; +begin + Result := TcxCustomGridTableViewAccess(GridView).GetItemSortByDisplayText(AItemIndex, ASortByDisplayText); +end; + +function TcxGridBoldDataController.GetItemValueSource( + AItemIndex: Integer): TcxDataEditValueSource; +begin + Result := TcxCustomGridTableViewAccess(GridView).GetItemValueSource(AItemIndex); +end; + +function TcxGridBoldDataController.GetSortingBySummaryEngineClass: TcxSortingBySummaryEngineClass; +begin + Result := GridView.ViewData.GetSortingBySummaryEngineClass; +end; + +procedure TcxGridBoldDataController.UpdateData; +begin + inherited; + TcxCustomGridTableViewAccess(GridView).UpdateRecord; +end; + + +procedure TcxGridBoldDataController.DoDragOver( + Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); +var + lcxGridSite: TcxGridSite; + lcxCustomGridHitTest: TcxCustomGridHitTest; + lcxGridRecordCellHitTest: TcxGridRecordCellHitTest; + lBoldRoleRTInfo: TBoldRoleRTInfo; + lBoldList: TBoldList; +begin + Accept := false; + lcxGridSite := TcxGridSite(Sender); + lcxCustomGridHitTest := lcxGridSite.ViewInfo.GetHitTest(X, Y); + lBoldList := BoldHandle.MutableList; + if Assigned(lBoldList) then + begin + lBoldRoleRTInfo := lBoldList.BoldMemberRTInfo as TBoldRoleRTInfo; + // not allowed for association classes + Accept := not Assigned(lBoldRoleRTInfo) or not (lBoldRoleRTInfo.RoleType = rtLinkRole); + // do not allow drag in a single grid if the list is a member and is not ordered + Accept := Accept and not ((TcxDragControlObject(Source).Control = Sender) and (Assigned(lBoldRoleRTInfo) and not lBoldRoleRTInfo.IsOrdered)); + // do not allow drop in the system owned class list (ie all instances) + Accept := Accept and not (lBoldList.OwningElement is TBoldSystem); + // accept drop only where applicable + Accept := Accept and ((lcxCustomGridHitTest is TcxGridViewNoneHitTest) or (lcxCustomGridHitTest is TcxGridRecordCellHitTest)); + // do not allow drop after the last row of the grid if the dragged item is already last in the list + if Accept and (lcxCustomGridHitTest is TcxGridViewNoneHitTest) and (TcxDragControlObject(Source).Control = Sender) then + begin + Accept := Follower.CurrentIndex <> Follower.SubFollowerCount - 1; + end + else + if Accept and (lcxCustomGridHitTest is TcxGridRecordCellHitTest) and (TcxDragControlObject(Source).Control = Sender) then + begin + lcxGridRecordCellHitTest := TcxGridRecordCellHitTest(lcxCustomGridHitTest); + // do not allow source and desination row to be same if drag within single grid + Accept := Accept and (lcxGridRecordCellHitTest.GridRecord.RecordIndex <> FocusedRecordIndex); + end; + // check if destination already contains all source objects (and the desination is not ordered) + if Accept and Assigned(lBoldRoleRTInfo) and not lBoldRoleRTInfo.IsOrdered and lBoldList.IncludesAll(BoldGUIHandler.DraggedObjects) then + Accept := false; + end; + Accept := Accept and BoldProperties.DragOver(Follower, BoldHandle.MutableList, Y); +end; + +procedure TcxGridBoldDataController.DoDragDrop(Sender, Source: TObject; X, + Y: Integer); +var + i: integer; + lIndex: integer; + lcxCustomGridHitTest: TcxCustomGridHitTest; + lcxGridSite: TcxGridSite; +begin + lcxGridSite := TcxGridSite(Sender); + lcxCustomGridHitTest := lcxGridSite.ViewInfo.GetHitTest(X, Y); + + lIndex := -1; + if lcxCustomGridHitTest is TcxGridRecordCellHitTest then + begin + lIndex := TcxGridRecordCellHitTest(lcxCustomGridHitTest).GridRecord.RecordIndex; + end; + + BoldProperties.DragDrop(Follower, BoldHandle.MutableList, lIndex); + TcxBoldDataSource(CustomDataSource).fIsBoldInitiatedChange := true; + try + {$IFDEF DisplayAll} + TBoldQueueable.DisplayAll; + {$ENDIF} + CustomDataSource.DataChanged; + BeginUpdate; + try + ClearSelection; + for I := 0 to BoldGUIHandler.DraggedObjects.Count - 1 do + begin + lIndex := BoldHandle.List.IndexOf(BoldGUIHandler.DraggedObjects[i]); + if lIndex < RowCount then + ChangeRowSelection(lIndex, True); + end; + finally + EndUpdate; + end; + finally + TcxBoldDataSource(CustomDataSource).fIsBoldInitiatedChange := false + end; +end; + +procedure TcxGridBoldDataController.DoEndDrag(Sender, Target: TObject; X, + Y: Integer); +begin + BoldProperties.EndDrag; +end; + +procedure TcxGridBoldDataController.DoStartDrag(Sender: TObject; + var DragObject: TDragObject); +begin + {$IFDEF DisplayAll} + TBoldQueueable.DisplayAll; + {$ENDIF} + SelectionChanged; // make sure the follower selection is updated + BoldProperties.StartDrag(Follower); +end; + +{ TcxGridItemBoldDataBinding } + +procedure TcxGridItemBoldDataBinding.Assign(Source: TPersistent); +begin + if Source is TcxGridItemBoldDataBinding then + fBoldProperties.Assign(TcxGridItemBoldDataBinding(Source).BoldProperties); + inherited; +end; + +constructor TcxGridItemBoldDataBinding.Create( + AItem: TcxCustomGridTableItem); +begin + inherited Create(AItem); + fSubscriber := TBoldPassthroughSubscriber.Create(Receive); + fBoldProperties := TBoldCxGridVariantFollowerController.Create(DataController.GetOwnerOrView); + (fBoldProperties as TBoldCxGridVariantFollowerController).fcxGridItemBoldDataBinding := self; + fBoldProperties.ApplyPolicy := bapExit; + DataController.fBoldColumnsProperties.Add(fBoldProperties); + fBoldProperties.OnGetContextType := DataController.GetHandleStaticType; + fBoldProperties.AddSmallSubscription(fSubscriber, [beValueChanged], beValueChanged); + FBoldProperties.AfterMakeUptoDate := DataController._AfterMakeCellUptoDate; + (DefaultValuesProvider as TcxGridBoldDefaultValuesProvider).BoldHandleFollower := DataController.BoldHandleFollower; + (DefaultValuesProvider as TcxGridBoldDefaultValuesProvider).BoldProperties := fBoldProperties; + Data := TObject(DataController.fBoldColumnsProperties.Count-1); +end; + +destructor TcxGridItemBoldDataBinding.Destroy; +begin + FreeAndNil(FBoldProperties); + FreeAndNil(fSubscriber); + inherited; +end; + +function TcxGridItemBoldDataBinding.GetDataController: TcxGridBoldDataController; +begin + Result := TcxGridBoldDataController(inherited DataController); +end; + +function TcxGridItemBoldDataBinding.GetDefaultValueTypeClass: TcxValueTypeClass; +begin + Result := TcxStringValueType; +end; + +procedure TcxGridItemBoldDataBinding.Init; +begin + inherited; + with Item do + if BoldProperties.Expression = cOCLConstraint then + begin + OnCustomDrawCell := DataController.ConstraintColumnCustomDrawCell; + OnGetCellHint := DataController.GetCellHint; + end + else + begin + if not Assigned(OnCustomDrawCell) then + OnCustomDrawCell := DataController.ColumnCustomDrawCell; + end; +end; + +procedure TcxGridItemBoldDataBinding.SetBoldProperties( + Value: TBoldVariantFollowerController); +begin + if Assigned(Value) then + fBoldProperties.Assign(Value); +end; + +procedure TcxGridItemBoldDataBinding.Receive(Originator: TObject; + OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); +var + lContextType: TBoldElementTypeInfo; + lResultType: TBoldElementTypeInfo; + lBoldMemberRTInfo: TBoldMemberRTInfo; + lEvaluator: TBoldOcl; +begin + if not GridView.IsLoading and not DataController.fCreatingColumns then + if Assigned(DataController.BoldHandle) and Assigned(DataController.BoldHandle.ListElementType) then + begin + lContextType := DataController.BoldHandle.ListElementType; + lEvaluator := lContextType.Evaluator as TBoldOcl; + Assert(Assigned(lEvaluator)); + lResultType := lEvaluator.ExpressionType(BoldProperties.Expression, lContextType, false, BoldProperties.VariableList); + if Assigned(lResultType) then + begin + DataController.SetValueTypeAndProperties(lResultType, Item, (Item.RepositoryItem = nil) and (Item.PropertiesClassName = '')); + end; + if (Item.Caption = '') then + begin + lBoldMemberRTInfo := lEvaluator.RTInfo(BoldProperties.Expression, lContextType, false, BoldProperties.VariableList); + if Assigned(lBoldMemberRTInfo) then + begin + Item.Caption := lBoldMemberRTInfo.ModelName; + end; + end; + end; +end; + +procedure TcxGridItemBoldDataBinding.Remove; +var + i: integer; + lBoldColumnsProperties: TBoldControllerList; + lcxGridItemBoldDataBinding: TcxGridItemBoldDataBinding; +begin + DataController.fBoldColumnsProperties.Remove(fBoldProperties); + if (not GridView.IsDestroying) then + begin + lBoldColumnsProperties := DataController.fBoldColumnsProperties; + for I := 0 to DataController.ItemCount - 1 do + begin + lcxGridItemBoldDataBinding := ((DataController.GetItem(i) as TcxCustomGridTableItem).DataBinding as TcxGridItemBoldDataBinding); + lcxGridItemBoldDataBinding.Data := TObject(lBoldColumnsProperties.IndexOf(lcxGridItemBoldDataBinding.fBoldProperties)); + end; + end; + inherited; +end; + +function TcxGridItemBoldDataBinding.GetBoldProperties: TBoldVariantFollowerController; +begin + result := fBoldProperties; +end; + +{ TcxBoldDataController } + +function TcxBoldDataController.GetBoldHandle: TBoldAbstractListHandle; +begin + if not assigned(fBoldHandleFollower) then + result := nil + else + Result := fBoldHandleFollower.BoldHandle; +end; + +procedure TcxBoldDataController.SetBoldHandle( + const Value: TBoldAbstractListHandle); +begin + if fBoldHandleFollower.BoldHandle <> Value then + begin + CustomDataSource.free; + CustomDataSource := nil; + fBoldHandleFollower.BoldHandle := value; + end; +end; + +function TcxBoldDataController.GetBoldHandleIndexLock: Boolean; +begin + Result := fBoldHandleFollower.HandleIndexLock; +end; + +procedure TcxBoldDataController.SetBoldHandleIndexLock( + const Value: Boolean); +begin + fBoldHandleFollower.HandleIndexLock := Value; +end; + +procedure TcxBoldDataController.SetController( + const Value: TBoldListAsFollowerListController); +begin + fBoldProperties.Assign(Value); +end; + +procedure TcxBoldDataController.SetDataChanged(const Value: boolean); +begin + if fDataChanged = value then + Exit; + fDataChanged := Value; + if Value then + EnsureEventQueued; +end; + +procedure TcxBoldDataController.SetRecNo(const Value: Integer); +begin + fBoldHandleFollower.SetFollowerIndex(Value); +end; + +constructor TcxBoldDataController.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FUseDelayedScrollUpdate := true; + fClearColumnsOnTypeChange := true; + fBoldColumnsProperties := TBoldControllerList.Create(AOwner{GridView}); + fBoldProperties := TBoldListAsFollowerListController.Create(AOwner{GridView}, fBoldColumnsProperties); + fBoldHandleFollower := TBoldListHandleFollower.Create(AOwner.Owner{Form}, fBoldProperties); + Options := Options + [dcoImmediatePost]; + fSubscriber := TBoldPassthroughSubscriber.Create(Receive); + + if GetOwner is TcxComponent and TcxComponent(GetOwner).IsDesigning then + begin + // nothing needed at design time + end + else + begin +// don't need insert before we hook up datasource in _AfterMakeListUptoDate, so will set it there +// fBoldProperties.OnAfterInsertItem := _InsertRow; + fBoldProperties.OnAfterDeleteItem := _DeleteRow; + fBoldProperties.OnReplaceitem := _ReplaceRow; + fBoldProperties.AfterMakeUptoDate := _AfterMakeListUptoDate; + fBoldProperties.BeforeMakeUptoDate := _BeforeMakeListUptoDate; + fBoldProperties.OnGetContextType := GetHandleStaticType; + end; + fBoldProperties.OnGetContextType := GetHandleStaticType; +end; + +function TcxBoldDataController.CreateDataControllerInfo: TcxCustomDataControllerInfo; +begin + result := TcxBoldCustomDataControllerInfo.Create(Self); +end; + +function TcxBoldDataController.CreateList: TBoldList; +begin + if Assigned(fCurrentListElementType) then + result := TBoldMemberFactory.CreateMemberFromBoldType(fCurrentListElementType.ListTypeInfo) as TBoldList + else + result := TBoldElementList.Create; +end; + +procedure TcxBoldDataController.ProcessQueueEvent(Sender: TObject); +begin +// +end; + +procedure TcxBoldDataController.BeforeSorting; +begin + inherited; +// DataControllerInfo. +end; + +procedure TcxBoldDataController.BeginDelayScrollUpdate; +begin + if InDelayScrollUpdate then + exit; + fInDelayScrollUpdate := true; + inc(FSkipSyncFocusedRecord); + fStoredRecordIndex := CurrentIndex; +end; + +procedure TcxBoldDataController.EndDelayScrollUpdate; +begin + if not InDelayScrollUpdate then + exit; + fInDelayScrollUpdate := false; + dec(FSkipSyncFocusedRecord); + if (FocusedRecordIndex <> Follower.CurrentIndex) then + begin + Follower.CurrentIndex := FocusedRecordIndex; + CheckDataSetCurrent; + if self is TcxGridBoldDataController then + begin + if TcxGridBoldDataController(self).GridView is TcxGridBoldTableView then + with TcxCustomGridTableViewAccess(TcxGridBoldDataController(self).GridView), TcxGridBoldTableView(TcxGridBoldDataController(self).GridView) do + DoFocusedRecordChanged(FPrevFocusedRecordIndex, FocusedRecordIndex, FPrevFocusedDataRecordIndex, FocusedDataRowIndex, false) + else + if TcxGridBoldDataController(self).GridView is TcxGridBoldBandedTableView then + with TcxCustomGridTableViewAccess(TcxGridBoldDataController(self).GridView), TcxGridBoldBandedTableView(TcxGridBoldDataController(self).GridView) do + DoFocusedRecordChanged(FPrevFocusedRecordIndex, FocusedRecordIndex, FPrevFocusedDataRecordIndex, FocusedDataRowIndex, false) + end; + end; +end; + +procedure TcxBoldDataController.DisplayFollowers; +var + Queueable: TBoldQueueable; +begin + if Assigned(Follower) and (Follower.IsInDisplayList or not Follower.Displayable) then + repeat + Queueable := TBoldFollowerAccess(Follower).MostPrioritizedQueuableOrSelf; + if Assigned(Queueable) then + TBoldQueueableAccess(Queueable).display; + until not Assigned(Queueable); +end; + +function TcxBoldDataController.MainFollowerNeedsDisplay: boolean; +begin + result := Assigned(Follower) and (Follower.IsInDisplayList or not Follower.Displayable); +end; + +procedure TcxBoldDataController.EnsureEventQueued; +begin + BoldInstalledQueue.AddEventToPostDisplayQueue(ProcessQueueEvent, nil, self) +end; + +function TcxBoldDataController.EnsureFollower(ARecordIndex, AItemIndex: integer): boolean; +var + lMainFollower: TBoldFollower; + lRowFollower: TBoldFollower; + lCellFollower: TBoldFollower; + lResultElement: TBoldElement; + lItem: TObject; + lBoldAwareViewItem: IBoldAwareViewItem; + lIcxBoldEditProperties: IcxBoldEditProperties; +begin + result := false; + lCellFollower := nil; + lMainFollower := Follower; + lItem := FindItemByData(AItemIndex); + Assert(Assigned(lItem), 'lItem not found for index '+ IntToStr(AItemIndex)); + Assert(lItem.GetInterface(IBoldAwareViewItem, lBoldAwareViewItem), 'lItem.GetInterface(IBoldAwareViewItem, lBoldAwareViewItem)1'); + if not lMainFollower.Displayable then + begin +// Assert(IsDetailExpanding); + DisplayFollowers; + end; + inc(FSkipMakeCellUptoDate); + try + // if not lMainFollower.Displayable then + // DisplayFollowers; + with TBoldFollowerList(lMainFollower.RendererData) do + begin + if (ARecordIndex < FirstActive) or (ARecordIndex > LastActive) then + begin + PreFetchColumns(nil, -1) + end;// AdjustActiveRange(ARecordIndex, -1); + end; + if ARecordIndex >= lMainFollower.SubFollowerCount then + begin + PreFetchColumns(nil, AItemIndex); + AdjustActiveRange(nil, -1); + end; + if ARecordIndex >= lMainFollower.SubFollowerCount then + Assert(false, Format('RecordIndex = %d Out of bounds, count = %d', [ARecordIndex, lMainFollower.SubFollowerCount])); + lRowFollower := lMainFollower.SubFollowers[ARecordIndex]; + if not Assigned(lRowFollower) then + begin + PreFetchColumns(nil, -1); + AdjustActiveRange(nil, AItemIndex); + lRowFollower := lMainFollower.SubFollowers[ARecordIndex]; + end; + if not Assigned(lRowFollower) then + exit; + if not lRowFollower.ElementValid then // if not lRowFollower.Displayable then + AdjustActiveRange(nil, AItemIndex); + Assert(lRowFollower.ElementValid, 'lRowFollower.ElementValid'); + if not lRowFollower.Displayable then + lRowFollower.EnsureDisplayable; + Assert(lRowFollower.Active, 'lRowFollower.Active'); + if not lRowFollower.SubFollowerAssigned[AItemIndex] then + begin + // AdjustActiveRange(nil, AItemIndex); +// if not lRowFollower.SubFollowerAssigned[AItemIndex] then + result := false; +// AdjustActiveRange(nil, AItemIndex);// Assert(false); + // lCellFollower := lRowFollower.SubFollowers[AItemIndex]; + // Assert(lRowFollower.SubFollowerAssigned[AItemIndex], 'SubFollowerAssigned not assigned'); + end; + try + lRowFollower.EnsureDisplayable; + except + exit; + end; + lCellFollower := lRowFollower.SubFollowers[AItemIndex]; + Assert(Assigned(lCellFollower), 'lCellFollower not assigned'); + if not lCellFollower.Displayable then + lCellFollower.EnsureDisplayable; + Assert(lCellFollower.Displayable, ' lCellFollower not Displayable'); + finally + result := Assigned(lCellFollower) and lCellFollower.Displayable; + dec(FSkipMakeCellUptoDate); + end; +end; + +destructor TcxBoldDataController.Destroy; +begin + BoldInstalledQueue.RemoveFromPostDisplayQueue(Self); + fBoldProperties.OnAfterInsertItem := nil; + fBoldProperties.OnAfterDeleteItem := nil; + fBoldProperties.OnReplaceitem := nil; + FreeAndNil(fBoldHandleFollower); + FreeAndNil(fBoldProperties); + CustomDataSource.Free; + CustomDataSource := nil; + FreeAndNil(fBoldColumnsProperties); + FreeAndNil(fSubscriber); + FreeAndNil(fSelection); + inherited Destroy; +end; + +procedure TcxBoldDataController._BeforeMakeListUpToDate( + Follower: TBoldFollower); +var + i: integer; +begin + inc(FSkipMakeCellUptoDate); + BeginFullUpdate; + + if GetOwner is TcxComponent and TcxComponent(GetOwner).IsDesigning then exit; +// if isPattern then exit; + + if (Assigned(CustomDataSource) and (GetHandleListElementType <> fCurrentListElementType)) or (not Assigned(CustomDataSource) and Assigned(fCurrentListElementType)) then + begin + fFetchedAll := false; + CustomDataSource.free; + fBoldProperties.OnAfterInsertItem := nil; + fBoldProperties.OnAfterDeleteItem := nil; + fBoldProperties.OnReplaceitem := nil; + end; + if (CustomDataSource = nil) then + begin +// TODO: +// if Assigned(OnBeforeLoad) then +// OnBeforeLoad(GridView); + end; + if (CustomDataSource = nil) or (Follower.SubFollowerCount = 0) then + begin +// if not LoadAll then + // we need to set ActiveRange here, otherwise all followers will be active and all objects will be fetched + BoldProperties.SetActiveRange(Follower, 0, -1, 0); + end; + if Assigned(CustomDataSource) then + TcxBoldDataSource(CustomDataSource).fIsBoldInitiatedChange := true; + for i := 0 to ItemCount - 1 do + begin + BoldPropertiesFromItem(i).AfterMakeUptoDate := nil; + end; +end; + +procedure TcxBoldDataController._AfterMakeListUptoDate( + Follower: TBoldFollower); +var + lcxBoldDataSource: TcxBoldDataSource; + lFirstLoad: boolean; + i: integer; +begin + {$IFDEF BoldDevExLog} + _Log((GetOwner as TComponent).Name + ':_AfterMakeListUpToDate:' + IntToStr(FSkipMakeCellUptoDate), className); + {$ENDIF} + + lFirstLoad := (CustomDataSource = nil); + if lFirstLoad then + begin + lcxBoldDataSource := cxBoldDataSourceClass.Create(self); + CustomDataSource := lcxBoldDataSource; + TypeMayHaveChanged; + end; + dec(FSkipMakeCellUptoDate); + + CustomDataSource.DataChanged; + for i := 0 to ItemCount - 1 do + begin + BoldPropertiesFromItem(i).AfterMakeUptoDate := _AfterMakeCellUptoDate; + end; + PreFetchColumns(); + EndFullUpdate; + if Assigned(CustomDataSource) then + TcxBoldDataSource(CustomDataSource).fIsBoldInitiatedChange := false; +end; + +procedure TcxBoldDataController._InsertRow(index: Integer; Follower: TBoldFollower); +begin + DataHasChanged := true; +end; + +procedure TcxBoldDataController._ReplaceRow(index: Integer; + AFollower: TBoldFollower); +begin + DataHasChanged := true; +end; + +procedure TcxBoldDataController._DeleteRow(index: Integer; + owningFollower: TBoldFollower); +var + vRowIndex: integer; + vRecordIndex: integer; +begin + DataHasChanged := true; + if fInDeleteSelection then + exit; + with DataControllerInfo.Selection do + if (DataControllerInfo.Selection.Count > 1) and IsRecordSelected(Index) then + DataControllerInfo.Selection.Delete(FindByRecordIndex(Index)); +end; + +function TcxBoldDataController.GetHandleStaticType: TBoldElementTypeInfo; +begin + if assigned(BoldHandle) then + result := BoldHandle.StaticBoldType + else + result := nil; +end; + +procedure TcxBoldDataController._AfterMakeCellUptoDate( + Follower: TBoldFollower); +begin +// TODO: ? +end; + +function TcxBoldDataController.GetFollower: TBoldFollower; +begin + Result := nil; + if Assigned(fBoldHandleFollower) then + Result := fBoldHandleFollower.Follower; +end; + +function TcxBoldDataController.GetCellFollower(ARecordIndex, AItemIndex: Integer): TBoldFollower; +var + lRowFollower: TBoldFollower; +begin + lRowFollower := GetRowFollower(ARecordIndex); + if assigned(lRowFollower) and + (AItemIndex >= 0) and + (AItemIndex < lRowFollower.SubFollowerCount) then + Result := lRowFollower.SubFollowers[AItemIndex] + else + result := nil; +end; + +function TcxBoldDataController.GetHasCellFollower(ARecordIndex, AItemIndex: Integer): boolean; +var + lRowFollower: TBoldFollower; +begin + lRowFollower := GetRowFollower(ARecordIndex); + result := assigned(lRowFollower) and lRowFollower.SubFollowerAssigned[AItemIndex]; +end; + +function TcxBoldDataController.GetDataProviderClass: TcxCustomDataProviderClass; +begin + Result := TcxBoldCustomDataProvider; +end; + +function TcxBoldDataController.GetRecNo: Integer; +begin + result := Follower.CurrentIndex; +end; + +function TcxBoldDataController.GetRecordCount: Integer; +begin + if (DetailMode = dcdmPattern) or not Assigned(TcxCustomDataProviderAccess(provider).CustomDataSource) then + result := inherited GetRecordCount + else + begin + Result := TcxBoldDataSource(TcxCustomDataProviderAccess(provider).CustomDataSource).GetRecordCount; + end; +end; + +function TcxBoldDataController.GetRowFollower( + DataRow: Integer): TBoldFollower; +var + lFollower: TBoldFollower; +begin + lFollower := Follower; + if datarow < lFollower.SubFollowerCount then + Result := lFollower.SubFollowers[DataRow] + else + result := nil; +end; + +function TcxBoldDataController.GetSearchClass: TcxDataControllerSearchClass; +begin + result := TcxBoldDataControllerSearch; +end; + +function TcxBoldDataController.InDelayScrollUpdate: boolean; +begin + result := FUseDelayedScrollUpdate and fInDelayScrollUpdate; +end; + +function TcxBoldDataController.IsDataLinked: Boolean; +begin + Result := BoldHandle <> nil; +end; + +function TcxBoldDataController.IsSmartRefresh: Boolean; +begin + result := false; +end; + +procedure TcxBoldDataController.AdjustActiveRange(aList: TBoldList = nil; aItem: integer = -1); +var + lFollower: TBoldFollower; + i,j: integer; +begin + lFollower := Follower; + if Assigned(lFollower) and Assigned(lFollower.element) and (lFollower.Element is TBoldList) then + begin + if RequiresAllRecords or LoadAll then + BoldProperties.SetActiveRange(lFollower, 0, lFollower.SubFollowerCount-1, 0) + else + begin + FindMinMaxIndex(aList, BoldList, i, j); + BoldProperties.SetActiveRange(lFollower, i, j, 0); + end; +{ if aList = nil then + PreFetchColumns(BoldList, aItem) + else + PreFetchColumns(aList, aItem);} + end; +end; + +procedure TcxBoldDataController.AdjustActiveRange(aRecordIndex: integer; aItem: integer = -1); +var + lList: TBoldObjectList; +begin + if (Follower.Element is TBoldObjectList) and (aRecordIndex >= 0) and (aRecordIndex < TBoldObjectList(Follower.Element).Count) then + begin + lList := TBoldObjectList.Create; + try + lList.Add( TBoldObjectList(Follower.Element)[aRecordIndex]); + AdjustActiveRange(lList, aItem); + finally + lList.free; + end; + end; +end; + +function TcxBoldDataController.TypeMayHaveChanged: boolean; +var + lNewListElementType: TBoldElementTypeInfo; + lOldListElementType: TBoldElementTypeInfo; +begin + result := false; + if not Assigned(BoldHandle) or not Assigned(BoldHandle.List) then + begin + if Assigned(fCurrentListElementType) then + begin + lOldListElementType := fCurrentListElementType; + fCurrentListElementType := nil; + TypeChanged(nil, lOldListElementType); + result := true; + end; + end + else + begin + lNewListElementType := GetHandleListElementType; + if (lNewListElementType <> fCurrentListElementType) then + begin + {$IFDEF BoldDevExLog} + if Assigned(fCurrentListElementType) then + begin + if Assigned(lNewListElementType) then + _Log((GetOwner as TComponent).Name + ':TypeMayHaveChanged:' + fCurrentListElementType.AsString + '->' + lNewListElementType.AsString, className) + else + _Log((GetOwner as TComponent).Name + ':TypeMayHaveChanged:' + fCurrentListElementType.AsString + '-> nil', className); + end + else + _Log((GetOwner as TComponent).Name + ':TypeMayHaveChanged:' + lNewListElementType.AsString, className); + {$ENDIF} + lOldListElementType := fCurrentListElementType; + fCurrentListElementType := lNewListElementType; + TypeChanged(lNewListElementType, lOldListElementType); + result := true; + end; + end; +end; + +function TcxBoldDataController.GetHandleListElementType: TBoldElementTypeInfo; +begin + if Assigned(BoldHandle) then + Result := BoldHandle.ListElementType //BoldType + else + Result := nil; +end; + +function TcxBoldDataController.BoldPropertiesFromItem( + aIndex: integer): TBoldVariantFollowerController; +var + lBoldAwareViewItem: IBoldAwareViewItem; +begin + if GetItem(aIndex).GetInterface(IBoldAwareViewItem, lBoldAwareViewItem) then + result := lBoldAwareViewItem.BoldProperties + else + result := nil; +end; + +function TcxBoldDataController.BoldSetValue(AItemHandle: TcxDataItemHandle; + ACellFollower: TBoldFollower; const AValue: variant): boolean; +begin + result := false; +end; + +function TcxBoldDataController.GetCurrentBoldObject: TBoldObject; +begin + if GetCurrentElement is TBoldObject then + result := TBoldObject(GetCurrentElement) + else + result := nil; +end; + +function TcxBoldDataController.GetCurrentElement: TBoldElement; +var + lFollower: TBoldFollower; +begin + if CurrentIndex = -1 then + result := nil + else + begin + lFollower := Follower.CurrentSubFollower; + if Assigned(lFollower) then + result := lFollower.Element + else + result := nil; + end; +end; + +function TcxBoldDataController.GetCurrentIndex: integer; +begin + if InDelayScrollUpdate then + result := fStoredRecordIndex + else + result := Follower.CurrentIndex; +end; + + +procedure TcxBoldDataController.Receive(Originator: TObject; + OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); +begin + case RequestedEvent of + beSystemDestroying: + begin + fCurrentListElementType := nil; + end; + beSelectionDestroying: + begin + fSelection := nil; + raise EcxGridBoldSupport.Create('Grid Selection destroyed, do not free the grid selection !'); + end; + end; +end; + +function TcxBoldDataController.RequiresAllRecords(AItem: TObject): boolean; +begin + result := true; +end; + +function TcxBoldDataController.RequiresAllRecords: boolean; +begin + result := true; +end; + +procedure TcxBoldDataController.TypeChanged(aNewType, aOldType: TBoldElementTypeInfo); +begin + fSubscriber.CancelAllSubscriptions; + FreeAndNil(fSelection); + if Assigned(aNewType) then + aNewType.SystemTypeInfo.AddSubscription(fSubscriber, beDestroying, beSystemDestroying); +end; + +function TcxBoldDataController.IsProviderMode: Boolean; +begin + result := true; +end; + +procedure TcxBoldDataController.PreFetchColumns(aList: TBoldList; aItem: integer); +begin +end; + +function TcxBoldDataController.GetCurrentDetailDataController(ARelationIndex: integer = 0): TcxBoldDataController; +begin + if CurrentIndex = -1 then + result := nil + else + result := GetDetailDataController(CurrentIndex, ARelationIndex) as TcxBoldDataController; +end; + +procedure TcxBoldDataController.FilterChanged; +begin + fSkipCancel := true; + try + inherited; + finally + fSkipCancel := false; + end; +end; + +function TcxBoldDataController.FindItemByData(AData: Integer): TObject; +var + I: Integer; +begin + if (AData > -1) and (AData < ItemCount) then + begin + Result := GetItem(AData); + if GetItemData(Result) = AData then + Exit; + end; + for I := 0 to ItemCount - 1 do + begin + Result := GetItem(I); + if GetItemData(Result) = AData then + Exit; + end; + Result := nil; +end; + +procedure TcxBoldDataController.FindMinMaxIndex(ListA, ListB: TBoldList; + var AFrom, ATo: integer); +var + i,j: integer; + vCount: integer; +begin + vCount := ListB.Count; + if (ListA is TBoldObjectList) and (ListB is TBoldObjectList) then + begin + AFrom := maxInt; + ATo := -1; + for I := 0 to ListA.Count - 1 do + begin + if TBoldObjectList(ListB).Locators[i] = TBoldObjectList(ListA).Locators[i] then + j := i + else + j := TBoldObjectList(ListB).IndexOfLocator(TBoldObjectList(ListA).Locators[i]); + AFrom := Min(AFrom, j); + ATo := max(ATo, j); + if (AFrom = 0) and (ATo = vCount-1) then + exit; + end; + end + else + begin + AFrom := maxInt; + ATo := -1; + for I := 0 to ListA.Count - 1 do + begin + j := ListB.IndexOf(ListA[i]); + AFrom := Min(AFrom, j); + ATo := max(ATo, j); + if (AFrom = 0) and (ATo = vCount-1) then + exit; + end; + if (ATo = -1) and (ListA.Count > 0) and (ListB.Count > 0) then + begin + AFrom := 0; + ATo := ListB.Count -1; + end; + end; +end; + +function TcxBoldDataController.GetSelection: TBoldList; +var + ListType: TBoldElementTypeInfo; +begin + if not Assigned(fSelection) then + begin + fSelection := CreateList; + fSelection.AddSubscription(fSubscriber, beDestroying, beSelectionDestroying); + SelectionChanged; + end; + result := fSelection; +end; + +procedure TcxBoldDataController.Cancel; +var + i: integer; + lRowFollower: TBoldFollower; +begin + if fSkipCancel then + exit; + if FocusedRecordIndex = -1 then + inherited + else + begin + lRowFollower := Follower.SubFollowers[FocusedRecordIndex]; + for i := 0 to lRowFollower.SubFollowerCount - 1 do + begin + lRowFollower.SubFollowers[i].DiscardChange; + end; + end; +end; + +procedure TcxBoldDataController.SelectionChanged; +begin +// do nothing +end; + +function TcxBoldDataController.GetBoldList: TBoldList; +begin + if Assigned(BoldHandle) then + result := BoldHandle.List //Follower.Element as TBoldList; + else + result := nil; +end; + +{ TcxBoldDataSource } + +constructor TcxBoldDataSource.Create( + aBoldDataController: TcxBoldDataController); +begin + inherited Create; + fBoldDataController := aBoldDataController; +end; + +function TcxBoldDataSource.GetRecordCount: Integer; +begin + result := fBoldDataController.Follower.SubFollowerCount; + if not fBoldDataController.fInternalLoading then + if (fBoldDataController.Follower.state <> bfsCurrent) and (result <> fBoldDataController.DataStorage.RecordCount) then + result := fBoldDataController.DataStorage.RecordCount; +end; + +function TcxBoldDataSource.GetValue(ARecordHandle: TcxDataRecordHandle; + AItemHandle: TcxDataItemHandle): Variant; +var + lMainFollower: TBoldFollower; + lCellFollower: TBoldFollower; + lItemIndex: integer; + lRecordIndex: integer; + lResultElement: TBoldElement; + lItem: TObject; + lcxBoldDataController: TcxBoldDataController; + lBoldAwareViewItem: IBoldAwareViewItem; + lIcxBoldEditProperties: IcxBoldEditProperties; +begin + result := null; + lItemIndex := Integer(AItemHandle); + lRecordIndex := Integer(ARecordHandle); + lcxBoldDataController := DataController as TcxBoldDataController; + if not lcxBoldDataController.EnsureFollower(lRecordIndex, lItemIndex) then + exit; + lMainFollower := lcxBoldDataController.Follower; + lCellFollower := lMainFollower.SubFollowers[lRecordIndex].SubFollowers[lItemIndex]; + lItem := lcxBoldDataController.FindItemByData(lItemIndex); + if (lItem is TcxCustomGridTableItem) and Supports(TcxCustomGridTableItemAccess(lItem).GetProperties, IcxBoldEditProperties, lIcxBoldEditProperties) then + begin + lResultElement := lCellFollower.Value; + if Assigned(lResultElement) then + result := lIcxBoldEditProperties.BoldElementToEditValue(lCellFollower, lResultElement, nil) + else + result := (lCellFollower.Controller as TBoldVariantFollowerController).GetCurrentAsVariant(lCellFollower); + end + else + result := (lCellFollower.Controller as TBoldVariantFollowerController).GetCurrentAsVariant(lCellFollower); +end; + +procedure TcxBoldDataSource.SetValue(ARecordHandle: TcxDataRecordHandle; + AItemHandle: TcxDataItemHandle; const AValue: Variant); +var + lRowFollower: TBoldFollower; + lCellFollower: TBoldFollower; + lItemIndex: integer; + lDone: boolean; +begin + lItemIndex := Integer(AItemHandle); + + lRowFollower := fBoldDataController.Follower.SubFollowers[Integer(ARecordHandle)]; + Assert(Assigned(lRowFollower)); + + inc(fBoldDataController.FSkipMakeCellUptoDate); + try + lRowFollower.EnsureDisplayable; + finally + dec(fBoldDataController.FSkipMakeCellUptoDate); + end; + lCellFollower := lRowFollower.SubFollowers[lItemIndex]; + + lDone := fBoldDataController.BoldSetValue(AItemHandle, lCellFollower, AValue); + + if not lDone then + begin + (lCellFollower.Controller as TBoldVariantFollowerController).MayHaveChanged(aValue, lCellFollower); + end; + if (lCellFollower.State = bfsDirty) and (lCellFollower.Controller.ApplyPolicy <> bapDemand) then + begin + lCellFollower.Apply; + {$IFDEF DisplayAll} + inc(fBoldDataController.FSkipMakeCellUptoDate); + try + TBoldQueueable.DisplayAll; + finally + dec(fBoldDataController.FSkipMakeCellUptoDate); + end; + {$ENDIF} + end; +end; + +function TcxBoldDataSource.IsCustomSorting: Boolean; +var + i: integer; +begin + result := false; + + with TcxCustomDataControllerInfoAccess(DataController.DataControllerInfo) do + for I := 0 to RecordList.Count - 1 do + Assert(Integer(RecordList.Items[i]) < DataController.RecordCount); +end; + +procedure TcxBoldDataSource.CustomSort; +var + i,j: integer; + lOcl: string; + SourceList: TBoldList; +begin + SourceList := fBoldDataController.BoldList; + for I := 0 to TcxCustomDataControllerInfoAccess(DataController.DataControllerInfo).TotalSortingFieldList.Count - 1 do + begin + j := TcxCustomDataControllerInfoAccess(DataController.DataControllerInfo).TotalSortingFieldList[i].Field.Index; + lOcl := fBoldDataController.BoldColumnsProperties[j].Expression; +// FetchOclSpan(SourceList, lOcl); + end; + SourceList.Sort(CustomSortElementCompare); +end; + +function TcxBoldDataSource.CustomSortElementCompare(Item1, + Item2: TBoldElement): integer; +var + i,j: integer; + IE1, IE2: TBoldIndirectElement; +begin + result := 0; + IE1 := TBoldIndirectElement.Create; + IE2 := TBoldIndirectElement.Create; + try + for I := 0 to TcxCustomDataControllerInfoAccess(DataController.DataControllerInfo).TotalSortingFieldList.Count - 1 do + begin + j := TcxCustomDataControllerInfoAccess(DataController.DataControllerInfo).TotalSortingFieldList[i].Field.Index; + Item1.EvaluateExpression(fBoldDataController.BoldColumnsProperties[j].Expression, ie1); + Item2.EvaluateExpression(fBoldDataController.BoldColumnsProperties[j].Expression, ie2); + if Assigned(IE1.Value) then + result := IE1.Value.CompareTo(IE2.Value); + end; + finally + ie1.free; + ie2.free; + end; +end; + +procedure TcxBoldDataSource.DeleteRecord( + ARecordHandle: TcxDataRecordHandle); +var + lRowFollower: TBoldFollower; + lIndex: integer; + lBoldObject: TBoldObject; +begin + if not fIsBoldInitiatedChange then + begin + lIndex := Integer(ARecordHandle); + lRowFollower := fBoldDataController.Follower.SubFollowers[lIndex]; + Assert(Assigned(lRowFollower)); + Assert(lIndex = lRowFollower.index); + fIsBoldInitiatedChange := true; + try + {$IFDEF DisplayAll} + TBoldQueueable.DisplayAll; + {$ENDIF} +// Assert(lRowFollower.Element = fBoldDataController.Follower.SubFollowers[lIndex].Element, 'lRowFollower.Element = fBoldDataController.Follower.SubFollowers[lIndex].Element'); + lBoldObject := (lRowFollower.Element as TBoldObject); + if Assigned(lBoldObject) then + Assert(lBoldObject = fBoldDataController.BoldHandle.ObjectList[lIndex], 'lBoldObject = fBoldDataController.BoldHandle.ObjectList[lIndex]') + else + lBoldObject := fBoldDataController.BoldHandle.ObjectList[lIndex]; + + if lBoldObject.BoldClassTypeInfo.IsLinkClass then + begin + if lBoldObject.BoldObjectExists then // not already deleted + lBoldObject.delete; + end + else + begin + fBoldDataController.BoldHandle.MutableList.Remove(lBoldObject); + end; +{ + if lBoldObject.BoldObjectExists then // not already deleted + lBoldObject.delete; +} +// TBoldQueueable.DisplayAll; + {$IFDEF BoldDevExLog} + _Log((TcxBoldDataController(DataController).GetOwner as TComponent).Name + ':DataChanged4', ClassName); + {$ENDIF} + TcxBoldDataController(DataController).DataHasChanged := true; //DataChanged; +{ + if (lIndex < GetRecordCount) and (GetRecordCount > 0)then + begin + (fBoldDataController.GridView.Controller as TcxGridTableController).FocusedRow.Selected := true; + end; +} + finally + fIsBoldInitiatedChange := false; + end; + end; +end; + +function TcxBoldDataSource.GetDetailHasChildren(ARecordIndex, + ARelationIndex: Integer): Boolean; +var + lcxCustomDataController: TcxCustomDataController; + lFollower: TBoldFollower; + lOcl: string; + Ie: TBoldIndirectElement; + lDetailObject: TcxDetailObject; + lObject: TObject; + lGridLevel: TcxGridLevel; + lcxCustomDataRelation: TcxCustomDataRelation; + lPatternView: IBoldAwareView; + lcxCustomDataProviderAccess: TcxCustomDataProviderAccess; +begin + lcxCustomDataProviderAccess := TcxCustomDataProviderAccess(CurrentProvider); + Assert(fBoldDataController = lcxCustomDataProviderAccess.DataController); + result := false; + + if not (lcxCustomDataProviderAccess.DataController is TcxGridBoldDataController) then + exit; +// lDetailObject := fBoldDataController.GetDetailLinkObject(ARecordIndex, ARelationIndex) as TcxDetailObject; + + lDetailObject := lcxCustomDataProviderAccess.DataController.Relations.GetDetailObject(ARecordIndex); + lObject := lDetailObject.LinkObjects[ARelationIndex]; + + if Assigned(lObject) then + begin + lcxCustomDataController := lcxCustomDataProviderAccess.DataController.GetDetailDataController(ARecordIndex, ARelationIndex); + result := lcxCustomDataController.RecordCount > 0; + end + else + begin + lcxCustomDataRelation := lcxCustomDataProviderAccess.DataController.Relations[ARelationIndex]; + lGridLevel := lcxCustomDataRelation.Item as TcxGridLevel; + if lGridLevel.GridView.IsPattern and (lGridLevel.GridView <> TcxGridBoldDataController(lcxCustomDataProviderAccess.DataController).GridView) then + begin + lPatternView := (lGridLevel.GridView as IBoldAwareView); + if Assigned(lPatternView.DataController.BoldHandle) and (lPatternView.DataController.BoldHandle is TBoldListHandle) then + begin + TBoldQueueable.DisplayAll; + lOcl := (lPatternView.DataController.BoldHandle as TBoldListHandle).Expression; + Ie := TBoldIndirectElement.Create; + try + TcxBoldDataController(lcxCustomDataProviderAccess.DataController).AdjustActiveRange(); + lFollower := TcxBoldDataController(lcxCustomDataProviderAccess.DataController).Follower.SubFollowers[ARecordIndex]; + if not Assigned(lFollower) or not Assigned(lFollower.Element) then + exit; + if (lPatternView.DataController.BoldHandle as TBoldListHandle).Variables <> nil then + lFollower.Element.EvaluateExpression(lOcl, Ie, false, (lPatternView.DataController.BoldHandle as TBoldListHandle).Variables.VariableList) + else + lFollower.Element.EvaluateExpression(lOcl, Ie); + if Ie.Value is TBoldList then + begin + result := TBoldList(Ie.Value).Count > 0; + end + else + result := false; //Assigned(Ie.Value); + finally + Ie.free; + end; + end; + end; + end; +end; + +function TcxBoldDataSource.GetItemHandle( + AItemIndex: Integer): TcxDataItemHandle; +var + lItem: TObject; +begin + lItem := TcxCustomDataProviderAccess(CurrentProvider).DataController.GetItem(AItemIndex); + if lItem is TcxCustomGridTableItem then + result := TcxCustomGridTableItem(lItem).DataBinding.Data + else + result := TcxDataItemHandle(AItemIndex); // this handles cxLookupGrid which doesn't allow column moving so indexes are static +end; + +function TcxBoldDataSource.GetRecordHandle( + ARecordIndex: Integer): TcxDataRecordHandle; +begin + result := TcxDataRecordHandle(ARecordIndex); +end; + +function TcxBoldDataSource.GetRecordHandleByIndex( + ARecordIndex: Integer): TcxDataRecordHandle; +begin + Result := TcxDataRecordHandle(ARecordIndex); +end; + +destructor TcxBoldDataSource.Destroy; +begin + inherited; +end; + +function TcxBoldDataSource.IsRecordIdSupported: Boolean; +begin + result := true; +end; + +procedure TcxBoldDataSource.LoadRecordHandles; +begin +{$IFDEF BoldDevExLog} + if Assigned(fBoldDataController.BoldHandle) then + _Log(fBoldDataController.BoldHandle.Name + ':' + IntToStr(GetRecordCount), 'recordhandles'); +{$ENDIF} + inherited; +end; + +function TcxBoldDataSource.GetRecordId( + ARecordHandle: TcxDataRecordHandle): Variant; +begin + result := Integer(ARecordHandle); +end; + +{ TcxGridBoldColumn } + +function TcxGridBoldColumn.CalculateBestFitWidth: Integer; +begin + GridView.OptionsBehavior.BestFitMaxRecordCount := GridView.ViewInfo.VisibleRecordCount; + result := inherited CalculateBestFitWidth; +end; + +destructor TcxGridBoldColumn.Destroy; +begin + DataBinding.Remove; + inherited; +end; + +function TcxGridBoldColumn.GetDataBinding: TcxGridItemBoldDataBinding; +begin + Result := TcxGridItemBoldDataBinding(inherited DataBinding); +end; + +function TcxGridBoldColumn.GetProperties(AProperties: TStrings): Boolean; +begin + AProperties.Add('OnCustomDrawCell'); + AProperties.Add('OnGetFilterValues'); + AProperties.Add('OnUserFilteringEx'); + AProperties.Add('OnGetCellHint'); + AProperties.Add('Sorting'); + AProperties.Add('Grouping'); + AProperties.Add('Filtering'); + AProperties.Add('Caption'); + AProperties.Add('IncSearch'); + AProperties.Add('Expression'); + AProperties.Add('Renderer'); + Result := inherited GetStoredProperties(AProperties); +end; + +procedure TcxGridBoldColumn.GetPropertyValue(const AName: string; + var AValue: Variant); +var + method: TMethod; + Renderer: TBoldRenderer; +begin + if Assigned(OnCustomDrawCell) and (AName = 'OnCustomDrawCell') then + begin + method := TMethod(OnCustomDrawCell); + if method.Data <> DataController then + AValue := TObject(Method.Data).MethodName(Method.Code); + end + else + if Assigned(OnGetFilterValues) and (AName = 'OnGetFilterValues') then + begin + method := TMethod(OnGetFilterValues); + if method.Data <> DataController then + AValue := TObject(Method.Data).MethodName(Method.Code); + end + else + if Assigned(OnUserFilteringEx) and (AName = 'OnUserFilteringEx') then + begin + method := TMethod(OnUserFilteringEx); + if method.Data <> DataController then + AValue := TObject(Method.Data).MethodName(Method.Code); + end + else + if Assigned(OnGetCellHint) and (AName = 'OnGetCellHint') then + begin + method := TMethod(OnGetCellHint); + if method.Data <> DataController then + AValue := TObject(Method.Data).MethodName(Method.Code); + end + else + if AName = 'Sorting' then + AValue := Options.Sorting + else + if AName = 'Grouping' then + AValue := Options.Grouping + else + if AName = 'Filtering' then + AValue := Options.Filtering + else + if AName = 'Caption' then + AValue := Caption + else + if AName = 'IncSearch' then + AValue := Options.IncSearch + else + if AName = 'Expression' then + AValue := DataBinding.BoldProperties.expression + else + if AName = 'Renderer' then + begin + if Assigned(DataBinding.BoldProperties.Renderer) then + begin + Renderer := DataBinding.BoldProperties.Renderer; + if Assigned(Renderer.Owner) and (Renderer.Owner <> Owner.Owner) then + begin + AValue := Renderer.Owner.Name + '.'+ Renderer.Name; + end + else + AValue := Renderer.Name; + end; + end + else + inherited; +end; + +procedure TcxGridBoldColumn.SetDataBinding( + Value: TcxGridItemBoldDataBinding); +begin + inherited DataBinding := Value; +end; + +procedure TcxGridBoldColumn.SetPropertyValue(const AName: string; + const AValue: Variant); + + function FindEvent(const AEventName: string): TMethod; + var + vObject: TObject; + begin + result.Code := nil; + result.Data := nil; + vObject := self; + repeat + if Integer(vObject.MethodAddress(AEventName)) <> 0 then + begin + result.Code := vObject.MethodAddress(AEventName); + result.Data := vObject; + end + else + if vObject is TComponent then + vObject := TComponent(vObject).Owner; + until (Integer(result.Code) <> 0) or not Assigned(vObject); + end; + +var + Renderer: TBoldCustomAsVariantRenderer; + s: string; + i: integer; + Component: TComponent; +begin + if AName = 'OnCustomDrawCell' then + begin + if AValue = '' then + OnCustomDrawCell := nil + else + OnCustomDrawCell := TcxGridTableDataCellCustomDrawEvent(FindEvent(AValue)); + end + else + if AName = 'OnGetFilterValues' then + begin + if AValue = '' then + OnGetFilterValues := nil + else + OnGetFilterValues := TcxGridGetFilterValuesEvent(FindEvent(AValue)); + end + else + if AName = 'OnUserFilteringEx' then + begin + if AValue = '' then + OnUserFilteringEx := nil + else + OnUserFilteringEx := TcxGridUserFilteringExEvent(FindEvent(AValue)); + end + else + if AName = 'OnGetCellHint' then + begin + if AValue = '' then + OnGetCellHint := nil + else + OnGetCellHint := TcxGridGetCellHintEvent(FindEvent(AValue)); + end + else + if AName = 'Sorting' then + Options.Sorting := AValue + else + if AName = 'Grouping' then + Options.Grouping := AValue + else + if AName = 'Filtering' then + Options.Filtering := AValue + else + if AName = 'Caption' then + Caption := AValue + else + if AName = 'IncSearch' then + begin + Options.IncSearch := AValue; + if Options.IncSearch then + GridView.OptionsBehavior.IncSearchItem := self; + end + else + if AName = 'Expression' then + DataBinding.BoldProperties.expression := AValue + else + if AName = 'Renderer' then + begin + i := Pos('.', AValue); + if i > 1 then + begin + s := Copy(aValue, 1, i-1); + Component := Application.FindComponent(s); + s := Copy(aValue, i+1, maxint); + Renderer := Component.FindComponent(s) as TBoldCustomAsVariantRenderer; + end + else + begin + Renderer := FindComponent(AValue) as TBoldCustomAsVariantRenderer; + if not Assigned(Renderer) and Assigned(GridView.Owner) then + Renderer := GridView.Owner.FindComponent(AValue) as TBoldCustomAsVariantRenderer; + end; + DataBinding.BoldProperties.Renderer := Renderer; + end + else + inherited; +end; + +procedure TcxGridBoldColumn.VisibleChanged; +begin + inherited; +// if Visible and not IsLoading then +// (DataController as TcxGridBoldDataController).AdjustActiveRange(); +end; + +{ TcxGridBoldTableView } + +function TcxGridBoldTableView.DoCellDblClick( + ACellViewInfo: TcxGridTableDataCellViewInfo; AButton: TMouseButton; + AShift: TShiftState): Boolean; +var + lAutoForm: TForm; + lElement: TBoldElement; +begin + result := false; + if DataController.BoldProperties.DefaultDblClick and not Controller.IsSpecialRowFocused and Assigned(DataController.Follower.CurrentSubFollower) then + begin + lElement := DataController.Follower.CurrentSubFollower.Element; + lAutoForm := AutoFormProviderRegistry.FormForElement(lElement); + if assigned(lAutoForm) then + begin + result := true; + lAutoForm.Show; + end + end; + if not result then + begin + result := inherited DoCellDblClick(ACellViewInfo, AButton, AShift); + end; +end; + +//{$IFNDEF UseBoldEditors} +//type +// IcxBoldEditProperties = Interface +// ['{D50859F1-F550-4CE6-84DE-5074921512E5}'] +// procedure SetStoredValue(aEdit: TcxCustomEdit; aFollower: TBoldFollower; var aDone: boolean); +// end; +//{$ENDIF} + +function TcxGridBoldTableView.DoEditing( + AItem: TcxCustomGridTableItem): Boolean; +begin + if Controller.IsSpecialRowFocused then + begin + result := inherited DoEditing(aItem); + end + else + begin + result := DataController.DoEditing(AItem) and inherited DoEditing(aItem); + end; +end; + +procedure TcxGridBoldTableView.DoEditKeyPress( + AItem: TcxCustomGridTableItem; AEdit: TcxCustomEdit; var Key: Char); +var + lRecord: integer; + lFollower: TBoldFollower; +begin + lRecord := DataController.RecNo; + if (lRecord <> -1) and (Key <> #8) and not Controller.IsSpecialRowFocused then + begin + lFollower := DataController.CellFollowers[lRecord, AItem.ID]; + if not (lFollower.AssertedController as TBoldVariantFollowerController).ValidateCharacter(key, lFollower) then + begin + key := #0; + end; + end; + inherited; +end; + +{$IFDEF DelayOnFocusedRecordChange} +procedure TcxGridBoldTableView.InheritedDoFocusedRecordChanged(APrevFocusedRecordIndex, + AFocusedRecordIndex, APrevFocusedDataRecordIndex, + AFocusedDataRecordIndex: Integer; ANewItemRecordFocusingChanged: Boolean); +begin + if AFocusedRecordIndex >= TcxCustomDataControllerInfoAccess(DataController.DataControllerInfo).RecordList.Count then + begin + DataController.DataControllerInfo.Refresh; + Assert(DataController.FilteredRecordCount = TcxCustomDataControllerInfoAccess(DataController.DataControllerInfo).RecordList.Count, Format('DataController.FilteredRecordCount = %d <> DataController.DataControllerInfo.GetRowCount = %d', [DataController.FilteredRecordCount, TcxCustomDataControllerInfoAccess(DataController.DataControllerInfo).RecordList.Count])); + end; + inherited DoFocusedRecordChanged(APrevFocusedRecordIndex, AFocusedRecordIndex, APrevFocusedDataRecordIndex, AFocusedDataRecordIndex, ANewItemRecordFocusingChanged); +end; +{$ENDIF} + +procedure TcxGridBoldTableView.DoFocusedRecordChanged(APrevFocusedRecordIndex, + AFocusedRecordIndex, APrevFocusedDataRecordIndex, + AFocusedDataRecordIndex: Integer; ANewItemRecordFocusingChanged: Boolean); +begin + if DataController.InDelayScrollUpdate then + begin + if FPrevFocusedRecordIndex = MaxInt then // MaxInt used as flag to only store Prev values once + begin + FPrevFocusedRecordIndex := APrevFocusedRecordIndex; + FPrevFocusedDataRecordIndex := APrevFocusedDataRecordIndex; + end; + end + else +{$IFDEF DelayOnFocusedRecordChange} + if Assigned(OnFocusedRecordChanged)then + begin + DataController.EnsureEventQueued; + DataController.fFocusChanged := true; + DataController.fPrevFocusedRecordIndex := APrevFocusedRecordIndex; + DataController.fFocusedRecordIndex := AFocusedRecordIndex; + DataController.fPrevFocusedDataRecordIndex := APrevFocusedDataRecordIndex; + DataController.fFocusedDataRecordIndex := AFocusedDataRecordIndex; + DataController.fNewItemRecordFocusingChanged := ANewItemRecordFocusingChanged; + end + else +{$ENDIF} + begin +// if not TBoldQueueable.IsDisplayQueueEmpty and not TBoldQueueable.IsDisplaying then +// TBoldQueueable.DisplayAll; + inherited; + FPrevFocusedRecordIndex := MaxInt; + end; +end; + +procedure TcxGridBoldTableView.DoChanged(AChangeKind: TcxGridViewChangeKind); +begin + if Assigned(DataController) and Assigned(DataController.CustomDataSource) and DataController.MainFollowerNeedsDisplay then + if DataController.LockCount = 0 then + DataController.DisplayFollowers; + inherited; +end; + +procedure TcxGridBoldTableView.DoCustomDrawCell(ACanvas: TcxCanvas; + AViewInfo: TcxGridTableDataCellViewInfo; var ADone: Boolean); +var + CellFollower: TBoldFollower; + Controller: TBoldVariantFollowerController; + Color: TColor; +begin + Color := ACanvas.Brush.Color; + inherited DoCustomDrawCell(ACanvas, AViewInfo, ADone); + if ADone then + exit; + CellFollower := (AViewInfo.GridView as IBoldAwareView).DataController.CellFollowers[AViewInfo.RecordViewInfo.GridRecord.RecordIndex, AViewInfo.Item.ID]; + if Assigned(CellFollower) then + begin + Controller := CellFollower.Controller as TBoldVariantFollowerController; + Controller.SetColor(Color, Color, CellFollower); + if Color > -1 then + ACanvas.Brush.Color := Color; + end; +end; + +procedure TcxGridBoldTableView.DoItemsAssigned; +begin + DataController.RestructData; + inherited; +end; + +function TcxGridBoldTableView.GetSelection: TBoldList; +begin + result := DataController.Selection; +end; + +procedure TcxGridBoldTableView.DoSelectionChanged; +begin + DataController.SelectionChanged; + inherited; +end; + +function TcxGridBoldTableView.GetViewInfoClass: TcxCustomGridViewInfoClass; +begin + result := TcxGridBoldTableViewInfo; +end; + +function TcxGridBoldTableView.GetControllerClass: TcxCustomGridControllerClass; +begin + result := TcxGridBoldTableController; +end; + +function TcxGridBoldTableView.GetDataController: TcxGridBoldDataController; +begin + Result := TcxGridBoldDataController(FDataController); +end; + +function TcxGridBoldTableView.GetDataControllerClass: TcxCustomDataControllerClass; +begin + Result := TcxGridBoldDataController; +end; + +function TcxGridBoldTableView.GetFake: TNotifyEvent; +begin + result := nil; +end; + +procedure TcxGridBoldTableView.SetFake(const Value: TNotifyEvent); +begin + +end; + +function TcxGridBoldTableView.GetItemClass: TcxCustomGridTableItemClass; +begin + Result := TcxGridBoldColumn; +end; + +procedure TcxGridBoldTableView.HookDragDrop; +begin + OnDragDrop := DataController.DoDragDrop; + OnStartDrag := DataController.DoStartDrag; + OnEndDrag := DataController.DoEndDrag; + OnDragOver := DataController.DoDragOver; +end; + +procedure TcxGridBoldTableView.SetDataController( + Value: TcxGridBoldDataController); +begin + FDataController.Assign(Value); +end; + +function TcxGridBoldTableView.ValidateComponent( + ComponentValidator: TBoldComponentValidator; NamePrefix: string): Boolean; +var + i: integer; + lContext: TBoldElementTypeInfo; + lBoldValidateableComponent: IBoldValidateableComponent; +begin + lContext := DataController.GetHandleStaticType; + result := ComponentValidator.ValidateExpressionInContext( + '', lContext, format('%s%s', [NamePrefix, Name])); // do not localize + if assigned(lContext) then + for i := 0 to ItemCount - 1 do + begin + result := ComponentValidator.ValidateExpressionInContext( + Items[i].BoldProperties.Expression, + lContext, + format('%s%s.Column[%d]', [NamePrefix, Name, i]), + Items[i].BoldProperties.VariableList) and result; // do not localize + if Supports((DataController.GetItem(i) as TcxCustomGridTableItem).GetProperties, IBoldValidateableComponent, lBoldValidateableComponent) then + result := lBoldValidateableComponent.ValidateComponent(ComponentValidator, namePrefix) and result; + end; +end; + +constructor TcxGridBoldTableView.Create(AOwner: TComponent); +begin + inherited; +{$IFDEF DefaultDragMode} + DragMode := dmAutomatic; +{$ENDIF} + hookDragDrop; +end; + +{ TcxGridBoldBandedTableView } + +constructor TcxGridBoldBandedTableView.Create(AOwner: TComponent); +begin + inherited; +{$IFDEF DefaultDragMode} + DragMode := dmAutomatic; +{$ENDIF} + hookDragDrop; +end; + +destructor TcxGridBoldBandedTableView.Destroy; +begin + inherited; +end; + +{$IFDEF DelayOnFocusedRecordChange} +procedure TcxGridBoldBandedTableView.InheritedDoFocusedRecordChanged(APrevFocusedRecordIndex, + AFocusedRecordIndex, APrevFocusedDataRecordIndex, + AFocusedDataRecordIndex: Integer; ANewItemRecordFocusingChanged: Boolean); +begin + if AFocusedRecordIndex >= TcxCustomDataControllerInfoAccess(DataController.DataControllerInfo).RecordList.Count then + begin + DataController.DataControllerInfo.Refresh; + Assert(DataController.FilteredRecordCount = TcxCustomDataControllerInfoAccess(DataController.DataControllerInfo).RecordList.Count, Format('DataController.FilteredRecordCount = %d <> DataController.DataControllerInfo.GetRowCount = %d', [DataController.FilteredRecordCount, TcxCustomDataControllerInfoAccess(DataController.DataControllerInfo).RecordList.Count])); + end; + inherited DoFocusedRecordChanged(APrevFocusedRecordIndex, AFocusedRecordIndex, APrevFocusedDataRecordIndex, AFocusedDataRecordIndex, ANewItemRecordFocusingChanged); +end; +{$ENDIF} + +procedure TcxGridBoldBandedTableView.DoFocusedRecordChanged(APrevFocusedRecordIndex, + AFocusedRecordIndex, APrevFocusedDataRecordIndex, + AFocusedDataRecordIndex: Integer; ANewItemRecordFocusingChanged: Boolean); +begin + if DataController.InDelayScrollUpdate then + begin + if FPrevFocusedRecordIndex = MaxInt then // MaxInt used as flag to only store Prev values once + begin + FPrevFocusedRecordIndex := APrevFocusedRecordIndex; + FPrevFocusedDataRecordIndex := APrevFocusedDataRecordIndex; + end; + end + else +{$IFDEF DelayOnFocusedRecordChange} + if Assigned(OnFocusedRecordChanged)then + begin + DataController.EnsureEventQueued; + DataController.fFocusChanged := true; + DataController.fPrevFocusedRecordIndex := APrevFocusedRecordIndex; + DataController.fFocusedRecordIndex := AFocusedRecordIndex; + DataController.fPrevFocusedDataRecordIndex := APrevFocusedDataRecordIndex; + DataController.fFocusedDataRecordIndex := AFocusedDataRecordIndex; + DataController.fNewItemRecordFocusingChanged := ANewItemRecordFocusingChanged; + end + else +{$ENDIF} + begin +// if not TBoldQueueable.IsDisplayQueueEmpty and not TBoldQueueable.IsDisplaying then +// TBoldQueueable.DisplayAll; + inherited; + FPrevFocusedRecordIndex := MaxInt; + end; +end; + +procedure TcxGridBoldBandedTableView.DoChanged(AChangeKind: TcxGridViewChangeKind); +begin + if Assigned(DataController) and Assigned(DataController.CustomDataSource) and DataController.MainFollowerNeedsDisplay then + DataController.DisplayFollowers; + inherited; +end; + +function TcxGridBoldBandedTableView.DoCellDblClick( + ACellViewInfo: TcxGridTableDataCellViewInfo; AButton: TMouseButton; + AShift: TShiftState): Boolean; +var + lAutoForm: TForm; + lElement: TBoldElement; +begin + result := false; + if DataController.BoldProperties.DefaultDblClick and not Controller.IsSpecialRowFocused and Assigned(DataController.Follower.CurrentSubFollower) then + begin + lElement := DataController.Follower.CurrentSubFollower.Element; + lAutoForm := AutoFormProviderRegistry.FormForElement(lElement); + if assigned(lAutoForm) then + begin + result := true; + lAutoForm.Show; + end + end; + if not result then + begin + result := inherited DoCellDblClick(ACellViewInfo, AButton, AShift); + end; +end; + +function TcxGridBoldBandedTableView.DoEditing( + AItem: TcxCustomGridTableItem): Boolean; +begin + if Controller.IsSpecialRowFocused then + begin + result := inherited DoEditing(aItem); + end + else + begin + result := DataController.DoEditing(AItem) and inherited DoEditing(aItem); + end; +end; + +procedure TcxGridBoldBandedTableView.DoSelectionChanged; +begin + DataController.SelectionChanged; + inherited; +end; + +function TcxGridBoldBandedTableView.GetControllerClass: TcxCustomGridControllerClass; +begin + result := TcxGridBoldBandedTableController; +end; + +function TcxGridBoldBandedTableView.GetCurrentBoldObject: TBoldObject; +begin + result := DataController.CurrentBoldObject; +end; + +function TcxGridBoldBandedTableView.GetCurrentElement: TBoldElement; +begin + result := DataController.CurrentElement; +end; + +function TcxGridBoldBandedTableView.GetCurrentIndex: integer; +begin + result := DataController.CurrentIndex; +end; + +function TcxGridBoldBandedTableView.GetDataController: TcxGridBoldDataController; +begin + Result := TcxGridBoldDataController(FDataController); +end; + +function TcxGridBoldBandedTableView.GetDataControllerClass: TcxCustomDataControllerClass; +begin + Result := TcxGridBoldDataController; +end; + +function TcxGridBoldBandedTableView.GetItem(Index: Integer): IBoldAwareViewItem; +begin + result := inherited Items[Index] as IBoldAwareViewItem; +end; + +function TcxGridBoldBandedTableView.GetItemClass: TcxCustomGridTableItemClass; +begin + Result := TcxGridBoldBandedColumn; +end; + +function TcxGridBoldBandedTableView.GetItemCount: Integer; +begin + result := inherited ItemCount; +end; + +function TcxGridBoldBandedTableView.GetSelection: TBoldList; +begin + result := DataController.Selection; +end; + +function TcxGridBoldBandedTableView.GetViewInfoClass: TcxCustomGridViewInfoClass; +begin + Result := TcxGridBoldBandedTableViewInfo; +end; + +procedure TcxGridBoldBandedTableView.HookDragDrop; +begin + OnDragDrop := DataController.DoDragDrop; + OnStartDrag := DataController.DoStartDrag; + OnEndDrag := DataController.DoEndDrag; + OnDragOver := DataController.DoDragOver; +end; + +procedure TcxGridBoldBandedTableView.SetDataController( + Value: TcxGridBoldDataController); +begin + FDataController.Assign(Value); +end; + +function TcxGridBoldBandedTableView.ValidateComponent( + ComponentValidator: TBoldComponentValidator; NamePrefix: string): Boolean; +var + i: integer; + lContext: TBoldElementTypeInfo; + lBoldValidateableComponent: IBoldValidateableComponent; +begin + lContext := DataController.GetHandleStaticType; + result := ComponentValidator.ValidateExpressionInContext( + '', lContext, format('%s%s', [NamePrefix, Name])); // do not localize + if assigned(lContext) then + begin + for i := 0 to ItemCount - 1 do + begin + result := ComponentValidator.ValidateExpressionInContext( + Items[i].BoldProperties.Expression, + lContext, + format('%s%s.Column[%d]', [NamePrefix, Name, i]), + Items[i].BoldProperties.VariableList) and result; // do not localize + if Supports((DataController.GetItem(i) as TcxCustomGridTableItem).GetProperties, IBoldValidateableComponent, lBoldValidateableComponent) then + result := lBoldValidateableComponent.ValidateComponent(ComponentValidator, namePrefix) and result; + end; + end; +end; + +destructor TcxGridBoldTableView.Destroy; +begin + TBoldFollowerControllerAccess(DataController.fBoldColumnsProperties).FreePublisher; + inherited; +end; + +function TcxGridBoldTableView.GetCurrentBoldObject: TBoldObject; +begin + result := DataController.CurrentBoldObject; +end; + +function TcxGridBoldTableView.GetCurrentIndex: integer; +begin + result := DataController.CurrentIndex; +end; + +function TcxGridBoldTableView.GetCurrentElement: TBoldElement; +begin + result := DataController.CurrentElement; +end; + +function TcxGridBoldTableView.GetItem(Index: Integer): IBoldAwareViewItem; +begin + result := inherited Items[Index] as IBoldAwareViewItem; +end; + +function TcxGridBoldTableView.GetItemCount: Integer; +begin + result := inherited ItemCount; +end; + +function TcxGridBoldTableView.GetProperties(AProperties: TStrings): Boolean; +begin + with AProperties do + begin + Add('IncSearch'); + end; + Result := inherited GetProperties(AProperties); +end; + +procedure TcxGridBoldTableView.SetPropertyValue(const AName: string; + const AValue: Variant); +begin + if AName = 'IncSearch' then + OptionsBehavior.IncSearch := AValue + else + inherited; +end; + +procedure TcxGridBoldTableView.GetPropertyValue(const AName: string; + var AValue: Variant); +begin + if AName = 'IncSearch' then + AValue := OptionsBehavior.IncSearch + else + inherited; +end; + +{ TcxGridBoldCardView } + +constructor TcxGridBoldCardView.Create(AOwner: TComponent); +begin + inherited; +{$IFDEF DefaultDragMode} +// Drag drop is currently not supported in the CardView + +// DragMode := dmAutomatic; +// hookDragDrop; +{$ENDIF} +end; + +destructor TcxGridBoldCardView.Destroy; +begin + inherited; +end; + +function TcxGridBoldCardView.DoCellDblClick( + ACellViewInfo: TcxGridTableDataCellViewInfo; AButton: TMouseButton; + AShift: TShiftState): Boolean; +var + lAutoForm: TForm; + lElement: TBoldElement; +begin + result := false; + if DataController.BoldProperties.DefaultDblClick and Assigned(DataController.Follower.CurrentSubFollower) then + begin + lElement := DataController.Follower.CurrentSubFollower.Element; + lAutoForm := AutoFormProviderRegistry.FormForElement(lElement); + if assigned(lAutoForm) then + begin + result := true; + lAutoForm.Show; + end + end; + if not result then + begin + result := inherited DoCellDblClick(ACellViewInfo, AButton, AShift); + end; +end; + +function TcxGridBoldCardView.DoEditing( + AItem: TcxCustomGridTableItem): Boolean; +begin + result := DataController.DoEditing(AItem) and inherited DoEditing(aItem); +end; + +procedure TcxGridBoldCardView.DoSelectionChanged; +begin + DataController.SelectionChanged; + inherited; +end; + +function TcxGridBoldCardView.GetControllerClass: TcxCustomGridControllerClass; +begin + result := TcxGridBoldCardViewController; +end; + +function TcxGridBoldCardView.GetCurrentBoldObject: TBoldObject; +begin + result := DataController.CurrentBoldObject; +end; + +function TcxGridBoldCardView.GetCurrentElement: TBoldElement; +begin + result := DataController.CurrentElement; +end; + +function TcxGridBoldCardView.GetCurrentIndex: integer; +begin + result := DataController.CurrentIndex; +end; + +function TcxGridBoldCardView.GetDataController: TcxGridBoldDataController; +begin + Result := TcxGridBoldDataController(FDataController); +end; + +function TcxGridBoldCardView.GetDataControllerClass: TcxCustomDataControllerClass; +begin + Result := TcxGridBoldDataController; +end; + +function TcxGridBoldCardView.GetItem(Index: Integer): IBoldAwareViewItem; +begin + result := inherited Items[Index] as IBoldAwareViewItem; +end; + +function TcxGridBoldCardView.GetItemClass: TcxCustomGridTableItemClass; +begin + Result := TcxGridBoldCardViewRow; +end; + +function TcxGridBoldCardView.GetItemCount: Integer; +begin + result := inherited ItemCount; +end; + +function TcxGridBoldCardView.GetSelection: TBoldList; +begin + result := DataController.Selection; +end; + +function TcxGridBoldCardView.GetViewInfoClass: TcxCustomGridViewInfoClass; +begin + Result := TcxGridBoldCardViewViewInfo; +end; + +procedure TcxGridBoldCardView.SetDataController( + Value: TcxGridBoldDataController); +begin + FDataController.Assign(Value); +end; + +function TcxGridBoldCardView.ValidateComponent( + ComponentValidator: TBoldComponentValidator; NamePrefix: string): Boolean; +var + i: integer; + lContext: TBoldElementTypeInfo; + lBoldValidateableComponent: IBoldValidateableComponent; +begin + lContext := DataController.GetHandleStaticType; + result := ComponentValidator.ValidateExpressionInContext( + '', lContext, format('%s%s', [NamePrefix, Name])); // do not localize + if assigned(lContext) then + begin + for i := 0 to ItemCount - 1 do + begin + result := ComponentValidator.ValidateExpressionInContext( + Items[i].BoldProperties.Expression, + lContext, + format('%s%s.Column[%d]', [NamePrefix, Name, i]), + Items[i].BoldProperties.VariableList) and result; // do not localize + if Supports((DataController.GetItem(i) as TcxCustomGridTableItem).GetProperties, IBoldValidateableComponent, lBoldValidateableComponent) then + result := lBoldValidateableComponent.ValidateComponent(ComponentValidator, namePrefix) and result; + end; + end; +end; + +{ TcxBoldCustomDataProvider } + +function TcxBoldCustomDataProvider.GetValue(ARecordIndex: Integer; AField: TcxCustomDataField): Variant; +var + ARecordHandle: TcxDataRecordHandle; + AItemHandle: TcxDataItemHandle; + lBoldDataSource: TcxBoldDataSource; +begin + Result := Null; + lBoldDataSource := CustomDataSource as TcxBoldDataSource; + if Assigned(lBoldDataSource) then + begin + lBoldDataSource.CurrentProvider := Self; + ARecordHandle := TcxDataRecordHandle(ARecordIndex); + AItemHandle := lBoldDataSource.GetItemHandle(AField.Index); + Result := lBoldDataSource.GetValue(ARecordHandle, AItemHandle); + end; +end; + +function TcxBoldCustomDataProvider.IsActiveDataSet: Boolean; +begin + result := Assigned(CustomDataSource); +end; + +function TcxBoldCustomDataProvider.SetEditValue(ARecordIndex: Integer; + AField: TcxCustomDataField; const AValue: Variant; + AEditValueSource: TcxDataEditValueSource): Boolean; +begin + DataController.SetValue(ARecordIndex, AField.Index, AValue); + SetModified; + Result := True; +end; + +procedure TcxBoldCustomDataProvider.SetValue(ARecordIndex: Integer; AField: TcxCustomDataField; const Value: Variant); +var + ARecordHandle: TcxDataRecordHandle; + AItemHandle: TcxDataItemHandle; + lBoldDataSource: TcxBoldDataSource; +begin + lBoldDataSource := CustomDataSource as TcxBoldDataSource; + if Assigned(lBoldDataSource) then + begin + lBoldDataSource.CurrentProvider := Self; + ARecordHandle := TcxDataRecordHandle(ARecordIndex); + AItemHandle := lBoldDataSource.GetItemHandle(AField.Index); + lBoldDataSource.SetValue(ARecordHandle, AItemHandle, Value); + end; +end; + +function TcxBoldCustomDataProvider.CanDelete: Boolean; +var + lcxBoldDataController: TcxBoldDataController; +begin + lcxBoldDataController := DataController as TcxBoldDataController; + result := Assigned(lcxBoldDataController) and Assigned(lcxBoldDataController.BoldHandle); + if result then + begin + if Assigned(lcxBoldDataController.fOnDelete) and Assigned(lcxBoldDataController.fCanDelete) then + begin + lcxBoldDataController.fCanDelete(lcxBoldDataController, result) + end + else + result := Assigned(lcxBoldDataController.BoldHandle.MutableList); +{ + for I := 0 to lcxBoldDataController.Selection.Count - 1 do + if not lcxBoldDataController.BoldHandle.MutableList.CanRemove( lcxBoldDataController.Selection[i] ) then + begin + result := false; + exit; + end; +} + end; +end; + +function TcxBoldCustomDataProvider.CanInsert: Boolean; +var + lcxBoldDataController: TcxBoldDataController; +begin + lcxBoldDataController := DataController as TcxBoldDataController; + result := Assigned(lcxBoldDataController) and Assigned(lcxBoldDataController.BoldHandle); + if result then + begin + if Assigned(lcxBoldDataController.fOnInsert) and Assigned(lcxBoldDataController.fCanInsert) then + begin + lcxBoldDataController.fCanInsert(lcxBoldDataController, result) + end + else + if Assigned(lcxBoldDataController.fCanInsert) then + lcxBoldDataController.fCanInsert(lcxBoldDataController, result); + result := result and Assigned(lcxBoldDataController.BoldHandle.MutableList) and lcxBoldDataController.BoldHandle.MutableList.CanCreateNew; + end; +end; + +type TcxCustomDataSourceAccess = class(TcxCustomDataSource); + +procedure TcxBoldCustomDataProvider.DeleteRecords(AList: TList); +var + i, {j,} ARecordIndex: Integer; + lListToDelete: TBoldObjectList; +// lOriginalList: TBoldObjectList; + lMutableList: TBoldObjectList; + lObjectToDelete: TBoldObject; + lFollower: TBoldFollower; +begin + DataController.BeginFullUpdate; + lListToDelete := TBoldObjectList.Create; + inc(TcxBoldDataController(DataController).fSkipMakeCellUptoDate); + try +// lOriginalList := TcxBoldDataController(DataController).Follower.Element as TBoldObjectList; + for I := AList.Count - 1 downto 0 do + begin + ARecordIndex := Integer(AList[I]); + with DataController.DataControllerInfo.Selection do + if (DataController.DataControllerInfo.Selection.Count > 1) and IsRecordSelected(ARecordIndex) then + DataController.DataControllerInfo.Selection.Delete(FindByRecordIndex(ARecordIndex)); + + lFollower := TcxBoldDataController(DataController).Follower.Subfollowers[ARecordIndex]; + lObjectToDelete := lFollower.element as TBoldObject; + if Assigned(lObjectToDelete) and not lObjectToDelete.BoldObjectIsDeleted then + lListToDelete.Add(lObjectToDelete); + end; + lMutableList := TcxBoldDataController(DataController).BoldHandle.MutableObjectList; + if Assigned(lMutableList.BoldRoleRTInfo) and (lMutableList.BoldRoleRTInfo.RoleType = rtLinkRole) then + begin + for I := lListToDelete.Count - 1 downto 0 do + begin + if lListToDelete[i].BoldObjectExists then // not already deleted + lListToDelete[i].Delete; + end; + end + else + lMutableList.RemoveList(lListToDelete); + if TcxCustomDataControllerAccess(DataController).FInDeleteSelection then + DataController.ClearSelection; + TcxGridBoldDataController(DataController).DataHasChanged := true; + finally + lListToDelete.free; + DataController.EndFullUpdate; + TcxCustomDataControllerAccess(DataController).CheckNearestFocusRow; + dec(TcxBoldDataController(DataController).fSkipMakeCellUptoDate); + end; +end; + +{ TcxGridBoldTableController } + +procedure TcxGridBoldTableController.DoKeyDown(var Key: Word; + Shift: TShiftState); +var + lColumnAutoWidth: boolean; + lVisibleCount: integer; +begin + if (Key = VK_DOWN) or (Key = VK_UP) or (Key = VK_NEXT) or (Key = VK_PRIOR) then + (DataController as TcxBoldDataController).BeginDelayScrollUpdate; + if (key = VK_ADD) and (shift = [ssCtrl]) then + begin + GridView.BeginUpdate; + try + GridView.OptionsView.ColumnAutoWidth := not GridView.OptionsView.ColumnAutoWidth; + lColumnAutoWidth := GridView.OptionsView.ColumnAutoWidth; + if not lColumnAutoWidth then + begin + lVisibleCount := GridView.ViewInfo.VisibleRecordCount; + if lVisibleCount <> GridView.OptionsBehavior.BestFitMaxRecordCount then + GridView.OptionsBehavior.BestFitMaxRecordCount := lVisibleCount; + ViewInfo.GridView.ApplyBestFit(nil, true, true); + if lColumnAutoWidth then + GridView.OptionsView.ColumnAutoWidth := true; + end; + finally + GridView.EndUpdate; + end; + end; + inherited; +end; +{ +procedure TcxGridBoldTableController.FocusedRecordChanged(APrevFocusedRecordIndex, AFocusedRecordIndex, + APrevFocusedDataRecordIndex, AFocusedDataRecordIndex: Integer; + ANewItemRecordFocusingChanged: Boolean); +begin +// CodeSite.Send('FocusedRecordChanged:' + IntToStr(AFocusedRecordIndex)); + inherited; +end; +} +function TcxGridBoldTableController.GetEditingControllerClass: TcxGridEditingControllerClass; +begin + result := TcxGridBoldEditingController; +end; + +procedure TcxGridBoldTableController.KeyDown(var Key: Word; + Shift: TShiftState); +var + lIndex: integer; + lBoldHandle: TBoldAbstractListHandle; + lBoldList: TBoldList; + lHandled: boolean; + lAllowed: boolean; + lcxBoldDataController: TcxBoldDataController; +begin + lcxBoldDataController := (DataController as TcxBoldDataController); + if DataController.FilteredRecordCount <> TcxCustomDataControllerInfoAccess(DataController.DataControllerInfo).RecordList.Count then + begin + DataController.DataControllerInfo.Refresh; + Assert(DataController.FilteredRecordCount = TcxCustomDataControllerInfoAccess(DataController.DataControllerInfo).RecordList.Count, Format('DataController.RecordCount = %d <> DataController.DataControllerInfo.GetRowCount = %d', [DataController.RecordCount, TcxCustomDataControllerInfoAccess(DataController.DataControllerInfo).RecordList.Count])); + end; + if not BlockRecordKeyboardHandling and (FocusedRecord <> nil) then + TcxCustomGridRecordAccess(FocusedRecord).KeyDown(Key, Shift); + case Key of + VK_INSERT: + if (Shift = []) then + begin + Key := 0; + lHandled := false; + if Assigned(lcxBoldDataController.fOnInsert) then + begin + lAllowed := CanInsert(true); + if lAllowed then + lcxBoldDataController.fOnInsert(lcxBoldDataController); + lHandled := true; + end + else + lAllowed := Assigned(lcxBoldDataController.BoldHandle) and Assigned(lcxBoldDataController.BoldHandle.MutableList); + if not lHandled and lAllowed then + begin + lBoldHandle := TcxBoldDataController(DataController).BoldHandle; + lBoldList := lBoldHandle.MutableList; + if Assigned(lBoldList.BoldMemberRTInfo) and TBoldRoleRTInfo(lBoldList.BoldMemberRTInfo).IsOrdered and ((DataController as TcxBoldDataController).Follower.CurrentIndex <> -1) then + begin + lIndex := TcxBoldDataController(DataController).Follower.CurrentIndex; + lBoldList.InsertNew(lIndex); + end + else + begin + lIndex := lBoldList.IndexOf(lBoldList.AddNew); + end; + TBoldQueueable.DisplayAll; + (DataController as TcxBoldDataController).Follower.CurrentIndex := lIndex; + end; + end + else + if (Shift = [ssCtrl]) and not IsEditing then + GridView.CopyToClipboard(False); + VK_DELETE: + if ((Shift = []) or (Shift = [ssCtrl])) and (SelectedRecordCount > 0) then + begin + Key := 0; + lHandled := false; + lAllowed := CanDelete(true); + if Assigned(lcxBoldDataController.fOnDelete) then + begin + if lAllowed then + lcxBoldDataController.fOnDelete(lcxBoldDataController); + lHandled := true; + end; + if not lHandled and lAllowed then + begin + DeleteSelection; + end; + TBoldQueueable.DisplayAll; + end; + VK_HOME: + begin + if ([ssCtrl] = Shift) {or not FocusedRecordHasCells(True)} then + begin + GoToFirst(True) + end + else + inherited; //FocusNextItem(-1, True, False, False, true); + end; + VK_END: + begin + if ([ssCtrl] = Shift) {or not FocusedRecordHasCells(True)} then + begin + GoToLast(False, True) + end + else + inherited; // FocusNextItem(-1, False, True, False, true) + end; + else + inherited + end; +end; + +procedure TcxGridBoldTableController.KeyUp(var Key: Word; Shift: TShiftState); +{$IFDEF CenterResultOnIncSearch} +var + AVisibleRecordCount: Integer; +{$ENDIF} +begin + inherited; + with TcxBoldDataController(DataController) do + EndDelayScrollUpdate; +{$IFDEF CenterResultOnIncSearch} + if (FocusedRecord <> nil) and IsIncSearching then + begin + AVisibleRecordCount := ViewInfo.VisibleRecordCount; + GridView.Controller.TopRowIndex := GridView.Controller.FocusedRecordIndex - (AVisibleRecordCount div 2); + end; +{$ENDIF} +end; + +procedure TcxBoldGridSite.WndProc(var Message: TMessage); +var + vDataController: TcxBoldDataController; +begin + try + if Controller is TcxGridTableController then + begin + vDataController := TcxGridTableControllerAccess(Controller).DataController as TcxBoldDataController; + if Assigned(vDataController) and (vDataController.LockCount = 0) then + begin + Case Message.Msg of WM_PAINT, WM_SETFOCUS, WM_KILLFOCUS, WM_WINDOWPOSCHANGING, WM_MOVE, WM_MOUSEMOVE: + if Assigned(vDataController.CustomDataSource) and vDataController.MainFollowerNeedsDisplay then + vDataController.DisplayFollowers; + end; + end; + end; + finally + inherited; + end; +end; + +{ TcxGridBoldBandedTableController } + +procedure TcxGridBoldBandedTableController.DoKeyDown(var Key: Word; + Shift: TShiftState); +var + lColumnAutoWidth: boolean; + lVisibleCount: integer; +begin + if (Key = VK_DOWN) or (Key = VK_UP) or (Key = VK_NEXT) or (Key = VK_PRIOR) then + (DataController as TcxBoldDataController).BeginDelayScrollUpdate; + if (key = VK_ADD) and (shift = [ssCtrl]) then + begin + GridView.BeginUpdate; + try + GridView.OptionsView.ColumnAutoWidth := not GridView.OptionsView.ColumnAutoWidth; + lColumnAutoWidth := GridView.OptionsView.ColumnAutoWidth; + if not lColumnAutoWidth then + begin + lVisibleCount := GridView.ViewInfo.VisibleRecordCount; + if lVisibleCount <> GridView.OptionsBehavior.BestFitMaxRecordCount then + GridView.OptionsBehavior.BestFitMaxRecordCount := lVisibleCount; + ViewInfo.GridView.ApplyBestFit(nil, true, true); + if lColumnAutoWidth then + GridView.OptionsView.ColumnAutoWidth := true; + end; + finally + GridView.EndUpdate; + end; + end; + inherited; +end; + +function TcxGridBoldBandedTableController.GetEditingControllerClass: TcxGridEditingControllerClass; +begin + result := TcxGridBoldEditingController; +end; + +procedure TcxGridBoldBandedTableController.KeyDown(var Key: Word; + Shift: TShiftState); +var + lIndex: integer; + lBoldHandle: TBoldAbstractListHandle; + lBoldList: TBoldList; + lHandled: boolean; + lAllowed: boolean; + lcxBoldDataController: TcxBoldDataController; +begin + lcxBoldDataController := (DataController as TcxBoldDataController); + if DataController.FilteredRecordCount <> TcxCustomDataControllerInfoAccess(DataController.DataControllerInfo).RecordList.Count then + begin + DataController.DataControllerInfo.Refresh; + Assert(DataController.FilteredRecordCount = TcxCustomDataControllerInfoAccess(DataController.DataControllerInfo).RecordList.Count, Format('DataController.FilteredRecordCount = %d <> DataController.DataControllerInfo.GetRowCount = %d', [DataController.FilteredRecordCount, TcxCustomDataControllerInfoAccess(DataController.DataControllerInfo).RecordList.Count])); + end; + if not BlockRecordKeyboardHandling and (FocusedRecord <> nil) then + TcxCustomGridRecordAccess(FocusedRecord).KeyDown(Key, Shift); + case Key of + VK_INSERT: + if (Shift = []) then + begin + Key := 0; + lHandled := false; + if Assigned(lcxBoldDataController.fOnInsert) then + begin + lAllowed := CanInsert(true); + if lAllowed then + lcxBoldDataController.fOnInsert(lcxBoldDataController); + lHandled := true; + end + else + lAllowed := Assigned(lcxBoldDataController.BoldHandle) and Assigned(lcxBoldDataController.BoldHandle.MutableList); + if not lHandled and lAllowed then + begin + lBoldHandle := TcxBoldDataController(DataController).BoldHandle; + lBoldList := lBoldHandle.MutableList; + if Assigned(lBoldList.BoldMemberRTInfo) and TBoldRoleRTInfo(lBoldList.BoldMemberRTInfo).IsOrdered and ((DataController as TcxBoldDataController).Follower.CurrentIndex <> -1) then + begin + lIndex := TcxBoldDataController(DataController).Follower.CurrentIndex; + lBoldList.InsertNew(lIndex); + end + else + begin + lIndex := lBoldList.IndexOf(lBoldList.AddNew); + end; + TBoldQueueable.DisplayAll; + (DataController as TcxBoldDataController).Follower.CurrentIndex := lIndex; + end; + end + else + if (Shift = [ssCtrl]) and not IsEditing then + GridView.CopyToClipboard(False); + VK_DELETE: + if ((Shift = []) or (Shift = [ssCtrl])) and (SelectedRecordCount > 0) then + begin + Key := 0; + lHandled := false; + lAllowed := true; + if Assigned(lcxBoldDataController.fOnDelete) then + begin + lAllowed := CanDelete(true); + if lAllowed then + lcxBoldDataController.fOnDelete(lcxBoldDataController); + lHandled := true; + end; + if not lHandled and lAllowed then + begin + DeleteSelection; + end; + TBoldQueueable.DisplayAll; + end; + VK_HOME: + begin + if ([ssCtrl] = Shift) {or not FocusedRecordHasCells(True)} then + begin + GoToFirst(True) + end + else + inherited; //FocusNextItem(-1, True, False, False, true); + end; + VK_END: + begin + if ([ssCtrl] = Shift) {or not FocusedRecordHasCells(True)} then + begin + GoToLast(False, True) + end + else + inherited; // FocusNextItem(-1, False, True, False, true) + end; + else + inherited + end; +end; + +procedure TcxGridBoldBandedTableController.KeyUp(var Key: Word; + Shift: TShiftState); +{$IFDEF CenterResultOnIncSearch} +var + AVisibleRecordCount: Integer; +{$ENDIF} +begin + inherited; + with TcxBoldDataController(DataController) do + EndDelayScrollUpdate; +{$IFDEF CenterResultOnIncSearch} + if (FocusedRecord <> nil) and IsIncSearching then + begin + AVisibleRecordCount := ViewInfo.VisibleRecordCount; + GridView.Controller.TopRowIndex := GridView.Controller.FocusedRecordIndex - (AVisibleRecordCount div 2); + end; +{$ENDIF} +end; + +{ TcxBoldDataControllerSearch } + +function TcxBoldDataControllerSearch.Locate(AItemIndex: Integer; const ASubText: string; AIsAnywhere: Boolean = False {$IFDEF BOLD_DELPHI25_OR_LATER}; ASyncSelection: Boolean = True{$ENDIF}): Boolean; +begin + with DataController as TcxBoldDataController do + AdjustActiveRange(BoldList, AItemIndex); + result := inherited Locate(AItemIndex, ASubText {$IFDEF BOLD_DELPHI25_OR_LATER}, AIsAnywhere, ASyncSelection{$ENDIF}); +end; + +function TcxBoldDataControllerSearch.LocateNext(AForward: Boolean; AIsAnywhere: Boolean = False {$IFDEF BOLD_DELPHI25_OR_LATER}; ASyncSelection: Boolean = True{$ENDIF}): Boolean; +begin + (DataController as TcxBoldDataController).AdjustActiveRange(); + result := inherited LocateNext(AForward {$IFDEF BOLD_DELPHI25_OR_LATER}, AIsAnywhere, ASyncSelection{$ENDIF}); +end; + +{ TcxGridBoldCardViewRow } + +function TcxGridBoldCardViewRow.CalculateBestFitWidth: Integer; +begin + GridView.OptionsBehavior.BestFitMaxRecordCount := GridView.ViewInfo.VisibleRecordCount; + result := inherited CalculateBestFitWidth; +end; + +destructor TcxGridBoldCardViewRow.Destroy; +begin + DataBinding.Remove; + inherited; +end; + +function TcxGridBoldCardViewRow.GetDataBinding: TcxGridItemBoldDataBinding; +begin + Result := TcxGridItemBoldDataBinding(inherited DataBinding); +end; + +procedure TcxGridBoldCardViewRow.SetDataBinding( + Value: TcxGridItemBoldDataBinding); +begin + inherited DataBinding := Value; +end; + +procedure TcxGridBoldCardViewRow.VisibleChanged; +begin + inherited; +// if Visible and not IsLoading then +// (DataController as TcxGridBoldDataController).AdjustActiveRange(); +end; + +{ TcxGridBoldEditingController } + +procedure TcxGridBoldEditingController.DoEditKeyDown(var Key: Word; + Shift: TShiftState); +var + lWasEditing: boolean; +// lController: TcxGridTableController; + lHideFilterRowOnEnter: boolean; +begin +// lController := nil; + lHideFilterRowOnEnter := false; +// if Controller is TcxGridTableController then + begin +// lController := Controller as TcxGridTableController; + lWasEditing := (EditingItem <> nil) and EditingItem.Editing; + if lWasEditing and (Key = VK_ESCAPE) then + begin + Key := VK_ESCAPE; + end + else + if Controller.IsFilterRowFocused then + begin + if (Key = VK_RETURN) and lWasEditing then + begin + lHideFilterRowOnEnter := true; + end; + end; + end; + inherited; + if lHideFilterRowOnEnter and (EditingItem = nil) and (GridView.DataController.FilteredRecordCount > 0) then + Controller.GridView.FilterRow.Visible := false +end; + +procedure TcxGridBoldEditingController.EditChanged(Sender: TObject); +var + lEdit: TcxCustomEdit; + lFollower: TBoldFollower; + lDataController: TcxGridBoldDataController; + lIcxBoldEditProperties: IcxBoldEditProperties; + lDone: Boolean; +begin +// inherited; // moved to the end of the method, coz it fires OnChange event and we don't want that to happen before we make the change +{ + Here we basically ignore ApplyPolicy. We want to mark follower dirty as soon as possible (ie here) + But we don't want to apply changes to ObjectSpace yet as changes may cause reload of data, + especially if the view is grouped/sorted and user is editing a grouped/sorted column. + So if this happens editing loses focus and view reloads data, so we want to avoid this. +} + if (EditingItem <> nil) {EditingItem is TcxGridBoldColumn} and not Controller.IsSpecialRowFocused then + begin + lEdit := Sender as TcxCustomEdit; + lDataController := EditingItem.DataBinding.DataController as TcxGridBoldDataController; + lFollower := lDataController.Follower.SubFollowers[lDataController.FocusedRecordIndex]; + if lFollower.Active then + begin + lFollower := lFollower.SubFollowers[Integer(EditingItem.DataBinding.Data)]; + lDone := false; + Assert(EditingItem.GetProperties <> nil); + if Supports(EditingItem.GetProperties, IcxBoldEditProperties, lIcxBoldEditProperties) then + begin + lIcxBoldEditProperties.SetStoredValue(Null, lDataController.BoldHandle, lEdit, lFollower, lDone); + end; + if not lDone then + begin + lDone := (lFollower.Controller as TBoldVariantFollowerController).MayHaveChanged(Edit.EditingValue, lFollower); + end; + if lDone then + begin + lDataController.fInternalChange := true; + try + TBoldQueueable.DisplayAll; + finally + lDataController.fInternalChange := false; + inherited; + end; + end; + end; + end + else + inherited; +end; + +procedure TcxGridBoldEditingController.EditExit(Sender: TObject); +begin +// self.EditChanged(Sender); + inherited; +end; + +procedure TcxGridBoldEditingController.HideEdit(Accept: Boolean); +var + lcxBoldDataController: TcxBoldDataController; + lFollower: TBoldFollower; +begin + if not Accept and Assigned(Edit) and Edit.ModifiedAfterEnter then + begin + lcxBoldDataController := EditingItem.DataBinding.DataController as TcxBoldDataController; + if (lcxBoldDataController.FocusedRecordIndex <> -1) then + begin + lFollower := lcxBoldDataController.Follower.SubFollowers[lcxBoldDataController.FocusedRecordIndex]; + lFollower := lFollower.SubFollowers[Integer(EditingItem.DataBinding.Data)]; + begin + lFollower.DiscardChange; + end; + end; + end; +// if Assigned(Edit) and Edit.ModifiedAfterEnter then +// self.EditChanged(Edit); + inherited; +end; + +{ TcxGridBoldBandedColumn } + +function TcxGridBoldBandedColumn.CalculateBestFitWidth: Integer; +begin + GridView.OptionsBehavior.BestFitMaxRecordCount := GridView.ViewInfo.VisibleRecordCount; + result := inherited CalculateBestFitWidth; +end; + +destructor TcxGridBoldBandedColumn.Destroy; +begin + DataBinding.Remove; + inherited; +end; + +function TcxGridBoldBandedColumn.GetDataBinding: TcxGridItemBoldDataBinding; +begin + Result := TcxGridItemBoldDataBinding(inherited DataBinding); +end; + +procedure TcxGridBoldBandedColumn.SetDataBinding( + Value: TcxGridItemBoldDataBinding); +begin + inherited DataBinding := Value; +end; + +procedure TcxGridBoldBandedColumn.VisibleChanged; +begin + inherited; +// if Visible and not IsLoading then +// (DataController as TcxGridBoldDataController).AdjustActiveRange(); +end; + +{ TcxGridBoldChartDataController } +(* +procedure TcxGridBoldChartDataController.AssignData( + ADataController: TcxCustomDataController); +begin +end; + +procedure TcxGridBoldChartDataController.CreateAllItems( + AMissingItemsOnly: Boolean); +begin +end; + +procedure TcxGridBoldChartDataController.DeleteAllItems; +begin +end; + +function TcxGridBoldChartDataController.GetChartItem( + AItemClass: TcxGridChartItemClass; AIndex: Integer): TcxGridChartItem; +var + AFields: TList; +begin + AFields := TList.Create; + try + GetValidValueFields(AItemClass, AFields); +// Result := GridView.FindItemByFieldName(AItemClass, TField(AFields[AIndex]).FieldName); + finally + AFields.Free; + end; +end; + +procedure TcxGridBoldChartDataController.GetFakeComponentLinks(AList: TList); +begin + if (BoldHandle <> nil) and (BoldHandle.Owner <> GridView.Component) and + (AList.IndexOf(BoldHandle.Owner) = -1) then + AList.Add(BoldHandle.Owner); +end; + +procedure TcxGridBoldChartDataController.GetItemCaptions( + AItemClass: TcxGridChartItemClass; ACaptions: TStringList); +var + AFields: TList; + I: Integer; +begin + AFields := TList.Create; + try + GetValidValueFields(AItemClass, AFields); +// for I := 0 to AFields.Count - 1 do +// ACaptions.Add(TField(AFields[I]).DisplayName); + finally + AFields.Free; + end; +end; + +procedure TcxGridBoldChartDataController.GetValidValueFields( + AItemClass: TcxGridChartItemClass; AFields: TList); +var + I: Integer; +// AField: TField; +begin +{ + if DataSet = nil then Exit; + for I := 0 to DataSet.FieldCount - 1 do + begin + AField := DataSet.Fields[I]; + if not AItemClass.IsValue or + IsValueTypeClassValid(GetValueTypeClassByField(AField)) then + AFields.Add(AField); + end; + AFields.Sort(CompareFields); +} +end; + +function TcxGridBoldChartDataController.HasAllItems: Boolean; +begin + Result := True; +end; + +procedure TcxGridBoldChartDataController.InitItem(AItem: TcxGridChartItem; + AIndex: Integer); +var + AFields: TList; +begin + AFields := TList.Create; + try + GetValidValueFields(TcxGridChartItemClass(AItem.ClassType), AFields); +// TcxGridBoldChartItemDataBinding(AItem.DataBinding).FieldName := TField(AFields[AIndex]).FieldName; + finally + AFields.Free; + end; +end; + +function TcxGridBoldChartDataController.IsDataChangeable: Boolean; +begin + Result := False; +end; + +function TcxGridBoldChartDataController.SupportsCreateAllItems: Boolean; +begin + Result := False; +end; + +{ TcxGridBoldChartItemDataBinding } + +procedure TcxGridBoldChartItemDataBinding.Assign(Source: TPersistent); +begin +// if Source is TcxGridBoldChartItemDataBinding then +// FieldName := TcxGridBoldChartItemDataBinding(Source).FieldName; + inherited; +end; + +constructor TcxGridBoldChartItemDataBinding.Create(AGridView: TcxGridChartView; + AIsValue: Boolean; ADefaultValueTypeClass: TcxValueTypeClass); +begin + inherited Create(AGridView, AIsValue, ADefaultValueTypeClass); + fBoldProperties := TBoldVariantFollowerController.Create(AGridView.Component); + +// DataController.fBoldColumnsProperties.Add(fBoldProperties); +// fBoldProperties.OnGetContextType := DataController.GetHandleStaticType; +// FBoldProperties.AfterMakeUptoDate := DataController._AfterMakeCellUptoDate; +end; + +destructor TcxGridBoldChartItemDataBinding.Destroy; +begin + FreeAndNil(FBoldProperties); + inherited; +end; + +function TcxGridBoldChartItemDataBinding.GetDataController: TcxGridBoldChartDataController; +begin + Result := TcxGridBoldChartDataController(inherited DataController); +end; + +procedure TcxGridBoldChartItemDataBinding.SetBoldProperties( + Value: TBoldVariantFollowerController); +begin + if Assigned(Value) then + fBoldProperties.Assign(Value); +end; + +{ TcxGridBoldChartCategories } + +function TcxGridBoldChartCategories.GetDataBinding: TcxGridBoldChartItemDataBinding; +begin + Result := TcxGridBoldChartItemDataBinding(inherited DataBinding); +end; + +procedure TcxGridBoldChartCategories.SetDataBinding( + Value: TcxGridBoldChartItemDataBinding); +begin + inherited DataBinding := Value; +end; + +{ TcxGridBoldChartDataGroup } + +function TcxGridBoldChartDataGroup.GetDataBinding: TcxGridBoldChartItemDataBinding; +begin + Result := TcxGridBoldChartItemDataBinding(inherited DataBinding); +end; + +procedure TcxGridBoldChartDataGroup.SetDataBinding( + Value: TcxGridBoldChartItemDataBinding); +begin + inherited DataBinding := Value; +end; + +{ TcxGridBoldChartSeries } + +function TcxGridBoldChartSeries.GetDataBinding: TcxGridBoldChartItemDataBinding; +begin + Result := TcxGridBoldChartItemDataBinding(inherited DataBinding); +end; + +procedure TcxGridBoldChartSeries.SetDataBinding( + Value: TcxGridBoldChartItemDataBinding); +begin + inherited DataBinding := Value; +end; + +{ TcxBoldGridChartView } + +procedure TcxBoldGridChartView.ClearItems; +begin + ClearSeries; +end; + +constructor TcxBoldGridChartView.Create(AOwner: TComponent); +begin + inherited; +end; + +function TcxBoldGridChartView.CreateDataGroup: TcxGridBoldChartDataGroup; +begin + Result := TcxGridBoldChartDataGroup(inherited CreateDataGroup); +end; + +function TcxBoldGridChartView.CreateSeries: TcxGridBoldChartSeries; +begin + Result := TcxGridBoldChartSeries(inherited CreateSeries); +end; + +destructor TcxBoldGridChartView.Destroy; +begin + inherited; +end; + +function TcxBoldGridChartView.FindDataGroupByFieldName( + const AFieldName: string): TcxGridBoldChartDataGroup; +begin + Result := TcxGridBoldChartDataGroup(FindItemByFieldName(GetDataGroupClass, AFieldName)); +end; + +function TcxBoldGridChartView.FindItemByFieldName( + AItemClass: TcxGridChartItemClass; + const AFieldName: string): TcxGridChartItem; +var + AItems: TList; + I: Integer; +begin + AItems := GetItemList(AItemClass); + for I := 0 to AItems.Count - 1 do + begin + Result := TcxGridChartItem(AItems[I]); +// if SameText(TcxGridBoldChartItemDataBinding(Result.DataBinding).FieldName, AFieldName) then Exit; + end; + Result := nil; +end; + +function TcxBoldGridChartView.FindSeriesByFieldName( + const AFieldName: string): TcxGridBoldChartSeries; +begin + Result := TcxGridBoldChartSeries(FindItemByFieldName(GetSeriesClass, AFieldName)); +end; + +function TcxBoldGridChartView.GetCategories: TcxGridBoldChartCategories; +begin + Result := TcxGridBoldChartCategories(inherited Categories); +end; + +function TcxBoldGridChartView.GetCategoriesClass: TcxGridChartCategoriesClass; +begin + Result := TcxGridBoldChartCategories; +end; + +function TcxBoldGridChartView.GetDataController: TcxGridBoldChartDataController; +begin + Result := TcxGridBoldChartDataController(inherited DataController); +end; + +function TcxBoldGridChartView.GetDataControllerClass: TcxCustomDataControllerClass; +begin + Result := TcxGridBoldChartDataController; +end; + +function TcxBoldGridChartView.GetDataGroup( + Index: Integer): TcxGridBoldChartDataGroup; +begin + Result := TcxGridBoldChartDataGroup(inherited DataGroups[Index]); +end; + +function TcxBoldGridChartView.GetDataGroupClass: TcxGridChartDataGroupClass; +begin + Result := TcxGridBoldChartDataGroup; +end; + +function TcxBoldGridChartView.GetItem(Index: Integer): IBoldAwareViewItem; +begin + result := inherited Items[Index] as IBoldAwareViewItem; +end; + +function TcxBoldGridChartView.GetItemCount: Integer; +begin + result := inherited SeriesCount; +end; + +function TcxBoldGridChartView.GetItemDataBindingClass: TcxGridChartItemDataBindingClass; +begin + Result := TcxGridBoldChartItemDataBinding; +end; + +function TcxBoldGridChartView.GetSelection: TBoldList; +begin + result := fSelection; +end; + +function TcxBoldGridChartView.GetSeries(Index: Integer): TcxGridBoldChartSeries; +begin + Result := TcxGridBoldChartSeries(inherited Series[Index]); +end; + +function TcxBoldGridChartView.GetSeriesClass: TcxGridChartSeriesClass; +begin + Result := TcxGridBoldChartSeries; +end; + +procedure TcxBoldGridChartView.SetCategories(Value: TcxGridBoldChartCategories); +begin + inherited Categories := Value; +end; + +procedure TcxBoldGridChartView.SetDataController( + Value: TcxGridBoldChartDataController); +begin + FDataController.Assign(Value); +end; + +procedure TcxBoldGridChartView.SetDataGroup(Index: Integer; + Value: TcxGridBoldChartDataGroup); +begin + inherited DataGroups[Index] := Value; +end; + +procedure TcxBoldGridChartView.SetSeries(Index: Integer; + Value: TcxGridBoldChartSeries); +begin + inherited Series[Index] := Value; +end; + +function TcxBoldGridChartView.ValidateComponent( + ComponentValidator: TBoldComponentValidator; NamePrefix: String): Boolean; +var + i: integer; + lContext: TBoldElementTypeInfo; +begin + lContext := DataController.GetHandleStaticType; + result := ComponentValidator.ValidateExpressionInContext( + '', lContext, format('%s%s', [NamePrefix, Name])); // do not localize + if assigned(lContext) then + for i := 0 to ItemCount - 1 do + result := ComponentValidator.ValidateExpressionInContext( + Items[i].DataBinding.BoldProperties.Expression, + lContext, + format('%s%s.Column[%d]', [NamePrefix, Name, i])) and result; // do not localize +end; +*) + +{ TcxGridBoldCardViewController } + +function TcxGridBoldCardViewController.GetEditingControllerClass: TcxGridEditingControllerClass; +begin + result := TcxGridBoldCardEditingController; //TcxGridBoldEditingController; +end; + +{ TcxGridBoldCardEditingController } + +procedure TcxGridBoldCardEditingController.EditChanged(Sender: TObject); +var + lEdit: TcxCustomEdit; + lFollower: TBoldFollower; + lDataController: TcxGridBoldDataController; + lIcxBoldEditProperties: IcxBoldEditProperties; + lDone: Boolean; +begin +// inherited; // moved to the end of the method, coz it fires OnChange event and we don't want that to happen before we make the change +{ + Here we basically ignore ApplyPolicy. We want to mark follower dirty as soon as possible (ie here) + But we don't want to apply changes to ObjectSpace yet as changes may cause reload of data, + especially if the view is grouped/sorted and user is editing a grouped/sorted column. + So if this happens editing loses focus and view reloads data, so we want to avoid this. +} + if EditingItem is TcxGridBoldCardViewRow then + begin + lEdit := Sender as TcxCustomEdit; + lDataController := EditingItem.DataBinding.DataController as TcxGridBoldDataController; + lFollower := lDataController.Follower.SubFollowers[lDataController.FocusedRecordIndex]; + if lFollower.Active then + begin + lFollower := lFollower.SubFollowers[Integer(EditingItem.DataBinding.Data)]; + lDone := false; + Assert(EditingItem.GetProperties <> nil); + if Supports(EditingItem.GetProperties, IcxBoldEditProperties, lIcxBoldEditProperties) then + begin + lIcxBoldEditProperties.SetStoredValue(Null, lDataController.BoldHandle, lEdit, lFollower, lDone); + end; + if not lDone then + begin + lDone := (lFollower.Controller as TBoldVariantFollowerController).MayHaveChanged(Edit.EditingValue, lFollower); + end; + if lDone then + begin + lDataController.fInternalChange := true; + try + TBoldQueueable.DisplayAll; + finally + lDataController.fInternalChange := false; + inherited; + end; + end; + end; + end + else + inherited; +end; + +{ TcxGridBoldDefaultValuesProvider } + +function TcxGridBoldDefaultValuesProvider.DefaultCanModify: Boolean; +begin + Result := inherited DefaultCanModify {and Follower.MayModify}; +end; + +function TcxGridBoldDefaultValuesProvider.IsDisplayFormatDefined( + AIsCurrencyValueAccepted: Boolean): Boolean; +begin + with Owner as TcxGridItemBoldDataBinding do + Result := IsDisplayFormatDefined(AIsCurrencyValueAccepted) or Assigned(BoldProperties.Renderer); +end; + +{ TcxGridBoldTableViewInfo } + +function TcxGridBoldTableViewInfo.GetRecordsViewInfoClass: TcxCustomGridRecordsViewInfoClass; +begin + result := TcxBoldGridRowsViewInfo; +end; + +function TcxGridBoldTableViewInfo.GetSiteClass: TcxGridSiteClass; +begin + Result := TcxBoldGridSite; +end; + +procedure TcxGridBoldTableViewInfo.Calculate; +var + vDataController: TcxBoldDataController; +begin + vDataController := DataController as TcxBoldDataController; + if Assigned(vDataController) then + begin + with vDataController as TcxBoldDataController do + begin + if Assigned(vDataController.CustomDataSource) then + if MainFollowerNeedsDisplay then + DisplayFollowers; + end; + end; + inherited; +end; + +{ TcxGridBoldBandedTableViewInfo } + +function TcxGridBoldBandedTableViewInfo.GetRecordsViewInfoClass: TcxCustomGridRecordsViewInfoClass; +begin + Result := TcxGridBoldBandedRowsViewInfo; +end; + +{ TcxGridBoldBandedTableViewInfo } + +function TcxGridBoldBandedTableViewInfo.GetSiteClass: TcxGridSiteClass; +begin + Result := TcxBoldGridSite; +end; + +procedure TcxGridBoldBandedTableViewInfo.Calculate; +var + vDataController: TcxBoldDataController; +begin + vDataController := DataController as TcxBoldDataController; + if Assigned(vDataController) then + begin + with vDataController as TcxBoldDataController do + begin + if Assigned(vDataController.CustomDataSource) then + if MainFollowerNeedsDisplay then + DisplayFollowers; + end; + end; + inherited; +end; + +{ TcxGridBoldCardViewViewInfo } + +function TcxGridBoldCardViewViewInfo.GetRecordsViewInfoClass: TcxCustomGridRecordsViewInfoClass; +begin + Result := TcxGridBoldCardsViewInfo; +end; + +function TcxGridBoldCardViewViewInfo.GetSiteClass: TcxGridSiteClass; +begin + Result := TcxBoldGridSite; +end; + + +{ TcxGridBoldLayoutView } + +constructor TcxGridBoldLayoutView.Create(AOwner: TComponent); +begin + inherited; + +end; + +destructor TcxGridBoldLayoutView.Destroy; +begin + + inherited; +end; + +function TcxGridBoldLayoutView.CreateItem: TcxGridBoldLayoutViewItem; +begin + Result := TcxGridBoldLayoutViewItem(inherited CreateItem); +end; + +function TcxGridBoldLayoutView.GetCurrentBoldObject: TBoldObject; +begin + result := DataController.CurrentBoldObject; +end; + +function TcxGridBoldLayoutView.GetCurrentElement: TBoldElement; +begin + result := DataController.CurrentElement; +end; + +function TcxGridBoldLayoutView.GetCurrentIndex: integer; +begin + result := DataController.CurrentIndex; +end; + +function TcxGridBoldLayoutView.GetDataController: TcxGridBoldDataController; +begin + Result := TcxGridBoldDataController(FDataController); +end; + +function TcxGridBoldLayoutView.GetDataControllerClass: TcxCustomDataControllerClass; +begin + Result := TcxGridBoldDataController; +end; + +function TcxGridBoldLayoutView.GetItem(Index: Integer): IBoldAwareViewItem; +begin + result := inherited Items[Index] as IBoldAwareViewItem; +end; + +function TcxGridBoldLayoutView.GetItemClass: TcxCustomGridTableItemClass; +begin + Result := TcxGridBoldLayoutViewItem; +end; + +function TcxGridBoldLayoutView.GetItemCount: Integer; +begin + result := inherited ItemCount; +end; + +function TcxGridBoldLayoutView.GetSelection: TBoldList; +begin + result := DataController.Selection; +end; + +procedure TcxGridBoldLayoutView.SetDataController( + Value: TcxGridBoldDataController); +begin + FDataController.Assign(Value); +end; + +function TcxGridBoldLayoutView.ValidateComponent( + ComponentValidator: TBoldComponentValidator; NamePrefix: string): Boolean; +var + i: integer; + lContext: TBoldElementTypeInfo; + lBoldValidateableComponent: IBoldValidateableComponent; +begin + lContext := DataController.GetHandleStaticType; + result := ComponentValidator.ValidateExpressionInContext( + '', lContext, format('%s%s', [NamePrefix, Name])); // do not localize + if assigned(lContext) then + begin + for i := 0 to ItemCount - 1 do + begin + result := ComponentValidator.ValidateExpressionInContext( + Items[i].BoldProperties.Expression, + lContext, + format('%s%s.Column[%d]', [NamePrefix, Name, i]), + Items[i].BoldProperties.VariableList) and result; // do not localize + if Supports((self.DataController.GetItem(i) as TcxCustomGridTableItem).GetProperties, IBoldValidateableComponent, lBoldValidateableComponent) then + result := lBoldValidateableComponent.ValidateComponent(ComponentValidator, namePrefix) and result; + end; + end; +end; + +{ TcxGridBoldLayoutViewItem } + +destructor TcxGridBoldLayoutViewItem.Destroy; +begin + DataBinding.Remove; + inherited; +end; + +function TcxGridBoldLayoutViewItem.GetDataBinding: TcxGridItemBoldDataBinding; +begin + Result := TcxGridItemBoldDataBinding(inherited DataBinding); +end; + +procedure TcxGridBoldLayoutViewItem.SetDataBinding( + Value: TcxGridItemBoldDataBinding); +begin + inherited DataBinding := Value; +end; + +{ TBoldCxGridVariantFollowerController } + +constructor TBoldCxGridVariantFollowerController.Create( + aOwningComponent: TComponent); +begin + inherited Create(aOwningComponent); +end; + +function TBoldCxGridVariantFollowerController.SubFollowersActive: boolean; +begin + result := false; //cxGridItemBoldDataBinding.Item.ActuallyVisible; +end; + +{ TcxBoldCustomDataControllerInfo } + +procedure TcxBoldCustomDataControllerInfo.DoFilter; +var + i: integer; + RootFilter: TcxFilterCriteriaItemList; + lList: TBoldList; + lDataController: TcxBoldDataController; +begin + try + lDataController := (DataController as TcxBoldDataController); + lList := lDataController.BoldList; + RootFilter := (DataController.Filter as TcxFilterCriteria).Root; + if not (not Assigned(lList) or lList.Empty or (RootFilter.Count = 0)) then + for I := 0 to RootFilter.Count - 1 do + if RootFilter.Items[i] is TcxDataFilterCriteriaItem then + lDataController.PreFetchColumns(lList, lDataController.GetItemData(TcxDataFilterCriteriaItem(RootFilter.Items[i]).Field.Item)); + finally + inherited; + // SelectionChanged; // ? + end; +end; + +procedure TcxBoldCustomDataControllerInfo.DoSort; +var + i: integer; + lList: TBoldList; + lWholeList: TBoldList; + lGuard: IBoldGuard; + IsObjectList: boolean; +begin + try + GetTotalSortingFields; + if (TotalSortingFieldList.Count = 0) or (RecordList.Count = 0) then + exit; + lWholeList := TcxBoldDataController(DataController).BoldList; + if not Assigned(lWholeList) then + exit; + if RecordList.Count = lWholeList.Count then + lList := lWholeList as TBoldList + else + begin + lGuard := TBoldGuard.Create(lList); + lList := TcxBoldDataController(DataController).CreateList; + lList.DuplicateMode := bldmAllow; + lList.Capacity := RecordList.Count; + IsObjectList := (lList is TBoldObjectList) and (lWholeList is TBoldObjectList); + for I := 0 to RecordList.Count -1 do + begin + if Integer(RecordList[i]) < lWholeList.Count then + if IsObjectList then + TBoldObjectList(lList).AddLocator( TBoldObjectList(lWholeList).Locators[Integer(RecordList[i])] ) + else + lList.Add( lWholeList[Integer(RecordList[i])] ); + end; + end; + for I := 0 to TotalSortingFieldList.Count - 1 do + begin + TcxBoldDataController(DataController).PreFetchColumns(lList, TcxBoldDataController(DataController).GetItemData(TotalSortingFieldList[i].Field.Item)); + end; + finally + inherited; + end; +end; + +{ TcxBoldDataSummary } + +procedure TcxBoldDataSummary.CalculateSummary( +{$IFDEF BOLD_DELPHI16_OR_LATER} + ASummaryItems: TcxDataSummaryItems; ABeginIndex, AEndIndex: Integer; + var ACountValues: TcxDataSummaryCountValues; var ASummaryValues: TcxDataSummaryValues +{$ELSE} + ASummaryItems: TcxDataSummaryItems; ABeginIndex, AEndIndex: Integer; + var ACountValues: TcxDataSummaryCountValues; var ASummaryValues: TcxDataSummaryValues; var SummaryValues: Variant +{$ENDIF} +); +var + I: Integer; + lList: TBoldList; + lWholeList: TBoldList; + lGuard: IBoldGuard; + ARecordIndex: Integer; + IsObjectList: boolean; +begin + lWholeList := TcxBoldDataController(DataController).BoldList; + if (ASummaryItems.Count = 0) or not Assigned(lWholeList) then + exit; + if lWholeList.Count = 0 then + exit; + if (ABeginIndex = 0) and (AEndIndex = lWholeList.Count-1) then + begin + lList := lWholeList; + end + else + begin + lGuard := TBoldGuard.Create(lList); + lList := TcxBoldDataController(DataController).CreateList; + lList.DuplicateMode := bldmAllow; + lList.Capacity := AEndIndex - ABeginIndex; + IsObjectList := (lList is TBoldObjectList) and (lWholeList is TBoldObjectList); + for I := ABeginIndex to AEndIndex do + begin + ARecordIndex := GetRecordIndex(I); + if ARecordIndex <> -1 then + begin + if IsObjectList then + TBoldObjectList(lList).AddLocator(TBoldObjectList(lWholeList).Locators[ARecordIndex]) + else + lList.Add(lWholeList[ARecordIndex]); + end + end; + end; + for I := 0 to ASummaryItems.Count - 1 do + if Assigned(ASummaryItems[i].Field) then + with TcxBoldDataController(DataController) do + PreFetchColumns(lList, GetItemData(ASummaryItems[i].Field.Item)); + inherited; +end; + +initialization + cxGridRegisteredViews.Register(TcxGridBoldTableView, 'Bold Table'); + cxGridRegisteredViews.Register(TcxGridBoldCardView, 'Bold Card'); +// cxGridRegisteredViews.Register(TcxBoldGridChartView, 'Bold Chart'); + cxGridRegisteredViews.Register(TcxGridBoldBandedTableView, 'Bold Banded Table'); + cxGridRegisteredViews.Register(TcxGridBoldLayoutView, 'Bold Layout'); + Classes.RegisterClasses([TcxGridBoldColumn, TcxGridItemBoldDataBinding, TcxGridBoldBandedColumn, TcxGridBoldCardViewRow, TcxGridBoldLayoutViewItem]); + +finalization + cxGridRegisteredViews.Unregister(TcxGridBoldTableView); + cxGridRegisteredViews.Unregister(TcxGridBoldCardView); +// cxGridRegisteredViews.Unregister(TcxBoldGridChartView); + cxGridRegisteredViews.Unregister(TcxGridBoldBandedTableView); + cxGridRegisteredViews.Unregister(TcxGridBoldLayoutView); + Classes.UnRegisterClasses([TcxGridBoldColumn, TcxGridItemBoldDataBinding, TcxGridBoldBandedColumn, TcxGridBoldCardViewRow, TcxGridBoldLayoutViewItem]); +// FilterEditsController.Unregister(TcxSingleLinkEditProperties, TcxFilterSingleLinkEditHelper); + +end. diff --git a/Source/BoldAwareGUI/BoldDevex/cxLookupBoldGrid.pas b/Source/BoldAwareGUI/BoldDevex/cxLookupBoldGrid.pas new file mode 100644 index 00000000..c4a4129f --- /dev/null +++ b/Source/BoldAwareGUI/BoldDevex/cxLookupBoldGrid.pas @@ -0,0 +1,629 @@ +unit cxLookupBoldGrid; + +{$I cxVer.inc} + +// v2.03 - 25 Jan 2011 2007-2011 Daniel Mauric + +interface + +uses + Windows, + SysUtils, Classes, Controls, Graphics, Forms, StdCtrls, //DB, + cxClasses, cxControls, cxGraphics, cxLookAndFeelPainters, + cxEdit, +// cxDBEdit, + cxCustomData, +// cxDB, cxDBData, + cxEditRepositoryItems, + cxLookupGrid, + + cxGridBoldSupportUnit, + cxBoldEditors, + BoldVariantControlPack, //BoldStringControlPack, + BoldAbstractListHandle, + BoldListListControlPack, + BoldControlPack; + +const + DefaultSyncMode = False; + +type + TcxCustomLookupBoldGrid = class; + + { TcxLookupGridBoldDataController } + + TcxLookupGridBoldDataController = class(TcxBoldDataController) + private + function GetGrid: TcxCustomLookupBoldGrid; + protected + function GetItemID(AItem: TObject): Integer; override; + function GetItemData(AItem: TObject): Integer; override; +// procedure UpdateScrollBars; override; + procedure _AfterMakeCellUptoDate(Follower: TBoldFollower); override; + procedure _AfterMakeListUptoDate(Follower: TBoldFollower); override; + public + constructor Create(AOwner: TComponent); override; + function GetItem(Index: Integer): TObject; override; + property Grid: TcxCustomLookupBoldGrid read GetGrid; + published + property OnCompare; + end; + + { TcxLookupBoldGridColumn } + + TcxLookupBoldGridDefaultValuesProvider = class(TcxCustomBoldEditDefaultValuesProvider) + function IsDisplayFormatDefined(AIsCurrencyValueAccepted: Boolean): Boolean; override; + end; + + TcxLookupBoldGridColumn = class(TcxLookupGridColumn, IBoldAwareViewItem) + private + fBoldProperties: TBoldVariantFollowerController; + function GetDataController: TcxLookupGridBoldDataController; + procedure SetBoldProperties( + const Value: TBoldVariantFollowerController); + function GetBoldProperties: TBoldVariantFollowerController; +// function GetField: TField; +// function GetFieldName: string; +// procedure SetFieldName(const Value: string); + protected + function GetDefaultValuesProviderClass: TcxCustomEditDefaultValuesProviderClass; override; + procedure InitDefaultValuesProvider; + property DataController: TcxLookupGridBoldDataController read GetDataController; + public + constructor Create(Collection: TCollection); override; + destructor Destroy; override; + procedure Assign(Source: TPersistent); override; + function DefaultCaption: string; override; + function DefaultRepositoryItem: TcxEditRepositoryItem; override; + function DefaultWidth: Integer; override; +// property Field: TField read GetField; + published + property BoldProperties: TBoldVariantFollowerController read GetBoldProperties write SetBoldProperties; + end; + + { TcxLookupBoldGridColumns } + + TcxLookupBoldGridColumns = class(TcxLookupGridColumns) + private + function GetColumn(Index: Integer): TcxLookupBoldGridColumn; + procedure SetColumn(Index: Integer; Value: TcxLookupBoldGridColumn); + public + function Add: TcxLookupBoldGridColumn; +// function ColumnByFieldName(const AFieldName: string): TcxLookupBoldGridColumn; + property Items[Index: Integer]: TcxLookupBoldGridColumn read GetColumn write SetColumn; default; + end; + + { TcxLookupBoldGridOptions } + + TcxLookupBoldGridOptions = class(TcxLookupGridOptions) + private + function GetGrid: TcxCustomLookupBoldGrid; + function GetSyncMode: Boolean; + procedure SetSyncMode(Value: Boolean); + public + procedure Assign(Source: TPersistent); override; + property Grid: TcxCustomLookupBoldGrid read GetGrid; + published + property SyncMode: Boolean read GetSyncMode write SetSyncMode + default DefaultSyncMode; + end; + + { TcxCustomLookupBoldGrid } + + TcxCustomLookupBoldGrid = class(TcxCustomLookupGrid) + private + function GetColumns: TcxLookupBoldGridColumns; + function GetDataController: TcxLookupGridBoldDataController; +// function GetDataSource: TDataSource; +// function GetKeyFieldNames: string; + function GetOptions: TcxLookupBoldGridOptions; + procedure SetColumns(Value: TcxLookupBoldGridColumns); + procedure SetDataController(Value: TcxLookupGridBoldDataController); +// procedure SetDataSource(Value: TDataSource); +// procedure SetKeyFieldNames(const Value: string); + procedure SetOptions(Value: TcxLookupBoldGridOptions); + function GetBoldListHandle: TBoldAbstractListHandle; + procedure SetBoldListHandle(const Value: TBoldAbstractListHandle); + function GetBoldProperties: TBoldListAsFollowerListController; + procedure SetBoldProperties( + const Value: TBoldListAsFollowerListController); + protected +// procedure CreateColumnsByFields(AFieldNames: TStrings); virtual; + procedure DataChanged; override; + function GetColumnClass: TcxLookupGridColumnClass; override; + function GetColumnsClass: TcxLookupGridColumnsClass; override; + function GetDataControllerClass: TcxCustomDataControllerClass; override; + function GetOptionsClass: TcxLookupGridOptionsClass; override; + procedure InitScrollBarsParameters; override; + procedure Scroll(AScrollBarKind: TScrollBarKind; AScrollCode: TScrollCode; var AScrollPos: Integer); override; + procedure UpdateScrollBars; override; // for Delphi .NET + public + procedure CreateAllColumns; +// procedure CreateColumnsByFieldNames(const AFieldNames: string); + property Align; + property Anchors; + property Color; + property Columns: TcxLookupBoldGridColumns read GetColumns write SetColumns; + property DataController: TcxLookupGridBoldDataController read GetDataController write SetDataController; + property Font; + property LookAndFeel; + property Options: TcxLookupBoldGridOptions read GetOptions write SetOptions; + property ParentFont; + property Visible; + published +// property DataSource: TDataSource read GetDataSource write SetDataSource; +// property KeyFieldNames: string read GetKeyFieldNames write SetKeyFieldNames; + property BoldLookupListHandle: TBoldAbstractListHandle read GetBoldListHandle write SetBoldListHandle; + property BoldProperties: TBoldListAsFollowerListController read GetBoldProperties write SetBoldProperties; + end; + + TcxCustomLookupBoldGridClass = class of TcxCustomLookupBoldGrid; + +implementation + +uses + BoldElements, + BoldSystem, + BoldOcl, + BoldSystemRT, + BoldControlPackDefs; +// cxEditBoldRegisteredRepositoryItems; // cxEditDBRegisteredRepositoryItems; + +function TcxLookupBoldGridDefaultValuesProvider.IsDisplayFormatDefined(AIsCurrencyValueAccepted: Boolean): Boolean; +begin + with TcxLookupBoldGridColumn(Owner) do + Result := DataController.GetItemTextStored(Index); +end; + +{ TcxLookupBoldGridColumn } + +procedure TcxLookupBoldGridColumn.Assign(Source: TPersistent); +begin + if Source is TcxLookupBoldGridColumn then + BoldProperties.Assign(TcxLookupBoldGridColumn(Source).BoldProperties); + inherited Assign(Source); +end; + +function TcxLookupBoldGridColumn.DefaultCaption: string; +var + lContextType: TBoldElementTypeInfo; + lResultType: TBoldElementTypeInfo; + lBoldMemberRTInfo: TBoldMemberRTInfo; + lEvaluator: TBoldOcl; +begin + result := ''; + lContextType := DataController.GetHandleStaticType; + if Assigned(lContextType) then + begin + lEvaluator := lContextType.Evaluator as TBoldOcl; + lBoldMemberRTInfo := lEvaluator.RTInfo(BoldProperties.Expression, lContextType, false); + if Assigned(lBoldMemberRTInfo) then + result := lBoldMemberRTInfo.ModelName + else + begin + lResultType := lEvaluator.ExpressionType(BoldProperties.Expression, lContextType, false, BoldProperties.VariableList); + if Assigned(lResultType) then + begin + result := lResultType.ModelName; + end; + end; + end; +end; + +function TcxLookupBoldGridColumn.DefaultRepositoryItem: TcxEditRepositoryItem; +begin +// TODO: fix + result := nil; +// Result := GetDefaultEditDBRepositoryItems.GetItemByField(Field); +end; + +function TcxLookupBoldGridColumn.DefaultWidth: Integer; +var + lContextType: TBoldElementTypeInfo; + lBoldMemberRTInfo: TBoldMemberRTInfo; + lEvaluator: TBoldOcl; + ACanvas: TcxCanvas; + W: Integer; + lLength: Integer; +begin + Result := inherited DefaultWidth; + lContextType := DataController.GetHandleStaticType; + if Assigned(lContextType) then + begin + lEvaluator := lContextType.Evaluator as TBoldOcl; + lBoldMemberRTInfo := lEvaluator.RTInfo(BoldProperties.Expression, lContextType, false); + if (lBoldMemberRTInfo is TBoldAttributeRTInfo) then + begin + lLength := TBoldAttributeRTInfo(lBoldMemberRTInfo).Length; + // we could perhaps provide sensible values for types with more or less known length, + // such as Date, Time, Boolean, maybe even integer... + if lLength > 0 then + begin + ACanvas := Grid.ViewInfo.Canvas; + ACanvas.Font := GetContentFont; + Result := lLength * ACanvas.TextWidth('0') + 4; + if Grid.Options.ShowHeader then + begin + W := Grid.Painter.LFPainterClass.HeaderWidth(ACanvas, cxBordersAll, Caption, + Grid.ViewInfo.GetHeaderFont); + if W > Result then Result := W; + end; + end; + end; + end; + CheckWidthValue(Result); +end; + +function TcxLookupBoldGridColumn.GetDefaultValuesProviderClass: TcxCustomEditDefaultValuesProviderClass; +begin + Result := TcxLookupBoldGridDefaultValuesProvider; +end; + +procedure TcxLookupBoldGridColumn.InitDefaultValuesProvider; +begin +// TcxCustomDBEditDefaultValuesProvider(DefaultValuesProvider.GetInstance).Field := Field; + TcxCustomBoldEditDefaultValuesProvider(DefaultValuesProvider.GetInstance).BoldHandleFollower := DataController.BoldHandleFollower; +// TcxCustomBoldEditDefaultValuesProvider(DefaultValuesProvider.GetInstance).BoldHandle := DataController.BoldHandle; + TcxCustomBoldEditDefaultValuesProvider(DefaultValuesProvider.GetInstance).BoldProperties := BoldProperties; + // TODO: check this + +end; + +function TcxLookupBoldGridColumn.GetDataController: TcxLookupGridBoldDataController; +begin + Result := TcxLookupGridBoldDataController(inherited DataController); +end; +{ +function TcxLookupBoldGridColumn.GetField: TField; +begin + Result := DataController.GetItemField(Index); +end; + +function TcxLookupBoldGridColumn.GetFieldName: string; +begin + Result := DataController.GetItemFieldName(Index); +end; + +procedure TcxLookupBoldGridColumn.SetFieldName(const Value: string); +begin + DataController.ChangeFieldName(Index, Value); +end; +} +constructor TcxLookupBoldGridColumn.Create(Collection: TCollection); +begin + inherited; + fBoldProperties := TBoldVariantFollowerController.Create(nil); // no useful owner can be provided + fBoldProperties.ApplyPolicy := bapExit; + fBoldProperties.OnGetContextType := DataController.GetHandleStaticType; + DataController.BoldColumnsProperties.Add(fBoldProperties); + + // TODO: check this + (DefaultValuesProvider as TcxLookupBoldGridDefaultValuesProvider).BoldHandleFollower := DataController.BoldHandleFollower; + (DefaultValuesProvider as TcxLookupBoldGridDefaultValuesProvider).BoldProperties := BoldProperties; +// fBoldProperties.AddSmallSubscription(fSubscriber, [beValueChanged], beValueChanged); +end; + +destructor TcxLookupBoldGridColumn.Destroy; +begin +// FBoldProperties get freeded by DataController.BoldColumnsProperties +// so we only need to free FBoldProperties if DataController is assigned + if Assigned(DataController) then + begin + DataController.BoldColumnsProperties.Remove(fBoldProperties); + FreeAndNil(FBoldProperties); + end; + inherited; +end; + +procedure TcxLookupBoldGridColumn.SetBoldProperties( + const Value: TBoldVariantFollowerController); +begin + if Assigned(Value) then + fBoldProperties.Assign(Value); +end; + +function TcxLookupBoldGridColumn.GetBoldProperties: TBoldVariantFollowerController; +begin + result := fBoldProperties; +end; + +{ TcxLookupBoldGridColumns } + +function TcxLookupBoldGridColumns.Add: TcxLookupBoldGridColumn; +begin + Result := inherited Add as TcxLookupBoldGridColumn; +end; + +{function TcxLookupBoldGridColumns.ColumnByFieldName(const AFieldName: string): TcxLookupBoldGridColumn; +var + I: Integer; +begin + for I := 0 to Count - 1 do + begin + Result := Items[I]; + if AnsiCompareText(Result.FieldName, AFieldName) = 0 then + Exit; + end; + Result := nil; +end; +} +function TcxLookupBoldGridColumns.GetColumn(Index: Integer): TcxLookupBoldGridColumn; +begin + Result := inherited Items[Index] as TcxLookupBoldGridColumn; +end; + +procedure TcxLookupBoldGridColumns.SetColumn(Index: Integer; Value: TcxLookupBoldGridColumn); +begin + inherited Items[Index] := Value; +end; + +{ TcxLookupGridBoldDataController } + +constructor TcxLookupGridBoldDataController.Create(AOwner: TComponent); +begin + inherited Create(AOwner); +// DataModeController.SyncMode := DefaultSyncMode; +// DataModeController.SyncInsert := False; +end; + +function TcxLookupGridBoldDataController.GetItem(Index: Integer): TObject; +begin + Result := Grid.Columns[Index]; +end; + +{procedure TcxLookupGridBoldDataController.UpdateScrollBars; +begin + Grid.UpdateScrollBars; +end;} + +function TcxLookupGridBoldDataController.GetGrid: TcxCustomLookupBoldGrid; +begin + Result := GetOwner as TcxCustomLookupBoldGrid; +end; + +{procedure TcxLookupGridBoldDataController.UpdateScrollBars; +begin + Grid.UpdateScrollBars; +end;} + +procedure TcxLookupGridBoldDataController._AfterMakeCellUptoDate( + Follower: TBoldFollower); +{var + lRowIndex: integer; + lRecordIndex: integer; + lcxLookupGridRowViewInfo: TcxLookupGridRowViewInfo; + lcxCustomEditViewInfo: TcxCustomEditViewInfo; +} +begin +// inherited; + if DataHasChanged or (SkipMakeCellUptoDate > 0) then + exit; + Grid.Change([lgcData]); +// Grid.CheckChanges + exit; +{ lRecordIndex := Follower.OwningFollower.index; + lRowIndex := GetRowIndexByRecordIndex(lRecordIndex, false); + lcxLookupGridRowViewInfo := Grid.ViewInfo.Rows.FindByRowIndex(lRowIndex); + lcxCustomEditViewInfo := lcxLookupGridRowViewInfo[Follower.index].EditViewInfo; + if Assigned(lcxCustomEditViewInfo.Edit) then + begin + lcxCustomEditViewInfo.Edit.Refresh; + lcxCustomEditViewInfo.Edit.Invalidate; + end; +} +end; + +procedure TcxLookupGridBoldDataController._AfterMakeListUptoDate( + Follower: TBoldFollower); +begin +// would be nice if we could force a recalc of dropdown height somehow in order for it to adjust to potential new record count + inherited; +end; + +function TcxLookupGridBoldDataController.GetItemID( + AItem: TObject): Integer; +begin + if AItem is TcxLookupBoldGridColumn then + Result := TcxLookupBoldGridColumn(AItem).ID + else + Result := -1; +end; + +function TcxLookupGridBoldDataController.GetItemData( + AItem: TObject): Integer; +begin + if AItem is TcxLookupBoldGridColumn then + Result := Integer(TcxLookupBoldGridColumn(AItem).Index) + else + Result := -1; +end; + +{ TcxLookupBoldGridOptions } + +procedure TcxLookupBoldGridOptions.Assign(Source: TPersistent); +begin + if Source is TcxLookupBoldGridOptions then + begin + if Assigned(Grid) then + Grid.BeginUpdate; + try + inherited Assign(Source); + SyncMode := TcxLookupBoldGridOptions(Source).SyncMode; + finally + if Assigned(Grid) then + Grid.EndUpdate; + end; + end + else + inherited Assign(Source); +end; + +function TcxLookupBoldGridOptions.GetGrid: TcxCustomLookupBoldGrid; +begin + Result := TcxCustomLookupBoldGrid(FGrid); +end; + +function TcxLookupBoldGridOptions.GetSyncMode: Boolean; +begin + Result := DefaultSyncMode; +{ if Assigned(Grid) then + Result := Grid.DataController.DataModeController.SyncMode + else + Result := DefaultSyncMode; +} +end; + +procedure TcxLookupBoldGridOptions.SetSyncMode(Value: Boolean); +begin +// if Assigned(Grid) then +// Grid.DataController.DataModeController.SyncMode := Value; +end; + +{ TcxCustomLookupBoldGrid } + +procedure TcxCustomLookupBoldGrid.CreateAllColumns; +begin + Assert(false, 'TcxCustomLookupBoldGrid.CreateAllColumns not implemented yet.'); +end; + +{procedure TcxCustomLookupBoldGrid.CreateColumnsByFieldNames(const AFieldNames: string); +begin + Assert(false); +end;} + +{procedure TcxCustomLookupBoldGrid.CreateColumnsByFields(AFieldNames: TStrings); +begin + Assert(false); +end;} + +procedure TcxCustomLookupBoldGrid.DataChanged; +var + I: Integer; +begin + for I := 0 to Columns.Count - 1 do + Columns[I].InitDefaultValuesProvider; + inherited DataChanged; +end; + +function TcxCustomLookupBoldGrid.GetColumnClass: TcxLookupGridColumnClass; +begin + Result := TcxLookupBoldGridColumn; +end; + +function TcxCustomLookupBoldGrid.GetColumnsClass: TcxLookupGridColumnsClass; +begin + Result := TcxLookupBoldGridColumns; +end; + +function TcxCustomLookupBoldGrid.GetDataControllerClass: TcxCustomDataControllerClass; +begin + Result := TcxLookupGridBoldDataController; +end; + +function TcxCustomLookupBoldGrid.GetOptionsClass: TcxLookupGridOptionsClass; +begin + Result := TcxLookupBoldGridOptions; +end; + +procedure TcxCustomLookupBoldGrid.InitScrollBarsParameters; +begin +{ + if DataController.IsGridMode and DataController.IsSequenced then + begin + SetScrollBarInfo(sbVertical, 0, + (DataController.DataSetRecordCount - 1) + (ViewInfo.VisibleRowCount - 1), + 1, ViewInfo.VisibleRowCount, DataController.RecNo - 1, True, True); + end + else +} + inherited InitScrollBarsParameters; +end; + +procedure TcxCustomLookupBoldGrid.Scroll(AScrollBarKind: TScrollBarKind; + AScrollCode: TScrollCode; var AScrollPos: Integer); +begin +{ if DataController.IsGridMode and DataController.IsSequenced then + begin + if AScrollBarKind = sbVertical then + begin + case AScrollCode of + scLineUp: + FocusNextRow(False); + scLineDown: + FocusNextRow(True); + scPageUp: + FocusPriorPage; + scPageDown: + FocusNextPage; + scTrack: ; + scPosition: + DataController.RecNo := AScrollPos + 1; + end; + end + else + inherited Scroll(AScrollBarKind, AScrollCode, AScrollPos); + AScrollPos := DataController.RecNo - 1; + end + else +} + inherited Scroll(AScrollBarKind, AScrollCode, AScrollPos); +end; + +procedure TcxCustomLookupBoldGrid.UpdateScrollBars; +begin + inherited UpdateScrollBars; +end; + +function TcxCustomLookupBoldGrid.GetColumns: TcxLookupBoldGridColumns; +begin + Result := inherited Columns as TcxLookupBoldGridColumns; +end; + +function TcxCustomLookupBoldGrid.GetDataController: TcxLookupGridBoldDataController; +begin + Result := TcxLookupGridBoldDataController(FDataController); +end; + +function TcxCustomLookupBoldGrid.GetOptions: TcxLookupBoldGridOptions; +begin + Result := TcxLookupBoldGridOptions(FOptions); +end; + +procedure TcxCustomLookupBoldGrid.SetColumns(Value: TcxLookupBoldGridColumns); +begin + inherited Columns := Value; +end; + +procedure TcxCustomLookupBoldGrid.SetDataController(Value: TcxLookupGridBoldDataController); +begin + FDataController.Assign(Value); +end; + +procedure TcxCustomLookupBoldGrid.SetOptions(Value: TcxLookupBoldGridOptions); +begin + FOptions.Assign(Value); +end; + +function TcxCustomLookupBoldGrid.GetBoldListHandle: TBoldAbstractListHandle; +begin + result := DataController.BoldHandle; +end; + +procedure TcxCustomLookupBoldGrid.SetBoldListHandle( + const Value: TBoldAbstractListHandle); +begin + DataController.BoldHandle.Assign(Value); +end; + +function TcxCustomLookupBoldGrid.GetBoldProperties: TBoldListAsFollowerListController; +begin + result := DataController.BoldProperties; +end; + +procedure TcxCustomLookupBoldGrid.SetBoldProperties( + const Value: TBoldListAsFollowerListController); +begin + DataController.BoldProperties.Assign(Value); +end; + +end. diff --git a/Source/BoldAwareGUI/BoldDevex/dxBarBoldNav.pas b/Source/BoldAwareGUI/BoldDevex/dxBarBoldNav.pas new file mode 100644 index 00000000..4d0415aa --- /dev/null +++ b/Source/BoldAwareGUI/BoldDevex/dxBarBoldNav.pas @@ -0,0 +1,515 @@ +unit dxBarBoldNav; + +interface + +{$I bold.inc} +{$I cxVer.inc} + + +// v2.03 - 25 Jan 2011 2007-2011 Daniel Mauric + +uses + Classes, Messages, DB, cxClasses, dxBar, + BoldNavigatorDefs, + BoldListListControlPack, + BoldVariantControlPack, + BoldListHandleFollower, + BoldAbstractListHandle, + BoldControlPack; + + +resourcestring + dxSBAR_DBNAVERROR1 = 'You already have an existing BoldNavigator button with the same defined style'; + + dxSBAR_CATEGORYNAME = 'Bold Navigator'; + dxSBAR_DELETERECORD = 'Do you want to delete the current record?'; + + dxSBAR_BTNCAPTION_FIRST = 'First'; + dxSBAR_BTNCAPTION_PRIOR = 'Prior'; + dxSBAR_BTNCAPTION_NEXT = 'Next'; + dxSBAR_BTNCAPTION_LAST = 'Last'; + dxSBAR_BTNCAPTION_INSERT = 'Insert'; + dxSBAR_BTNCAPTION_DELETE = 'Delete'; + dxSBAR_BTNCAPTION_EDIT = 'Edit'; + dxSBAR_BTNCAPTION_POST = 'Post'; + dxSBAR_BTNCAPTION_CANCEL = 'Cancel'; + dxSBAR_BTNCAPTION_REFRESH = 'Refresh'; + +type + TdxBarBoldNavigator = class; + TdxBarBoldNavButton = class; + + TdxBarDBEnableType = (dxdbtCanModify, dxdbtNotEOF, dxdbtNotBOF, + dxdbtHasRecords, dxdbtIsModified, dxdbtIsNotModified); + TdxBarDBEnableTypes = set of TdxBarDBEnableType; + +// TdxBarBoldNavButtonType = (dxbnFirst, dxbnPrior, dxbnNext, dxbnLast, dxbnInsert, dxbnDelete, dxbnEdit, dxbnPost, dxbnCancel, dxbnRefresh); +// TdxBarBoldNavButtonTypes = set of TdxBarBoldNavButtonType; + + TBoldNavigateBtn = (nbFirst, nbPrior, nbNext, nbLast, nbInsert, nbDelete, nbMoveUp, nbMoveDown); + TBoldButtonSet = set of TBoldNavigateBtn; + + TdxBarBoldNavButton = class(TdxBarButton) + private + FBarBoldNavigator: TdxBarBoldNavigator; + FNavButton: TBoldNavigateBtn; + procedure SetNavButton(Value: TBoldNavigateBtn); + protected + procedure Loaded; override; + procedure UpdateButtons; + public + destructor Destroy; override; + procedure DoClick; override; + published + property BarBoldNavigator: TdxBarBoldNavigator read FBarBoldNavigator write FBarBoldNavigator; + property NavButton: TBoldNavigateBtn read FNavButton write SetNavButton; + end; + + TBoldNavigatorDeleteEvent = TNotifyEvent; + TBoldNavigatorInsertEvent = TNotifyEvent; + + TdxBarBoldNavigator = class(TComponent) + private + FBarManager: TdxBarManager; + FCategoryName: string; + FConfirmDelete: Boolean; + FSetVisFlag: Boolean; + FVisibleButtons: TBoldButtonSet; + + fBoldDeleteMode: TBoldDeleteMode; + fBoldProperties: TBoldListAsFollowerListController; + fFollowerController: TBoldVariantFollowerController; + fHandleFollower: TBoldListHandleFollower; + fOnBoldNavigatorDelete: TBoldNavigatorDeleteEvent; + fOnBoldNavigatorInsert: TBoldNavigatorInsertEvent; + + procedure SetBoldListHandle(Value: TBoldAbstractListHandle); + function GetBoldListHandle: TBoldAbstractListHandle; + + procedure SetBarManager(Value: TdxBarManager); + procedure SetCategoryName(const Value: String); + procedure SetVisibleButtons(Value: TBoldButtonSet); + + procedure AddButton(AButton: TdxBarBoldNavButton); + procedure RemoveButton(AButton: TdxBarBoldNavButton); + + function MapMinus(CanDeleteObject: Boolean): Boolean; + + protected + Buttons: array[TBoldNavigateBtn] of TdxBarBoldNavButton; + procedure ActiveChanged; + procedure DataChanged; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + procedure _BeforeMakeUptoDate(Follower: TBoldFollower); + procedure _AfterMakeUptoDate(Follower: TBoldFollower); + procedure SetActiveButtons; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + published + property BarManager: TdxBarManager read FBarManager write SetBarManager; + property CategoryName: string read FCategoryName write SetCategoryName; + property VisibleButtons: TBoldButtonSet read FVisibleButtons + write SetVisibleButtons default []; + property BoldDeleteMode: TBoldDeleteMode read fBoldDeleteMode write fBoldDeleteMode default dmDefault; + property BoldHandle: TBoldAbstractListHandle read GetBoldListHandle write SetBoldListHandle; + property ConfirmDelete: Boolean read fConfirmDelete write fConfirmDelete default True; + property OnBoldNavigatorDelete: TBoldNavigatorDeleteEvent read fOnBoldNavigatorDelete write fOnBoldNavigatorDelete; + property OnBoldNavigatorInsert: TBoldNavigatorInsertEvent read fOnBoldNavigatorInsert write fOnBoldNavigatorInsert; + end; + +implementation + +{$R dxBarBoldNav.res} + +uses + Windows, + SysUtils, + Forms, +// dxBardbNavStrs, + dxCore, + BoldElements, + BoldSystem, + BoldGuiResourceStrings, + BoldDefs; + +const + BtnResStr = 'DXBARBOLDNAVBTN_'; + dxBarBoldNavBtnName = 'dxBarBoldNav'; + +{ dxBarBoldNavButton } + +destructor TdxBarBoldNavButton.Destroy; +begin + if BarBoldNavigator <> nil then + BarBoldNavigator.RemoveButton(Self); + inherited Destroy; +end; + +procedure TdxBarBoldNavButton.SetNavButton(Value: TBoldNavigateBtn); +const + dxBarNames: array[TBoldNavigateBtn] of string = + ('First', 'Prev', 'Next', 'Last', 'Insert', 'Delete', 'MoveUp', 'MoveDown'); +{ + PResStrs: array[TBoldNavigateBtn] of String = (SNavHintFirst, + SNavHintPrior, SNavHintNext, SNavHintLast, + SNavHintNew, SNavHintDelete, SNavHintMoveUp, SNavHintMoveDown); +} + PResStrs: array[TBoldNavigateBtn] of Pointer = (@dxSBAR_BTNCAPTION_FIRST, + @dxSBAR_BTNCAPTION_PRIOR, @dxSBAR_BTNCAPTION_NEXT, @dxSBAR_BTNCAPTION_LAST, + @dxSBAR_BTNCAPTION_INSERT, @dxSBAR_BTNCAPTION_DELETE, @dxSBAR_BTNCAPTION_EDIT, + @dxSBAR_BTNCAPTION_POST{, @dxSBAR_BTNCAPTION_CANCEL, @dxSBAR_BTNCAPTION_REFRESH}); + +begin + if (FNavButton <> Value) or (Name = '') then + if csLoading in ComponentState then + FNavButton := Value + else + begin + if (BarBoldNavigator <> nil) and not BarBoldNavigator.FSetVisFlag and + (BarBoldNavigator.Buttons[Value] <> nil) then + raise Exception.Create(cxGetResourceString(@dxSBAR_DBNavERROR1)); + if (BarBoldNavigator <> nil) and not BarBoldNavigator.FSetVisFlag then + BarBoldNavigator.RemoveButton(Self); + FNavButton := Value; + if BarBoldNavigator <> nil then + begin + BarBoldNavigator.AddButton(Self); +{$IFDEF BOLD_DELPHI25_OR_LATER} + Glyph.LoadFromResource(HInstance, PChar(BtnResStr + IntToStr(Integer(FNavButton) + 1)), RT_BITMAP); +{$ELSE} + Glyph.LoadFromResourceName(HInstance, PChar(BtnResStr + IntToStr(Integer(FNavButton) + 1))); +{$ENDIF} + end; + try + if BarManager.Designing then + Name := (BarManager as IdxBarDesigner).UniqueName(dxBarBoldNavBtnName + dxBarNames[FNavButton]); + Caption := cxGetResourceString(PResStrs[FNavButton]); + Hint := Caption; + except + raise; + end; + end; +end; + +procedure TdxBarBoldNavButton.Loaded; +begin + inherited Loaded; + if BarBoldNavigator <> nil then + begin + BarBoldNavigator.AddButton(Self); + BarBoldNavigator.ActiveChanged; + end; +end; + +procedure TdxBarBoldNavButton.DoClick; +var + lSelection: TBoldObjectList; + +procedure GetSelection; +{var + i: integer; + lFollower: TBoldFollower; +} +begin +{ lFollower := BarBoldNavigator.fHandleFollower.Follower; + lSelection := TBoldObjectList.Create; + lSelection.SubscribeToObjectsInList := false; + lSelection.SubscribeToLocatorsInList := false; + for i := 0 to lFollower.SubFollowerCount - 1 do + begin + if BarBoldNavigator.fBoldProperties.GetSelected(lFollower, i) then + lSelection.Add( lFollower.SubFollowers[i].Element as TBoldObject ); + end; +} + if (lSelection.Count = 0) then + lSelection.Add(BarBoldNavigator.BoldHandle.CurrentBoldObject); +end; + +var + i: integer; + lList: TBoldObjectList; + lBoldObject: TBoldObject; +begin + inherited; + if Assigned(OnClick) then Exit; + if BarBoldNavigator <> nil then + with BarBoldNavigator.BoldHandle do + case FNavButton of + nbFirst: First; + nbPrior: Prior; + nbNext: Next; + nbLast: Last; + nbInsert: + begin + if Assigned(BarBoldNavigator.fOnBoldNavigatorInsert) then + BarBoldNavigator.fOnBoldNavigatorInsert(BarBoldNavigator) + else + List.AddNew; //Insert; + end; + nbDelete: + if not BarBoldNavigator.ConfirmDelete or + (Application.MessageBox(PChar(cxGetResourceString(@dxSBAR_DELETERECORD)), + PChar(Application.Title), MB_ICONQUESTION or MB_YESNO) = ID_YES) then + begin + if Assigned(BarBoldNavigator.fOnBoldNavigatorDelete) then + BarBoldNavigator.fOnBoldNavigatorDelete(BarBoldNavigator) + else + begin + lList := BarBoldNavigator.BoldHandle.ObjectList; + GetSelection; + try + for i := lSelection.count - 1 downto 0 do + begin + lBoldObject := lSelection[i]; + case BarBoldNavigator.BoldDeleteMode of + dmDefault, dmRemoveFromList: + lList.Remove(lBoldObject); + dmDelete: + lBoldObject.delete; + dmUnlinkAllAndDelete: + begin + lBoldObject.UnLinkAll; + lBoldObject.Delete + end; + end; + end; + finally + lSelection.free; + end; + end; + end; + nbMoveUp: ; //Edit; + nbMoveDown: ; //Post; + end; +end; + +{ TdxBarBoldNavigator } + +constructor TdxBarBoldNavigator.Create(AOwner: TComponent); +var + ABarManager: TdxBarManager; +begin + ABarManager := GetBarManagerForComponent(AOwner); + {if (ABarManager = nil) and (dxBarManagerList.Count <> 0) then + ABarManager := dxBarManagerList[0];} + inherited Create(AOwner); + FBarManager := ABarManager; + FCategoryName := 'Bold Navigator'; + ConfirmDelete := true; + fFollowerController := TBoldVariantFollowerController.Create(self); + fBoldProperties := TBoldListAsFollowerListController.Create(self, fFollowerController); + fHandleFollower := TBoldListHandleFollower.Create(Owner, fBoldProperties); + if not (csDesigning in ComponentState) then + begin + fBoldProperties.AfterMakeUptoDate := _AfterMakeUptoDate; + fBoldProperties.BeforeMakeUptoDate := _BeforeMakeUptoDate; + end; +end; + +destructor TdxBarBoldNavigator.Destroy; +begin + VisibleButtons := []; + inherited Destroy; +end; + +procedure TdxBarBoldNavigator.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited Notification(AComponent, Operation); + if Operation = opRemove then + begin + if AComponent = BarManager then BarManager := nil; +// if AComponent = DataSource then DataSource := nil; + end; +end; + +procedure TdxBarBoldNavigator.DataChanged; +begin + SetActiveButtons; +end; + +procedure TdxBarBoldNavigator.ActiveChanged; +begin + DataChanged; +end; + +procedure TdxBarBoldNavigator.SetBarManager(Value: TdxBarManager); +var + SaveVisButtons: TBoldButtonSet; +begin + if FBarManager <> Value then + begin + SaveVisButtons := FVisibleButtons; + VisibleButtons := []; + FBarManager := Value; + VisibleButtons := SaveVisButtons; + end; +end; + +procedure TdxBarBoldNavigator.SetCategoryName(const Value: String); +var + Index1, Index2: Integer; + I: TBoldNavigateBtn; +begin + if FCategoryName <> Value then + if csLoading in ComponentState then + FCategoryName := Value + else + if BarManager <> nil then + begin + Index1 := BarManager.Categories.IndexOf(FCategoryName); + FCategoryName := Value; + Index2 := BarManager.Categories.IndexOf(FCategoryName); + if Index2 = -1 then + begin + BarManager.Categories.Add(FCategoryName); + Index2 := BarManager.Categories.IndexOf(FCategoryName); + end; + for I := Low(Buttons) to High(Buttons) do + if Buttons[I] <> nil then Buttons[I].Category := Index2; + if (Index1 > -1) and (BarManager.GetCountByCategory(Index1) = 0) then + BarManager.Categories.Delete(Index1); + end; +end; + +procedure TdxBarBoldNavigator.SetVisibleButtons(Value: TBoldButtonSet); +var + I: TBoldNavigateBtn; + AIndex: Integer; +begin + if FVisibleButtons <> Value then + begin + FVisibleButtons := Value; + FSetVisFlag := True; + if not (csLoading in ComponentState) and (BarManager <> nil) then + for I := Low(Buttons) to High(Buttons) do + begin + if (Buttons[I] <> nil) and //not (csDestroying in Buttons[I].ComponentState) and + not (I in Value) then + begin + Buttons[I].Free; + Buttons[I] := nil; + end; + if (Buttons[I] = nil) and (I in Value) then + begin + Buttons[I] := TdxBarBoldNavButton.Create(Owner); + with Buttons[I] do + begin + BarBoldNavigator := Self; + Buttons[I].Tag := Ord(i); + AIndex := BarManager.Categories.IndexOf(FCategoryName); + if AIndex = -1 then + begin + BarManager.Categories.Add(FCategoryName); + AIndex := BarManager.Categories.IndexOf(FCategoryName); + end; + Category := AIndex; + NavButton := I; + end; + end; + end; + ActiveChanged; + FSetVisFlag := False; + end; + if (FVisibleButtons = []) and (BarManager <> nil) and + not (csDestroying in BarManager.ComponentState) then + begin + AIndex := BarManager.Categories.IndexOf(FCategoryName); + if (AIndex > -1) and (BarManager.GetCountByCategory(AIndex) = 0) then + BarManager.Categories.Delete(AIndex); + end; +end; + +procedure TdxBarBoldNavigator.AddButton(AButton: TdxBarBoldNavButton); +begin + Buttons[AButton.NavButton] := AButton; + FVisibleButtons := FVisibleButtons + [AButton.NavButton]; +end; + +procedure TdxBarBoldNavigator.RemoveButton(AButton: TdxBarBoldNavButton); +begin + Buttons[AButton.NavButton] := nil; + FVisibleButtons := FVisibleButtons - [AButton.NavButton]; +end; + +function TdxBarBoldNavigator.GetBoldListHandle: TBoldAbstractListHandle; +begin + if Assigned(fHandleFollower) then + Result := fHandleFollower.BoldHandle + else + Result := nil; +end; + +procedure TdxBarBoldNavigator.SetBoldListHandle( + Value: TBoldAbstractListHandle); +begin + fHandleFollower.BoldHandle := value; +end; + +procedure TdxBarBoldNavigator._BeforeMakeUptoDate(Follower: TBoldFollower); +begin + if Assigned(BoldHandle) and Assigned(Follower) then + fBoldProperties.SetActiveRange(Follower, BoldHandle.CurrentIndex, BoldHandle.CurrentIndex); +end; + +procedure TdxBarBoldNavigator._AfterMakeUptoDate(Follower: TBoldFollower); +begin + SetActiveButtons; +end; + +procedure TdxBarBoldNavigator.SetActiveButtons; +var + i: TBoldNavigateBtn; +begin + if (csDesigning in ComponentState) then exit; + for I := Low(Buttons) to High(Buttons) do + if Buttons[I] <> nil then Buttons[I].UpdateButtons; +end; + +function TdxBarBoldNavigator.MapMinus(CanDeleteObject: Boolean): Boolean; +begin + case BoldDeleteMode of + dmDefault, dmRemoveFromList: + Result := True; + dmDelete: + Result := CanDeleteObject; + dmUnlinkAllAndDelete: + Result := True; + else + raise EBold.CreateFmt(sUnknownDeleteMode, [ClassName]); + end; +end; + +procedure TdxBarBoldNavButton.UpdateButtons; +var + EnabledAndHandle: boolean; + lBoldHandle: TBoldAbstractListHandle; +begin + lBoldHandle := BarBoldNavigator.BoldHandle; + EnabledAndHandle := assigned(lBoldHandle) and Assigned(lBoldHandle.Value); + case TBoldNavigateBtn(Tag) of + nbFirst: Enabled := EnabledAndHandle and lBoldHandle.HasPrior; + nbPrior: Enabled := EnabledAndHandle and lBoldHandle.HasPrior; + nbNext: Enabled := EnabledAndHandle and lBoldHandle.HasNext; + nbLast: Enabled := EnabledAndHandle and lBoldHandle.HasNext; + nbInsert: Enabled := assigned(lBoldHandle) {and (nbInsert in BarBoldNavigator.VisibleButtons)} and + assigned(lBoldHandle.MutableList) and + lBoldHandle.MutableList.CanCreateNew; + nbDelete: Enabled := EnabledAndHandle {and (nbDelete in VisibleButtons)} and + assigned(lBoldHandle.CurrentBoldObject) and + BarBoldNavigator.MapMinus(lBoldHandle.CurrentBoldObject.CanDelete); +(* nbMoveUp: Enabled := EnabledAndHandle {and (nbMoveUp in VisibleButtons)} and + assigned(lBoldHandle.CurrentBoldObject) and + lBoldHandle.List.CanMove(lBoldHandle.CurrentIndex, + lBoldHandle.CurrentIndex -1); + nbMoveDown: Enabled := EnabledAndHandle {and (nbMoveDown in VisibleButtons)} and + assigned(lBoldHandle.CurrentBoldObject) and + lBoldHandle.List.CanMove(lBoldHandle.CurrentIndex, lBoldHandle.CurrentIndex + 1); +*) + end; +end; + +initialization + dxBarRegisterItem(TdxBarBoldNavButton, TdxBarButtonControl, False); + +end. diff --git a/Source/BoldAwareGUI/BoldDevex/dxBarBoldNav.res b/Source/BoldAwareGUI/BoldDevex/dxBarBoldNav.res new file mode 100644 index 00000000..149d2b99 Binary files /dev/null and b/Source/BoldAwareGUI/BoldDevex/dxBarBoldNav.res differ diff --git a/Source/BoldAwareGUI/ControlPacks/BoldCheckboxStateControlPack.pas b/Source/BoldAwareGUI/ControlPacks/BoldCheckboxStateControlPack.pas index 1ec7c5a7..807c789c 100644 --- a/Source/BoldAwareGUI/ControlPacks/BoldCheckboxStateControlPack.pas +++ b/Source/BoldAwareGUI/ControlPacks/BoldCheckboxStateControlPack.pas @@ -1,3 +1,7 @@ + +{ Global compiler directives } +{$include bold.inc} + unit BoldCheckboxStateControlPack; {$UNDEF BOLDCOMCLIENT} @@ -18,10 +22,10 @@ TBoldAsCheckBoxStateRenderer = class; TBoldCheckBoxRendererData = class; { TBoldAsCheckBoxStateRenderer } - TBoldGetAsCheckBoxState = function (Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression): TCheckBoxState of object; - TBoldSetAsCheckBoxState = procedure (Element: TBoldElement; newValue: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression) of object; - TBoldValidateCheckBoxState = function (Element: TBoldElement; Value: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression): Boolean of object; - TBoldCheckBoxIsChanged = function (RendererData: TBoldCheckBoxRendererData; NewValue: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression): Boolean of object; + TBoldGetAsCheckBoxState = function (aFollower: TBoldFollower): TCheckBoxState of object; + TBoldSetAsCheckBoxState = procedure (aFollower: TBoldFollower; newValue: TCheckBoxState) of object; + TBoldValidateCheckBoxState = function (aFollower: TBoldFollower; Value: TCheckBoxState): Boolean of object; + TBoldCheckBoxIsChanged = function (Follower: TBoldFollower; NewValue: TCheckBoxState): Boolean of object; { TBoldCheckBoxRendererData } TBoldCheckBoxRendererData = class(TBoldRendererData) @@ -34,6 +38,7 @@ TBoldCheckBoxRendererData = class(TBoldRendererData) end; { TBoldAsCheckBoxStateRenderer } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldAsCheckBoxStateRenderer = class(TBoldSingleRenderer) private FOnGetAsCheckBoxState: TBoldGetAsCheckBoxState; @@ -44,15 +49,15 @@ TBoldAsCheckBoxStateRenderer = class(TBoldSingleRenderer) function GetRendererDataClass: TBoldRendererDataClass; override; public class function DefaultRenderer: TBoldAsCheckBoxStateRenderer; - class function DefaultGetAsCheckBoxStateAndSubscribe(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): TCheckBoxState; virtual; - class procedure DefaultSetAsCheckBoxState(Element: TBoldElement; newValue: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); virtual; - class function DefaultValidateCheckBoxState(Element: TBoldElement; Value: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; virtual; - procedure MakeUptodateAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldFollowerController; Subscriber: TBoldSubscriber); override; - function DefaultIsChanged(RendererData: TBoldCheckBoxRendererData; NewValue: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; - function GetAsCheckBoxStateAndSubscribe(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): TCheckBoxState; virtual; - procedure SetAsCheckBoxState(Element: TBoldElement; Value: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); virtual; - function ValidateCheckBoxState(Element: TBoldElement; Value: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression;VariableList: TBoldExternalVariableList): Boolean; virtual; - function IsChanged(RendererData: TBoldCheckBoxRendererData; NewValue: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; + class function DefaultGetAsCheckBoxStateAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): TCheckBoxState; virtual; + class procedure DefaultSetAsCheckBoxState(aFollower: TBoldFollower; newValue: TCheckBoxState); virtual; + class function DefaultValidateCheckBoxState(aFollower: TBoldFollower; Value: TCheckBoxState): Boolean; virtual; + procedure MakeUptodateAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); override; + function DefaultIsChanged(Follower: TBoldFollower; NewValue: TCheckBoxState): Boolean; + function GetAsCheckBoxStateAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): TCheckBoxState; virtual; + procedure SetAsCheckBoxState(aFollower: TBoldFollower; Value: TCheckBoxState); virtual; + function ValidateCheckBoxState(aFollower: TBoldFollower; Value: TCheckBoxState): Boolean; virtual; + function IsChanged(Follower: TBoldFollower; NewValue: TCheckBoxState): Boolean; published property OnGetAsCheckBoxState: TBoldGetAsCheckBoxState read FOnGetAsCheckBoxState write FOnGetAsCheckBoxState; property OnSetAsCheckBoxState: TBoldSetAsCheckBoxState read FOnSetAsCheckBoxState write FOnSetAsCheckBoxState; @@ -85,7 +90,8 @@ implementation SysUtils, BoldGuiResourceStrings, BoldControlPackDefs, - BoldAttributes; + BoldAttributes, + BoldGuard; var DefaultAsCheckBoxStateRenderer: TBoldAsCheckBoxStateRenderer; @@ -122,52 +128,65 @@ function TBoldCheckBoxStateFollowerController.GetCurrentAsCheckBoxState(Follower procedure TBoldCheckBoxStateFollowerController.SetAsCheckBoxState(Value: TCheckBoxState; Follower: TBoldFollower); begin - EffectiveAsCheckBoxStateRenderer.SetAsCheckBoxState(Follower.Element, Value, Representation, Expression, VariableList); + EffectiveAsCheckBoxStateRenderer.SetAsCheckBoxState(Follower, Value); end; function TBoldCheckBoxStateFollowerController.ValidateCheckBoxState(Value: TCheckBoxState; Follower: TBoldFollower): Boolean; begin - Result := EffectiveAsCheckBoxStateRenderer.ValidateCheckBoxState(Follower.Element, Value, Representation, Expression, VariableList); + Result := EffectiveAsCheckBoxStateRenderer.ValidateCheckBoxState(Follower, Value); end; procedure TBoldCheckBoxStateFollowerController.MayHaveChanged(NewValue: TCheckBoxState; Follower: TBoldFollower); +var + lIsChanged: boolean; + lRendererData: TBoldCheckBoxRendererData; begin if Follower.State in bfsDisplayable then begin - (Follower.RendererData as TBoldCheckBoxRendererData).CurrentValue := NewValue; - Follower.ControlledValueChanged(EffectiveAsCheckBoxStateRenderer.IsChanged(Follower.RendererData as TBoldCheckBoxRendererData, NewValue, Representation, Expression, VariableList)); + lRendererData := Follower.RendererData as TBoldCheckBoxRendererData; + lRendererData.CurrentValue := NewValue; + lIsChanged := EffectiveAsCheckBoxStateRenderer.IsChanged(Follower, NewValue); + if lIsChanged then + begin + Follower.ControlledValueChanged; + end; end; end; procedure TBoldCheckBoxStateFollowerController.MakeClean(Follower: TBoldFollower); begin - ReleaseChangedValue(Follower); // note, must do first, since set can change element +// if (ApplyPolicy <> bapChange) or EffectiveRenderer.ChangedValueEventsAssigned then + begin + ReleaseChangedValue(Follower); // note, must do first, since set can change element + end; SetAsCheckBoxState(GetCurrentAsCheckBoxState(Follower), Follower); end; { TBoldAsCheckBoxStateRenderer } -procedure TBoldAsCheckBoxStateRenderer.MakeUpToDateANdSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldFollowerController; Subscriber: TBoldSubscriber); +procedure TBoldAsCheckBoxStateRenderer.MakeUpToDateANdSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); var s: TCheckBoxState; - Controller: TBoldCheckBoxStateFollowerController; + lRendererData: TBoldCheckBoxRendererData; begin - Controller := FollowerController as TBoldCheckBoxStateFollowerController; - s := GetAsCheckBoxStateAndSubscribe(Element, Controller.Representation, Controller.Expression, Controller.GetVariableListAndSubscribe(Subscriber), Subscriber); - (RendererData as TBoldCheckBoxRendererData).OldValue := s; - (RendererData as TBoldCheckBoxRendererData).CurrentValue := s; + s := GetAsCheckBoxStateAndSubscribe(aFollower, Subscriber); + lRendererData := (aFollower.RendererData as TBoldCheckBoxRendererData); + lRendererData.OldValue := s; + lRendererData.CurrentValue := s; end; -class function TBoldAsCheckBoxStateRenderer.DefaultGetAsCheckBoxStateAndSubscribe(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): TCheckBoxState; +class function TBoldAsCheckBoxStateRenderer.DefaultGetAsCheckBoxStateAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): TCheckBoxState; var {$IFDEF BOLDCOMCLIENT} // DefaultGet e: IBoldElement; Attribute: IBoldAttribute; {$ELSE} E: TBoldIndirectElement; + lResultElement: TBoldElement; + lGuard: IBoldGuard; {$ENDIF} begin Result := cbGrayed; - if Assigned(Element) then + if Assigned(aFollower.Element) then begin {$IFDEF BOLDCOMCLIENT} // defaultGet if assigned(Subscriber) then @@ -184,32 +203,34 @@ class function TBoldAsCheckBoxStateRenderer.DefaultGetAsCheckBoxStateAndSubscrib Result := cbUnchecked; end; {$ELSE} - E := TBoldIndirectElement.Create; - try - Element.EvaluateAndSubscribeToExpression(Expression, Subscriber, E, False, False, VariableList); - if E.Value is TBABoolean then - with E.Value as TBABoolean do - if IsNull then - Result := cbGrayed - else if AsBoolean then - Result := cbChecked - else - Result := cbUnchecked; - finally - E.Free; + lResultElement := aFollower.Value; + if not Assigned(lResultElement) then + begin + lGuard:= TBoldGuard.Create(E); + e := TBoldIndirectElement.Create; + aFollower.Element.EvaluateAndSubscribeToExpression(aFollower.AssertedController.Expression, Subscriber, E, False, False, aFollower.Controller.GetVariableListAndSubscribe(Subscriber)); + lResultElement := e.Value; end; + if lResultElement is TBABoolean then + with lResultElement as TBABoolean do + if IsNull then + Result := cbGrayed + else if AsBoolean then + Result := cbChecked + else + Result := cbUnchecked; {$ENDIF} end; end; -class procedure TBoldAsCheckBoxStateRenderer.DefaultSetAsCheckBoxState(Element: TBoldElement; newValue: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); +class procedure TBoldAsCheckBoxStateRenderer.DefaultSetAsCheckBoxState(aFollower: TBoldFollower; newValue: TCheckBoxState); var ValueElement: TBoldElement; {$IFDEF BOLDCOMCLIENT} // defaulSet Attribute: IBoldAttribute; {$ENDIF} begin - ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); + ValueElement := aFollower.Value; {$IFDEF BOLDCOMCLIENT} // defaultSet if valueElement.QueryInterface(IBoldAttribute, Attribute) = S_OK then begin @@ -234,7 +255,7 @@ class procedure TBoldAsCheckBoxStateRenderer.DefaultSetAsCheckBoxState(Element: {$ENDIF} end else - raise EBold.CreateFmt(sCannotSetValue, [ClassName]); + raise EBold.CreateFmt('%s: Can''t set value', [ClassName]); end; function TBoldAsCheckBoxStateRenderer.GetRendererDataClass: TBoldRendererDataClass; @@ -242,40 +263,40 @@ function TBoldAsCheckBoxStateRenderer.GetRendererDataClass: TBoldRendererDataCla Result := TBoldCheckBoxRendererData; end; - class function TBoldAsCheckBoxStateRenderer.DefaultValidateCheckBoxState(Element: TBoldElement; Value: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; +class function TBoldAsCheckBoxStateRenderer.DefaultValidateCheckBoxState(aFollower: TBoldFollower; Value: TCheckBoxState): Boolean; begin Result := True; end; -function TBoldAsCheckBoxStateRenderer.GetAsCheckBoxStateAndSubscribe(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): TCheckBoxState; +function TBoldAsCheckBoxStateRenderer.GetAsCheckBoxStateAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): TCheckBoxState; begin if Assigned(OnSubscribe) and Assigned(Subscriber) then begin - if Assigned(Element) then - OnSubscribe(Element, Representation, Expression, Subscriber); + if Assigned(aFollower.Element) then + OnSubscribe(aFollower, Subscriber); Subscriber := nil; end; if Assigned(OnGetAsCheckBoxState) then - Result := OnGetAsCheckBoxState(Element, Representation, Expression) + Result := OnGetAsCheckBoxState(aFollower) else - Result := DefaultGetAsCheckBoxStateAndSubscribe(Element, Representation, Expression, VariableList, Subscriber); + Result := DefaultGetAsCheckBoxStateAndSubscribe(aFollower, Subscriber); end; -procedure TBoldAsCheckBoxStateRenderer.SetAsCheckBoxState(Element: TBoldElement; Value: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression;VariableList: TBoldExternalVariableList); +procedure TBoldAsCheckBoxStateRenderer.SetAsCheckBoxState(aFollower: TBoldFollower; Value: TCheckBoxState); begin if Assigned(OnSetAsCheckBoxState) then - OnSetAsCheckBoxState(Element, Value, Representation, Expression) + OnSetAsCheckBoxState(aFollower, Value) else - DefaultSetAsCheckBoxState(Element, Value, Representation, Expression, VariableList); + DefaultSetAsCheckBoxState(aFollower, Value); end; -function TBoldAsCheckBoxStateRenderer.ValidateCheckBoxState(Element: TBoldElement; Value: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; +function TBoldAsCheckBoxStateRenderer.ValidateCheckBoxState(aFollower: TBoldFollower; Value: TCheckBoxState): Boolean; begin if Assigned(OnValidateCheckBoxState) then - Result := OnValidateCheckBoxState(Element, Value, Representation, Expression) + Result := OnValidateCheckBoxState(aFollower, Value) else - Result := DefaultValidateCheckBoxState(Element, Value, Representation, Expression, VariableList); + Result := DefaultValidateCheckBoxState(aFollower, Value); end; class function TBoldAsCheckBoxStateRenderer.DefaultRenderer: TBoldAsCheckBoxStateRenderer; @@ -283,17 +304,17 @@ function TBoldAsCheckBoxStateRenderer.ValidateCheckBoxState(Element: TBoldElemen Result := DefaultAsCheckBoxStateRenderer; end; -function TBoldAsCheckBoxStateRenderer.DefaultIsChanged(RendererData: TBoldCheckBoxRendererData; NewValue: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; +function TBoldAsCheckBoxStateRenderer.DefaultIsChanged(Follower: TBoldFollower; NewValue: TCheckBoxState): Boolean; begin - Result := NewValue <> TBoldCheckBoxRendererData(RendererData).OldValue; + Result := NewValue <> TBoldCheckBoxRendererData(Follower.RendererData).OldValue; end; -function TBoldAsCheckBoxStateRenderer.IsChanged(RendererData: TBoldCheckBoxRendererData; NewValue: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; +function TBoldAsCheckBoxStateRenderer.IsChanged(Follower: TBoldFollower; NewValue: TCheckBoxState): Boolean; begin if Assigned(fOnIsChanged) then - Result := fOnIsChanged(RendererData, NewValue, Representation, Expression) + Result := fOnIsChanged(Follower, NewValue) else - Result := DefaultIsChanged(RendererData, NewValue, Representation, Expression, VariableList); + Result := DefaultIsChanged(Follower, NewValue); end; initialization @@ -303,3 +324,4 @@ finalization FreeAndNil(DefaultAsCheckBoxStateRenderer); end. + diff --git a/Source/BoldAwareGUI/ControlPacks/BoldControlPack.pas b/Source/BoldAwareGUI/ControlPacks/BoldControlPack.pas index 6afe786a..c44fbec3 100644 --- a/Source/BoldAwareGUI/ControlPacks/BoldControlPack.pas +++ b/Source/BoldAwareGUI/ControlPacks/BoldControlPack.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldControlPack; {$UNDEF BOLDCOMCLIENT} @@ -9,8 +12,12 @@ interface SysUtils, Controls, {$IFDEF BOLD_DELPH6_OR_LATER} - Types, // IFDEF BOLD_DELPH6_OR_LATER + Types, {$ENDIF} +{$IFNDEF BOLDCOMCLIENT} + BoldSystemRT, + BoldSystem, +{$ENDIF} Menus, Graphics, Windows, @@ -21,8 +28,13 @@ interface BoldSubscription, BoldElements, BoldQueue, + BoldHandles, BoldOclVariables; +const + befFollowerResultElementOutOfDate = BoldElementFlag4; + befFollowerEnsured = BoldElementFlag5; + type {Forward declarations of all classes} TBoldRendererData = class; @@ -33,12 +45,35 @@ TBoldFollowerController = class; TBoldSingleFollowerController = class; TBoldSingleRenderer = class; TBoldPopup = class; + TBoldAbstractHandleFollower = class; TBoldRendererDataClass = class of TBoldRendererData; + TBoldFollowerControllerClass = class of TBoldFollowerController; TBoldFollowerEvent = procedure (Follower: TBoldFollower) of object; TBoldGetContextTypeEvent = function: TBoldElementTypeInfo of object; TBoldSubFollowerEvent = procedure (index: Integer; OwningFollower: TBoldFollower) of object; + TBoldValidateString = function (aFollower: TBoldFollower; const Value: string): Boolean of object; + TBoldApplyExceptionEvent = function (E: Exception; Elem: TBoldElement; var Discard: Boolean): Boolean of object; + TBoldDisplayExceptionEvent = function(E: Exception; Elem: TBoldElement): Boolean of object; + + TBoldFollowerArray = array of TBoldFollower; + + { TBoldAbstractHandleFollower } + TBoldAbstractHandleFollower = class(TBoldQueueable) + private + fFollower: TBoldFollower; + fSubscriber: TBoldSubscriber; + protected + function GetBoldHandle: TBoldElementHandle; virtual; abstract; + procedure Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); virtual; abstract; + property Subscriber: TBoldSubscriber read fSubscriber; + public + constructor Create(AMatchObject: TObject; Controller: TBoldFollowerController); + destructor Destroy; override; + property BoldHandle: TBoldElementHandle read GetBoldHandle; + property Follower: TBoldFollower read fFollower; + end; { TBoldFollowerSubscriber } TBoldFollowerSubscriber = class(TBoldSubscriber) @@ -47,39 +82,41 @@ TBoldFollowerSubscriber = class(TBoldSubscriber) protected procedure Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); override; function GetContextString: string; override; + function ContextObject: TObject; override; public - constructor Create(follower: TBoldFollower); + constructor Create(Follower: TBoldFollower); + destructor Destroy; override; property Follower: TBoldFollower read fFollower; end; { TBoldRendererData } - // Abstract class, concrete versions defined with typed renderer TBoldRendererData = class(TBoldMemoryManagedObject) private fOwningFollower: TBoldFollower; - fMayModify: Boolean; protected procedure EnsureSubfollowersDisplayable; virtual; function GetSubFollowerCount: Integer; virtual; function GetSubFollower(index: Integer): TBoldFollower; virtual; + function GetEnsuredSubFollower(Index: Integer): TBoldFollower; virtual; function GetCurrentSubFollowerIndex: Integer; virtual; procedure SetCurrentSubFollowerIndex(index:integer); virtual; + function GetSubFollowerAssigned(Index: Integer): boolean; virtual; public constructor Create(OwningFollower: TBoldFollower); virtual; property OwningFollower: TBoldFollower read fOwningFollower; - property MayModify: Boolean read fMayModify write fMayModify; end; { TBoldRenderer } - TBoldMayModify = function (Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; Subscriber: TBoldSubscriber): Boolean of object; - TBoldHoldsChangedValue = procedure (Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; Subscriber: TBoldSubscriber) of object; - TBoldReleaseChangedValue = procedure (Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; Subscriber: TBoldSubscriber) of object; - TBoldSubscribe = procedure (Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; Subscriber: TBoldSubscriber) of object; - + TBoldMayModify = function(aFollower: TBoldFollower): Boolean of object; + TBoldHoldsChangedValue = procedure(aFollower: TBoldFollower) of object; + TBoldReleaseChangedValue = procedure(aFollower: TBoldFollower) of object; + TBoldSubscribe = procedure(aFollower: TBoldFollower; Subscriber: TBoldSubscriber) of object; + TBoldEnsureFetched = procedure (List: TBoldObjectList; Expression: TBoldExpression) of object; TBoldStartDrag = procedure (Element: TBoldElement; DragMode: TBoldDragMode; RendererData: TBoldRendererData) of object; TBoldEndDrag = procedure (DragMode: TBoldDragMode; InternalDrag: Boolean) of object; TBoldDragOver = function (Element: TBoldElement; DropMode: TBoldDropMode; InternalDrag: Boolean; RendererData: TBoldRendererData; dropindex: Integer): Boolean of object; TBoldDragDrop = procedure (Element: TBoldElement; DropMode: TBoldDropMode; dropindex: Integer) of object; + TBoldValidateCharacter = function (AFollower: TBoldFollower; C: Char): Boolean of object; TBoldRenderer = class(TBoldSubscribableComponentViaBoldElem) private @@ -91,7 +128,9 @@ TBoldRenderer = class(TBoldSubscribableComponentViaBoldElem) FOnHoldsChangedValue: TBoldHoldsChangedValue; FOnReleaseChangedValue: TBoldReleaseChangedValue; FOnSubscribe: TBoldSubscribe; + FOnEnsureFetched: TBoldEnsureFetched; FRepresentations: TStringList; + FOnValidateCharacter: TBoldValidateCharacter; function GetRepresentations: TStrings; procedure SetRepresentations(Value: TStrings); function StoreRepresentations: Boolean; @@ -100,12 +139,17 @@ TBoldRenderer = class(TBoldSubscribableComponentViaBoldElem) class function GetExpressionAsDirectElement(Element: TBoldElement; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): TBoldElement; function GetRendererDataClass: TBoldRendererDataClass; virtual; function GetSupportsMulti: Boolean; virtual; + procedure DefaultHoldsChangedValue(aFollower: TBoldFollower); virtual; + procedure DefaultReleaseChangedValue(aFollower: TBoldFollower); virtual; + function DefaultMayModify(aFollower: TBoldFollower): Boolean; virtual; + function DefaultValidateCharacter(aFollower: TBoldFollower; C: Char): Boolean; virtual; procedure DefaultStartDrag(Element: TBoldElement; DragMode: TBoldDragMode; RendererData: TBoldRendererData); virtual; procedure DefaultEndDrag(DragMode: TBoldDragMode; InternalDrag: Boolean); virtual; function DefaultDragOver(Element: TBoldElement; DropMode: TBoldDropMode; InternalDrag: Boolean; RendererData: TBoldRendererData; dropindex: Integer): Boolean; virtual; procedure DefaultDragDrop(Element: TBoldElement; DropMode: TBoldDropMode; dropindex: Integer); virtual; procedure DrawOnCanvas(Follower: TBoldFollower; Canvas: TCanvas; Rect: TRect; Aligment: TAlignment; Margins: TPoint); virtual; - function HasEventOverrides: boolean; virtual; + function HasSetValueEventOverrides: boolean; virtual; + function ValidateCharacter(aFollower: TBoldFollower; C: Char): Boolean; virtual; function GetDefaultRepresentationStringList: TStringList; virtual; property OnStartDrag: TBoldStartDrag read FOnStartDrag write FOnStartDrag; property OnEndDrag: TBoldEndDrag read FOnEndDrag write FOnEndDrag; @@ -113,18 +157,17 @@ TBoldRenderer = class(TBoldSubscribableComponentViaBoldElem) property OnDragDrop: TBoldDragDrop read FOnDragDrop write FOnDragDrop; public destructor Destroy; override; - procedure Changed; - function DefaultMayModify(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): Boolean; virtual; - procedure DefaultHoldsChangedValue(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber); virtual; - procedure DefaultReleaseChangedValue(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList;Subscriber: TBoldSubscriber); virtual; - function MayModify(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): Boolean; virtual; - procedure HoldsChangedValue(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber); virtual; - procedure ReleaseChangedValue(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber); virtual; + procedure Assign(Source: TPersistent); override; + procedure Changed; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function MayModify(aFollower: TBoldFollower): Boolean; virtual; + procedure HoldsChangedValue(Follower: TBoldFollower); virtual; + procedure ReleaseChangedValue(Follower: TBoldFollower); virtual; procedure StartDrag(Element: TBoldElement; DragMode: TBoldDragMode; RendererData: TBoldRendererData); virtual; procedure EndDrag(DragMode: TBoldDragMode; InternalDrag: Boolean); virtual; function DragOver(Element: TBoldElement; DropMode: TBoldDropMode; InternalDrag: Boolean; RendererData: TBoldRendererData; dropindex: Integer): Boolean; virtual; procedure DragDrop(Element: TBoldElement; DropMode: TBoldDropMode; dropindex: Integer); virtual; - procedure SubscribeToElement(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; Subscriber: TBoldSubscriber; VariableList: TBoldExternalVariableList = nil); + procedure SubscribeToElement(aFollower: TBoldFollower); + procedure EnsureFetched(List: TBoldObjectList; BoldType: TBoldClassTypeInfo; Expression: TBoldExpression); property RendererDataClass: TBoldRendererDataClass read GetRendererDataClass; property SupportsMulti: Boolean read GetSupportsMulti; published @@ -133,6 +176,8 @@ TBoldRenderer = class(TBoldSubscribableComponentViaBoldElem) property OnHoldsChangedValue: TBoldHoldsChangedValue read FOnHoldsChangedValue write FOnHoldsChangedValue; property OnReleaseChangedValue: TBoldReleaseChangedValue read FOnReleaseChangedValue write FOnReleaseChangedValue; property OnSubscribe: TBoldSubscribe read FOnSubscribe write SetOnSubscribe; + property OnEnsureFetched: TBoldEnsureFetched read FOnEnsureFetched write FOnEnsureFetched; + property OnValidateCharacter: TBoldValidateCharacter read FOnValidateCharacter write FOnValidateCharacter; end; { TBoldFollower } @@ -140,56 +185,69 @@ TBoldFollower = class(TBoldQueueable) private fIndex: Integer; fOwningFollower: TBoldFollower; -// fSelected: Boolean; fState: TBoldFollowerState; fElement: TBoldElement; fRendererData: TBoldRendererData; fController: TBoldFollowerController; fControlData: TObject; FSubscriber: TBoldSubscriber; - function GetActive: Boolean; + FIndirectElement: TBoldIndirectElement; + function GetActive: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetActive(Value: Boolean); - function GetElementValid: Boolean; + function GetElementValid: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetElementValid(Value: Boolean); - function GetSubFollower(index: Integer): TBoldFollower; - function GetSubFollowerCount: Integer; - function GetCurrentIndex: Integer; + function GetSubFollower(index: Integer): TBoldFollower; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetEnsuredSubFollower(Index: Integer): TBoldFollower; + function GetSubFollowerCount: Integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetCurrentIndex: Integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetCurrentIndex(index: integer); - procedure SetElement(theElement: TBoldElement); - procedure SetState(Value: TBoldFollowerState); - function GetRendererData: TBoldRendererData; - procedure CollectMatchingDownwards(Followers: TBoldObjectArray; MatchController: TBoldFollowerController); - function GetAssertedController: TBoldFollowerController; + procedure SetElement(AElement: TBoldElement); + procedure SetState(AValue: TBoldFollowerState); + function GetRendererData: TBoldRendererData; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function CollectMatchingDownwards(Followers: TBoldFollowerArray; MatchController: TBoldFollowerController): TBoldFollowerArray; + function GetAssertedController: TBoldFollowerController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetCurrentSubFollower: TBoldFollower; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetIsDirty: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetValue: TBoldElement; + function GetSubFollowerAssigned(index: Integer): boolean; protected + function GetDebugInfo: string; override; procedure AddToDisplayList; override; procedure Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); - {The following two are virtual to allow overriden in the old hierarchy} - procedure MakeUptoDateAndSubscribe; // Displays, i.e. moves from B.O. to RendereData, also resubscribes if needed - class procedure MultiMakeUptodateAndSubscribe(Followers: TBoldObjectArray); - procedure MakeClean; // Applies, i.e. moves from rendererdata to B.O. + procedure MakeUptodateAndSubscribe; + class procedure MultiMakeUptodateAndSubscribe(Followers: TBoldFollowerArray); + procedure MakeClean; {State handling} procedure MarkDirty; - procedure MarkClean; - procedure CollectMatching(Followers: TBoldObjectArray; MatchController: TBoldFollowerController); + procedure MarkClean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure MarkEnsured; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function CollectMatching(MatchController: TBoldFollowerController): TBoldFollowerArray; + function CollectMatchingSiblings(WindowSize: Integer): TBoldFollowerArray; + property Ensured: Boolean index befFollowerEnsured read GetElementFlag write SetElementFlag; public constructor Create(MatchObject: TObject; Controller: TBoldFollowerController); constructor CreateSubFollower( OwningFollower: TBoldFollower; - Controller: TBoldFollowerController; - Element: TBoldElement); + aController: TBoldFollowerController; + aElement: TBoldElement; + aActive: boolean; + aIndex: integer); destructor Destroy; override; + procedure SetElementAndMakeCurrent(AElement: TBoldElement; AActive: boolean); procedure Display; override; procedure Apply; override; procedure MarkValueOutOfDate; procedure MarkSubscriptionOutOfDate; function CheckIfInHierarchy(aElement: TBoldElement; aController: TBoldFollowerController): Boolean; - procedure ControlledValueChanged(IsChanged: Boolean); + procedure ControlledValueChanged; procedure DiscardChange; override; - function Displayable: Boolean; + function Displayable: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure EnsureDisplayable; function ExistInOwner: Boolean; - function MayChange: Boolean; + function MayChange: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function MayModify: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure EnsureMulti; + procedure EnsureSiblings; property Active: Boolean read GetActive write SetActive; property ElementValid: Boolean read GetElementValid write SetElementValid; property Controller: TBoldFollowerController read fController; @@ -201,10 +259,16 @@ TBoldFollower = class(TBoldQueueable) property OwningFollower: TBoldFollower read FOwningFollower; property RendererData: TBoldRendererData read GetRendererData; property State: TBoldFollowerState read fState; + property IsDirty: boolean read GetIsDirty; property Selected: Boolean index befFollowerSelected read GetElementFlag write SetElementFlag; + property ResultElementOutOfDate: Boolean index befFollowerResultElementOutOfDate read GetElementFlag write SetElementFlag; property SubFollowerCount: Integer read GetSubFollowerCount; property SubFollowers[index: Integer]: TBoldFollower read GetSubFollower; + property SubFollowerAssigned[index: Integer]: boolean read GetSubFollowerAssigned; + property CurrentSubFollower : TBoldFollower read GetCurrentSubFollower; + property EnsuredSubFollowers[Index: Integer]: TBoldFollower read GetEnsuredSubFollower; property Subscriber: TBoldSubscriber read fSubscriber; + property Value: TBoldElement read GetValue; end; { TBoldFollowerController } @@ -225,14 +289,15 @@ TBoldFollowerController = class(TBoldSubscribablePersistent) fComponentSubscriber: TBoldPassthroughSubscriber; FOnGetContextType: TBoldGetContextTypeEvent; fVariables: TBoldOclVariables; + fApplyException: TBoldApplyExceptionEvent; + fDisplayException: TBoldDisplayExceptionEvent; procedure _Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); - function GetRendererDataClass: TBoldRendererDataClass; + function GetRendererDataClass: TBoldRendererDataClass; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetRepresentation(Value: TBoldRepresentation); - procedure SetExpression(Value: string); + procedure SetExpression(const Value: string); procedure SetUntypedRenderer(NewRender: TBoldRenderer); procedure SetVariables(const Value: TBoldOclVariables); procedure Resubscribe; - function GetVariableList: TBoldExternalVariableList; function GetSupportsMulti: Boolean; function HandleApplyException(E: Exception; Elem: TBoldElement; var Discard: Boolean): Boolean; function HandleDisplayException(E: Exception; Elem: TBoldElement): Boolean; @@ -240,19 +305,19 @@ TBoldFollowerController = class(TBoldSubscribablePersistent) function GetOwner: TPersistent; override; function GetEffectiveRenderer: TBoldRenderer; virtual; function GetContextType: TBoldElementTypeInfo; virtual; + function GetVariableList: TBoldExternalVariableList; virtual; procedure DoMakeUptodateAndSubscribe(Follower: TBoldFollower; Subscribe: Boolean); virtual; - procedure DoMultiMakeUptodateAndSubscribe(Followers: TBoldObjectArray); virtual; - procedure Changed; + procedure DoMultiMakeUptodateAndSubscribe(Followers: TBoldFollowerArray); virtual; + procedure Changed; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure DoAssign(Source: TPersistent); virtual; + function DoApplyException(E: Exception; Elem: TBoldElement; var Discard: Boolean): Boolean; + function DoDisplayException(E: Exception; Elem: TBoldElement): Boolean; procedure CleanRendererData(RendererData: TBoldRendererData); virtual; - procedure MultiMakeEnsure(Followers: TBoldObjectArray); + procedure MultiMakeEnsure(Followers: TBoldFollowerArray); function GetSupportsMultiEnsure: Boolean; virtual; property EffectiveRenderer: TBoldRenderer read GetEffectiveRenderer; property RendererDataClass: TBoldRendererDataClass read GetRendererDataClass; - property OwningComponent: TComponent read FOwningComponent; property InternalDrag: Boolean read FInternalDrag write FInternalDrag; - property Representation: TBoldRepresentation read FRepresentation write SetRepresentation default brDefault; - property Expression: TBoldExpression read FExpression write SetExpression nodefault; property UntypedRenderer: TBoldRenderer read fUntypedRenderer write SetUntypedRenderer; property Variables: TBoldOclVariables read fVariables write SetVariables; public @@ -260,20 +325,22 @@ TBoldFollowerController = class(TBoldSubscribablePersistent) destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure MakeClean(Follower: TBoldFollower); virtual; - function MayModify(Follower: TBoldFollower): Boolean; - procedure HoldsChangedValue(Follower: TBoldFollower); - procedure ReleaseChangedValue(Follower: TBoldFollower); + function MayModify(Follower: TBoldFollower): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure HoldsChangedValue(Follower: TBoldFollower); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure ReleaseChangedValue(Follower: TBoldFollower); {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetVariableListAndSubscribe(Subscriber: TBoldSubscriber): TBoldExternalVariableList; procedure StartDrag(Follower: TBoldFollower); procedure EndDrag; - procedure MakeUptodateAndSubscribe(Follower: TBoldFollower; Subscribe: Boolean); - procedure SubscribeToElement(Element: TBoldElement; Subscriber: TBoldSubscriber); - procedure MultiMakeUptodateAndSubscribe(Followers: TBoldObjectArray); + procedure MakeUptodateAndSubscribe(aFollower: TBoldFollower; Subscribe: Boolean); + procedure SubscribeToElement(aFollower: TBoldFollower); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure MultiMakeUptodateAndSubscribe(Followers: TBoldFollowerArray); function DragOver(Follower: TBoldFollower; ReceivingElement: TBoldElement; dropindex: Integer): Boolean; virtual; procedure DragDrop(Follower: TBoldFollower; ReceivingElement: TBoldElement; dropindex: Integer); virtual; procedure DrawOnCanvas(Follower: TBoldFollower; Canvas: TCanvas; Rect: TRect; Alignment: TAlignment; Margins: TPoint); virtual; + function SubFollowersActive: boolean; virtual; + property OwningComponent: TComponent read FOwningComponent; property ApplyPolicy: TBoldApplyPolicy read FApplyPolicy write FApplyPolicy default bapExit; - property CleanOnEqual: Boolean read FCleanOnEqual write FCleanOnEqual default false; + property CleanOnEqual: Boolean read FCleanOnEqual write FCleanOnEqual default true; property Popup: TBoldPopup read FPopup write FPopup; {temporarily} property AfterMakeUptoDate: TBoldFollowerEvent read fAfterMakeUptoDate write fAfterMakeUptoDate; property BeforeMakeUptoDate: TBoldFollowerEvent read fBeforeMakeUptoDate write fBeforeMakeUptoDate; @@ -282,16 +349,19 @@ TBoldFollowerController = class(TBoldSubscribablePersistent) property VariableList: TBoldExternalVariableList read GetVariableList; property SupportsMulti: Boolean read GetSupportsMulti; property SupportsMultiEnsure : Boolean read GetSupportsMultiEnsure; + property Expression: TBoldExpression read FExpression write SetExpression nodefault; + property Representation: TBoldRepresentation read FRepresentation write SetRepresentation default brDefault; published - property DragMode: TBoldDragMode read FDragMode write FDragMode default bdgNone; - property DropMode: TBoldDropMode read FDropMode write FDropMode default bdpNone; - // property Popup: TBoldPopup read fPopup write fPopup; + property DragMode: TBoldDragMode read FDragMode write FDragMode default DefaultBoldDragMode; + property DropMode: TBoldDropMode read FDropMode write FDropMode default DefaultBoldDropMode; + property OnApplyException: TBoldApplyExceptionEvent read fApplyException write fApplyException; + property OnDisplayException: TBoldDisplayExceptionEvent read fDisplayException write fDisplayException; end; { TBoldSingleRenderer } TBoldSingleRenderer = class(TBoldRenderer) public - procedure MakeUptodateAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldFollowerController; Subscriber: TBoldSubscriber); virtual; abstract; + procedure MakeUptodateAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); virtual; abstract; end; { TBoldSingleFollowerController } @@ -312,7 +382,7 @@ TBoldSingleFollowerController = class(TBoldFollowerController) { TBoldPopup } TBoldPopup = class(TPersistent) private - FEnable: Boolean; // FIXME notify owner of change here + FEnable: Boolean; FInsertNew: Boolean; FDelete: TBoldPopupDeleteType; FMove: Boolean; @@ -326,7 +396,7 @@ TBoldPopup = class(TPersistent) property Move: Boolean read FMove write FMove default False; end; -{$IFDEF BOLDCOMCLIENT} // List/InterfaceArray +{$IFDEF BOLDCOMCLIENT} type TBoldClientableList = TBoldInterfaceArray; @@ -343,12 +413,15 @@ implementation uses BoldExceptionHandlers, BoldGuiResourceStrings, -{$IFNDEF BOLDCOMCLIENT} // uses - BoldSystem, - BoldSystemRT, +{$IFNDEF BOLDCOMCLIENT} BoldGUI, {$ENDIF} - BoldGuard; +{$IFDEF SpanFetch} + AttracsSpanFetchManager, +{$ENDIF} + BoldGuard, + BoldListControlPack, + BoldDomainElement; const breVariablesRemoved = 42; @@ -360,7 +433,7 @@ implementation var DefaultRenderer: TBoldRenderer; -{$IFDEF BOLDCOMCLIENT} // BoldTestType +{$IFDEF BOLDCOMCLIENT} function BoldTestType(element: IUnknown; const TypeOrInterface: TGUID): Boolean; var Res: IUnknown; @@ -388,7 +461,7 @@ function TBoldRendererData.GetSubFollowerCount: Integer; function TBoldRendererData.GetSubFollower(index: Integer): TBoldFollower; begin - raise EBold.CreateFmt(sClassHasNoSubfollowers, [ClassName]); + raise EBold.CreateFmt('%s: This class has no subfollowers', [ClassName]); end; function TBoldRendererData.GetCurrentSubFollowerIndex: Integer; @@ -396,6 +469,12 @@ function TBoldRendererData.GetCurrentSubFollowerIndex: Integer; Result := -1; end; +function TBoldRendererData.GetEnsuredSubFollower( + Index: Integer): TBoldFollower; +begin + result := GetSubFollower(Index); +end; + { TBoldFollowerController } constructor TBoldFollowerController.Create(aOwningComponent: TComponent); @@ -404,16 +483,20 @@ constructor TBoldFollowerController.Create(aOwningComponent: TComponent); fComponentSubscriber := TBoldPassthroughSubscriber.Create(_Receive); FOwningComponent := aOwningComponent; FApplyPolicy := bapExit; - FDragMode := bdgNone; - FDropMode := bdpNone; + FDragMode := DefaultBoldDragMode; + FDropMode := DefaultBoldDropMode; FPopup := TBoldPopup.Create; FRepresentation := brDefault; + fCleanOnEqual := true; end; destructor TBoldFollowerController.Destroy; begin FreeAndNil(fComponentSubscriber); FreeAndNil(FPopup); + fBeforeMakeUptodate := nil; + fAfterMakeUptodate := nil; + fVariables := nil; inherited; end; @@ -425,6 +508,14 @@ procedure TBoldFollowerController.Assign(Source: TPersistent); inherited Assign(Source); end; +function TBoldFollowerController.DoApplyException(E: Exception; + Elem: TBoldElement; var Discard: Boolean): Boolean; +begin + result := false; + if Assigned(fApplyException) then + result := fApplyException(E, Elem, Discard); +end; + procedure TBoldFollowerController.DoAssign(Source: TPersistent); begin Assert(Source is TBoldFollowerController); @@ -440,21 +531,35 @@ procedure TBoldFollowerController.DoAssign(Source: TPersistent); UntypedRenderer := (TBoldFollowerController(Source).UntypedRenderer); end; -procedure TBoldFollowerController.MakeUptodateAndSubscribe(Follower: TBoldFollower; Subscribe: Boolean); +function TBoldFollowerController.DoDisplayException(E: Exception; + Elem: TBoldElement): Boolean; +begin + result := false; + if Assigned(fApplyException) then + result := fDisplayException(E, Elem); +end; + +procedure TBoldFollower.MarkClean; +begin + SetState(bfsCurrent); +end; + +procedure TBoldFollowerController.MakeUptodateAndSubscribe(aFollower: TBoldFollower; Subscribe: Boolean); begin if Assigned(BeforeMakeUptoDate) then - BeforeMakeUptoDate(Follower); + BeforeMakeUptoDate(aFollower); try - DoMakeUptodateAndSubscribe(Follower, Subscribe); + DoMakeUptodateAndSubscribe(aFollower, Subscribe); finally + aFollower.MarkClean; if Assigned(AfterMakeUptoDate) then - AfterMakeUptoDate(Follower); + AfterMakeUptoDate(aFollower); end; end; procedure TBoldFollowerController.MakeClean(Follower: TBoldFollower); begin - raise EBoldInternal.CreateFmt(sNotImplemented, [ClassName, 'MakeClean']); // do not localize + raise EBoldInternal.CreateFmt('%s.MakeClean not implemented', [ClassName]); end; procedure TBoldFollowerController.Changed; @@ -479,7 +584,64 @@ function TBoldFollowerController.GetEffectiveRenderer: TBoldRenderer; procedure TBoldFollowerController.DoMakeUptodateAndSubscribe(Follower: TBoldFollower; Subscribe: Boolean); begin - Follower.RendererData.MayModify := EffectiveRenderer.MayModify(Follower.Element, Representation, Expression, GetVariableListAndSubscribe(Follower.Subscriber), Follower.Subscriber); +end; + +function TBoldFollower.GetAssertedController: TBoldFollowerController; +begin + if not assigned(fController) then + raise EBold.CreateFmt('%s.GetAssertedController: Controller not assigned', [classname]); + result := fController; +end; + +function TBoldFollower.GetActive: Boolean; +begin + Result := not (State in [bfsInactiveValidElement, bfsInactiveInvalidElement]); +end; + +function TBoldFollower.GetElementValid: Boolean; +begin + Result := State <> bfsInactiveInValidElement; +end; + +function TBoldFollower.GetRendererData: TBoldRendererData; +begin + if not Active then + raise EBold.Create(SBoldInactiveFollowerNoRenderData); + if not Assigned(FRendererData) then + FRendererData := AssertedController.RendererDataClass.Create(Self); + Result := FRendererData; +end; + +function TBoldFollower.GetSubFollower(index: Integer): TBoldFollower; +begin + Result := RendererData.GetSubFollower(index); +end; + +function TBoldFollower.GetEnsuredSubFollower( + Index: Integer): TBoldFollower; +begin + Result := RendererData.GetEnsuredSubFollower(index); +end; + +function TBoldFollower.GetSubFollowerCount: Integer; +begin + if Active then + Result := RendererData.GetSubFollowerCount + else + result := 0 +end; + +function TBoldFollower.GetCurrentIndex: Integer; +begin + Result := RendererData.GetCurrentSubFollowerIndex; +end; + +function TBoldFollower.GetCurrentSubFollower: TBoldFollower; +begin + if CurrentIndex = -1 then + result := nil + else + Result := SubFollowers[CurrentIndex]; end; procedure TBoldFollowerController.StartDrag(Follower: TBoldFollower); @@ -520,13 +682,11 @@ procedure TBoldFollowerController.DragDrop(Follower: TBoldFollower; ReceivingEle except on E: Exception do begin - Discard := true; Handled := HandleApplyException(E, ReceivingElement, Discard); if Discard then Follower.DiscardChange; if not Handled then raise; - end; end; end; @@ -538,7 +698,7 @@ procedure TBoldFollowerController.DrawOnCanvas(Follower: TBoldFollower; Canvas: function TBoldFollowerController.MayModify(Follower: TBoldFollower): Boolean; begin - Result := Follower.RendererData.MayModify; + result := EffectiveRenderer.MayModify(Follower) end; procedure TBoldFollowerController.SetRepresentation(Value: TBoldRepresentation); @@ -550,7 +710,7 @@ procedure TBoldFollowerController.SetRepresentation(Value: TBoldRepresentation); end; end; -procedure TBoldFollowerController.SetExpression(Value: string); +procedure TBoldFollowerController.SetExpression(const Value: string); begin if Value <> Expression then begin @@ -571,12 +731,12 @@ procedure TBoldFollowerController.SetUntypedRenderer(NewRender: TBoldRenderer); procedure TBoldFollowerController.HoldsChangedValue(Follower: TBoldFollower); begin - EffectiveRenderer.HoldsChangedValue(Follower.Element, Representation, Expression, VariableList, Follower.Subscriber); + EffectiveRenderer.HoldsChangedValue(Follower); end; procedure TBoldFollowerController.ReleaseChangedValue(Follower: TBoldFollower); begin - EffectiveRenderer.ReleaseChangedValue(Follower.Element, Representation, Expression, VariableList, Follower.Subscriber); + EffectiveRenderer.ReleaseChangedValue(Follower); end; { TBoldSingleFollowerController } @@ -586,9 +746,9 @@ procedure TBoldSingleFollowerController.DoMakeUptodateAndSubscribe(Follower: TBo with EffectiveRenderer as TBoldSingleRenderer do begin if Subscribe then - MakeUptodateAndSubscribe(Follower.Element, Follower.RendererData, Self, Follower.Subscriber) + MakeUptodateAndSubscribe(Follower, Follower.Subscriber) else - MakeUptodateAndSubscribe(Follower.Element, Follower.RendererData, Self, nil); + MakeUptodateAndSubscribe(Follower, nil); end; end; @@ -614,7 +774,6 @@ procedure TBoldRenderer.SetRepresentations(Value: TStrings); end; function TBoldRenderer.StoreRepresentations: Boolean; - // Don't store the stringlist if it's empty or if it's equal to the default representation stringlist. begin Result := False; if Assigned(FRepresentations) and (FRepresentations.Count > 0) then @@ -630,11 +789,18 @@ class function TBoldRenderer.GetExpressionAsDirectElement(Element: TBoldElement; begin Result := nil; if Assigned(Element) then - {$IFDEF BOLDCOMCLIENT} // GetAsDirectElement // FIXME: VariableList is lost - Result := Element.EvaluateExpression(Expression); - {$ELSE} - Result := Element.EvaluateExpressionAsDirectElement(Expression, VariableList); - {$ENDIF} + begin + if Expression = '' then + begin + Result := Element; + end + else + {$IFDEF BOLDCOMCLIENT} + Result := Element.EvaluateExpression(Expression); + {$ELSE} + Result := Element.EvaluateExpressionAsDirectElement(Expression, VariableList); + {$ENDIF} + end; end; function TBoldRenderer.GetRendererDataClass: TBoldRendererDataClass; @@ -658,62 +824,111 @@ function TBoldRenderer.GetDefaultRepresentationStringList: TStringList; end; end; -function TBoldRenderer.DefaultMayModify(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): Boolean; +function TBoldRenderer.DefaultMayModify(aFollower: TBoldFollower): Boolean; + + function CheckPessimisticLocking(AElement: TBoldDomainElement): boolean; + var + BoldSystem: TBoldSystem; + begin + result := true; + BoldSystem := TBoldDomainElement(AElement).BoldSystem as TBoldSystem; + if Assigned(BoldSystem) and Assigned(BoldSystem.PessimisticLockHandler) then + result := BoldSystem.PessimisticLockHandler.LockElement(AElement); + end; + var ValueElement: TBoldElement; begin - ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); + ValueElement := aFollower.Value; if Assigned(ValueElement) then - {$IFDEF BOLDCOMCLIENT} // DefaultMayModify // fixme - result := ValueElement.mutable + begin + {$IFDEF BOLDCOMCLIENT} + result := ValueElement.mutable; {$ELSE} - Result := ValueElement.ObserverMayModify(Subscriber) + Result := ValueElement.ObserverMayModify(aFollower.Subscriber); {$ENDIF} + if (ValueElement is TBoldDomainElement) then + result := result and CheckPessimisticLocking(ValueElement as TBoldDomainElement); + end else Result := False; end; -procedure TBoldRenderer.DefaultHoldsChangedValue(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber); -{$IFNDEF BOLDCOMCLIENT} // DefaultHoldsChangedValue +procedure TBoldRenderer.DefaultHoldsChangedValue(aFollower: TBoldFollower); +{$IFNDEF BOLDCOMCLIENT} var ValueElement: TBoldElement; begin - ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); + ValueElement := aFollower.Value; if Assigned(ValueElement) then - ValueElement.RegisterModifiedValueHolder(Subscriber) - else - raise EBold.CreateFmt(sCannotModifyValue, [ClassName]); + ValueElement.RegisterModifiedValueHolder(aFollower.Subscriber) end; {$ELSE} begin end; {$ENDIF} -procedure TBoldRenderer.DefaultReleaseChangedValue(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber); -{$IFNDEF BOLDCOMCLIENT} // defaultReleaseChangedValue +procedure TBoldRenderer.DefaultReleaseChangedValue(aFollower: TBoldFollower); +{$IFNDEF BOLDCOMCLIENT} var ValueElement: TBoldElement; begin - ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); + ValueElement := aFollower.Value; if Assigned(ValueElement) then - ValueElement.UnRegisterModifiedValueHolder(Subscriber) + ValueElement.UnRegisterModifiedValueHolder(aFollower.Subscriber) end; {$ELSE} begin end; {$ENDIF} -function TBoldRenderer.MayModify(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): Boolean; +function TBoldRenderer.MayModify(aFollower: TBoldFollower): Boolean; begin - if Assigned(FOnMayModify) and - Assigned(Element) then - Result := OnMayModify(Element, Representation, Expression, Subscriber) - else if HasEventOverrides then - // this forces readonly of renderers that has an OnSubscribeEvent but no OnMayModify - // OnMayModify is mandatory for a writeable renderer. - result := false + if Assigned(aFollower.Value) then + begin + Result := aFollower.Value.ObserverMayModify(aFollower.Subscriber); + if not result then + Result := HasSetValueEventOverrides and + ((aFollower.Value.ModifiedValueHolder = nil) or (aFollower.Value.ModifiedValueHolder = aFollower.Subscriber)); + end + else + Result := HasSetValueEventOverrides; + if Assigned(FOnMayModify) then + Result := Result and OnMayModify(aFollower) else - Result := DefaultMayModify(Element, Representation, Expression, VariableList, Subscriber) + Result := Result and HasSetValueEventOverrides or DefaultMayModify(aFollower); +end; + +procedure TBoldRenderer.EnsureFetched(List: TBoldObjectList; BoldType: TBoldClassTypeInfo; Expression: TBoldExpression); +{$IFNDEF SpanFetch} +var + ListType: TBoldListTypeInfo; + RealObjectList: TBoldObjectList; + ie: TBoldIndirectElement; + i: Integer; +{$ENDIF} +begin + if assigned(FOnEnsureFetched) then + FOnEnsureFetched(List, expression) + else if Expression <> '' then + {$IFDEF SpanFetch} + FetchOclSpan(List, Expression); + {$ELSE} + if (List.Count > 1) then + begin + try + List.EnsureObjects; + ListType := BoldType.ListTypeInfo; + RealObjectlist := TBoldMemberFactory.CreateMemberFromBoldType(ListType) as TBoldObjectList; + RealObjectList.AddList(List); + ie := TBoldIndirectElement.Create; + RealObjectList.EvaluateExpression('self->collect(' + Expression + ')', ie); + finally + FreeAndNil(RealObjectList); + FreeAndNil(ie); + end; + end; +{$ENDIF} end; function TBoldRenderer.GetSupportsMulti: Boolean; @@ -721,29 +936,29 @@ function TBoldRenderer.GetSupportsMulti: Boolean; Result := false; end; -procedure TBoldRenderer.HoldsChangedValue(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber); +procedure TBoldRenderer.HoldsChangedValue(Follower: TBoldFollower); begin if Assigned(FOnHoldsChangedValue) then - OnHoldsChangedValue(Element, Representation, Expression, Subscriber) + OnHoldsChangedValue(Follower) else - DefaultHoldsChangedValue(Element, Representation, Expression, VariableList, Subscriber) + DefaultHoldsChangedValue(Follower) end; -procedure TBoldRenderer.ReleaseChangedValue(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber); +procedure TBoldRenderer.ReleaseChangedValue(Follower: TBoldFollower); begin if Assigned(FOnReleaseChangedValue) then - OnReleaseChangedValue(Element, Representation, Expression, Subscriber) + OnReleaseChangedValue(Follower) else - DefaultReleaseChangedValue(Element, Representation, Expression, VariableList, Subscriber) + DefaultReleaseChangedValue(Follower) end; procedure TBoldRenderer.DefaultStartDrag(Element: TBoldElement; DragMode: TBoldDragMode; RendererData: TBoldRendererData); -{$IFNDEF BOLDCOMCLIENT} // DragDrop +{$IFNDEF BOLDCOMCLIENT} var Obj: TBoldObject; -{$ENDIF} +{$ENDIF} begin - {$IFNDEF BOLDCOMCLIENT} // DragDrop + {$IFNDEF BOLDCOMCLIENT} if BoldGUIHandler.DraggedObjects.Count <> 0 then raise EBold.Create(SDraggedObjectsNotCleared); @@ -762,16 +977,27 @@ procedure TBoldRenderer.DefaultStartDrag(Element: TBoldElement; DragMode: TBoldD {$ENDIF} end; +function TBoldRenderer.DefaultValidateCharacter(aFollower: TBoldFollower; C: Char): Boolean; +var + ValueElement: TBoldElement; +begin + ValueElement := aFollower.Value; + if Assigned(ValueElement) then + Result := ValueElement.ValidateCharacter(C, aFollower.AssertedController.Representation) + else + Result := True; +end; + procedure TBoldRenderer.DefaultEndDrag(DragMode: TBoldDragMode; InternalDrag: Boolean); begin - {$IFNDEF BOLDCOMCLIENT} // dragdrop + {$IFNDEF BOLDCOMCLIENT} BoldGUIHandler.DraggedObjects.Clear; {$ENDIF} end; function TBoldRenderer.DefaultDragOver(Element: TBoldElement; DropMode: TBoldDropMode; InternalDrag: Boolean; RendererData: TBoldRendererData; dropindex: Integer): Boolean; begin - {$IFDEF BOLDCOMCLIENT} // dragdrop + {$IFDEF BOLDCOMCLIENT} result := false; {$ELSE} Result := Assigned(Element) and Element.ObserverMayModify(Self) and @@ -781,7 +1007,7 @@ function TBoldRenderer.DefaultDragOver(Element: TBoldElement; DropMode: TBoldDro end; procedure TBoldRenderer.DefaultDragDrop(Element: TBoldElement; DropMode: TBoldDropMode; dropindex: Integer); -{$IFNDEF BOLDCOMCLIENT} // dragdrop +{$IFNDEF BOLDCOMCLIENT} var i: integer; offset, @@ -789,17 +1015,18 @@ procedure TBoldRenderer.DefaultDragDrop(Element: TBoldElement; DropMode: TBoldDr BoldObject: TBoldObject; TheLink: TBoldObjectReference; TheList: TBoldObjectList; + DraggedObjects: TBoldObjectList; begin + DraggedObjects := BoldGUIHandler.DraggedObjects; if element is TBoldObjectReference then begin TheLink := Element as TBoldObjectReference; - with BoldGUIHandler.DraggedObjects do - if Count = 0 then - BoldObject := nil - else if Count = 1 then - BoldObject := BoldObjects[0] - else - raise EBold.Create(SCannotDragOverMultipleObjects); + if DraggedObjects.Count = 0 then + BoldObject := nil + else if DraggedObjects.Count = 1 then + BoldObject := DraggedObjects[0] + else + raise EBold.Create(SCannotDragOverMultipleObjects); case DropMode of bdpInsert, bdpAppend: if Assigned(TheLink.BoldObject) and Assigned(BoldObject) then @@ -815,25 +1042,25 @@ procedure TBoldRenderer.DefaultDragDrop(Element: TBoldElement; DropMode: TBoldDr TheList := Element as TBoldObjectlist; case DropMode of bdpAppend: - for i := 0 to BoldGUIHandler.DraggedObjects.Count - 1 do - if TheList.IndexOf(BoldGUIHandler.DraggedObjects[I]) = -1 then - TheList.Add(BoldGUIHandler.DraggedObjects[i]); + for i := 0 to DraggedObjects.Count - 1 do + if TheList.IndexOf(DraggedObjects[I]) = -1 then + TheList.Add(DraggedObjects[i]); bdpReplace: - raise EBoldFeatureNotImplementedYet.CreateFmt(sReplaceNotImplemented, [ClassName]); + raise EBoldFeatureNotImplementedYet.CreateFmt('%s.DefaultDragDrop: Replace not implemented yet', [ClassName]); bdpInsert: begin if dropindex < 0 then dropindex := 0; - for I := 0 to BoldGUIHandler.DraggedObjects.Count - 1 do + for I := 0 to DraggedObjects.Count - 1 do begin - prevIndex := TheList.IndexOf(BoldGUIHandler.DraggedObjects[I]); + prevIndex := TheList.IndexOf(DraggedObjects[I]); Offset := 0; if prevIndex = -1 then begin if dropindex < TheList.Count then - TheList.Insert(dropindex + Offset, BoldGUIHandler.DraggedObjects[I]) + TheList.Insert(dropindex + Offset, DraggedObjects[I]) else - TheList.Add(BoldGUIHandler.DraggedObjects[I]); + TheList.Add(DraggedObjects[I]); INC(dropindex); end else @@ -876,16 +1103,27 @@ function TBoldRenderer.DragOver(Element: TBoldElement; DropMode: TBoldDropMode; Result := DefaultDragOver(Element, DropMode, InternalDrag, RendererData, dropindex) end; -procedure TBoldRenderer.SubscribeToElement(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; Subscriber: TBoldSubscriber; VariableList: TBoldExternalVariableList = nil); +procedure TBoldRenderer.SubscribeToElement(aFollower: TBoldFollower); begin - if assigned(fOnSubscribe) then - fOnSubscribe(element, representation, expression, subscriber) - else if assigned(Element) then - {$IFDEF BOLDCOMCLIENT} - Element.SubscribeToExpression(Expression, Subscriber.ClientId, Subscriber.SubscriberId, False, false); - {$ELSE} - Element.SubscribeToExpression(expression, subscriber, false, false, variableList); - {$ENDIF} + if Assigned(aFollower.Element) then + begin + if assigned(fOnSubscribe) then + fOnSubscribe(aFollower, aFollower.Subscriber) + else + {$IFDEF BOLDCOMCLIENT} + Element.SubscribeToExpression(Expression, Subscriber.ClientId, Subscriber.SubscriberId, False, false); + {$ELSE} + aFollower.Element.SubscribeToExpression(aFollower.AssertedController.Expression, aFollower.subscriber, false, false, aFollower.Controller.GetVariableListAndSubscribe(aFollower.subscriber)); + {$ENDIF} + end; +end; + +function TBoldRenderer.ValidateCharacter(aFollower: TBoldFollower; C: Char): Boolean; +begin + if Assigned(FOnValidateCharacter) then + Result := OnValidateCharacter(aFollower, C) + else + Result := DefaultValidateCharacter(aFollower, C); end; procedure TBoldRenderer.DragDrop(Element: TBoldElement; DropMode: TBoldDropMode; dropindex: Integer); @@ -900,41 +1138,98 @@ procedure TBoldRenderer.DrawOnCanvas(Follower: TBoldFollower; Canvas: TCanvas; R begin end; -function TBoldRenderer.HasEventOverrides: boolean; +function TBoldRenderer.HasSetValueEventOverrides: boolean; begin - result := assigned(fOnSubscribe); + result := false; end; { TBoldFollower } +procedure TBoldFollower.SetElementAndMakeCurrent(AElement: TBoldElement; AActive: boolean); +begin + if {not assigned(AElement) or} (AElement <> fElement) then + begin + fElement := AElement; + if IsInDisplayList then + RemoveFromDisplayList(false); + if AActive then + begin + SetState(bfsActivating); + MakeUptodateAndSubscribe; + end + else + begin + if Assigned(fElement) then + fState := bfsInactiveValidElement + else + fState := bfsInactiveInvalidElement; + end; + end; +end; + constructor TBoldFollower.Create(MatchObject: TObject; Controller: TBoldFollowerController); begin - inherited Create(MatchObject); + inherited Create(BoldGuiHandler.FindHostingForm(MatchObject as TComponent)); Assert(assigned(Controller)); fController := Controller; fSubscriber := TBoldFollowerSubscriber.Create(Self); + fIndirectElement := TBoldIndirectElement.Create; + ResultElementOutOfDate := true; fIndex := -1; end; constructor TBoldFollower.CreateSubFollower(OwningFollower: TBoldFollower; - Controller: TBoldFollowerController; - Element: TBoldElement); + aController: TBoldFollowerController; + aElement: TBoldElement; + aActive: boolean; + aIndex: integer); + begin + Assert(assigned(aController)); inherited Create(OwningFollower.MatchObject); FOwningFollower := OwningFollower; PrioritizedQueuable := OwningFollower; - Assert(assigned(Controller)); - fController := Controller; + fController := aController; fSubscriber := TBoldFollowerSubscriber.Create(Self); - fElement := Element; - fIndex := -1; - MarkSubscriptionOutOfDate; + fIndirectElement := TBoldIndirectElement.Create; + fElement := aElement; + fIndex := aIndex; + ResultElementOutOfDate := true; + if aActive {and not PrioritizedQueuable.IsInDisplayList} and // check MostPrioritizedQueuable instead of PrioritizedQueuable ? + not ((aController is TBoldAsFollowerListController) and TBoldAsFollowerListController(aController).PrecreateFollowers) then + begin + fState := bfsActivating; + MakeUptodateAndSubscribe; + end + else + if aActive then + begin +// MarkSubscriptionOutOfDate + fState := bfsSubscriptionOutOfDate; + AddToDisplayList; + if Assigned(fElement) then + fElement.AddSubscription(Subscriber, beDestroying, beDestroying); + end + else + begin + if Assigned(fElement) then + fState := bfsInactiveValidElement + else + fState := bfsInactiveInvalidElement; + if Assigned(fElement) then + fElement.AddSubscription(Subscriber, beDestroying, beDestroying); + end; end; destructor TBoldFollower.Destroy; begin + FreeAndNil(FIndirectElement); FreeAndNil(FRendererData); FreeAndNil(fSubscriber); + fCOntroller := nil; + fControlData := nil; + fElement := nil; + fOwningFollower := nil; inherited; end; @@ -981,27 +1276,75 @@ function TBoldFollower.CheckIfInHierarchy(aElement: TBoldElement; aController: T end; end; -function TBoldFollower.GetSubFollower(index: Integer): TBoldFollower; +function TBoldFollower.GetIsDirty: Boolean; begin - Result := RendererData.GetSubFollower(index); + result := fState = bfsDirty; end; -function TBoldFollower.GetSubFollowerCount: Integer; -begin - if Active then - Result := RendererData.GetSubFollowerCount - else - result := 0 -end; +type + TBoldFlaggedObjectAccess = class(TBoldFlaggedObject); -function TBoldFollower.GetCurrentIndex: Integer; +procedure TBoldFollower.SetState(AValue: TBoldFollowerState); begin - Result := RendererData.GetCurrentSubFollowerIndex; + if not (fState in [bfsEmpty, bfsCurrent, bfsDirty, + bfsValueOutOfDate, bfsSubscriptionOutOfDate, + bfsInactiveValidElement, bfsInactiveInvalidElement, bfsActivating]) then + raise Exception.Create('TBoldFollower.SetState old state is ' + IntToStr(Integer(fState))); + {action when leaving state} + case State of + bfsValueOutOfDate, bfsSubscriptionOutOfDate: {bfsOutOfDate} + RemoveFromDisplayList(false); + bfsDirty: + begin + if not ResultElementOutOfDate and Assigned(fIndirectElement.Value) + and TBoldFlaggedObjectAccess(fIndirectElement.Value).GetElementFlag(befHasModifiedValueHolder) + and (fIndirectElement.Value.ModifiedValueHolder = Subscriber) then + AssertedController.ReleaseChangedValue(self); + RemoveFromApplyList; + end; + end; + + if AValue = bfsDirty then // process Dirty before changeing fState, since HoldsChangedValue can fail. + begin + AssertedController.HoldsChangedValue(Self); + AddToApplyList; + end; + + fState := AValue; + + {action when entering state} + case State of + bfsValueOutOfDate: + begin + AddToDisplayList; + Ensured := false; + ResultElementOutOfDate := true; + end; + bfsSubscriptionOutOfDate: + begin + AddToDisplayList; + Ensured := false; + Subscriber.CancelAllSubscriptions; + ResultElementOutOfDate := true; + end; + bfsInactiveValidElement, bfsInactiveInvalidElement: + begin + Subscriber.CancelAllSubscriptions; + FreeAndNil(fRendererData); + ResultElementOutOfDate := true; + if Assigned(fElement) then + Element.AddSubscription(Subscriber, beDestroying, beDestroying); + end; + bfsEmpty, bfsCurrent, bfsActivating, bfsDirty: + {no action} + else + raise EBoldInternal.CreateFmt('%s: Unknown FollowerState', [ClassName]); + end; end; -function TBoldFollower.GetActive: Boolean; +function TBoldFollower.GetSubFollowerAssigned(index: Integer): boolean; begin - Result := not (State in [bfsInactiveValidElement, bfsInactiveInvalidElement]); + result := Active and RendererData.GetSubFollowerAssigned(Index); end; procedure TBoldFollower.SetActive(Value: Boolean); @@ -1012,8 +1355,7 @@ procedure TBoldFollower.SetActive(Value: Boolean); begin Assert(State <> bfsInactiveInvalidElement); SetState(bfsActivating); - MakeUptodateAndSubscribe; //CHECKME This could cause errors if an owning follower is in bfsOutOfDate - MarkClean; + MakeUptodateAndSubscribe; end else if (State <> bfsDirty) then @@ -1021,30 +1363,33 @@ procedure TBoldFollower.SetActive(Value: Boolean); end; end; -function TBoldFollower.GetElementValid: Boolean; +function TBoldFollower.GetValue: TBoldElement; begin - Result := State <> bfsInactiveInValidElement; + if ResultElementOutOfDate then + begin + fIndirectElement.SetReferenceValue(nil); + if {ElementValid and} Assigned(Element) then + try + ResultElementOutOfDate := false; + Element.EvaluateAndSubscribeToExpression(Controller.Expression, Subscriber, FIndirectElement, false, false, Controller.GetVariableListAndSubscribe(Subscriber)); + except + // perhaps raise exception + end; + if (state = bfsInactiveValidElement) then + Active := true; + end; + result := fIndirectElement.Value; end; procedure TBoldFollower.SetElementValid(Value: Boolean); begin - Assert(not Active or value); - if value <> elementValid then - begin - if value then - SetState(bfsInactivevalidElement) - else - SetState(bfsInactiveInvalidElement); - end; -end; - -function TBoldFollower.GetRendererData: TBoldRendererData; -begin - if not Active then - raise EBold.Create(SBoldInactiveFollowerNoRenderData); - if not Assigned(FRendererData) then - FRendererData := AssertedController.RendererDataClass.Create(Self); - Result := FRendererData; + if value <> elementValid then + begin + if value then + SetState(bfsInactivevalidElement) + else + SetState(bfsInactiveInvalidElement); + end; end; function TBoldFollower.MayChange: Boolean; @@ -1055,6 +1400,11 @@ function TBoldFollower.MayChange: Boolean; Result := True; end; +function TBoldFollower.MayModify: Boolean; +begin + result := AssertedController.MayModify(self); +end; + procedure TBoldFollower.DiscardChange; begin if State = bfsDirty then @@ -1067,9 +1417,9 @@ procedure TBoldFollower.DiscardChange; procedure TBoldFollower.Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); begin -{$IFNDEF BOLDCOMCLIENT} // CHECKME +{$IFNDEF BOLDCOMCLIENT} if (OriginalEvent = beDestroying) and (Originator = Element) then - FElement := nil; //CHECKME Is this necesary? /frha + FElement := nil; {$ENDIF} case RequestedEvent of breReEvaluate: @@ -1080,6 +1430,7 @@ procedure TBoldFollower.Receive(Originator: TObject; OriginalEvent: TBoldEvent; begin if OriginalEvent = beDestroying then begin + RemoveFromDisplayList(false); if assigned(fRendererData) then AssertedController.CleanRendererData(fRendererData); FreeAndNil(fRendererData); @@ -1088,9 +1439,9 @@ procedure TBoldFollower.Receive(Originator: TObject; OriginalEvent: TBoldEvent; if Assigned(FRendererData) and not (FRendererData is AssertedController.RendererDataClass) then FreeAndNil(fRendererData); MarkSubscriptionOutOfDate; + if OriginalEvent <> beDestroying then + AssertedController.AddSmallSubscription(Subscriber, [beValueChanged, beDestroying], breControllerChanged); end; - else - raise EBoldInternal.CreateFmt(sUnknownRequestedEvent, [Classname, RequestedEvent]); end; end; @@ -1100,8 +1451,14 @@ procedure TBoldFollower.MakeUptodateAndSubscribe; begin Subscriber.CancelAllSubscriptions; AssertedController.AddSmallSubscription(Subscriber, [beValueChanged, beDestroying], breControllerChanged); - end; - AssertedController.MakeUptodateAndSubscribe(Self, State in bfdNeedResubscribe); + Controller.MakeUptodateAndSubscribe(Self, true); + if Assigned(Element) then + Element.AddSubscription(Subscriber, beDestroying, beDestroying); + if Assigned(Element) and (State in bfdNeedResubscribe) then + Controller.SubscribeToElement(self); + end + else + AssertedController.MakeUptodateAndSubscribe(Self, State in bfdNeedResubscribe); end; procedure TBoldFollower.MakeClean; @@ -1111,35 +1468,18 @@ procedure TBoldFollower.MakeClean; SetState(bfsSubscriptionOutOfDate); end; -procedure TBoldFollower.ControlledValueChanged(IsChanged: Boolean); +procedure TBoldFollower.ControlledValueChanged; begin - if IsChanged then + if (State <> bfsDirty) then begin - if (State <> bfsDirty) then - begin - AssertedController.HoldsChangedValue(Self); - MarkDirty; - end; - if AssertedController.ApplyPolicy = bapChange then - Apply; - end - else - begin - if (State = bfsDirty) and AssertedController.CleanOnEqual then - DiscardChange; + // if ApplyPolicy is bapChange and there are no events assigned for HoldsChangedValue and ReleaseChangedValue + // then there's no need to call HoldsChangedValue and ReleaseChangedValue + // no need to call Controller.HoldsChangedValue(Self); here as it will be called in SetState as a result of MarkDirty bellow + MarkDirty; end; -end; - -procedure TBoldFollower.SetElement(theElement: TBoldElement); -begin - // if the fElement is nil and the new element is nil aswell we still need - // to mark the follower out of date since other properties of the controller - // might have changed (especially the nilstringrepresentation) - if not assigned(theElement) or (theElement <> fElement) then + if AssertedController.ApplyPolicy = bapChange then begin - fElement := theElement; - ElementValid := true; - MarkSubscriptionOutOfDate; + Apply; end; end; @@ -1149,10 +1489,10 @@ procedure TBoldFollower.MarkValueOutOfDate; bfsEmpty, bfsCurrent, bfsDirty: SetState(bfsValueOutOfDate); bfsInactiveValidElement, bfsValueOutOfDate, - bfsSubscriptionOutOfDate, bfsActivating: // FIXME bfsActivating is a temporary fix for the delayd fetch problem + bfsSubscriptionOutOfDate, bfsActivating: {no action} else - raise EBoldInternal.CreateFmt(sFollowerStateError, [ClassName, 'MarkOutOfDate']); // do not localize + raise EBoldInternal.CreateFmt('%s.MarkOutOfDate: Follower state error', [ClassName]); end; end; @@ -1165,16 +1505,27 @@ procedure TBoldFollower.MarkSubscriptionOutOfDate; bfsSubscriptionOutOfDate, bfsActivating : {no action}; - // these two should not happen, but it is safe to ignore them - // a bug in the grid seems to cause these when the grid is not displayed - // right after creation (if it is on an invisible pagecontrol) + bfsInactiveValidElement, bfsInactiveInvalidElement: begin - // DebugCode below - can safely be removed SetState(State);{no action} end else - raise EBoldInternal.CreateFmt(sFollowerStateError, [ClassName, 'MarkSubscriptionOutOfDate']); + raise EBoldInternal.CreateFmt('%s.MarkSubscriptionOutOfDate: Follower state error', [ClassName]); + end; +end; + +procedure TBoldFollower.SetElement(AElement: TBoldElement); +begin + if not assigned(AElement) or (AElement <> fElement) then + begin + Assert(not (not ResultElementOutOfDate and Assigned(fIndirectElement.Value) + and TBoldFlaggedObjectAccess(fIndirectElement.Value).GetElementFlag(befHasModifiedValueHolder) + and (fIndirectElement.Value.ModifiedValueHolder = Subscriber))); + fElement := AElement; + ElementValid := true; + MarkSubscriptionOutOfDate; + ResultElementOutOfDate := true; end; end; @@ -1186,13 +1537,14 @@ procedure TBoldFollower.MarkDirty; bfsDirty: {no action} else - raise EBoldInternal.CreateFmt(sFollowerStateError, [Classname, 'MarkDirty']); + raise EBoldInternal.CreateFmt('%s.MarkDirty: Follower state error', [Classname]); end; end; -procedure TBoldFollower.MarkClean; + +procedure TBoldFollower.MarkEnsured; begin - SetState(bfsCurrent); + Ensured := true; end; function TBoldFollower.Displayable: Boolean; @@ -1200,72 +1552,25 @@ function TBoldFollower.Displayable: Boolean; Result := State in bfsDisplayable; end; -procedure TBoldFollower.SetState(Value: TBoldFollowerState); -begin - {action when leaving state} - case State of - bfsValueOutOfDate, bfsSubscriptionOutOfDate: {bfsOutOfDate} - RemoveFromDisplayList; - bfsDirty: - RemoveFromApplyList; - end; - - fState := Value; - - {action when entering state} - case State of - bfsValueOutOfDate: - AddToDisplayList; - bfsSubscriptionOutOfDate: - begin - AddToDisplayList; - Subscriber.CancelAllSubscriptions; - end; - bfsDirty: - begin - AssertedController.HoldsChangedValue(Self); - AddToApplyList; - end; - bfsInactiveValidElement, bfsInactiveInvalidElement: - begin - Subscriber.CancelAllSubscriptions; - FreeAndNil(fRendererData); - end; - bfsEmpty, bfsCurrent, bfsActivating: - {no action} - else - raise EBoldInternal.CreateFmt('%s: Unknown FollowerState', [ClassName]); - end; -end; - procedure TBoldFollower.Display; procedure DisplaySelf; begin - try +{.$IFNDEF BoldQueue_Optimization} +// This check is already done in Queue.DisplayOne, so it only serves to protect direct calls to Display. That shouldn't be done anyway. if (MostPrioritizedQueuable <> nil) then - raise EBold.CreateFmt(sCannotDisplayInThisOrder, [ClassName]); + raise EBold.CreateFmt('%s.Display: Can not display because there is an owning follower that must be displayed before', [ClassName]); +{.$ENDIF} MakeUptodateAndSubscribe; - finally - MarkClean; - end; end; procedure DisplayMulti; var - i: integer; - Followers: TBoldObjectArray; - BoldGuard: IBoldGuard; + Followers: TBoldFollowerArray; + F: TBoldFollower; begin - BoldGuard := TBoldGuard.Create(Followers); - Followers := TBoldObjectArray.Create(10, []); - CollectMatching(Followers, Controller); - if Followers.Count > 1 then - try - MultiMakeUptodateAndSubscribe(Followers); - finally - for i := 0 to Followers.Count - 1 do - TBoldFollower(Followers[i]).MarkClean; - end + Followers := CollectMatching( Controller); + if Length(Followers) > 1 then + MultiMakeUptodateAndSubscribe(Followers) else DisplaySelf; end; @@ -1278,12 +1583,11 @@ procedure TBoldFollower.Display; except on E: Exception do begin - if assigned(Controller) and Controller.HandleDisplayException(E, Element) then - // don't re-raise + if assigned(Controller) and not Controller.HandleDisplayException(E, Element) then else begin if assigned(Controller) then - E.message := Format(sDisplayError, [E.message, BOLDCRLF, Controller.GetNamePath]); + E.message := Format('%s' + BOLDCRLF + 'occured when displaying component %s', [E.message, Controller.GetNamePath]); raise; end; end; @@ -1292,29 +1596,46 @@ procedure TBoldFollower.Display; procedure TBoldFollower.EnsureMulti; var - Followers: TBoldObjectArray; + Followers: TBoldFollowerArray; BoldGuard: IBoldGuard; begin - BoldGuard := TBoldGuard.Create(Followers); - Followers := TBoldObjectArray.Create(10, []); - CollectMatching(Followers, Controller); + Followers := CollectMatching(Controller); - if Followers.Count > 1 then + if Length(Followers) > 1 then try Controller.MultiMakeEnsure(Followers); except - ; // silence any exceptions + ; + end +end; + +procedure TBoldFollower.EnsureSiblings; +var + Followers: TBoldFollowerArray; +begin + if (not Assigned(fOwningFollower)) and (not Ensured) then + begin + SetLength(Followers, 1); + Followers[0] := self; end + else + Followers := CollectMatchingSiblings(20); + if Length(Followers) > 0 then + try + Controller.MultiMakeEnsure(Followers); + except + ; + end + end; procedure TBoldFollower.EnsureDisplayable; -//EnsureDisplayable may only be called when within Display or when ALL owning followers not is in bfsOutOfDate! begin if not Displayable then begin Active := True; - MakeUptodateAndSubscribe; - MarkClean; + if not Displayable then + MakeUptodateAndSubscribe; end; RendererData.EnsureSubfollowersDisplayable; end; @@ -1322,7 +1643,7 @@ procedure TBoldFollower.EnsureDisplayable; procedure TBoldFollower.Apply; var Discard: Boolean; - Handled: Boolean; + Handled: Boolean; begin if State = bfsDirty then begin @@ -1332,11 +1653,13 @@ procedure TBoldFollower.Apply; except on E: Exception do begin - Discard := true; Handled := assigned(Controller) and Controller.HandleApplyException(E, Element, Discard); if Discard then - DiscardChange; - if not handled then + DiscardChange + else + if State = bfsDirty then + AssertedController.HoldsChangedValue(self); + if not Handled then raise; end; end; @@ -1347,10 +1670,9 @@ procedure TBoldFollower.Apply; function TBoldPopup.GetMenu(CONTROL: TControl; Element: TBoldElement): TPopupMenu; begin Result := nil; - {$IFNDEF BOLDCOMCLIENT} // popup + {$IFNDEF BOLDCOMCLIENT} BoldGUIHandler.PopupElement := Element; BoldGUIHandler.PopupControl := CONTROL; - // fixme build actual menu if not Enable then Result := BoldPopupMenu; {$ENDIF} @@ -1375,9 +1697,20 @@ constructor TBoldFollowerSubscriber.Create(follower: TBoldFollower); fFollower := Follower; end; +destructor TBoldFollowerSubscriber.Destroy; +begin + fFollower := nil; + inherited; +end; + function TBoldFollowerSubscriber.GetContextString: string; begin - Result := Follower.AssertedController.Getnamepath + Result := Follower.AssertedController.GetNamepath +end; + +function TBoldFollowerSubscriber.ContextObject: TObject; +begin + result := Follower; end; procedure TBoldFollowerController._Receive(Originator: TObject; @@ -1401,7 +1734,11 @@ procedure TBoldFollower.SetCurrentIndex(index: integer); procedure TBoldRendererData.SetCurrentSubFollowerIndex(index: integer); begin - // just ignore; +end; + +function TBoldRendererData.GetSubFollowerAssigned(Index: Integer): boolean; +begin + raise EBold.CreateFmt('%s: This class has no subfollowers', [ClassName]); end; function TBoldFollowerController.GetContextType: TBoldElementTypeInfo; @@ -1412,6 +1749,21 @@ function TBoldFollowerController.GetContextType: TBoldElementTypeInfo; result := nil; end; +procedure TBoldRenderer.Assign(Source: TPersistent); +begin + inherited; + With Source as TBoldRenderer do + begin + self.OnMayModify := OnMayModify; + self.OnHoldsChangedValue := OnHoldsChangedValue; + self.OnReleaseChangedValue := OnReleaseChangedValue; + self.OnSubscribe := OnSubscribe; + self.OnEnsureFetched := OnEnsureFetched; + self.OnValidateCharacter := OnValidateCharacter; + self.Representations.Assign(Representations); + end; +end; + procedure TBoldRenderer.Changed; begin SendEvent(Self, beValueChanged); @@ -1473,31 +1825,84 @@ function TBoldFollowerController.GetVariableListAndSubscribe(Subscriber: TBoldSu result := GetVariableList; {$IFNDEF BOLDCOMCLIENT} if assigned(Subscriber) and assigned(Variables) then - Variables.SubscribeToHandles(Subscriber); + Variables.SubscribeToHandles(Subscriber, Expression); {$ENDIF} end; -procedure TBoldFollower.CollectMatching(Followers: TBoldObjectArray; - MatchController: TBoldFollowerController); +function TBoldFollower.CollectMatching( + MatchController: TBoldFollowerController): TBoldFollowerArray; begin if Assigned(fOwningFollower) then - fOwningFollower.CollectMatching(Followers, MatchController) + Result := fOwningFollower.CollectMatching(MatchController) else - CollectMatchingDownwards(Followers, MatchController); + Result := CollectMatchingDownwards(Result, MatchController); end; -procedure TBoldFollower.CollectMatchingDownwards(Followers: TBoldObjectArray; - MatchController: TBoldFollowerController); +function TBoldFollower.CollectMatchingSiblings(WindowSize: Integer): TBoldFollowerArray; +var + I, FirstToEnsure, LastToEnsure, found, RowIndex: integer; + CellFollower: TBoldFollower; + RowFollower, ListFollower: TBoldFollower; +begin + FirstToEnsure := 0; + LastToEnsure := -1; + // This actully only works for an array, and maybe a treewiew, but that is what we are trying to optimize anyway + RowFollower := OwningFollower; + if not Assigned(RowFollower) or (RowFollower.state in bfsOutOfDate) then + Exit; + ListFollower := RowFollower.OwningFollower; + if not Assigned(ListFollower) or (ListFollower.state in bfsOutOfDate) then + Exit; + RowIndex := RowFollower.index; + if WindowSize > 1 then + begin + FirstToEnsure := (RowIndex DIV WindowSize -1) * WindowSize; + LastToEnsure := ((RowIndex DIV WindowSize) + 1) * WindowSize; + end; + if FirstToEnsure < 0 then + FirstToEnsure := 0; + if FirstToEnsure >= ListFollower.SubfollowerCount then + FirstToEnsure := ListFollower.SubfollowerCount - 1; + if LastToEnsure >= ListFollower.SubfollowerCount then + LastToEnsure := ListFollower.SubfollowerCount - 1; + + SetLength(Result,LastToEnsure- FirstToEnsure+1); + Found := 0; + for I := FirstToEnsure to LastToEnsure do + begin + RowFollower := ListFollower.SubFollowers[I]; + if (RowFollower = nil) or (not RowFollower.Active) or (RowFollower.SubfollowerCount <= Index) then + Continue; + CellFollower := RowFollower.SubFollowers[Index]; + if Assigned(CellFollower) and (CellFollower.Controller = self.Controller) and Assigned(CellFollower.Element) and + (not CellFollower.Ensured) then + begin + Result[Found] := CellFollower; + Inc(Found); + end; + end; + SetLength(Result, Found); +end; + +function TBoldFollower.CollectMatchingDownwards(Followers: TBoldFollowerArray; + MatchController: TBoldFollowerController): TBoldFollowerArray; var I: integer; begin if (Controller = MatchController) and Assigned(Element) and (State in bfsOutOfDate) and (MostPrioritizedQueuable = nil) then - Followers.Add(Self); + begin + SetLength(Result, Length(Followers) + 1); + for i := 0 to Length(Followers) - 1 do + Result[i] := Followers[i]; + Result[Length(Followers)] := Self; + end + else + Result := Followers; if not (state in bfsOutOfDate) then begin for I := 0 to SubfollowerCount - 1 do - SubFollowers[I].CollectMatchingDownwards(Followers, MatchController); + if Assigned(SubFollowers[I]) then SubFollowers[I].CollectMatchingDownwards(Followers, MatchController); end; end; @@ -1507,41 +1912,43 @@ function TBoldFollowerController.GetSupportsMulti: Boolean; end; class procedure TBoldFollower.MultiMakeUptodateAndSubscribe( - Followers: TBoldObjectArray); + Followers: TBoldFollowerArray); var - I: integer; + F: TBoldFollower; Controller: TBoldFollowerController; begin - Assert(Followers.Count > 0); + Assert(Length(Followers) > 0); Controller := TBoldFollower(Followers[0]).AssertedController; - for I := 0 to Followers.Count - 1 do - if TBoldFollower(Followers[i]).State in bfdNeedResubscribe then + for F in Followers do + if F.State in bfdNeedResubscribe then begin - TBoldFollower(Followers[i]).Subscriber.CancelAllSubscriptions; // CHECKME ever needed? - Controller.AddSmallSubscription(TBoldFollower(Followers[i]).Subscriber, [beValueChanged, beDestroying], breControllerChanged); + F.Subscriber.CancelAllSubscriptions; + Controller.AddSmallSubscription(F.Subscriber, [beValueChanged, beDestroying], breControllerChanged); end; Controller.MultiMakeUptodateAndSubscribe(Followers); end; procedure TBoldFollowerController.MultiMakeUptodateAndSubscribe( - Followers: TBoldObjectArray); + Followers: TBoldFollowerArray); var - I: integer; + F: TBoldFollower; begin if Assigned(BeforeMakeUptoDate) then - for i := 0 to Followers.Count - 1 do - BeforeMakeUptoDate(TBoldFollower(Followers[I])); + for F in Followers do + BeforeMakeUptoDate(F); try DoMultiMakeUptodateAndSubscribe(Followers); finally + for F in Followers do + F.MarkClean; if Assigned(AfterMakeUptoDate) then - for i := 0 to Followers.Count - 1 do - AfterMakeUptoDate(TBoldFollower(Followers[I])); + for F in Followers do + AfterMakeUptoDate(F); end; end; procedure TBoldFollowerController.DoMultiMakeUptodateAndSubscribe( - Followers: TBoldObjectArray); + Followers: TBoldFollowerArray); begin raise EBoldInternal.Create('DoMultiMakeUptodateAndSubscribe: called when Multi not supported'); end; @@ -1549,34 +1956,30 @@ procedure TBoldFollowerController.DoMultiMakeUptodateAndSubscribe( procedure TBoldFollowerSubscriber.Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); begin + if not Assigned(Follower) then + raise EBold.Create('TBoldFollowerSubscriber.Receive called after Destroy'); Follower.Receive(Originator, OriginalEvent, RequestedEvent); end; -function TBoldFollower.GetAssertedController: TBoldFollowerController; +procedure TBoldFollowerController.SubscribeToElement(aFollower: TBoldFollower); begin - if not assigned(fController) then - raise EBold.CreateFmt(sControllerNotAssigned, [classname]); - result := fController; -end; - -procedure TBoldFollowerController.SubscribeToElement(Element: TBoldElement; Subscriber: TBoldSubscriber); -begin - EffectiveRenderer.SubscribeToElement(Element, representation, Expression, Subscriber, VariableList); + EffectiveRenderer.SubscribeToElement(aFollower); end; function TBoldFollowerController.HandleApplyException(E: Exception; Elem: TBoldElement; var Discard: Boolean): Boolean; var ExceptionHandler: TBoldExceptionHandler; begin - ExceptionHandler := TBoldExceptionHandler.FindExceptionHandler(fOwningComponent); - Result := assigned(ExceptionHandler); - if Result then - ExceptionHandler.HandleApplyException(E, fOwningComponent, Elem, Discard, Result); -end; - -procedure TBoldFollowerController.CleanRendererData(RendererData: TBoldRendererData); -begin - // do nothing + Result := false; + Discard := False; + if Assigned(fApplyException) then + Result := DoApplyException(E, Elem, Discard); + if not result and not Discard then + begin + ExceptionHandler := TBoldExceptionHandler.FindExceptionHandler(fOwningComponent); + if assigned(ExceptionHandler) then + ExceptionHandler.HandleApplyException(E, fOwningComponent, Elem, Discard, Result); + end; end; function TBoldFollowerController.HandleDisplayException(E: Exception; @@ -1584,21 +1987,23 @@ function TBoldFollowerController.HandleDisplayException(E: Exception; var ExceptionHandler: TBoldExceptionHandler; begin + Result := false; ExceptionHandler := TBoldExceptionHandler.FindExceptionHandler(fOwningComponent); - Result := Assigned(ExceptionHandler); - if Result then + if Assigned(ExceptionHandler) then ExceptionHandler.HandleDisplayException(E, fOwningComponent, Elem, Result); end; -procedure TBoldFollowerController.MultiMakeEnsure(Followers: TBoldObjectArray); +procedure TBoldFollowerController.CleanRendererData(RendererData: TBoldRendererData); +begin +end; + +procedure TBoldFollowerController.MultiMakeEnsure(Followers: TBoldFollowerArray); {$IFNDEF BOLDCOMCLIENT} var BoldType: TBoldClassTypeInfo; ListType: TBoldListTypeInfo; ObjectList: TBoldObjectList; - RealObjectList: TBoldObjectLIst; ie: TBoldIndirectElement; - i: integer; follower: TBoldFollower; procedure AddObject(Obj: TBoldObject); begin @@ -1613,12 +2018,12 @@ procedure TBoldFollowerController.MultiMakeEnsure(Followers: TBoldObjectArray); BoldGuard: IBoldGuard; begin - BoldGuard := TBoldGuard.Create(ie, RealObjectList, ObjectList); + BoldGuard := TBoldGuard.Create(ObjectList); ObjectList := TBoldObjectList.Create; BoldType := nil; - for i := 0 to Followers.Count - 1 do + for Follower in Followers do begin - Follower := TBoldFollower(Followers[i]); + Follower.MarkEnsured; if Follower.element is TBoldObject then begin AddObject(Follower.element as TBoldObject); @@ -1626,18 +2031,7 @@ procedure TBoldFollowerController.MultiMakeEnsure(Followers: TBoldObjectArray); end; if assigned(BoldType) then - begin - ObjectList.EnsureObjects; - if (ObjectList.Count > 1) and (Expression <> '') then - begin - ListType := BoldType.SystemTypeInfo.ListTypeInfoByElement[BoldType]; - RealObjectlist := TBoldMemberFactory.CreateMemberFromBoldType(ListType) as TBoldObjectList; - RealObjectList.AddList(ObjectList); - - ie := TBoldIndirectElement.Create; - RealObjectList.EvaluateExpression(Expression, ie); - end; - end; + TBoldFollower(Followers[0]).Controller.EffectiveRenderer.EnsureFetched(ObjectList,BoldType, Expression); end; {$ELSE} @@ -1650,12 +2044,61 @@ function TBoldFollowerController.GetSupportsMultiEnsure: Boolean; result := false; end; +function TBoldFollowerController.SubFollowersActive: boolean; +begin + result := true; +end; + procedure TBoldFollower.AddToDisplayList; begin if Assigned(Controller) then inherited AddToDisplayList; end; +function TBoldFollower.GetDebugInfo: string; +var + vFollower: TBoldFollower; +begin + result := ''; +{ vFollower := self; + repeat + + until ; + if Assigned(OwningFollower) then + result := OwningFollower.GetDebugInfo + else +} + if Assigned(MatchObject) then + begin + if MatchObject is TComponent then + result := TComponent(MatchObject).Name + ':' + TComponent(MatchObject).ClassName + else + if MatchObject is TBoldElement then + result := TBoldElement(MatchObject).DebugInfo + else + Assert(false, MatchObject.ClassName); + end; +end; + +{ TBoldAbstractHandleFollower } + +constructor TBoldAbstractHandleFollower.Create(AMatchObject: TObject; + Controller: TBoldFollowerController); +begin + inherited Create(BoldGuiHandler.FindHostingForm(AMatchObject as TComponent)); + fSubscriber := TBoldPassthroughSubscriber.Create(Receive); + fFollower := TBoldFollower.Create(MatchObject, Controller); + fFollower.PrioritizedQueuable := Self; +end; + +destructor TBoldAbstractHandleFollower.Destroy; +begin + RemoveFromDisplayList(true); + FreeAndNil(fFollower); + FreeAndNil(fSubscriber); + inherited; +end; + initialization DefaultRenderer := TBoldRenderer.Create(nil); @@ -1663,4 +2106,3 @@ finalization FreeAndNil(DefaultRenderer); end. - diff --git a/Source/BoldAwareGUI/ControlPacks/BoldControllerListControlPack.pas b/Source/BoldAwareGUI/ControlPacks/BoldControllerListControlPack.pas index e301aa5d..82df9f8d 100644 --- a/Source/BoldAwareGUI/ControlPacks/BoldControllerListControlPack.pas +++ b/Source/BoldAwareGUI/ControlPacks/BoldControllerListControlPack.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldControllerListControlPack; {$UNDEF BOLDCOMCLIENT} @@ -6,7 +9,7 @@ interface uses Classes, - BoldControlPackDefs, + BoldControlPackDefs, BoldElements, BoldControlPack, BoldListControlPack; @@ -19,19 +22,21 @@ TBoldControllerList = class; TBoldControllerList = class(TBoldAsFollowerListController) private FList: TList; - function GetCount: Integer; - function GetSubController(index: Integer): TBoldFollowerController; + function GetCount: Integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetSubController(index: Integer): TBoldFollowerController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected procedure DoMakeUptodateAndSubscribe(Follower: TBoldFollower; Subscribe: Boolean); override; function GetEffectiveRenderer: TBoldRenderer; override; - function GetEffectiveDisplayPropertyListRenderer: TBoldControllerListAsFollowerListRenderer; + function GetEffectiveDisplayPropertyListRenderer: TBoldControllerListAsFollowerListRenderer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + class function PrecreateFollowers: boolean; override; public constructor Create(aOwningComponent: TComponent); destructor Destroy; override; - procedure Add(BoldFollowerController: TBoldFollowerController); - procedure Delete(index: Integer); - procedure Remove(BoldFollowerController: TBoldFollowerController); - procedure Move(CurIndex, ToIndex: Integer); + procedure Add(BoldFollowerController: TBoldFollowerController); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure Delete(index: Integer); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure Remove(BoldFollowerController: TBoldFollowerController); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure Move(CurIndex, ToIndex: Integer); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function IndexOf(BoldFollowerController: TBoldFollowerController): integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} property Count: Integer read GetCount; property Items[index: Integer]: TBoldFollowerController read GetSubController; default; published @@ -49,7 +54,8 @@ TBoldControllerListAsFollowerListRenderer = class(TBoldAsFollowerListRenderer) implementation uses - SysUtils; + SysUtils, + BoldRev; var DefaultDisplayPropertyListRenderer: TBoldControllerListAsFollowerListRenderer; @@ -63,6 +69,16 @@ constructor TBoldControllerList.Create(aOwningComponent: TComponent); DropMode := bdpInsert; end; +function TBoldControllerList.GetCount: Integer; +begin + Result := FList.Count; +end; + +function TBoldControllerList.GetSubController(index: Integer): TBoldFollowerController; +begin + Result := TBoldSingleFollowerController(FList[index]); +end; + destructor TBoldControllerList.Destroy; var I: Integer; @@ -78,18 +94,13 @@ procedure TBoldControllerList.DoMakeUptodateAndSubscribe(Follower: TBoldFollower inherited DoMakeUptodateAndSubscribe(Follower, Subscribe); (EffectiveRenderer as TBoldControllerListAsFollowerListRenderer).MakeUptodate(Follower, Follower.Element); if Subscribe and Assigned(Follower.Element) then - {$IFDEF BOLDCOMCLIENT} // MakeUpToDate + {$IFDEF BOLDCOMCLIENT} Follower.Element.SubscribeToExpression('', Follower.Subscriber.ClientId, Follower.Subscriber.SubscriberId, False, true); {$ELSE} - Follower.Element.SubscribeToExpression('', Follower.Subscriber, False); + Follower.Element.SubscribeToExpression('', Follower.Subscriber, False); // Follower.Element.DefaultSubscribe(Follower.Subscriber); {$ENDIF} end; -function TBoldControllerList.GetSubController(index: Integer): TBoldFollowerController; -begin - Result := TBoldSingleFollowerController(FList[index]); -end; - procedure TBoldControllerList.Add(BoldFollowerController: TBoldFollowerController); begin FList.Add(BoldFollowerController); @@ -115,9 +126,9 @@ procedure TBoldControllerList.Move(CurIndex, ToIndex: Integer); Changed; end; -function TBoldControllerList.GetCount: Integer; +function TBoldControllerList.GetEffectiveDisplayPropertyListRenderer: TBoldControllerListAsFollowerListRenderer; begin - Result := FList.Count; + Result := TBoldControllerListAsFollowerListRenderer.DefaultRenderer; end; function TBoldControllerList.GetEffectiveRenderer: TBoldRenderer; @@ -125,9 +136,15 @@ function TBoldControllerList.GetEffectiveRenderer: TBoldRenderer; Result := GetEffectiveDisplayPropertyListRenderer; end; -function TBoldControllerList.GetEffectiveDisplayPropertyListRenderer: TBoldControllerListAsFollowerListRenderer; +function TBoldControllerList.IndexOf( + BoldFollowerController: TBoldFollowerController): integer; +begin + result := fList.IndexOf(BoldFollowerController); +end; + +class function TBoldControllerList.PrecreateFollowers: boolean; begin - Result := TBoldControllerListAsFollowerListRenderer.DefaultRenderer; // currently always uses default. + result := false; end; {---TBoldControllerListAsFollowerListRenderer---} @@ -142,11 +159,17 @@ procedure TBoldControllerListAsFollowerListRenderer.MakeUptodate(Follower: TBold SourceList: TBoldControllerList; SourceIndex: Integer; DestList: TBoldFollowerList; + lPrecreateFollowers: boolean; begin DestList := Follower.RendererData as TBoldFollowerList; SourceList := Follower.Controller as TBoldControllerList; + lPrecreateFollowers := SourceList.PrecreateFollowers; + DestList.SetCapacity(SourceList.Count); for sourceIndex := 0 to SourceList.Count-1 do - DestList.EnsureFollower(SourceList, SourceIndex, Element, SourceList[SourceIndex]); + if lPrecreateFollowers then + DestList.EnsuredFollower(SourceList, SourceIndex, Element, SourceList[SourceIndex]) + else + DestList.EnsuredFollower(SourceList, SourceIndex, nil, SourceList[SourceIndex]); DestList.PurgeEnd(SourceList, SourceList.Count); end; @@ -157,4 +180,3 @@ finalization FreeAndNil(DefaultDisplayPropertyListRenderer); end. - diff --git a/Source/BoldAwareGUI/ControlPacks/BoldDateTimeControlPack.pas b/Source/BoldAwareGUI/ControlPacks/BoldDateTimeControlPack.pas index 3549bf73..0f3d6d17 100644 --- a/Source/BoldAwareGUI/ControlPacks/BoldDateTimeControlPack.pas +++ b/Source/BoldAwareGUI/ControlPacks/BoldDateTimeControlPack.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDateTimeControlPack; {$UNDEF BOLDCOMCLIENT} @@ -17,9 +20,9 @@ TBoldAsDateTimeRenderer = class; TBoldDateTimeFollowerController = class; {TBoldAsDateTimeRenderer} - TBoldGetAsDateTimeEvent = function (Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression): TDateTime of object; - TBoldSetAsDateTimeEvent = procedure (Element: TBoldElement; const Value: TDateTime; Representation: TBoldRepresentation; Expression: TBoldExpression) of object; - TBoldDateTimeIsChangedEvent = function (RenderData: TBoldDateTimeRendererData; const NewValue: TDateTime; Representation: TBoldRepresentation; Expression: TBoldExpression): Boolean of object; + TBoldGetAsDateTimeEvent = function (aFollower: TBoldFollower): TDateTime of object; + TBoldSetAsDateTimeEvent = procedure (aFollower: TBoldFollower; const Value: TDateTime) of object; + TBoldDateTimeIsChangedEvent = function (aFollower: TBoldFollower; const NewValue: TDateTime): Boolean of object; { TBoldDateTimeRendererData } TBoldDateTimeRendererData = class(TBoldRendererData) @@ -40,15 +43,16 @@ TBoldAsDateTimeRenderer = class(TBoldsingleRenderer) protected class function DefaultRenderer: TBoldAsDateTimeRenderer; function GetRendererDataClass: TBoldRendererDataClass; override; - function DefaultGetAsDateTimeAndSubscribe(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): TDateTime; virtual; - procedure DefaultSetAsDateTime(Element: TBoldElement; const Value: TDateTime; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); virtual; - function GetAsDateTimeAndSubscribe(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): TDateTime; virtual; - procedure SetAsDateTime(Element: TBoldElement; const Value: TDateTime; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); virtual; + function DefaultGetAsDateTimeAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): TDateTime; virtual; + procedure DefaultSetAsDateTime(aFollower: TBoldFollower; const Value: TDateTime); virtual; + function GetAsDateTimeAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): TDateTime; virtual; + procedure SetAsDateTime(aFollower: TBoldFollower; const Value: TDateTime); virtual; + function HasSetValueEventOverrides: boolean; override; public - procedure MakeUptodateAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldFollowerController; Subscriber: TBoldSubscriber); override; - function DefaultMayModify(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): Boolean; override; - function DefaultIsChanged(RendererData: TBoldDateTimeRendererData; const NewValue: TDateTime; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; - function IsChanged(RendererData: TBoldDateTimeRendererData; const NewValue: TDateTime; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; + procedure MakeUptodateAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); override; + function DefaultMayModify(aFollower: TBoldFollower): Boolean; override; + function DefaultIsChanged(aFollower: TBoldFollower; const NewValue: TDateTime): Boolean; + function IsChanged(aFollower: TBoldFollower; const NewValue: TDateTime): Boolean; published property OnGetAsDateTime: TBoldGetAsDateTimeEvent read FOnGetAsDateTime write FOnGetAsDateTime; property OnSetAsDateTime: TBoldSetAsDateTimeEvent read FOnSetAsDateTime write FOnSetAsDateTime; @@ -65,7 +69,6 @@ TBoldDateTimeFollowerController = class(TBoldSingleFollowerController) function GetEffectiveRenderer: TBoldRenderer; override; property EffectiveAsDateTimeRenderer: TBoldAsDateTimeRenderer read GetEffectiveAsDateTimeRenderer; public -// procedure Assign(Source: TPersistent); override; function GetCurrentAsDateTime(Follower: TBoldFollower): TDateTime; procedure MakeClean(Follower: TBoldFollower); override; procedure MayHaveChanged(NewValue: TDateTime; Follower: TBoldFollower); @@ -78,9 +81,8 @@ implementation uses SysUtils, - BoldGuiResourceStrings, BoldControlPackDefs, - BoldAttributes, + BoldAttributes, BoldGuard; var @@ -97,35 +99,41 @@ function TBoldAsDateTimeRenderer.GetRendererDataClass: TBoldRendererDataClass; Result := TBoldDateTimeRendererData; end; -function TBoldAsDateTimeRenderer.DefaultMayModify(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): Boolean; -{$IFNDEF BOLDCOMCLIENT} // defaultMayModify +function TBoldAsDateTimeRenderer.HasSetValueEventOverrides: boolean; +begin + result := Assigned(FOnSetAsDateTime); +end; + +function TBoldAsDateTimeRenderer.DefaultMayModify(aFollower: TBoldFollower): Boolean; +{$IFNDEF BOLDCOMCLIENT} var ValueElement: TBoldElement; -{$ENDIF} +{$ENDIF} begin - {$IFDEF BOLDCOMCLIENT} // defaultMayModify + {$IFDEF BOLDCOMCLIENT} result := inherited DefaultMayModify(Element, Representation, Expression, VariableList, Subscriber); {$ELSE} - // Note! We don't call inherited DefaultMayModify to prevent evaluation of expression two times! - ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); - result := (ValueElement is TBAMoment) and ValueElement.ObserverMayModify(Subscriber); + ValueElement := aFollower.Value; + result := (ValueElement is TBAMoment) and ValueElement.ObserverMayModify(aFollower.Subscriber); {$ENDIF} end; -function TBoldAsDateTimeRenderer.DefaultGetAsDateTimeAndSubscribe(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): TDateTime; +function TBoldAsDateTimeRenderer.DefaultGetAsDateTimeAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): TDateTime; var - {$IFDEF BOLDCOMCLIENT} // DefaultGet + {$IFDEF BOLDCOMCLIENT} el: IBoldElement; attr: IBoldAttribute; {$ELSE} - IndirectElement: TBoldIndirectElement; - g: IBoldGuard; + lBoldIndirectElement: TBoldIndirectElement; + lBoldGuard: IBoldGuard; + lResultElement: TBoldElement; + lBAMoment: TBAMoment; {$ENDIF} begin Result := 0; - if Assigned(Element) then + if Assigned(aFollower.Element) then begin - {$IFDEF BOLDCOMCLIENT} //defaultGet + {$IFDEF BOLDCOMCLIENT} if assigned(Subscriber) then el := Element.EvaluateAndSubscribeToExpression(Expression, Subscriber.ClientId, Subscriber.SubscriberId, false, false) else @@ -135,40 +143,59 @@ function TBoldAsDateTimeRenderer.DefaultGetAsDateTimeAndSubscribe(Element: TBold if el.QueryInterface(IBoldAttribute, attr) = S_OK then Result := attr.AsVariant else - raise EBold.CreateFmt(sCannotGetDateTimeValueFromElement, [Attr.Asstring]) + raise EBold.CreateFmt('Can''t get datetime value from element (%s)', [Attr.Asstring]) end; {$ELSE} - g := TBoldGuard.Create(IndirectElement); - IndirectElement := TBoldIndirectElement.Create; - Element.EvaluateAndSubscribeToExpression(Expression, Subscriber, IndirectElement, False, false, VariableList); - if Assigned(IndirectElement.Value) then + lResultElement := aFollower.Value; + if not Assigned(lResultElement) then + begin + lBoldGuard:= TBoldGuard.Create(lBoldIndirectElement); + lBoldIndirectElement := TBoldIndirectElement.Create; + aFollower.Element.EvaluateAndSubscribeToExpression(aFollower.AssertedController.Expression, Subscriber, lBoldIndirectElement, False, False, aFollower.Controller.GetVariableListAndSubscribe(Subscriber)); + lResultElement := lBoldIndirectElement.Value; + end; + if Assigned(lResultElement) then begin - if (IndirectElement.Value is TBADateTime) then - Result := TBADateTime(IndirectElement.Value).AsDateTime - else if (IndirectElement.Value is TBADate) then - Result := TBADate(IndirectElement.Value).AsDate - else if (IndirectElement.Value is TBATime) then - Result := TBATime(IndirectElement.Value).AsTime + if (lResultElement is TBAMoment) then + begin + lBAMoment := lResultElement as TBAMoment; + if lBAMoment.IsNull then + begin + Result := 0; //TODO Null will display as 0 which isn't best + end + else if (lBAMoment is TBADateTime) then + begin + Result := TBADateTime(lBAMoment).AsDateTime + end + else if (lBAMoment is TBADate) then + begin + Result := TBADate(lBAMoment).AsDate + end + else if (lBAMoment is TBATime) then + begin + Result := TBATime(lBAMoment).AsTime + end + end else - raise EBold.CreateFmt(sCannotGetDateTimeValueFromElement, [IndirectElement.Value.ClassName]) + raise EBold.CreateFmt('Can''t get datetime value from element (%s)', [lResultElement.ClassName]) end; {$ENDIF} end; end; -procedure TBoldAsDateTimeRenderer.DefaultSetAsDateTime(Element: TBoldElement; const Value: TDateTime; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); +procedure TBoldAsDateTimeRenderer.DefaultSetAsDateTime(aFollower: TBoldFollower; const Value: TDateTime); var - {$IFDEF BOLDCOMCLIENT} // defaultSet + {$IFDEF BOLDCOMCLIENT} Attr: IBoldAttribute; {$ENDIF} ValueElement: TBoldElement; begin - ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); - {$IFDEF BOLDCOMCLIENT} // defaultSet + ValueElement := aFollower.Value; + {$IFDEF BOLDCOMCLIENT} if assigned(ValueElement) and (ValueElement.QueryInterface(IBoldAttribute, Attr) = S_OK) then Attr.AsVariant := Value else - raise EBold.CreateFmt(sCannotSetDateTimeValueOnElement, [ValueElement.AsString]); + raise EBold.CreateFmt('Can''t set datetime value on element (%s)', [ValueElement.AsString]); {$ELSE} if Assigned(ValueElement) and (ValueElement is TBADateTime) then TBADateTime(ValueElement).AsDateTime := Value @@ -177,59 +204,54 @@ procedure TBoldAsDateTimeRenderer.DefaultSetAsDateTime(Element: TBoldElement; co else if Assigned(ValueElement) and (ValueElement is TBATime) then TBATime(ValueElement).AsTime := Value else - raise EBold.CreateFmt(sCannotSetDateTimeValueOnElement, [ValueElement.ClassName]); + raise EBold.CreateFmt('Can''t set datetime value on element (%s)', [ValueElement.ClassName]); {$ENDIF} end; -function TBoldAsDateTimeRenderer.GetAsDateTimeAndSubscribe(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): TDateTime; +function TBoldAsDateTimeRenderer.GetAsDateTimeAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): TDateTime; begin if Assigned(OnSubscribe) and Assigned(Subscriber) then begin - if Assigned(Element) then - OnSubscribe(Element, Representation, Expression, Subscriber); + if Assigned(aFollower.Element) then + OnSubscribe(aFollower, Subscriber); Subscriber := nil; end; if Assigned(OnGetAsDateTime) then - Result := OnGetAsDateTime(Element, Representation, Expression) + Result := OnGetAsDateTime(aFollower) else - Result := DefaultGetAsDateTimeAndSubscribe(Element, Representation, Expression, VariableList, Subscriber); + Result := DefaultGetAsDateTimeAndSubscribe(aFollower, Subscriber); end; -procedure TBoldAsDateTimeRenderer.SetAsDateTime(Element: TBoldElement; const Value: TDateTime; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); +procedure TBoldAsDateTimeRenderer.SetAsDateTime(aFollower: TBoldFollower; const Value: TDateTime); begin if Assigned(FOnSetAsDateTime) then - OnSetAsDateTime(Element, Value, Representation, Expression) + OnSetAsDateTime(aFollower, Value) else - DefaultSetAsDateTime(Element, Value, Representation, Expression, VariableList) + DefaultSetAsDateTime(aFollower, Value) end; -procedure TBoldAsDateTimeRenderer.MakeUptodateAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldFollowerController; Subscriber: TBoldSubscriber); +procedure TBoldAsDateTimeRenderer.MakeUptodateAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); var - Value: TDateTime; + lDateTime: TDateTime; + lRendererData: TBoldDateTimeRendererData; begin - Assert(FollowerController is TBoldDateTimeFollowerController); - Value := GetAsDateTimeAndSubscribe(Element, - TBoldDateTimeFollowerController(FollowerController).Representation, - TBoldDateTimeFollowerController(FollowerController).Expression, FollowerController.GetVariableListAndSubscribe(Subscriber), - subscriber); - with (RendererData as TBoldDateTimeRendererData) do - begin - OldDateTimeValue := Value; - CurrentDateTimeValue := Value; - end; + lDateTime := GetAsDateTimeAndSubscribe(aFollower, subscriber); + lRendererData := aFollower.RendererData as TBoldDateTimeRendererData; + lRendererData.OldDateTimeValue := lDateTime; + lRendererData.CurrentDateTimeValue := lDateTime; end; -function TBoldAsDateTimeRenderer.DefaultIsChanged(RendererData: TBoldDateTimeRendererData; const NewValue: TDateTime; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; +function TBoldAsDateTimeRenderer.DefaultIsChanged(aFollower: TBoldFollower; const NewValue: TDateTime): Boolean; begin - Result := NewValue <> RendererData.OldDateTimeValue; + Result := NewValue <> TBoldDateTimeRendererData(aFollower.RendererData).OldDateTimeValue; end; -function TBoldAsDateTimeRenderer.IsChanged(RendererData: TBoldDateTimeRendererData; const NewValue: TDateTime; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; +function TBoldAsDateTimeRenderer.IsChanged(aFollower: TBoldFollower; const NewValue: TDateTime): Boolean; begin if Assigned(FOnIsChanged) then - Result := FOnIsChanged(RendererData, NewValue, Representation, Expression) + Result := FOnIsChanged(aFollower, NewValue) else - Result := DefaultIsChanged(RendererData, NewValue, Representation, Expression, VariableList); + Result := DefaultIsChanged(aFollower, NewValue); end; { TBoldDateTimeFollowerController } @@ -260,7 +282,7 @@ function TBoldDateTimeFollowerController.GetEffectiveAsDateTimeRenderer: TBoldAs if Assigned(Renderer) then Result := Renderer else - Result := DefaultAsDateTimeRenderer; //FIXME + Result := DefaultAsDateTimeRenderer; end; procedure TBoldDateTimeFollowerController.MakeClean(Follower: TBoldFollower); @@ -276,15 +298,23 @@ function TBoldDateTimeFollowerController.GetCurrentAsDateTime(Follower: TBoldFol procedure TBoldDateTimeFollowerController.SetAsDateTime(Value: TDateTime; Follower: TBoldFollower); begin - EffectiveAsDateTimeRenderer.SetAsDateTime(Follower.Element, Value, Representation, Expression, VariableList); + EffectiveAsDateTimeRenderer.SetAsDateTime(Follower, Value); end; procedure TBoldDateTimeFollowerController.MayHaveChanged(NewValue: TDateTime; Follower: TBoldFollower); +var + lIsChanged: boolean; + lRendererData: TBoldDateTimeRendererData; begin if Follower.State in bfsDisplayable then begin - (Follower.RendererData as TBoldDateTimeRendererData).CurrentDateTimeValue := NewValue; - Follower.ControlledValueChanged(EffectiveAsDateTimeRenderer.IsChanged(Follower.RendererData as TBoldDateTimeRendererData, NewValue, Representation, Expression, VariableList)); + lRendererData := (Follower.RendererData as TBoldDateTimeRendererData); + lRendererData.CurrentDateTimeValue := NewValue; + lIsChanged := EffectiveAsDateTimeRenderer.IsChanged(Follower, NewValue); + if lIsChanged then + begin + Follower.ControlledValueChanged; + end; end; end; diff --git a/Source/BoldAwareGUI/ControlPacks/BoldElementHandleFollower.pas b/Source/BoldAwareGUI/ControlPacks/BoldElementHandleFollower.pas index 1700c4d7..871f24c7 100644 --- a/Source/BoldAwareGUI/ControlPacks/BoldElementHandleFollower.pas +++ b/Source/BoldAwareGUI/ControlPacks/BoldElementHandleFollower.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldElementHandleFollower; {$UNDEF BOLDCOMCLIENT} @@ -18,27 +21,23 @@ interface TBoldElementHandleFollower = class; { TBoldElementHandleFollower } - TBoldElementHandleFollower = class(TBoldQueueable) + TBoldElementHandleFollower = class(TBoldAbstractHandleFollower) private fBoldHandle: TBoldElementHandle; - fFollower: TBoldFollower; fFollowerValueCurrent: Boolean; - fSubscriber: TBoldSubscriber; procedure SetFollowerValueCurrent(value: Boolean); procedure SetBoldHandle(value: TBoldElementHandle); property FollowerValueCurrent: Boolean read fFollowerValueCurrent write SetFollowerValueCurrent; protected - procedure Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); + function GetBoldHandle: TBoldElementHandle; override; + procedure Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); override; procedure Display; override; - property Subscriber: TBoldSubscriber read fSubscriber; public - constructor Create(MatchObject: TObject; Controller: TBoldFollowerController); - destructor Destroy; override; + constructor Create(AMatchObject: TObject; Controller: TBoldFollowerController); procedure Apply; override; procedure DiscardChange; override; - published +// published property BoldHandle: TBoldElementHandle read FBoldHandle write SetBoldHandle; - property Follower: TBoldFollower read fFollower; end; implementation @@ -60,29 +59,18 @@ procedure TBoldElementHandleFollower.Receive(Originator: TObject; FollowerValueCurrent := false; end; -constructor TBoldElementHandleFollower.Create(MatchObject: TObject; +constructor TBoldElementHandleFollower.Create(AMatchObject: TObject; Controller: TBoldFollowerController); begin - inherited Create(nil); - fSubscriber := TBoldPassthroughSubscriber.Create(Receive); - fFollower := TBoldFollower.Create(MatchObject, Controller); - fFollower.PrioritizedQueuable := Self; + inherited Create(AMatchObject, Controller); fFollowerValueCurrent := true; end; -destructor TBoldElementHandleFollower.Destroy; -begin - FreeAndNil(fFollower); - FreeAndNil(fSubscriber); - inherited; -end; - procedure TBoldElementHandleFollower.SetBoldHandle(value: TBoldElementHandle); begin if (value <> BoldHandle) then begin fBoldHandle := Value; - // will force subscription on Handle FollowerValueCurrent := false; end; end; @@ -129,12 +117,14 @@ procedure TBoldElementHandleFollower.SetFollowerValueCurrent(value: Boolean); begin if Value then begin - RemoveFromDisplayList; + RemoveFromDisplayList(false); PropagateValue; Subscribe; end else begin + if Follower.IsDirty then + Follower.DiscardChange; Follower.element := nil; Subscriber.CancelAllSubscriptions; AddToDisplayList; @@ -144,5 +134,9 @@ procedure TBoldElementHandleFollower.SetFollowerValueCurrent(value: Boolean); SubscribeToHandleReference; end; -end. +function TBoldElementHandleFollower.GetBoldHandle: TBoldElementHandle; +begin + result := fBoldHandle; +end; +end. diff --git a/Source/BoldAwareGUI/ControlPacks/BoldFloatControlPack.pas b/Source/BoldAwareGUI/ControlPacks/BoldFloatControlPack.pas index 953a64f9..b1f3b3b7 100644 --- a/Source/BoldAwareGUI/ControlPacks/BoldFloatControlPack.pas +++ b/Source/BoldAwareGUI/ControlPacks/BoldFloatControlPack.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldFloatControlPack; {$UNDEF BOLDCOMCLIENT} @@ -17,9 +20,9 @@ TBoldAsFloatRenderer = class; TBoldFloatFollowerController = class; { TBoldAsFloatRenderer } - TBoldGetAsFloatEvent = function (Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression): double of object; - TBoldSetAsFloatEvent = procedure (Element: TBoldElement; const Value: double; Representation: TBoldRepresentation; Expression: TBoldExpression) of object; - TBoldFloatIsChangedEvent = function (RenderData: TBoldFloatRendererData; const NewValue: double; Representation: TBoldRepresentation; Expression: TBoldExpression): Boolean of object; + TBoldGetAsFloatEvent = function (aFollower: TBoldFollower): double of object; + TBoldSetAsFloatEvent = procedure (aFollower: TBoldFollower; const Value: double) of object; + TBoldFloatIsChangedEvent = function (aFollower: TBoldFollower; const NewValue: double): Boolean of object; { TBoldFloatRendererData } TBoldFloatRendererData = class(TBoldRendererData) @@ -32,6 +35,7 @@ TBoldFloatRendererData = class(TBoldRendererData) end; { TBoldAsFloatRenderer } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldAsFloatRenderer = class(TBoldSingleRenderer) private FOnGetAsFloat: TBoldGetAsFloatEvent; @@ -40,15 +44,16 @@ TBoldAsFloatRenderer = class(TBoldSingleRenderer) protected class function DefaultRenderer: TBoldAsFloatRenderer; function GetRendererDataClass: TBoldRendererDataClass; override; - function DefaultGetAsFloatAndSubscribe(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): double; virtual; - procedure DefaultSetAsFloat(Element: TBoldElement; const Value: double; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); virtual; - function GetAsFloatAndSubscribe(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): double; virtual; - procedure SetAsFloat(Element: TBoldElement; const Value: double; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); virtual; + function DefaultGetAsFloatAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): double; virtual; + procedure DefaultSetAsFloat(aFollower: TBoldFollower; const Value: double); virtual; + function GetAsFloatAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): double; virtual; + procedure SetAsFloat(aFollower: TBoldFollower; const Value: double); virtual; + function HasSetValueEventOverrides: boolean; override; public - procedure MakeUptodateAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldFollowerController; Subscriber: TBoldSubscriber); override; - function DefaultMayModify(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): Boolean; override; - function DefaultIsChanged(RendererData: TBoldFloatRendererData; const NewValue: double; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; - function IsChanged(RendererData: TBoldFloatRendererData; const NewValue: double; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; + procedure MakeUptodateAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); override; + function DefaultMayModify(aFollower: TBoldFollower): Boolean; override; + function DefaultIsChanged(aFollower: TBoldFollower; const NewValue: double): Boolean; + function IsChanged(aFollower: TBoldFollower; const NewValue: double): Boolean; published property OnGetAsFloat: TBoldGetAsFloatEvent read FOnGetAsFloat write FOnGetAsFloat; property OnSetAsFloat: TBoldSetAsFloatEvent read FOnSetAsFloat write FOnSetAsFloat; @@ -65,7 +70,6 @@ TBoldFloatFollowerController = class(TBoldSingleFollowerController) property EffectiveAsFloatRenderer: TBoldAsFloatRenderer read GetEffectiveAsFloatRenderer; function GetEffectiveRenderer: TBoldRenderer; override; public -// procedure Assign(Source: TPersistent); override; function GetCurrentAsFloat(Follower: TBoldFollower): double; procedure MakeClean(Follower: TBoldFollower); override; procedure MayHaveChanged(NewValue: double; Follower: TBoldFollower); @@ -78,10 +82,9 @@ implementation uses SysUtils, - BoldGuiResourceStrings, BoldUtils, BoldAttributes, - BoldControlPackDefs, + BoldControlPackDefs, BoldGuard; var @@ -98,33 +101,38 @@ function TBoldAsFloatRenderer.GetRendererDataClass: TBoldRendererDataClass; Result := TBoldFloatRendererData; end; -function TBoldAsFloatRenderer.DefaultMayModify(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): Boolean; -{$IFNDEF BOLDCOMCLIENT} // defaultMayModify +function TBoldAsFloatRenderer.HasSetValueEventOverrides: boolean; +begin + result := Assigned(FOnSetAsFloat); +end; + +function TBoldAsFloatRenderer.DefaultMayModify(aFollower: TBoldFollower): Boolean; +{$IFNDEF BOLDCOMCLIENT} var ValueElement: TBoldElement; {$ENDIF} begin - {$IFDEF BOLDCOMCLIENT} // defaultMayModify + {$IFDEF BOLDCOMCLIENT} result := inherited DefaultMayModify(Element, Representation, Expression, VariableList, Subscriber); {$ELSE} - // Note! We don't call inherited DefaultMayModify to prevent evaluation of expression two times! - ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); - result := ((ValueElement is TBAFloat) or (ValueElement is TBADateTime)) and ValueElement.ObserverMayModify(Subscriber) + ValueElement := aFollower.Value; + result := ((ValueElement is TBAFloat) or (ValueElement is TBACurrency) {or (ValueElement is TBADateTime)}) and ValueElement.ObserverMayModify(aFollower.Subscriber) {$ENDIF} end; -function TBoldAsFloatRenderer.DefaultGetAsFloatAndSubscribe(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): double; +function TBoldAsFloatRenderer.DefaultGetAsFloatAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): double; var {$IFDEF BOLDCOMCLIENT} // defaultGet el: IBoldElement; attr: IBoldAttribute; {$ELSE} IndirectElement: TBoldIndirectElement; - g: IBoldGuard; + lGuard: IBoldGuard; + lResultElement: TBoldElement; {$ENDIF} begin Result := 0; - if Assigned(Element) then + if Assigned(aFollower.Element) then begin {$IFDEF BOLDCOMCLIENT} // defaultGet if assigned(Subscriber) then @@ -136,34 +144,39 @@ function TBoldAsFloatRenderer.DefaultGetAsFloatAndSubscribe(Element: TBoldElemen else raise EBold.CreateFmt(sCannotGetFloatValueFromElement, [Attr.AsString]) {$ELSE} - g := TBoldGuard.Create(IndirectElement); - IndirectElement := TBoldIndirectElement.Create; - Element.EvaluateAndSubscribeToExpression(Expression, Subscriber, IndirectElement, False, False, VariableList); - if Assigned(IndirectElement.Value) then + lResultElement := aFollower.Value; + if not Assigned(lResultElement) then begin - if (IndirectElement.Value is TBANumeric) then - Result := TBANumeric(IndirectElement.Value).AsFloat - else if (IndirectElement.Value is TBADate) then - Result := TBADate(IndirectElement.Value).AsDate - else if (IndirectElement.Value is TBATime) then - Result := TBATime(IndirectElement.Value).AsTime - else if (IndirectElement.Value is TBADateTime) then - Result := TBADateTime(IndirectElement.Value).AsDateTime - else - raise EBold.CreateFmt(sCannotGetFloatValueFromElement, [IndirectElement.Value.ClassName]) + lGuard:= TBoldGuard.Create(IndirectElement); + IndirectElement := TBoldIndirectElement.Create; + aFollower.Element.EvaluateAndSubscribeToExpression(aFollower.AssertedController.Expression, Subscriber, IndirectElement, False, False, aFollower.Controller.GetVariableListAndSubscribe(Subscriber)); + lResultElement := IndirectElement.Value; + end; + if Assigned(lResultElement) then + begin + if (lResultElement is TBANumeric) then + Result := TBANumeric(lResultElement).AsFloat +{ else if (lResultElement is TBADate) then + Result := TBADate(lResultElement).AsDate + else if (lResultElement is TBATime) then + Result := TBATime(lResultElement).AsTime + else if (lResultElement is TBADateTime) then + Result := TBADateTime(lResultElement).AsDateTime +} else + raise EBold.CreateFmt('Can''t get float value from element (%s)', [lResultElement.ClassName]) end; {$ENDIF} end; end; -procedure TBoldAsFloatRenderer.DefaultSetAsFloat(Element: TBoldElement; const Value: double; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); +procedure TBoldAsFloatRenderer.DefaultSetAsFloat(aFollower: TBoldFollower; const Value: double); var ValueElement: TBoldElement; {$IFDEF BOLDCOMCLIENT} // defaultSet attr: IBoldAttribute; {$ENDIF} begin - ValueElement := GetExpressionAsDirectElement(Element, Expression , VariableList); + ValueElement := aFollower.Value; {$IFDEF BOLDCOMCLIENT} // defaultSet if assigned(ValueElement) and (ValueElement.QueryInterface(IBoldAttribute, attr) = S_OK) then Attr.AsVariant := Value @@ -172,62 +185,61 @@ procedure TBoldAsFloatRenderer.DefaultSetAsFloat(Element: TBoldElement; const Va {$ELSE} if ValueElement is TBAFloat then TBAFloat(ValueElement).AsFloat := Value - else if ValueElement is TBADateTime then - TBADateTime(ValueElement).AsDateTime := Value else - raise EBold.CreateFmt(sCannotSetFloatValueOnElement, [ValueElement.ClassName]); + if ValueElement is TBACurrency then + TBACurrency(ValueElement).AsCurrency := Value +{ else + if ValueElement is TBADateTime then + TBADateTime(ValueElement).AsDateTime := Value} + else + raise EBold.CreateFmt('Can''t set float value on element (%s)', [ValueElement.ClassName]); {$ENDIF} end; -function TBoldAsFloatRenderer.GetAsFloatAndSubscribe(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): double; +function TBoldAsFloatRenderer.GetAsFloatAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): double; begin if Assigned(OnSubscribe) and Assigned(Subscriber) then begin - if Assigned(Element) then - OnSubscribe(Element, Representation, Expression, Subscriber); + if Assigned(aFollower.Element) then + OnSubscribe(aFollower, Subscriber); Subscriber := nil; end; if Assigned(OnGetAsFloat) then - Result := OnGetAsFloat(Element, Representation, Expression) + Result := OnGetAsFloat(aFollower) else - Result := DefaultGetAsFloatAndSubscribe(Element, Representation, Expression, VariableList, Subscriber); + Result := DefaultGetAsFloatAndSubscribe(aFollower, Subscriber); end; -procedure TBoldAsFloatRenderer.SetAsFloat(Element: TBoldElement; const Value: double; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); +procedure TBoldAsFloatRenderer.SetAsFloat(aFollower: TBoldFollower; const Value: double); begin if Assigned(FOnSetAsFloat) then - OnSetAsFloat(Element, Value, Representation, Expression) + OnSetAsFloat(aFollower, Value) else - DefaultSetAsFloat(Element, Value, Representation, Expression, VariableList) + DefaultSetAsFloat(aFollower, Value) end; -procedure TBoldAsFloatRenderer.MakeUptodateAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldFollowerController; Subscriber: TBoldSubscriber); +procedure TBoldAsFloatRenderer.MakeUptodateAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); var Value: double; + lRendererData: TBoldFloatRendererData; begin - Value := GetAsFloatAndSubscribe(Element, - (FollowerController as TBoldFloatFollowerController).Representation, - (FollowerController as TBoldFloatFollowerController).Expression, - FollowerController.GetVariableListAndSubscribe(Subscriber), - Subscriber); - with (RendererData as TBoldFloatRendererData) do - begin - OldFloatValue := Value; - CurrentFloatValue := Value; - end; + Value := GetAsFloatAndSubscribe(aFollower, Subscriber); + lRendererData := (aFollower.RendererData as TBoldFloatRendererData); + lRendererData.OldFloatValue := Value; + lRendererData.CurrentFloatValue := Value; end; -function TBoldAsFloatRenderer.DefaultIsChanged(RendererData: TBoldFloatRendererData; const NewValue: double; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; +function TBoldAsFloatRenderer.DefaultIsChanged(aFollower: TBoldFollower; const NewValue: double): Boolean; begin - Result := NewValue <> RendererData.OldFloatValue; + Result := NewValue <> TBoldFloatRendererData(aFollower.RendererData).OldFloatValue; end; -function TBoldAsFloatRenderer.IsChanged(RendererData: TBoldFloatRendererData; const NewValue: double; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; +function TBoldAsFloatRenderer.IsChanged(aFollower: TBoldFollower; const NewValue: double): Boolean; begin if Assigned(FOnIsChanged) then - Result := FOnIsChanged(RendererData, NewValue, Representation, Expression) + Result := FOnIsChanged(aFollower, NewValue) else - Result := DefaultIsChanged(RendererData, NewValue, Representation, Expression, VariableList); + Result := DefaultIsChanged(aFollower, NewValue); end; { TBoldFloatFollowerController } @@ -279,7 +291,7 @@ function TBoldFloatFollowerController.GetCurrentAsFloat(Follower: TBoldFollower) procedure TBoldFloatFollowerController.SetAsFloat(Value: double; Follower: TBoldFollower); begin - EffectiveAsFloatRenderer.SetAsFloat(Follower.Element, Value, Representation, Expression, VariableList); + EffectiveAsFloatRenderer.SetAsFloat(Follower, Value); end; procedure TBoldFloatFollowerController.MayHaveChanged(NewValue: double; Follower: TBoldFollower); @@ -287,7 +299,8 @@ procedure TBoldFloatFollowerController.MayHaveChanged(NewValue: double; Follower if Follower.State in bfsDisplayable then begin (Follower.RendererData as TBoldFloatRendererData).CurrentFloatValue := NewValue; - Follower.ControlledValueChanged(EffectiveAsFloatRenderer.IsChanged(Follower.RendererData as TBoldFloatRendererData, NewValue, Representation, Expression, VariableList)); + if EffectiveAsFloatRenderer.IsChanged(Follower, NewValue) then + Follower.ControlledValueChanged; end; end; diff --git a/Source/BoldAwareGUI/ControlPacks/BoldGenericListControlPack.pas b/Source/BoldAwareGUI/ControlPacks/BoldGenericListControlPack.pas index cf41b92e..2036cf0a 100644 --- a/Source/BoldAwareGUI/ControlPacks/BoldGenericListControlPack.pas +++ b/Source/BoldAwareGUI/ControlPacks/BoldGenericListControlPack.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldGenericListControlPack; {$UNDEF BOLDCOMCLIENT} @@ -21,18 +24,18 @@ TBoldGenericListParts = class; TBoldFollowerListWithOwnedList = class; {$IFDEF BOLD_BCB} - TGetFollowerControllerByNameEvent = procedure (Name: string; var FollowerController: TBoldFollowerController) of object; + TGetFollowerControllerByNameEvent = procedure (const Name: string; var FollowerController: TBoldFollowerController) of object; TGetFollowerControllerEvent = procedure (Element: TBoldElement; Subscriber: TBoldSubscriber; GetFollowerControllerByName: TGetFollowerControllerByNameEvent; var FollowerController: TBoldFollowerController) of object; {$ENDIF} {$IFDEF BOLD_DELPHI} - TGetFollowerControllerByNameEvent = function (Name: string): TBoldFollowerController of object; + TGetFollowerControllerByNameEvent = function (const Name: string): TBoldFollowerController of object; TGetFollowerControllerEvent = function (Element: TBoldElement; Subscriber: TBoldSubscriber; GetFollowerControllerByName: TGetFollowerControllerByNameEvent): TBoldFollowerController of object; {$ENDIF} - {$IFNDEF BOLDCOMCLIENT} // GetElementEvent + {$IFNDEF BOLDCOMCLIENT} TGetElementEvent = procedure (Sender: TBoldGenericListPart; Element: TBoldElement; Subscriber: TBoldSubscriber; ResultElement: TBoldIndirectElement; Resubscribe: Boolean) of object; - {$ENDIF} + {$ENDIF} { TBoldFollowerListWithOwnedList } TBoldFollowerListWithOwnedList = class (TBoldFollowerList) @@ -41,8 +44,8 @@ TBoldFollowerListWithOwnedList = class (TBoldFollowerList) public constructor Create(OwningFollower: TBoldFollower); override; destructor Destroy; override; - procedure AddOwnedElement(Element: TBoldElement); - procedure FreeAllOwnedElements; + procedure AddOwnedElement(Element: TBoldElement); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure FreeAllOwnedElements; {$IFDEF BOLD_INLINE} inline; {$ENDIF} end; { TBoldGenericListPart } @@ -51,18 +54,18 @@ TBoldGenericListPart = class(TCollectionItem) FElementExpression: TBoldExpression; FControllerExpression: TBoldExpression; FInterpretAsList: Boolean; - {$IFNDEF BOLDCOMCLIENT} // GetElementEvent + {$IFNDEF BOLDCOMCLIENT} FOnGetElement: TGetElementEvent; {$ENDIF} FOnGetFollowerController: TGetFollowerControllerEvent; fEnabled: Boolean; fName: String; fPublisher: TBoldPublisher; - function GetPublisher: TBoldPublisher; - function GetContextType: TBoldElementTypeInfo; + function GetPublisher: TBoldPublisher; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetContextType: TBoldElementTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} - procedure SetElementExpression(Value: TBoldExpression); - procedure SetControllerExpression(Value: TBoldExpression); + procedure SetElementExpression(const Value: TBoldExpression); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetControllerExpression(const Value: TBoldExpression); {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetInterpretAsList(Value: Boolean); procedure SetEnabled(const Value: Boolean); property Publisher: TBoldPublisher read GetPublisher; @@ -70,7 +73,7 @@ TBoldGenericListPart = class(TCollectionItem) constructor Create(Collection: TCollection); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; - {$IFDEF BOLDCOMCLIENT} // GetElementEvent + {$IFDEF BOLDCOMCLIENT} function GetElement(Element: TBoldElement; Subscriber: TBoldSubscriber; Resubscribe: Boolean): IBoldElement; {$ELSE} procedure DefaultGetElement(Element: TBoldElement; Subscriber: TBoldSubscriber; ResultElement: TBoldIndirectElement; Resubscribe: Boolean); @@ -85,7 +88,7 @@ TBoldGenericListPart = class(TCollectionItem) property InterpretAsList: Boolean read FInterpretAsList write SetInterpretAsList; property Name: String read fName write fName; property Enabled: Boolean read fEnabled write SetEnabled default true; - {$IFNDEF BOLDCOMCLIENT} // GetElementEvent + {$IFNDEF BOLDCOMCLIENT} property OnGetElement: TGetElementEvent read FOnGetElement write FOnGetElement; {$ENDIF} property OnGetFollowerController: TGetFollowerControllerEvent read FOnGetFollowerController write FOnGetFollowerController; @@ -95,14 +98,14 @@ TBoldGenericListPart = class(TCollectionItem) TBoldGenericListParts = class(TCollection) private FOwner: TBoldGenericListController; - function GetPart(Index: Integer): TBoldGenericListPart; - procedure SetPart(Index: Integer; Value: TBoldGenericListPart); + function GetPart(Index: Integer): TBoldGenericListPart; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetPart(Index: Integer; Value: TBoldGenericListPart); {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected function GetOwner: TPersistent; override; procedure Update(Item: TCollectionItem); override; public constructor Create(aOwner: TBoldGenericListController); - function Add: TBoldGenericListPart; + function Add: TBoldGenericListPart; {$IFDEF BOLD_INLINE} inline; {$ENDIF} property Items[Index: Integer]: TBoldGenericListPart read GetPart write SetPart; default; end; @@ -122,12 +125,13 @@ TBoldGenericListController = class(TBoldAsFollowerListController) private FParts: TBoldGenericListParts; FGetFollowerControllerByName: TGetFollowerControllerByNameEvent; - procedure SetParts(Value: TBoldGenericListParts); - function GetRenderer: TBoldGenericAsListRenderer; - procedure SetRenderer(Value: TBoldGenericAsListRenderer); + procedure SetParts(Value: TBoldGenericListParts); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetRenderer: TBoldGenericAsListRenderer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetRenderer(Value: TBoldGenericAsListRenderer); {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected + class function PrecreateFollowers: boolean; override; function GetEffectiveRenderer: TBoldRenderer; override; - function GetEffectiveGenericAsListRenderer: TBoldGenericAsListRenderer; + function GetEffectiveGenericAsListRenderer: TBoldGenericAsListRenderer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure DoMakeUptodateAndSubscribe(Follower: TBoldFollower; Subscribe: Boolean); override; procedure DoAssign(Source: TPersistent); override; property EffectiveGenericAsListRenderer: TBoldGenericAsListRenderer read GetEffectiveGenericAsListRenderer; @@ -135,8 +139,8 @@ TBoldGenericListController = class(TBoldAsFollowerListController) constructor Create(aOwningComponent: TComponent; GetFollowerControllerByNameFunc: TGetFollowerControllerByNameEvent); destructor Destroy; override; - function FindPartByName(Name: string): TBoldGenericListPart; - function CanHaveSubFollowers: Boolean; + function FindPartByName(const Name: string): TBoldGenericListPart; + function CanHaveSubFollowers: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} published property Parts: TBoldGenericListParts read FParts write SetParts; property Renderer: TBoldGenericAsListRenderer read GetRenderer write SetRenderer; @@ -149,8 +153,7 @@ implementation BoldUtils, BoldContainers, BoldControlPackDefs, - BoldGuiResourceStrings, - {$IFNDEF BOLDCOMCLIENT} // uses + {$IFNDEF BOLDCOMCLIENT} BoldSystem, {$ENDIF} BoldNodeControlPack; @@ -186,7 +189,7 @@ procedure TBoldFollowerListWithOwnedList.FreeAllOwnedElements; constructor TBoldGenericListPart.Create(Collection: TCollection); begin inherited Create(Collection); - FControllerExpression := 'oclType.asstring->union(oclType.allsupertypes.asString)->union('''')'; // do not localize + FControllerExpression := 'oclType.asstring->union(oclType.allsupertypes.asString)->union('''')'; fEnabled := true; end; @@ -197,7 +200,7 @@ procedure TBoldGenericListPart.Assign(Source: TPersistent); ElementExpression := TBoldGenericListPart(Source).ElementExpression; ControllerExpression := TBoldGenericListPart(Source).ControllerExpression; InterpretAsList := TBoldGenericListPart(Source).InterpretAsList; - {$IFNDEF BOLDCOMCLIENT} // GetElementEvent + {$IFNDEF BOLDCOMCLIENT} OnGetElement := TBoldGenericListPart(Source).OnGetElement; {$ENDIF} OnGetFollowerController := TBoldGenericListPart(Source).OnGetFollowerController; @@ -206,7 +209,7 @@ procedure TBoldGenericListPart.Assign(Source: TPersistent); inherited Assign(Source); end; -procedure TBoldGenericListPart.SetElementExpression(Value: TBoldExpression); +procedure TBoldGenericListPart.SetElementExpression(const Value: TBoldExpression); begin if Value <> ElementExpression then begin @@ -215,7 +218,7 @@ procedure TBoldGenericListPart.SetElementExpression(Value: TBoldExpression); end; end; -procedure TBoldGenericListPart.SetControllerExpression(Value: TBoldExpression); +procedure TBoldGenericListPart.SetControllerExpression(const Value: TBoldExpression); begin if Value <> ControllerExpression then begin @@ -233,7 +236,7 @@ procedure TBoldGenericListPart.SetInterpretAsList(Value: Boolean); end; end; -{$IFDEF BOLDCOMCLIENT} // GetElementEvent +{$IFDEF BOLDCOMCLIENT} function TBoldGenericListPart.GetElement(Element: TBoldElement; Subscriber: TBoldSubscriber; Resubscribe: Boolean): IBoldElement; begin if Assigned(Element) then @@ -268,7 +271,7 @@ procedure TBoldGenericListPart.GetElement(Element: TBoldElement; Subscriber: TBo function TBoldGenericListPart.DefaultGetFollowerController(Element: TBoldElement; Subscriber: TBoldSubscriber; GetFollowerControllerByName: TGetFollowerControllerByNameEvent): TBoldFollowerController; var -{$IFDEF BOLDCOMCLIENT} // DefaultGet +{$IFDEF BOLDCOMCLIENT} e: IBoldElement; {$ELSE} E: TBoldIndirectElement; @@ -296,7 +299,7 @@ function LoopList(List: TBoldList): TBoldFollowerController; begin Result := nil; - {$IFDEF BOLDCOMCLIENT} // DefaultGet + {$IFDEF BOLDCOMCLIENT} e := Element.EvaluateAndSubscribeToExpression(ControllerExpression, Subscriber.ClientId, Subscriber.SubscriberId, False, false); if Assigned(E) then begin @@ -344,7 +347,7 @@ function TBoldGenericListPart.GetFollowerController(Element: TBoldElement; Subsc except on E: Exception do begin - E.message := Format(sCouldNotGetController, [E.message, BOLDCRLF, GetNamePath]); + E.message := Format('%s' + BOLDCRLF + 'occured when getting controller for component %s', [E.message, GetNamePath]); raise; end; end; @@ -388,6 +391,11 @@ function TBoldGenericListController.GetRenderer: TBoldGenericAsListRenderer; Result := (UntypedRenderer as TBoldGenericAsListRenderer); end; +class function TBoldGenericListController.PrecreateFollowers: boolean; +begin + result := true; +end; + procedure TBoldGenericListController.SetRenderer(Value: TBoldGenericAsListRenderer); begin UntypedRenderer := Value; @@ -457,7 +465,7 @@ procedure TBoldGenericAsListRenderer.MakeUptodate(Follower: TBoldFollower; FollowerController := Part.GetFollowerController(Element, Follower.Subscriber, GetFollowerControllerByName); if Assigned(FollowerController) then begin - DestList.EnsureFollower(Controller, DestListIndex, Element, FollowerController); + DestList.EnsuredFollower(Controller, DestListIndex, Element, FollowerController); Inc(DestListIndex); end; end; @@ -466,7 +474,7 @@ procedure TBoldGenericAsListRenderer.MakeUptodate(Follower: TBoldFollower; {$IFDEF BOLDCOMCLIENT} begin element := part.GetElement(Follower.Element, Follower.Subscriber, False); - result := assigned(element); // fixme: true or false? + result := assigned(element); end; {$ELSE} var @@ -475,12 +483,11 @@ procedure TBoldGenericAsListRenderer.MakeUptodate(Follower: TBoldFollower; ie := TBoldIndirectElement.Create; try Part.GetElement(Follower.Element, Follower.Subscriber, ie, False); - if ie.OwnsValue then + result := ie.OwnsValue; + if result then Element := ie.RelinquishValue else Element := ie.Value; - - result := ie.OwnsValue; finally ie.Free; end; @@ -499,7 +506,7 @@ procedure TBoldGenericAsListRenderer.MakeUptodate(Follower: TBoldFollower; DestList.AddOwnedElement(Element); if Assigned(Element) then begin - {$IFDEF BOLDCOMCLIENT} // listconverting + {$IFDEF BOLDCOMCLIENT} Element.QueryInterface(IBoldList, SourceList); {$ELSE} if element is TBoldList then @@ -561,7 +568,7 @@ destructor TBoldGenericListPart.Destroy; inherited; end; -function TBoldGenericListController.FindPartByName(Name: string): TBoldGenericListPart; +function TBoldGenericListController.FindPartByName(const Name: string): TBoldGenericListPart; var i: integer; begin diff --git a/Source/BoldAwareGUI/ControlPacks/BoldListControlPack.pas b/Source/BoldAwareGUI/ControlPacks/BoldListControlPack.pas index 87b8d560..1c7f10ab 100644 --- a/Source/BoldAwareGUI/ControlPacks/BoldListControlPack.pas +++ b/Source/BoldAwareGUI/ControlPacks/BoldListControlPack.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldListControlPack; {$UNDEF BOLDCOMCLIENT} @@ -8,7 +11,7 @@ interface BoldDefs, Classes, BoldElements, - {$IFNDEF BOLDCOMCLIENT} // uses + {$IFNDEF BOLDCOMCLIENT} BoldSystem, {$ENDIF} BoldSubscription, @@ -24,27 +27,32 @@ TBoldFollowerList = class; TBoldAsFollowerListController = class(TBoldFollowerController) private fOnBeforeInsertItem: TBoldSubFollowerEvent; - fOnAfterInsertItem: TBoldFollowerEvent; - fOnBeforeDeleteItem: TBoldFollowerEvent; + fOnAfterInsertItem: TBoldSubFollowerEvent; + fOnBeforeDeleteItem: TBoldSubFollowerEvent; fOnAfterDeleteItem: TBoldSubFollowerEvent; + fOnReplaceItem: TBoldSubFollowerEvent; protected - procedure DoBeforeInsertItem(index: Integer; OwningFollower: TBoldFollower); - procedure DoAfterInsertItem(Follower: TBoldFollower); - procedure DoBeforeDeleteItem(Follower: TBoldFollower); - procedure DoAfterDeleteItem(index: Integer; OwningFollower: TBoldFollower); + procedure DoBeforeInsertItem(index: Integer; OwningFollower: TBoldFollower); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure DoAfterInsertItem(index: Integer; Follower: TBoldFollower); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure DoBeforeDeleteItem(index: Integer; Follower: TBoldFollower); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure DoAfterDeleteItem(index: Integer; OwningFollower: TBoldFollower); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure DoReplaceItem(index: Integer; Follower: TBoldFollower); {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure CleanRendererData(RendererData: TBoldRendererData); override; public + class function PrecreateFollowers: boolean; virtual; constructor Create(aOwningComponent: TComponent); procedure SetActiveRange(Follower: TBoldFollower; FirstActive: Integer; LastActive: Integer; RangeBuffer: Integer = 1); procedure SelectAll(Follower: TBoldFollower; SetSelect: Boolean); {Maybe make available in renderer?} - procedure SelectRange(Follower: TBoldFollower; index: Integer); - procedure SetSelected(Follower: TBoldFollower; index: Integer; Value: Boolean); - procedure ToggleSelected(Follower: TBoldFollower; index: Integer); - function GetSelected(Follower: TBoldFollower; index: Integer): Boolean; + procedure SelectRange(Follower: TBoldFollower; index: Integer); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetSelected(Follower: TBoldFollower; index: Integer; Value: Boolean); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure ToggleSelected(Follower: TBoldFollower; index: Integer); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure AddSelectedToList(Follower: TBoldFollower; BoldList: TBoldList); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetSelected(Follower: TBoldFollower; index: Integer): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} property OnBeforeInsertItem: TBoldSubFollowerEvent read fOnBeforeInsertItem write fOnBeforeInsertItem; - property OnAfterInsertItem: TBoldFollowerEvent read fOnAfterInsertItem write fOnAfterInsertItem; - property OnBeforeDeleteItem: TBoldFollowerEvent read fOnBeforeDeleteItem write fOnBeforeDeleteItem; + property OnAfterInsertItem: TBoldSubFollowerEvent read fOnAfterInsertItem write fOnAfterInsertItem; + property OnBeforeDeleteItem: TBoldSubFollowerEvent read fOnBeforeDeleteItem write fOnBeforeDeleteItem; property OnAfterDeleteItem: TBoldSubFollowerEvent read fOnAfterDeleteItem write fOnAfterDeleteItem; + property OnReplaceitem: TBoldSubFollowerEvent read fOnReplaceItem write fOnReplaceItem; end; {--- TBoldAsFollowerListRenderer ---} @@ -64,28 +72,34 @@ TBoldFollowerList = class(TBoldRendererData) FPrevSelected: Integer; function GetSelectedCount: Integer; procedure SetSelected(index: Integer; V: Boolean); - function GetSelected(index: Integer): Boolean; -// procedure UnselectPrev; + function GetSelected(index: Integer): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function UnsafeGetSelected(index: Integer): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure Insert(ListFollowerController: TBoldAsFollowerListController; Index: Integer; Follower: TBoldFollower); procedure Delete(ListFollowerController: TBoldAsFollowerListController; index: Integer); + procedure Replace(ListFollowerController: TBoldAsFollowerListController; index: Integer; Follower: TBoldFollower); + function GetBoldList: TBoldList; protected + function UnsafeGetSubFollower(Index: Integer): TBoldFollower; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure EnsureSubfollowersDisplayable; override; function GetSubFollowerCount: Integer; override; function GetSubFollower(Index: Integer): TBoldFollower; override; + function GetEnsuredSubFollower(Index: Integer): TBoldFollower; override; function GetCurrentSubFollowerIndex: Integer; override; procedure SetCurrentSubFollowerIndex(index: integer); override; + function GetSubFollowerAssigned(Index: Integer): boolean; override; public constructor Create(OwningFollower: TBoldFollower); override; destructor Destroy; override; + procedure SetCapacity(aNewCapacity: integer); procedure SetActiveRange(FirstActive, LastActive: Integer); procedure SelectAll(SetSelect: Boolean); procedure SelectRange(index: Integer); procedure AddSelectedToList(BoldList: TBoldList); procedure PurgeEnd(ListFollowerController: TBoldAsFollowerListController; PurgeCount: Integer); - procedure EnsureFollower(ListFollowerController: TBoldAsFollowerListController; - Index: Integer; - Element: TBoldElement; - Controller: TBoldFollowerController); { may disturb list after index} + function EnsuredFollower(aListFollowerController: TBoldAsFollowerListController; + aIndex: Integer; + aElement: TBoldElement; + aController: TBoldFollowerController): TBoldFollower; { may disturb list after index} property Followers[index: Integer]: TBoldFollower read GetSubFollower; default; property Count: Integer read GetSubFollowerCount; property FirstActive: Integer read FFirstActive; @@ -93,13 +107,16 @@ TBoldFollowerList = class(TBoldRendererData) property SelectedCount: Integer read GetSelectedCount; property Selected[index: Integer]: Boolean read GetSelected write SetSelected; property CurrentItem: Integer read FCurrentItem write FCurrentItem; + property BoldList: TBoldList read GetBoldList; end; implementation uses SysUtils, - BoldUtils; + BoldUtils, + BoldControllerListControlPack, + BoldListListControlPack; {---TBoldAsFollowerListController---} @@ -114,16 +131,23 @@ procedure TBoldAsFollowerListController.DoBeforeInsertItem(index: Integer; Ownin FOnBeforeInsertItem(index, OwningFollower); end; -procedure TBoldAsFollowerListController.DoAfterInsertItem(Follower: TBoldFollower); +procedure TBoldAsFollowerListController.DoReplaceItem(index: Integer; + Follower: TBoldFollower); +begin + if Assigned(fOnReplaceItem) then + fOnReplaceItem(index, Follower); +end; + +procedure TBoldAsFollowerListController.DoAfterInsertItem(index: Integer; Follower: TBoldFollower); begin if Assigned(FOnAfterInsertItem) then - FOnAfterInsertItem(Follower); + FOnAfterInsertItem(index, Follower); end; -procedure TBoldAsFollowerListController.DoBeforeDeleteItem(Follower: TBoldFollower); +procedure TBoldAsFollowerListController.DoBeforeDeleteItem(index: Integer; Follower: TBoldFollower); begin if Assigned(FOnBeforeDeleteItem) then - FOnBeforeDeleteItem(Follower); + FOnBeforeDeleteItem(index, Follower); end; procedure TBoldAsFollowerListController.DoAfterDeleteItem(index: Integer; OwningFollower: TBoldFollower); @@ -134,12 +158,14 @@ procedure TBoldAsFollowerListController.DoAfterDeleteItem(index: Integer; Owning procedure TBoldAsFollowerListController.SetActiveRange(Follower: TBoldFollower; FirstActive, LastActive: Integer; RangeBuffer: Integer = 1); begin - if Assigned(EffectiveRenderer) then // may be nil after finalization + if Assigned(EffectiveRenderer) then (EffectiveRenderer as TBoldAsFollowerListRenderer).SetActiveRange(Follower, FirstActive, LastActive, RangeBuffer); end; procedure TBoldAsFollowerListController.SelectAll(Follower: TBoldFollower; SetSelect: Boolean); begin + if SetSelect {and Follower.ElementValid and (Follower.Element is TBoldList)} then + TBoldAbstractListAsFollowerListController(Follower.Controller).SetActiveRange(Follower, 0, MaxInt); (Follower.RendererData as TBoldFollowerList).SelectAll(SetSelect) end; @@ -155,7 +181,8 @@ procedure TBoldAsFollowerListController.SetSelected(Follower: TBoldFollower; ind procedure TBoldAsFollowerListController.ToggleSelected(Follower: TBoldFollower; index: Integer); begin - (Follower.RendererData as TBoldFollowerList).Selected[index] := not (Follower.RendererData as TBoldFollowerList).Selected[index]; + with (Follower.RendererData as TBoldFollowerList) do + Selected[index] := not Selected[index]; end; function TBoldAsFollowerListController.GetSelected(Follower: TBoldFollower; index: Integer): Boolean; @@ -179,40 +206,64 @@ constructor TBoldFollowerList.Create(OwningFollower: TBoldFollower); begin inherited Create(OwningFollower); FArray := TList.Create; - FLastActive := High(FLastActive); FCurrentItem := -1; + FLastActive := MaxInt; +end; + +function TBoldFollowerList.UnsafeGetSubFollower( + Index: Integer): TBoldFollower; +begin + Result := TBoldFollower(FArray[index]) end; destructor TBoldFollowerList.Destroy; var I: Integer; + Follower: TBoldFollower; +// lBoldTreeNode: TBoldTreeNode; begin - for I := 0 to Count - 1 do - Followers[I].Free; + for I := Count - 1 downto 0 do + begin +{ Follower := UnsafeGetSubFollower(I); + if Assigned(Follower) and Assigned(Follower.ControlData) then + begin + lBoldTreeNode := Follower.ControlData as TBoldTreeNode; + lBoldTreeNode.Follower := nil; + end; +} + UnsafeGetSubFollower(I).free; + end; FreeAndNil(FArray); inherited; end; procedure TBoldFollowerList.SetActiveRange(FirstActive, LastActive: Integer); var - I: Integer; + lIndex: Integer; + lFollower: TBoldFollower; + lActive: boolean; begin FFirstActive := FirstActive; FLastActive := LastActive; - for I := 0 to Count - 1 do + for lIndex := 0 to Count - 1 do begin - Followers[I].Active := (I >= FirstActive) and (I <= LastActive); + lActive := (lIndex >= FirstActive) and (lIndex <= LastActive); + if lActive then + lFollower := GetSubFollower(lIndex) + else + lFollower := UnsafeGetSubFollower(lIndex); + if Assigned(lFollower) then + lFollower.Active := lActive; end; end; - function TBoldFollowerList.GetSelectedCount: Integer; var Row: Integer; begin Result := 0; for Row := 0 to Count - 1 do - if Selected[Row] then + if UnsafeGetSelected(Row) then Inc(Result); end; @@ -222,11 +273,65 @@ function TBoldFollowerList.GetSubFollowerCount: Integer; end; function TBoldFollowerList.GetSubFollower(Index: Integer): TBoldFollower; + procedure InternalRaise; + begin + Assert( Cardinal(Index) < Cardinal(fArray.Count), 'TBoldFollowerList.GetSubFollower index out of range.' + IntToStr(Index) + '/' + IntToStr(fArray.count)); + end; + +begin + if Cardinal(Index) >= Cardinal(fArray.Count) then + InternalRaise; + Result := TBoldFollower(FArray[index]); + if not Assigned(Result) then + begin + if (OwningFollower.Controller is TBoldControllerList) then + begin + result := EnsuredFollower( + OwningFollower.Controller as TBoldAsFollowerListController, + Index, + OwningFollower.element, + TBoldControllerList(OwningFollower.Controller)[Index]); + FArray[index] := result; + Assert(Assigned(result)); + end; + end; +end; + +function TBoldFollowerList.GetEnsuredSubFollower( + Index: Integer): TBoldFollower; +var + BoldAsFollowerListController: TBoldAsFollowerListController; +begin + result := GetSubFollower(Index); + if not Assigned(result) then + begin + BoldAsFollowerListController := nil; + if (OwningFollower.Controller is TBoldControllerList) then + BoldAsFollowerListController := OwningFollower.Controller as TBoldControllerList + else + if (OwningFollower.Controller is TBoldListAsFollowerListController) then + BoldAsFollowerListController := TBoldListAsFollowerListController(OwningFollower.Controller); + + if Assigned(BoldAsFollowerListController) then + begin +// Delete(OwningFollower.Controller as TBoldAsFollowerListController, Index); + result := TBoldFollower.CreateSubFollower(OwningFollower, BoldAsFollowerListController, OwningFollower.element, true, Index); + Replace(BoldAsFollowerListController, Index, result); +// Insert(OwningFollower.Controller as TBoldAsFollowerListController, Index, result); + end; + end; +end; + +function TBoldFollowerList.GetBoldList: TBoldList; begin - if (index >= 0) and (index < fArray.Count) then - Result := TBoldFollower(FArray[index]) + Assert(Assigned(OwningFollower)); + if OwningFollower.Element = nil then + result := nil else - result := nil; + begin + Assert(OwningFollower.Element is TBoldList); + result := OwningFollower.Element as TBoldList; + end; end; function TBoldFollowerList.GetCurrentSubFollowerIndex: Integer; @@ -238,7 +343,7 @@ procedure TBoldFollowerList.SetSelected(index: Integer; V: Boolean); begin if (index > -1) and (index < Count) and - (Followers[index].Selected <> V) then + Assigned(Followers[index]) and (Followers[index].Selected <> V) then begin if V then FPrevSelected := index; @@ -246,17 +351,34 @@ procedure TBoldFollowerList.SetSelected(index: Integer; V: Boolean); end; end; +function TBoldFollowerList.GetSubFollowerAssigned(Index: Integer): boolean; +begin + if Index < Count then + Result := Assigned(UnsafeGetSubFollower(index)) + else + result := false; +end; + function TBoldFollowerList.GetSelected(index: Integer): Boolean; begin - Result := Followers[index].Selected; + Result := Assigned(Followers[index]) and Followers[index].Selected; end; procedure TBoldFollowerList.SelectAll(SetSelect: Boolean); var Row: Integer; + lFollower: TBoldFollower; begin for Row := 0 to Count - 1 do - Followers[Row].Selected := SetSelect; + begin + if SetSelect then + lFollower := GetEnsuredSubFollower(Row) + else + lFollower := UnsafeGetSubFollower(Row); + Assert(not SetSelect or Assigned(lFollower)); + if Assigned(lFollower) then + lFollower.Selected := SetSelect; + end; end; procedure TBoldFollowerList.SelectRange(index: Integer); @@ -285,64 +407,166 @@ procedure TBoldFollowerList.UnselectPrev; procedure TBoldFollowerList.AddSelectedToList(BoldList: TBoldList); var Row: Integer; + lBoldFollower: TBoldFollower; begin for Row := 0 to Count - 1 do - if (Followers[Row].Selected) and - Assigned(Followers[Row].Element) and - BoldTestType(Followers[Row].Element, TBoldObject) then - BoldList.Add(Followers[Row].Element); + begin + lBoldFollower := UnsafeGetSubFollower(Row); + if Assigned(lBoldFollower) and (lBoldFollower.Selected) and + Assigned(lBoldFollower.Element) and + BoldTestType(lBoldFollower.Element, TBoldObject) then + BoldList.Add(lBoldFollower.Element); + end; end; procedure TBoldFollowerList.Delete(ListFollowerController: TBoldAsFollowerListController; Index: Integer); var I: Integer; + lFollower: TBoldFollower; begin - ListFollowerController.DoBeforeDeleteItem(Followers[index]); - Followers[index].Free; + lFollower := UnsafeGetSubFollower(index); + begin + ListFollowerController.DoBeforeDeleteItem(index, lFollower); + lFollower.Free; + end; FArray.Delete(index); for I := index to Count - 1 do - Followers[I].Index := I; + begin + lFollower := UnsafeGetSubFollower(I); + if Assigned(lFollower) then + lFollower.Index := I; + end; ListFollowerController.DoAfterDeleteItem(Index, OwningFollower); end; procedure TBoldFollowerList.Insert(ListFollowerController: TBoldAsFollowerListController; Index: Integer; Follower: TBoldFollower); var I: Integer; + lFollower: TBoldFollower; begin ListFollowerController.DoBeforeInsertItem(Index, OwningFollower); FArray.Insert(index, Follower); - for I := index to Count - 1 do - Followers[I].Index := I; - ListFollowerController.DoAfterInsertItem(Followers[Index]); + Assert(not Assigned(Follower) or (Follower.index = index)); + for I := index+1 to Count - 1 do + begin + lFollower := UnsafeGetSubFollower(I); + if Assigned(lFollower) then + lFollower.Index := I; + end; + ListFollowerController.DoAfterInsertItem(Index, Follower); +end; + +procedure TBoldFollowerList.Replace(ListFollowerController: TBoldAsFollowerListController; Index: Integer; Follower: TBoldFollower); +begin + ListFollowerController.DoReplaceItem(Index, Follower); + FArray[Index] := Follower; end; procedure TBoldFollowerList.PurgeEnd(ListFollowerController: TBoldAsFollowerListController; PurgeCount: Integer); var I: Integer; begin - TBoldPublisher.StartNotify; - try - for I := Count - 1 downto PurgeCount do - Delete(ListFollowerController, I); - finally - TBoldPublisher.EndNotify; + if Count > PurgeCount then + begin + TBoldPublisher.StartNotify; + try + for I := Count - 1 downto PurgeCount do + Delete(ListFollowerController, I); + finally + TBoldPublisher.EndNotify; + end; end; end; -procedure TBoldFollowerList.EnsureFollower(ListFollowerController: TBoldAsFollowerListController; - Index: Integer; - Element: TBoldElement; - Controller: TBoldFollowerController); +function TBoldFollowerList.EnsuredFollower(aListFollowerController: TBoldAsFollowerListController; + aIndex: Integer; + aElement: TBoldElement; + aController: TBoldFollowerController): TBoldFollower; +var + lBoldFollower: TBoldFollower; + lActive: boolean; begin - if (element = nil) and (index < Count) and (Followers[index].Controller = Controller) then - Followers[index].Element := Element; - if (index < Count) and (Followers[index].Element = Element) and (Followers[index].Controller = Controller) then - {all ok} - else if (index + 1 < Count) and (Followers[index + 1].Element = Element) and (Followers[index + 1].Controller = Controller) then - Delete(ListFollowerController, Index) + result := nil; + lActive := (aIndex <= LastActive) and (aIndex >= FirstActive); // and not aController.DelayedActivate; + if (not Assigned(aElement) or not lActive) and not (aListFollowerController.PrecreateFollowers) then + begin + if (aIndex >= Count) then + begin + Assert(aIndex = Count); + Insert(aListFollowerController, aIndex, nil); + end + else + begin + result := TBoldFollower(FArray[aIndex]); + if (not Assigned(result) and Assigned(aElement)) then + begin +// Delete(aListFollowerController, aIndex); + lBoldFollower := TBoldFollower.CreateSubFollower(OwningFollower, aController, aElement, lActive, aIndex); + Replace(aListFollowerController, aIndex, lBoldFollower); +// Insert(aListFollowerController, aIndex, lBoldFollower); + result := lBoldFollower; + end + else + begin + if (Assigned(result) and not Assigned(aElement) and ((result.Controller <> aController))) then + begin + Insert(aListFollowerController, aIndex, nil); + result := nil; + end; + end; + end; + exit; + end; + if (aIndex < Count) then + begin + lBoldFollower := UnsafeGetSubFollower(aIndex); + if Assigned(lBoldFollower) then + begin + if (lBoldFollower.Element = aElement) and (lBoldFollower.Controller = aController) then + begin + result := lBoldFollower; + result.Active := lActive; + exit; + end + else + begin + Assert(Assigned(aListFollowerController), lBoldFollower.className ); +// if (lBoldFollower.Controller = aController) +// begin +// lBoldFollower.SetElementAndMakeCurrent(AElement, lActive); +// Replace(aListFollowerController, aIndex, lBoldFollower); +// result := lBoldFollower; +// end +// else + begin + Delete(aListFollowerController, aIndex); + lBoldFollower := TBoldFollower.CreateSubFollower(OwningFollower, aController, aElement, lActive, aIndex); + Insert(aListFollowerController, aIndex, lBoldFollower); + result := lBoldFollower; + end; + end; + end + else + begin +// Delete(aListFollowerController, aIndex); + lBoldFollower := TBoldFollower.CreateSubFollower(OwningFollower, aController, aElement, lActive, aIndex); + Replace(aListFollowerController, aIndex, lBoldFollower); +// Insert(aListFollowerController, aIndex, lBoldFollower); + result := lBoldFollower; + end; + end else - Insert(ListFollowerController, index, TBoldFollower.CreateSubFollower(OwningFollower, Controller, Element)); - Followers[index].Active := (index >= FirstActive) and (index <= LastActive); + begin + lBoldFollower := TBoldFollower.CreateSubFollower(OwningFollower, aController, aElement, lActive, aIndex); + Insert(aListFollowerController, aIndex, lBoldFollower); + result := lBoldFollower; + end; +end; + +procedure TBoldFollowerList.SetCapacity(aNewCapacity: integer); +begin + if aNewCapacity > FArray.Capacity then + FArray.Capacity := aNewCapacity; end; procedure TBoldFollowerList.SetCurrentSubFollowerIndex(index: integer); @@ -353,12 +577,17 @@ procedure TBoldFollowerList.SetCurrentSubFollowerIndex(index: integer); procedure TBoldFollowerList.EnsureSubfollowersDisplayable; var - i: integer; + lIndex: integer; + lBoldFollower: TBoldFollower; begin - for I := 0 to Count - 1 do - with Followers[I] do - if Active then - EnsureDisplayable; + for lIndex := 0 to Count - 1 do + begin + lBoldFollower := UnsafeGetSubFollower(lIndex); + if Assigned(lBoldFollower) and not lBoldFollower.Displayable and lBoldFollower.Active then + begin + lBoldFollower.EnsureDisplayable; + end; + end; end; procedure TBoldAsFollowerListController.CleanRendererData(RendererData: TBoldRendererData); @@ -367,5 +596,20 @@ procedure TBoldAsFollowerListController.CleanRendererData(RendererData: TBoldRen (RendererData as TBoldFollowerList).PurgeEnd(self, 0); end; -end. +procedure TBoldAsFollowerListController.AddSelectedToList(Follower: TBoldFollower; + BoldList: TBoldList); +begin + (Follower.RendererData as TBoldFollowerList).AddSelectedToList(BoldList); +end; + +function TBoldFollowerList.UnsafeGetSelected(index: Integer): Boolean; +begin + Result := UnsafeGetSubFollower(index).Selected; +end; +class function TBoldAsFollowerListController.PrecreateFollowers: boolean; +begin + result := false; +end; + +end. diff --git a/Source/BoldAwareGUI/ControlPacks/BoldListHandleFollower.pas b/Source/BoldAwareGUI/ControlPacks/BoldListHandleFollower.pas index bf7f54f4..eab62439 100644 --- a/Source/BoldAwareGUI/ControlPacks/BoldListHandleFollower.pas +++ b/Source/BoldAwareGUI/ControlPacks/BoldListHandleFollower.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldListHandleFollower; {$UNDEF BOLDCOMCLIENT} @@ -12,39 +15,34 @@ interface BoldSubscription, BoldControlPack, BoldListListControlPack, - BoldAbstractListHandle; + BoldAbstractListHandle, + BoldHandles; -// Note, Currently subscibes to value-identity-change via element of handle, until -// subscribability has been added to the handle. type { forward declarations } TBoldListHandleFollower = class; { TBoldListHandleFollower } - TBoldListHandleFollower = class(TBoldQueueable) + TBoldListHandleFollower = class(TBoldAbstractHandleFollower) private fBoldHandle: TBoldAbstractListHandle; - fFollower: TBoldFollower; fFollowerValueCurrent: Boolean; fHandleIndexLock: Boolean; - fSubscriber: TBoldSubscriber; procedure SetFollowerValueCurrent(value: Boolean); procedure SetBoldHandle(value: TBoldAbstractListHandle); property FollowerValueCurrent: Boolean read fFollowerValueCurrent write SetFollowerValueCurrent; protected - procedure Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); + function GetBoldHandle: TBoldElementHandle; override; + procedure Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); override; procedure Display; override; - property Subscriber: TBoldSubscriber read fSubscriber; public procedure Apply; override; procedure DiscardChange; override; procedure SetFollowerIndex(index: integer); property BoldHandle: TBoldAbstractListHandle read FBoldHandle write SetBoldHandle; property HandleIndexLock: boolean read fHandleIndexLock write fHandleIndexLock default True; - property Follower: TBoldFollower read fFollower; - constructor Create(MatchObject: TObject; Controller: TBoldAbstractListAsFollowerListController); - destructor Destroy; override; + constructor Create(AMatchObject: TObject; Controller: TBoldAbstractListAsFollowerListController); end; implementation @@ -69,31 +67,20 @@ procedure TBoldListHandleFollower.Receive(Originator: TObject; end; end; -constructor TBoldListHandleFollower.Create(MatchObject: TObject; +constructor TBoldListHandleFollower.Create(AMatchObject: TObject; Controller: TBoldAbstractListAsFollowerListController); begin - inherited Create(nil); - fSubscriber := TBoldPassthroughSubscriber.Create(Receive); - fFollower := TBoldFollower.Create(MatchObject, Controller); - fFollower.PrioritizedQueuable := Self; + inherited Create(AMatchObject, Controller); fFollowerValueCurrent := true; fHandleIndexLock := true; end; -destructor TBoldListHandleFollower.Destroy; -begin - FreeAndNil(fFollower); - FreeAndNil(fSubscriber); - inherited; -end; - procedure TBoldListHandleFollower.SetBoldHandle( value: TBoldAbstractListHandle); begin if (value <> BoldHandle) then begin fBoldHandle := Value; - // will force subscription on Handle FollowerValueCurrent := false; end; end; @@ -119,13 +106,13 @@ procedure TBoldListHandleFollower.SetFollowerValueCurrent(value: Boolean); Assert(Assigned(Follower)); if Assigned(BoldHandle) then begin - fFollower.Element := BoldHandle.List; + Follower.Element := BoldHandle.List; if (HandleIndexLock) then - SetfollowerIndex((Follower.Controller as TBoldAbstractListAsFollowerListController).ListIndex(BoldHandle.CurrentIndex)); + SetFollowerIndex((Follower.Controller as TBoldAbstractListAsFollowerListController).ListIndex(BoldHandle.CurrentIndex)); end else begin - fFollower.Element := nil; + Follower.Element := nil; end; end; @@ -133,8 +120,8 @@ procedure TBoldListHandleFollower.SetFollowerValueCurrent(value: Boolean); begin if Assigned(BoldHandle) then begin - BoldHandle.AddSmallSubscription(Subscriber, [beValueIdentityChanged], breListIdentityChanged); // FIXME - BoldHandle.AddSmallSubscription(Subscriber, [beValueIdentityChanged], breHandleIndexChanged); // FIXME + BoldHandle.AddSmallSubscription(Subscriber, [beValueIdentityChanged], breListIdentityChanged); + BoldHandle.AddSmallSubscription(Subscriber, [beValueIdentityChanged], breHandleIndexChanged); end; end; @@ -150,7 +137,7 @@ procedure TBoldListHandleFollower.SetFollowerValueCurrent(value: Boolean); if Value then begin PropagateValue; - RemoveFromDisplayList; + RemoveFromDisplayList(false); Subscribe; end else @@ -177,5 +164,10 @@ procedure TBoldListHandleFollower.SetFollowerIndex(index: integer); BoldHandle.CurrentIndex := NewHandleIndex; end; -end. +function TBoldListHandleFollower.GetBoldHandle: TBoldElementHandle; +begin + result := fBoldHandle; +end; + +end. diff --git a/Source/BoldAwareGUI/ControlPacks/BoldListListControlPack.pas b/Source/BoldAwareGUI/ControlPacks/BoldListListControlPack.pas index a48b8adf..735c82c0 100644 --- a/Source/BoldAwareGUI/ControlPacks/BoldListListControlPack.pas +++ b/Source/BoldAwareGUI/ControlPacks/BoldListListControlPack.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldListListControlPack; {$UNDEF BOLDCOMCLIENT} @@ -5,7 +8,7 @@ interface uses - Classes, + Classes, BoldDefs, BoldElements, BoldControlPackDefs, @@ -25,28 +28,28 @@ TBoldAbstractListAsFollowerListController = class(TBoldAsFollowerListControlle fDefaultDblClick: Boolean; fFollowerController: TBoldFollowerController; fNilElementMode: TBoldNilElementMode; - function GetRenderer: TBoldListAsFollowerListRenderer; - procedure SetRenderer(Value: TBoldListAsFollowerListRenderer); + function GetRenderer: TBoldListAsFollowerListRenderer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetRenderer(Value: TBoldListAsFollowerListRenderer); {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetNilElementMode(const Value: TBoldNilElementMode); protected + class function PrecreateFollowers: boolean; override; function GetEffectiveRenderer: TBoldRenderer; override; - function GetEffectiveListAsFollowerListRenderer: TBoldListAsFollowerListRenderer; + function GetEffectiveListAsFollowerListRenderer: TBoldListAsFollowerListRenderer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure DoMakeUptodateAndSubscribe(Follower: TBoldFollower; Subscribe: Boolean); override; procedure DoAssign(Source: TPersistent); override; property EffectiveListAsFollowerListRenderer: TBoldListAsFollowerListRenderer read GetEffectiveListAsFollowerListRenderer; property DefaultDblClick: Boolean read fDefaultDblClick write fDefaultDblClick default True; - property DragMode default bdgSelection; - property DropMode default bdpAppend; + property DragMode; + property DropMode; property InternalDrag: Boolean read fInternalDrag write fInternalDrag default True; property Renderer: TBoldListAsFollowerListRenderer read GetRenderer write SetRenderer; - property NilElementMode: TBoldNilElementMode read fNilElementMode write SetNilElementMode; + property NilElementMode: TBoldNilElementMode read fNilElementMode write SetNilElementMode default neNone; public constructor Create(aOwningComponent: TComponent; FollowerController: TBoldFollowerController); -// procedure DragDrop(Follower: TBoldFollower; ReceivingElement: TBoldElement; dropindex: Integer); override; -// function DragOver(Follower: TBoldFollower; ReceivingElement: TBoldElement; dropindex: Integer): Boolean; override; - function GetListIndex(Follower: TBoldFollower): Integer; - function ListIndexToIndex(Follower: TBoldFollower; ListIndex: Integer): integer; - function ListIndex(index: integer): integer; + + function GetListIndex(Follower: TBoldFollower): Integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function ListIndexToIndex(Follower: TBoldFollower; ListIndex: Integer): integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function ListIndex(index: integer): integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} end; { TBoldListAsFollowerListController } @@ -75,9 +78,8 @@ implementation uses SysUtils, - BoldGuiResourceStrings, BoldUtils, - {$IFNDEF BOLDCOMCLIENT} // uses + {$IFNDEF BOLDCOMCLIENT} BoldSystem, BoldGUI, {$ENDIF} @@ -91,8 +93,8 @@ constructor TBoldAbstractListAsFollowerListController.Create(aOwningComponent: T begin inherited Create(aOwningComponent); fFollowerController := FollowerController; - DragMode := bdgSelection; - DropMode := bdpAppend; + DragMode := DefaultBoldDragMode; + DropMode := DefaultBoldDropMode; fDefaultDblClick := True; fNilElementMode := neNone; fInternalDrag := True; @@ -135,7 +137,7 @@ procedure TBoldAbstractListAsFollowerListController.DoMakeUptodateAndSubscribe(F begin inherited DoMakeUptodateAndSubscribe(Follower, Subscribe); (EffectiveRenderer as TBoldListAsFollowerListRenderer).MakeUptodate(Follower, fFollowerController); - {$IFDEF BOLDCOMCLIENT} // MakeUptodateAndSubscribe + {$IFDEF BOLDCOMCLIENT} if Subscribe and Assigned(Follower.Element) then Follower.Element.SubscribeToExpression('', Follower.Subscriber.ClientId, Follower.Subscriber.SubscriberId, false, false); {$ELSE} @@ -163,11 +165,6 @@ procedure TBoldAbstractListAsFollowerListController.SetNilElementMode(const Valu end; end; -function TBoldAbstractListAsFollowerListController.GetEffectiveRenderer: TBoldRenderer; -begin - Result := EffectiveListAsFollowerListRenderer; -end; - function TBoldAbstractListAsFollowerListController.GetEffectiveListAsFollowerListRenderer: TBoldListAsFollowerListRenderer; begin if Assigned(Renderer) then @@ -176,11 +173,29 @@ function TBoldAbstractListAsFollowerListController.GetEffectiveListAsFollowerLis Result := TBoldListAsFollowerListRenderer.DefaultRenderer; end; +function TBoldAbstractListAsFollowerListController.GetEffectiveRenderer: TBoldRenderer; +begin + Result := EffectiveListAsFollowerListRenderer; +end; + function TBoldAbstractListAsFollowerListController.GetListIndex(Follower: TBoldFollower): Integer; begin Result := Follower.CurrentIndex; if (NilElementMode = neInsertFirst) and (Result >= 0) then - Dec(Result); + Dec(Result) + else + if (NilElementMode = neAddLast) and (Result = Follower.SubFollowerCount-1) then + result := -1; +end; + +function TBoldAbstractListAsFollowerListController.ListIndex(index: integer): integer; +begin + if index = MaxInt then + result := index + else if NilElementMode = neInsertFirst then + Result := index + 1 + else + Result := index; end; {---TBoldListAsFollowerListRenderer---} @@ -192,6 +207,7 @@ procedure TBoldListAsFollowerListRenderer.SetActiveRange(Follower: TBoldFollower FirstToEnsure, LastToEnsure: integer; FirstFollowerActive, LastFollowerActive: integer; FollowerController: TBoldAbstractListAsFollowerListController; + Element: TBoldElement; begin if not assigned(follower.element) then exit; @@ -211,13 +227,18 @@ procedure TBoldListAsFollowerListRenderer.SetActiveRange(Follower: TBoldFollower if FirstToEnsure < 0 then FirstToEnsure := 0; - if FirstToEnsure >= List.Count then - FirstToEnsure := List.Count - 1; + i := List.Count; + if FirstToEnsure >= i then + FirstToEnsure := i - 1; - if LastToEnsure >= list.Count then - LastToEnsure := List.Count - 1; + if LastToEnsure >= i then + LastToEnsure := i - 1; - list.EnsureRange(FirstToEnsure, LastToEnsure); + if (LastToEnsure > FirstToEnsure) and (LastToEnsure <> -1) then + list.EnsureRange(FirstToEnsure, LastToEnsure); + + if Follower.Element <> List then + Follower.Element := List; FirstFollowerActive := FirstActive; LastFollowerActive := LastActive; @@ -225,22 +246,30 @@ procedure TBoldListAsFollowerListRenderer.SetActiveRange(Follower: TBoldFollower if FirstFollowerActive >= Follower.SubFollowerCount then FirstFollowerActive := Follower.SubFollowerCount-1; - if FirstFollowerActive >= List.Count then - FirstFollowerActive := List.Count - 1; + if FirstFollowerActive >= i then + FirstFollowerActive := i - 1; if FirstFollowerActive < 0 then FirstFollowerActive := 0; if LastFollowerActive >= Follower.SubFollowerCount then LastFollowerActive := Follower.SubFollowerCount - 1; - if LastFollowerActive >= list.Count then - LastFollowerActive := List.Count - 1; + if LastFollowerActive >= i then + LastFollowerActive := i - 1; - for i := FirstFollowerActive to LastFollowerActive do +{ for i := FirstFollowerActive to LastFollowerActive do with Follower.SubFollowers[i] do if not ElementValid then Element := List.Elements[FollowerController.ListIndex(i)]; +} + inherited SetActiveRange(Follower, FirstFollowerActive, LastFollowerActive); + + for i := FirstFollowerActive to LastFollowerActive do + begin + Element := List.Elements[FollowerController.ListIndex(i)]; + (Follower.RendererData as TBoldFollowerList).EnsuredFollower(FollowerController, i, Element, FollowerController.fFollowerController); + end; end; class function TBoldListAsFollowerListRenderer.DefaultRenderer: TBoldListAsFollowerListRenderer; @@ -263,12 +292,13 @@ procedure TBoldListAsFollowerListRenderer.MakeUptodate(Follower: TBoldFollower; procedure AddElement(aElement: TBoldElement); begin - DestList.EnsureFollower(Controller, DestIndex, aElement, FollowerController); + DestList.EnsuredFollower(Controller, DestIndex, aElement, FollowerController); Inc(DestIndex); end; begin DestList := Follower.RendererData as TBoldFollowerList; + Assert(DestList.BoldList = Follower.Element); Controller := Follower.Controller as TBoldAbstractListAsFollowerListController; DestIndex := 0; @@ -277,27 +307,37 @@ procedure TBoldListAsFollowerListRenderer.MakeUptodate(Follower: TBoldFollower; if Assigned(Follower.Element) then begin SourceList := Follower.Element as TBoldList; + Assert(Assigned(SourceList), 'TBoldListAsFollowerListRenderer.MakeUptodate: Assigned(SourceList)'); {$IFNDEF BOLDCOMCLIENT} SourceList.EnsureRange(Controller.ListIndex(DestList.FirstActive), Controller.ListIndex(DestList.LastActive)); {$ELSE} SourceVariant := SourceList.GetRange(Controller.ListIndex(DestList.FirstActive), Controller.ListIndex(DestList.LastActive)); {$ENDIF} - for SourceIndex := 0 to SourceList.Count - 1 do - if (DestIndex >= DestList.FirstActive) and (Destindex <= DestList.LastActive) then - {$IFNDEF BOLDCOMCLIENT} - AddElement(SourceList[SourceIndex]) - {$ELSE} - begin - unk := SourceVariant[SourceIndex]; - ElementInterface := unk as IBoldElement; - AddElement(ElementInterface); - end - {$ENDIF} - else + SourceIndex := 0; + SourceList := Follower.Element as TBoldList; + if Assigned(SourceList) then + begin + if SourceList.Count > 4 then + DestList.SetCapacity(SourceList.Count); + while SourceIndex < SourceList.Count do begin - AddElement(nil); - DestList[DestIndex-1].ElementValid := false; + if (DestIndex >= DestList.FirstActive) and (Destindex <= DestList.LastActive) then + begin + DestList.EnsuredFollower(Controller, DestIndex, SourceList[SourceIndex], FollowerController); + if not (Follower.Element = SourceList) then + Assert(Follower.Element = SourceList, 'If this fails, make a clone of SourceList before the loop.'); + // SourceList := Follower.Element as TBoldList; + Inc(DestIndex); + end + else + begin + DestList.EnsuredFollower(Controller, DestIndex, nil, FollowerController); + // DestList[DestIndex].ElementValid := false; + Inc(DestIndex); + end; + inc(SourceIndex); end; + end; end; if (Controller.NilElementMode=neAddLast) then AddElement(nil); @@ -305,16 +345,16 @@ procedure TBoldListAsFollowerListRenderer.MakeUptodate(Follower: TBoldFollower; end; procedure TBoldListAsFollowerListRenderer.DefaultStartDrag(Element: TBoldElement; DragMode: TBoldDragMode; RendererData: TBoldRendererData); -{$IFNDEF BOLDCOMCLIENT} // dragdrop - DefaultStartDrag +{$IFNDEF BOLDCOMCLIENT} var FollowerList: TBoldFollowerList; {$ENDIF} begin - {$IFNDEF BOLDCOMCLIENT} // dragdrop - DefaultStartDrag + {$IFNDEF BOLDCOMCLIENT} if (DragMode = bdgSelection) then begin if BoldGUIHandler.DraggedObjects.Count <> 0 then - raise EBold.CreateFmt(sDraggedObjectsNotCleared, [ClassName]); + raise EBold.Create('TBoldListAsFollowerListRenderer.DefaultStartDrag: TBoldGUIHandler.DraggedObjects not cleared'); Followerlist := RendererData as TBoldFollowerList; Followerlist.AddSelectedToList(BoldGUIHandler.DraggedObjects); @@ -324,16 +364,16 @@ procedure TBoldListAsFollowerListRenderer.DefaultStartDrag(Element: TBoldElement function TBoldListAsFollowerListRenderer.DefaultDragOver(Element: TBoldElement; DropMode: TBoldDropMode; InternalDrag: Boolean; RendererData: TBoldRendererData; dropindex: Integer): Boolean; begin - {$IFNDEF BOLDCOMCLIENT} // dragdrop - DefaultDragOver + {$IFNDEF BOLDCOMCLIENT} Result := (BoldGUIHandler.DraggedObjects.Count > 0) and - BoldGUIHandler.DraggedObjectsAssignable(Element, DropMode); // FIXME move here + BoldGUIHandler.DraggedObjectsAssignable(Element, DropMode); {$ELSE} result := false; {$ENDIF} end; procedure TBoldListAsFollowerListRenderer.DefaultDragDrop(Element: TBoldElement; DropMode: TBoldDropMode; dropindex: Integer); -{$IFNDEF BOLDCOMCLIENT} // dragdrop - DefaultDragDrop +{$IFNDEF BOLDCOMCLIENT} var prevIndex, Offset, @@ -344,7 +384,7 @@ procedure TBoldListAsFollowerListRenderer.DefaultDragDrop(Element: TBoldElement; (* if (NilElementMode=neInsertFirst) then Offset := 1 - else*) //FIXME + else*) Offset := 0; case DropMode of bdpInsert: @@ -376,11 +416,10 @@ procedure TBoldListAsFollowerListRenderer.DefaultDragDrop(Element: TBoldElement; bdpAppend: for I := 0 to BoldGUIHandler.DraggedObjects.Count - 1 do - // Dupe checking by the ObjectList ObjectList.Add(BoldGUIHandler.DraggedObjects[I]); bdpReplace: - raise EBoldFeatureNotImplementedYet.CreateFmt(sReplaceNotImplemented, [ClassName]); + raise EBoldFeatureNotImplementedYet.CreateFmt('%s.DefaultDragDrop: Replace not implemented yet', [ClassName]); end; end; {$ELSE} @@ -396,14 +435,10 @@ function TBoldAbstractListAsFollowerListController.ListIndexToIndex(Follower: TB Result := Listindex; end; -function TBoldAbstractListAsFollowerListController.ListIndex(index: integer): integer; + +class function TBoldAbstractListAsFollowerListController.PrecreateFollowers: boolean; begin - if index = MaxInt then - result := index // otherwise the result will overflow to -maxint - else if NilElementMode = neInsertFirst then - Result := index + 1 - else - Result := index; + result := false; end; initialization @@ -413,4 +448,3 @@ finalization FreeAndNil(DefaultListAsFollowerListRenderer); end. - diff --git a/Source/BoldAwareGUI/ControlPacks/BoldMLRenderers.pas b/Source/BoldAwareGUI/ControlPacks/BoldMLRenderers.pas index 9d1fef5d..9cc1681e 100644 --- a/Source/BoldAwareGUI/ControlPacks/BoldMLRenderers.pas +++ b/Source/BoldAwareGUI/ControlPacks/BoldMLRenderers.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldMLRenderers; interface @@ -13,25 +16,26 @@ interface { forward declarations } TBoldAsMLStringRenderer = class; - TBoldLanguageGetAsString = function (Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; Language: String): string of object; - TBoldLanguageSetAsString = procedure (Element: TBoldElement; Value: string; Representation: TBoldRepresentation; Expression: TBoldExpression; Language: String) of object; - TBoldLanguageSubscribe = procedure (Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; Subscriber: TBoldSubscriber; Language: String) of object; + TBoldLanguageGetAsString = function (aFollower: TBoldFollower; const Language: String): string of object; + TBoldLanguageSetAsString = procedure (aFollower: TBoldFollower; const Value: string; const Language: String) of object; + TBoldLanguageSubscribe = procedure (aFollower: TBoldFollower; const Language: String; Subscriber: TBoldSubscriber) of object; { TBoldAsMLStringRenderer } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldAsMLStringRenderer = class (TBoldAsStringRenderer) private fLanguage: String; fOnLanguageGetAsString: TBoldLanguageGetAsString; fOnLanguageSetAsString: TBoldLanguageSetAsString; - fOnLanguageSubscribe: TBoldLAnguageSubscribe; - procedure SetLanguage(newValue: String); + fOnLanguageSubscribe: TBoldLanguageSubscribe; + procedure SetLanguage(const newValue: String); protected - procedure SetAsString(Element: TBoldElement; Value: string; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); override; - function GetAsStringAndSubscribe(Element: TBoldElement; FollowerController: TBoldStringFollowerController; Subscriber: TBoldSubscriber): string; override; + procedure SetAsString(aFollower: TBoldFollower; const Value: string); override; + function GetAsStringAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): string; override; public - function DefaultGetAsStringAndSubscribe(Element: TBoldElement; FollowerController: TBoldStringFollowerController; Subscriber: TBoldSubscriber): string; override; - procedure DefaultSetAsString(Element: TBoldElement; Value: string; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); override; - procedure DefaultMakeUptodateAndSetMayModifyAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldStringFollowerController; Subscriber: TBoldSubscriber); override; + function DefaultGetAsStringAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): string; override; + procedure DefaultSetAsString(aFollower: TBoldFollower; const Value: string); override; + procedure DefaultMakeUptodateAndSetMayModifyAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); override; published property Language: String read fLanguage write SetLanguage; property OnLanguageGetAsString: TBoldLanguageGetAsString read FOnLanguageGetAsString write FOnLanguageGetAsString; @@ -43,153 +47,173 @@ implementation uses SysUtils, - BoldGuiResourceStrings, BoldMLAttributes, - BoldUtils; + BoldUtils, + BoldGuard; -function TBoldAsMLStringRenderer.GetAsStringAndSubscribe(Element: TBoldElement; FollowerController: TBoldStringFollowerController; Subscriber: TBoldSubscriber): string; +function TBoldAsMLStringRenderer.GetAsStringAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): string; begin if Assigned(OnLanguageSubscribe) and Assigned(Subscriber) then begin - if Assigned(Element) then - OnLanguageSubscribe(Element, FollowerController.Representation, FollowerController.Expression, Subscriber, Language); + if Assigned(aFollower.Element) then + OnLanguageSubscribe(aFollower, Language, Subscriber); Subscriber := nil; end; if Assigned(OnLanguageGetAsString) then begin - Result := OnLanguageGetAsString(Element, FollowerController.Representation, FollowerController.Expression, Language); + Result := OnLanguageGetAsString(aFollower, Language); if not assigned(OnLanguageSubscribe) and assigned(Subscriber) then - DefaultGetAsStringAndSubscribe(Element, FollowerController, Subscriber); + DefaultGetAsStringAndSubscribe(aFollower, Subscriber); end else - Result := DefaultGetAsStringAndSubscribe(Element, FollowerController, Subscriber); + Result := DefaultGetAsStringAndSubscribe(aFollower, Subscriber); end; -function TBoldAsMLStringRenderer.DefaultGetAsStringAndSubscribe(Element: TBoldElement; FollowerController: TBoldStringFollowerController; Subscriber: TBoldSubscriber): string; +function TBoldAsMLStringRenderer.DefaultGetAsStringAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): string; var E: TBoldIndirectElement; + lResultElement: TBoldElement; + lGuard: IBoldGuard; + lFollowerController: TBoldFollowerController; begin Result := ''; - if Assigned(Element) then + if Assigned(aFollower.Element) then begin - E := TBoldIndirectElement.Create; - try - Element.EvaluateAndSubscribeToExpression(FollowerController.Expression, Subscriber, E, False, false, FollowerController.GetVariableListAndSubscribe(subscriber)); - if Assigned(E.Value) then + lFollowerController := aFollower.AssertedController; + if Assigned(aFollower.Value) then + begin + lResultElement := aFollower.Value + end + else + begin + lGuard:= TBoldGuard.Create(E); + E := TBoldIndirectElement.Create; + aFollower.Element.EvaluateAndSubscribeToExpression(lFollowerController.Expression, Subscriber, E, False, False, lFollowerController.GetVariableListAndSubscribe(Subscriber)); + lResultElement := e.Value; + end; + if Assigned(lResultElement) then + begin + if lResultElement is TBAMLString then begin - if e.Value is TBAMLString then + result := (lResultElement as TBAMLString).AsStringByLanguage[Language].StringRepresentation[lFollowerController.Representation]; + if Assigned(Subscriber) then begin - result := (e.Value as TBAMLString).AsStringByLanguage[Language].StringRepresentation[FollowerController.Representation]; - if Assigned(Subscriber) then - begin - (e.Value as TBAMLString).SubscribeToLanguage(Language, Subscriber, breReEvaluate); - Publisher.AddSubscription(subscriber, beValueChanged, breReevaluate); - end; - end - else if e.Value is TBAMLValueSet then - begin - result := (e.Value as TBAMLValueSet).StringRepresentationByLanguage[FollowerController.Representation, Language]; - if Assigned(Subscriber) then - begin - (e.Value as TBAMLvalueSet).SubscribeToLanguage(FollowerController.Representation, Language, Subscriber, breReEvaluate); - Publisher.AddSubscription(subscriber, beValueChanged, breReevaluate); - end; - end - else + (lResultElement as TBAMLString).SubscribeToLanguage(Language, Subscriber, breReEvaluate); + Publisher.AddSubscription(subscriber, beValueChanged, breReevaluate); + end; + end + else if lResultElement is TBAMLValueSet then + begin + result := (lResultElement as TBAMLValueSet).StringRepresentationByLanguage[lFollowerController.Representation, Language]; + if Assigned(Subscriber) then begin - Result := E.Value.StringRepresentation[FollowerController.Representation]; - if Assigned(Subscriber) then - E.Value.SubscribeToStringRepresentation(FollowerController.Representation, Subscriber, breReEvaluate); + (lResultElement as TBAMLvalueSet).SubscribeToLanguage(lFollowerController.Representation, Language, Subscriber, breReEvaluate); + Publisher.AddSubscription(subscriber, beValueChanged, breReevaluate); end; end else - Result := ''; - finally - E.Free; - end; + begin + Result := lResultElement.StringRepresentation[lFollowerController.Representation]; + if Assigned(Subscriber) then + lResultElement.SubscribeToStringRepresentation(lFollowerController.Representation, Subscriber, breReEvaluate); + end; + end + else + Result := ''; end; end; -procedure TBoldAsMLStringRenderer.SetAsString(Element: TBoldElement; Value: string; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); +procedure TBoldAsMLStringRenderer.SetAsString(aFollower: TBoldFollower; const Value: string); begin if assigned(OnLanguageSetAsString) then - OnLanguageSetAsString(Element, Value, Representation, Expression, Language) + OnLanguageSetAsString(aFollower, Value, Language) else - DefaultSetAsString(Element, Value, Representation, Expression, VariableList); + DefaultSetAsString(aFollower, Value); end; -procedure TBoldAsMLStringRenderer.DefaultSetAsString(Element: TBoldElement; Value: string; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); +procedure TBoldAsMLStringRenderer.DefaultSetAsString(aFollower: TBoldFollower; const Value: string); var ValueElement: TBoldElement; MLValueSet: TBAMLValueSet; + lRepresentation: integer; begin - ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); + ValueElement := aFollower.Value; + lRepresentation := aFollower.AssertedController.Representation; if Assigned(ValueElement) then begin if (ValueElement is TBAMLValueSet) then begin MLValueSet := (ValueElement as TBAMLValueSet); - MLValueSet.StringRepresentationByLanguage[Representation, Language] := Value + MLValueSet.StringRepresentationByLanguage[lRepresentation, Language] := Value end else if ValueElement is TBAMLString then - (ValueElement as TBAMLString).AsStringByLanguage[Language].StringRepresentation[Representation] := Value + (ValueElement as TBAMLString).AsStringByLanguage[Language].StringRepresentation[lRepresentation] := Value else - ValueElement.StringRepresentation[Representation] := Value + ValueElement.StringRepresentation[lRepresentation] := Value end else - raise EBold.CreateFmt(sCannotSetStringValue, [ClassName]); + raise EBold.CreateFmt('%s.DefaultSetAsString: Can''t set string value', [ClassName]); end; -procedure TBoldAsMLStringRenderer.DefaultMakeUptodateAndSetMayModifyAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldStringFollowerController; Subscriber: TBoldSubscriber); +procedure TBoldAsMLStringRenderer.DefaultMakeUptodateAndSetMayModifyAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); var E: TBoldIndirectElement; S: String; + lRepresentation: integer; + lRendererData: TBoldStringRendererData; + lResultElement: TBoldElement; + lFollowerController: TBoldFollowerController; + lGuard: IBoldGuard; begin S := ''; - - if Assigned(Element) then + lRendererData := aFollower.RendererData as TBoldStringRendererData; + lFollowerController := aFollower.AssertedController; + if Assigned(aFollower.Element) then begin - E := TBoldIndirectElement.Create; - try - Element.EvaluateAndSubscribeToExpression(FollowerController.Expression, Subscriber, E, False); - if Assigned(E.Value) then + lRepresentation := lFollowerController.Representation; + lResultElement := aFollower.Value; + if not Assigned(lResultElement) then + begin + lGuard:= TBoldGuard.Create(E); + E := TBoldIndirectElement.Create; + aFollower.Element.EvaluateAndSubscribeToExpression(lFollowerController.Expression, Subscriber, E, False, False, lFollowerController.GetVariableListAndSubscribe(Subscriber)); + lResultElement := e.Value; + end; + if Assigned(lResultElement) then + begin + if lResultElement is TBAMLString then begin - if e.Value is TBAMLString then - begin - S := (e.Value as TBAMLString).AsStringByLanguage[Language].StringRepresentation[FollowerController.Representation]; - if Assigned(Subscriber) then - begin - (e.Value as TBAMLString).SubscribeToLanguage(Language, Subscriber, breReEvaluate); - Publisher.AddSubscription(subscriber, beValueChanged, breReevaluate); - end - end - else if e.Value is TBAMLValueSet then + S := (lResultElement as TBAMLString).AsStringByLanguage[Language].StringRepresentation[lRepresentation]; + if Assigned(Subscriber) then begin - S := (e.Value as TBAMLValueSet).StringRepresentationByLanguage[FollowerController.Representation, Language]; - if Assigned(Subscriber) then - begin - (e.Value as TBAMLvalueSet).SubscribeToLanguage(FollowerController.Representation, Language, Subscriber, breReEvaluate); - Publisher.AddSubscription(subscriber, beValueChanged, breReevaluate); - end; + (lResultElement as TBAMLString).SubscribeToLanguage(Language, Subscriber, breReEvaluate); + Publisher.AddSubscription(subscriber, beValueChanged, breReevaluate); end - else + end + else if lResultElement is TBAMLValueSet then + begin + S := TBAMLValueSet(lResultElement).StringRepresentationByLanguage[lRepresentation, Language]; + if Assigned(Subscriber) then begin - S := E.Value.StringRepresentation[FollowerController.Representation]; - if Assigned(Subscriber) then - E.Value.SubscribeToStringRepresentation(FollowerController.Representation, Subscriber, breReEvaluate); + TBAMLValueSet(lResultElement).SubscribeToLanguage(lRepresentation, Language, Subscriber, breReEvaluate); + Publisher.AddSubscription(subscriber, beValueChanged, breReevaluate); end; - RendererData.MayModify := E.Value.ObserverMayModify(Subscriber); end else - S := ''; - finally - E.Free; - end; + begin + S := lResultElement.StringRepresentation[lRepresentation]; + if Assigned(Subscriber) then + lResultElement.SubscribeToStringRepresentation(lRepresentation, Subscriber, breReEvaluate); + end; +// lRendererData.MayModify := lResultElement.ObserverMayModify(Subscriber); + end + else + S := ''; end; - (RendererData as TBoldStringRendererData).OldStringValue := S; - (RendererData as TBoldStringRendererData).CurrentStringValue := S; + lRendererData.OldStringValue := S; + lRendererData.CurrentStringValue := S; end; -procedure TBoldAsMLStringRenderer.SetLanguage(newValue: String); +procedure TBoldAsMLStringRenderer.SetLanguage(const newValue: String); begin if NewValue <> fLanguage then begin diff --git a/Source/BoldAwareGUI/ControlPacks/BoldNodeControlPack.pas b/Source/BoldAwareGUI/ControlPacks/BoldNodeControlPack.pas index 40f6393a..9965c40f 100644 --- a/Source/BoldAwareGUI/ControlPacks/BoldNodeControlPack.pas +++ b/Source/BoldAwareGUI/ControlPacks/BoldNodeControlPack.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldNodeControlPack; {$UNDEF BOLDCOMCLIENT} @@ -39,17 +42,18 @@ TBoldTreeFollowerController = class(TBoldGenericListController) FOnIconChanged: TBoldFollowerEvent; FOnTextChanged: TBoldFollowerEvent; FOnGetFollowerController: TGetFollowerControllerByNameEvent; - procedure SetNodeDescriptions(Value: TBoldNodeDescriptions); - function GetDefaultNodeDescriptionName: string; + procedure SetNodeDescriptions(Value: TBoldNodeDescriptions); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetDefaultNodeDescriptionName: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetDefaultNodeDescriptionName(const Value: string); protected - procedure DoIconChanged(Follower: TBoldFollower); - procedure DoTextChanged(Follower: TBoldFollower); + class function PrecreateFollowers: boolean; override; + procedure DoIconChanged(Follower: TBoldFollower); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure DoTextChanged(Follower: TBoldFollower); {$IFDEF BOLD_INLINE} inline; {$ENDIF} {$IFDEF BOLD_BCB} - procedure DoGetFollowerController(Name: string; var FollowerController: TBoldFollowerController); + procedure DoGetFollowerController(const Name: string; var FollowerController: TBoldFollowerController); {$ENDIF} {$IFDEF BOLD_DELPHI} - function DoGetFollowerController(Name: string): TBoldFollowerController; + function DoGetFollowerController(const Name: string): TBoldFollowerController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} {$ENDIF} procedure DoAssign(Source: TPersistent); override; function GetBoldNodeDescriptionsClass: TBoldNodeDescriptionsClass; virtual; @@ -69,8 +73,8 @@ TBoldTreeFollowerController = class(TBoldGenericListController) TBoldNodeDescriptions = class(TCollection) private FTreeFollowerController: TBoldTreeFollowerController; - function GetNodeControllerItem(Index: Integer): TBoldNodeDescription; - procedure SetNodeControllerItem(Index: Integer; Value: TBoldNodeDescription); + function GetNodeControllerItem(Index: Integer): TBoldNodeDescription; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetNodeControllerItem(Index: Integer; Value: TBoldNodeDescription); {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected function GetNodeDescriptionClass: TBoldNodeDescriptionClass; virtual; function GetOwner: TPersistent; override; @@ -87,17 +91,17 @@ TBoldNodeDescription = class(TCollectionItem) private FName: string; FNodeFollowerController: TBoldNodeFollowerController; - procedure SetName(Value: string); - function GetHideNodeWithNoChildren: Boolean; - procedure SetHideNodeWithNoChildren(Value: Boolean); - function GetListController: TBoldGenericListController; - function GetIconController: TBoldIntegerFollowerController; - function GetTextController: TBoldStringFollowerController; - procedure SetListController(Value: TBoldGenericListController); - procedure SetIconController(Value: TBoldIntegerFollowerController); - procedure SetTextController(Value: TBoldStringFollowerController); - function GetContextTypeName: String; - procedure SetContextTypeName(const Value: String); + procedure SetName(const Value: string); + function GetHideNodeWithNoChildren: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetHideNodeWithNoChildren(Value: Boolean); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetListController: TBoldGenericListController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetIconController: TBoldIntegerFollowerController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetTextController: TBoldStringFollowerController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetListController(Value: TBoldGenericListController); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetIconController(Value: TBoldIntegerFollowerController); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetTextController(Value: TBoldStringFollowerController); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetContextTypeName: String; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetContextTypeName(const Value: String); {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetContextType: TBoldElementTypeInfo; protected function GetDisplayName: string; override; @@ -128,6 +132,8 @@ TBoldNodeFollowerController = class(TBoldControllerList) procedure SetHideNodeWithNoChildren(Value: Boolean); procedure SetContextTypeName(const Value: String); function GetSystemTypeInfo: TBoldSystemTypeInfo; + protected + class function PrecreateFollowers: boolean; override; public constructor Create(aTreeFollowerController: TBoldTreeFollowerController);virtual; destructor Destroy; override; @@ -179,6 +185,11 @@ function TBoldTreeFollowerController.GetDefaultNodeDescriptionName: string; Result := ''; end; +class function TBoldTreeFollowerController.PrecreateFollowers: boolean; +begin + result := true; +end; + procedure TBoldTreeFollowerController.SetDefaultNodeDescriptionName(const Value: string); var NodeDescription: TBoldNodeDescription; @@ -192,7 +203,7 @@ procedure TBoldTreeFollowerController.SetDefaultNodeDescriptionName(const Value: Changed; end else - raise EBold.CreateFmt(sInvalidNodeName, [ClassName, Value]); + raise EBold.CreateFmt('%s.SetDefaultNodeDescriptionName: ''%s'' is not a valid name', [ClassName, Value]); end; end; @@ -223,10 +234,10 @@ procedure TBoldTreeFollowerController.DoTextChanged(Follower: TBoldFollower); end; {$IFDEF BOLD_BCB} -procedure TBoldTreeFollowerController.DoGetFollowerController(Name: string; var FollowerController: TBoldFollowerController); +procedure TBoldTreeFollowerController.DoGetFollowerController(const Name: string; var FollowerController: TBoldFollowerController); {$ENDIF} {$IFDEF BOLD_DELPHI} -function TBoldTreeFollowerController.DoGetFollowerController(Name: string): TBoldFollowerController; +function TBoldTreeFollowerController.DoGetFollowerController(const Name: string): TBoldFollowerController; {$ENDIF} begin {$IFDEF BOLD_BCB} @@ -319,7 +330,6 @@ function TBoldNodeDescription.GetBoldNodeFollowerControllerClass:TBoldNodeFollow destructor TBoldNodeDescription.Destroy; begin - // FIXME ??? FreePublisher; //CHECKME Is this really needed? FreeAndNil(FNodeFollowerController); inherited Destroy; end; @@ -346,7 +356,7 @@ function TBoldNodeDescription.GetDisplayName: string; Result := inherited GetDisplayName; end; -procedure TBoldNodeDescription.SetName(Value: string); +procedure TBoldNodeDescription.SetName(const Value: string); begin if FName <> Value then begin @@ -415,6 +425,7 @@ constructor TBoldNodeFollowerController.Create(aTreeFollowerController: TBoldTre fGenericListFollowerController.OnBeforeDeleteItem := FTreeFollowerController.DoBeforeDeleteItem; fGenericListFollowerController.OnAfterDeleteItem := FTreeFollowerController.DoAfterDeleteItem; fGenericListFollowerController.BeforeMakeUptoDate := FTreeFollowerController.BeforeMakeUptoDate; +// fGenericListFollowerController.OnReplaceitem := FTreeFollowerController.OnReplaceitem; fGenericListFollowerController.OnGetContextType := GetContextType; Add(fGenericListFollowerController); @@ -441,7 +452,7 @@ procedure TBoldNodeFollowerController.SetHideNodeWithNoChildren(Value: Boolean); destructor TBoldNodeFollowerController.Destroy; begin - FreePublisher; //CHECKME Is this really needed? + FreePublisher; inherited Destroy; end; @@ -482,6 +493,11 @@ function TBoldNodeFollowerController.GetSystemTypeInfo: TBoldSystemTypeInfo; result := nil; end; +class function TBoldNodeFollowerController.PrecreateFollowers: boolean; +begin + result := true; +end; + function TBoldNodeDescription.GetContextType: TBoldElementTypeInfo; var ContextType: TBoldElementTypeInfo; @@ -499,5 +515,3 @@ function TBoldNodeDescription.GetContextType: TBoldElementTypeInfo; end; end. - - diff --git a/Source/BoldAwareGUI/ControlPacks/BoldNumericControlPack.pas b/Source/BoldAwareGUI/ControlPacks/BoldNumericControlPack.pas index 98245e90..41c8719f 100644 --- a/Source/BoldAwareGUI/ControlPacks/BoldNumericControlPack.pas +++ b/Source/BoldAwareGUI/ControlPacks/BoldNumericControlPack.pas @@ -1,3 +1,6 @@ +///////////////////////////////////////////////////////// + + unit BoldNumericControlPack; {$UNDEF BOLDCOMCLIENT} @@ -20,9 +23,9 @@ TBoldAsIntegerRenderer = class; TBoldIntegerFollowerController = class; {TBoldAsIntegerRenderer} - TBoldGetAsIntegerEvent = function (Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression): Integer of object; - TBoldSetAsIntegerEvent = procedure (Element: TBoldElement; const Value: Integer; Representation: TBoldRepresentation; Expression: TBoldExpression) of object; - TBoldIntegerIsChangedEvent = function (RenderData: TBoldIntegerRendererData; const NewValue: Integer; Representation: TBoldRepresentation; Expression: TBoldExpression): Boolean of object; + TBoldGetAsIntegerEvent = function (aFollower: TBoldFollower): Integer of object; + TBoldSetAsIntegerEvent = procedure (aFollower: TBoldFollower; const Value: Integer) of object; + TBoldIntegerIsChangedEvent = function (aFollower: TBoldFollower; const NewValue: Integer): Boolean of object; { TBoldIntegerRendererData } TBoldIntegerRendererData = class(TBoldRendererData) @@ -35,6 +38,7 @@ TBoldIntegerRendererData = class(TBoldRendererData) end; { TBoldAsIntegerRenderer } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldAsIntegerRenderer = class(TBoldsingleRenderer) private FOnGetAsInteger: TBoldGetAsIntegerEvent; @@ -42,16 +46,16 @@ TBoldAsIntegerRenderer = class(TBoldsingleRenderer) FOnIsChanged: TBoldIntegerIsChangedEvent; protected function GetRendererDataClass: TBoldRendererDataClass; override; - function DefaultGetAsIntegerAndSubscribe(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): Integer; virtual; - procedure DefaultSetAsInteger(Element: TBoldElement; const Value: Integer; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); virtual; - function GetAsIntegerAndSubscribe(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): Integer; virtual; - procedure SetAsInteger(Element: TBoldElement; const Value: Integer; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); virtual; + function DefaultGetAsIntegerAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): Integer; virtual; + procedure DefaultSetAsInteger(aFollower: TBoldFollower; const Value: Integer); virtual; + function GetAsIntegerAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): Integer; virtual; + procedure SetAsInteger(aFollower: TBoldFollower; const Value: Integer); virtual; public class function DefaultRenderer: TBoldAsIntegerRenderer; - function DefaultIsChanged(RendererData: TBoldIntegerRendererData; const NewValue: Integer; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; - function DefaultMayModify(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): Boolean; override; - procedure MakeUptodateAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldFollowerController; Subscriber: TBoldSubscriber); override; - function IsChanged(RendererData: TBoldIntegerRendererData; const NewValue: Integer; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; + function DefaultIsChanged(aFollower: TBoldFollower; const NewValue: Integer): Boolean; + function DefaultMayModify(aFollower: TBoldFollower): Boolean; override; + procedure MakeUptodateAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); override; + function IsChanged(aFollower: TBoldFollower; const NewValue: Integer): Boolean; published property OnGetAsInteger: TBoldGetAsIntegerEvent read FOnGetAsInteger write FOnGetAsInteger; property OnSetAsInteger: TBoldSetAsIntegerEvent read FOnSetAsInteger write FOnSetAsInteger; @@ -83,7 +87,8 @@ implementation BoldUtils, BoldGuiResourceStrings, BoldAttributes, - BoldControlPackDefs; + BoldControlPackDefs, + BoldGuard; var DefaultAsIntegerRenderer: TBoldAsIntegerRenderer = nil; @@ -99,14 +104,14 @@ function TBoldAsIntegerRenderer.GetRendererDataClass: TBoldRendererDataClass; Result := TBoldIntegerRendererData; end; -function TBoldAsIntegerRenderer.DefaultMayModify(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): Boolean; +function TBoldAsIntegerRenderer.DefaultMayModify(aFollower: TBoldFollower): Boolean; {$IFNDEF BOLDCOMCLIENT} // defaultMayModify var ValueElement: TBoldElement; begin // Note! We don't call inherited DefaultMayModify to prevent evaluation of expression two times! - ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); - result := (ValueElement is TBANumeric) and ValueElement.ObserverMayModify(Subscriber) + ValueElement := aFollower.Value; + result := (ValueElement is TBANumeric) and ValueElement.ObserverMayModify(aFollower.Subscriber) end; {$ELSE} begin @@ -114,17 +119,19 @@ function TBoldAsIntegerRenderer.DefaultMayModify(Element: TBoldElement; Represen end; {$ENDIF} -function TBoldAsIntegerRenderer.DefaultGetAsIntegerAndSubscribe(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): Integer; +function TBoldAsIntegerRenderer.DefaultGetAsIntegerAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): Integer; var {$IFDEF BOLDCOMCLIENT} // defaultGet el: IBoldElement; attr: IBoldAttribute; {$ELSE} IndirectElement: TBoldIndirectElement; + lResultElement: TBoldElement; + lGuard: IBoldGuard; {$ENDIF} begin Result := 0; - if Assigned(Element) then + if Assigned(aFollower.Element) then begin {$IFDEF BOLDCOMCLIENT} // defaultGet if assigned(Subscriber) then @@ -136,33 +143,35 @@ function TBoldAsIntegerRenderer.DefaultGetAsIntegerAndSubscribe(Element: TBoldEl else raise EBold.CreateFmt(sCantGetIntegerValue, [el.AsString]) {$ELSE} - IndirectElement := TBoldIndirectElement.Create; - try - Element.EvaluateAndSubscribeToExpression(Expression, Subscriber, IndirectElement, False, False, VariableList); - if Assigned(IndirectElement.Value) then - begin - if (IndirectElement.Value is TBAInteger) then - Result := (IndirectElement.Value as TBAInteger).AsInteger - else if (IndirectElement.Value is TBANumeric) then - Result := Round((IndirectElement.Value as TBANumeric).AsFloat) - else - raise EBold.CreateFmt(sCantGetIntegerValue, [IndirectElement.Value.ClassName]) - end; - finally - IndirectElement.Free; + lResultElement := aFollower.Value; + if not Assigned(lResultElement) then + begin + lGuard:= TBoldGuard.Create(IndirectElement); + IndirectElement := TBoldIndirectElement.Create; + aFollower.Element.EvaluateAndSubscribeToExpression(aFollower.AssertedController.Expression, Subscriber, IndirectElement, False, False, aFollower.Controller.GetVariableListAndSubscribe(Subscriber)); + lResultElement := IndirectElement.Value; + end; + if Assigned(lResultElement) then + begin + if (lResultElement is TBAInteger) then + Result := TBAInteger(lResultElement).AsInteger + else if (lResultElement is TBANumeric) then + Result := Round(TBANumeric(lResultElement).AsFloat) + else + raise EBold.CreateFmt(sCantGetIntegerValue, [lResultElement.ClassName]) end; {$ENDIF} end; end; -procedure TBoldAsIntegerRenderer.DefaultSetAsInteger(Element: TBoldElement; const Value: Integer; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); +procedure TBoldAsIntegerRenderer.DefaultSetAsInteger(aFollower: TBoldFollower; const Value: Integer); var ValueElement: TBoldElement; {$IFDEF BOLDCOMCLIENT} // defaultSet Attr: IBoldAttribute; {$ENDIF} begin - ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); + ValueElement := aFollower.Value; {$IFDEF BOLDCOMCLIENT} // defaultSet if assigned(ValueElement) and (ValueElement.QueryInterface(IBoldAttribute, attr) = S_OK) then attr.AsVariant := Value @@ -170,59 +179,54 @@ procedure TBoldAsIntegerRenderer.DefaultSetAsInteger(Element: TBoldElement; cons raise EBold.CreateFmt(sCantSetIntegerValue, [ValueElement.AsString]); {$ELSE} if ValueElement is TBANumeric then - (ValueElement as TBANumeric).AsInteger := Value + TBANumeric(ValueElement).AsInteger := Value else raise EBold.CreateFmt(sCantSetIntegerValue, [ValueElement.ClassName]); {$ENDIF} end; -function TBoldAsIntegerRenderer.GetAsIntegerAndSubscribe(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): Integer; +function TBoldAsIntegerRenderer.GetAsIntegerAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): Integer; begin if Assigned(OnSubscribe) and Assigned(Subscriber) then begin - if Assigned(Element) then - OnSubscribe(Element, Representation, Expression, Subscriber); + if Assigned(aFollower.Element) then + OnSubscribe(aFollower, Subscriber); Subscriber := nil; end; if Assigned(OnGetAsInteger) then - Result := OnGetAsInteger(Element, Representation, Expression) + Result := OnGetAsInteger(aFollower) else - Result := DefaultGetAsIntegerAndSubscribe(Element, Representation, Expression, VariableList, Subscriber); + Result := DefaultGetAsIntegerAndSubscribe(aFollower, Subscriber); end; -procedure TBoldAsIntegerRenderer.SetAsInteger(Element: TBoldElement; const Value: Integer; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); +procedure TBoldAsIntegerRenderer.SetAsInteger(aFollower: TBoldFollower; const Value: Integer); begin if Assigned(FOnSetAsInteger) then - OnSetAsInteger(Element, Value, Representation, Expression) + OnSetAsInteger(aFollower, Value) else - DefaultSetAsInteger(Element, Value, Representation, Expression, VariableList) + DefaultSetAsInteger(aFollower, Value) end; -procedure TBoldAsIntegerRenderer.MakeUpToDateAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldFollowerController; Subscriber: TBoldSubscriber); +procedure TBoldAsIntegerRenderer.MakeUpToDateAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); var Value: Integer; - Controller: TBoldIntegerFollowerController; begin - Controller := FollowerController as TBoldIntegerFollowerController; - Value := GetAsIntegerAndSubscribe(Element, Controller.Representation, Controller.Expression, Controller.GetVariableListAndSubscribe(Subscriber) ,Subscriber); - with (RendererData as TBoldIntegerRendererData) do - begin - OldIntegerValue := Value; - CurrentIntegerValue := Value; - end; + Value := GetAsIntegerAndSubscribe(aFollower ,Subscriber); + (aFollower.RendererData as TBoldIntegerRendererData).OldIntegerValue := Value; + (aFollower.RendererData as TBoldIntegerRendererData).CurrentIntegerValue := Value; end; -function TBoldAsIntegerRenderer.DefaultIsChanged(RendererData: TBoldIntegerRendererData; const NewValue: Integer; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; +function TBoldAsIntegerRenderer.DefaultIsChanged(aFollower: TBoldFollower; const NewValue: Integer): Boolean; begin - Result := NewValue <> RendererData.OldIntegerValue; + Result := NewValue <> TBoldIntegerRendererData(aFollower.RendererData).OldIntegerValue; end; -function TBoldAsIntegerRenderer.IsChanged(RendererData: TBoldIntegerRendererData; const NewValue: Integer; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; +function TBoldAsIntegerRenderer.IsChanged(aFollower: TBoldFollower; const NewValue: Integer): Boolean; begin if Assigned(FOnIsChanged) then - Result := FOnIsChanged(RendererData, NewValue, Representation, Expression) + Result := FOnIsChanged(aFollower, NewValue) else - Result := DefaultIsChanged(RendererData, NewValue, Representation, Expression, VariableList); + Result := DefaultIsChanged(aFollower, NewValue); end; { TBoldIntegerFollowerController } @@ -252,7 +256,10 @@ function TBoldIntegerFollowerController.GetEffectiveAsIntegerRenderer: TBoldAsIn procedure TBoldIntegerFollowerController.MakeClean(Follower: TBoldFollower); begin - ReleaseChangedValue(Follower); +// if (ApplyPolicy <> bapChange) or EffectiveRenderer.ChangedValueEventsAssigned then + begin + ReleaseChangedValue(Follower); // note, must do first, since set can change element + end; SetAsInteger(GetCurrentAsInteger(Follower), Follower); end; @@ -263,15 +270,23 @@ function TBoldIntegerFollowerController.GetCurrentAsInteger(Follower: TBoldFollo procedure TBoldIntegerFollowerController.SetAsInteger(Value: Integer; Follower: TBoldFollower); begin - EffectiveAsIntegerRenderer.SetAsInteger(Follower.Element, Value, Representation, Expression, GetVariableListAndSubscribe(follower.Subscriber)); + EffectiveAsIntegerRenderer.SetAsInteger(Follower, Value); end; procedure TBoldIntegerFollowerController.MayHaveChanged(NewValue: Integer; Follower: TBoldFollower); +var + lIsChanged: boolean; + lRendererData: TBoldIntegerRendererData; begin if Follower.State in bfsDisplayable then begin - (Follower.RendererData as TBoldIntegerRendererData).CurrentIntegerValue := NewValue; - Follower.ControlledValueChanged(EffectiveAsIntegerRenderer.IsChanged(Follower.RendererData as TBoldIntegerRendererData, NewValue, Representation, Expression, GetVariableListAndSubscribe(follower.Subscriber))); + lRendererData := (Follower.RendererData as TBoldIntegerRendererData); + lRendererData.CurrentIntegerValue := NewValue; + lIsChanged := EffectiveAsIntegerRenderer.IsChanged(Follower, NewValue); + if lIsChanged then + begin + Follower.ControlledValueChanged; + end; end; end; @@ -283,3 +298,4 @@ finalization end. + diff --git a/Source/BoldAwareGUI/ControlPacks/BoldStringControlPack.pas b/Source/BoldAwareGUI/ControlPacks/BoldStringControlPack.pas index 26f989bf..5d435b1b 100644 --- a/Source/BoldAwareGUI/ControlPacks/BoldStringControlPack.pas +++ b/Source/BoldAwareGUI/ControlPacks/BoldStringControlPack.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldStringControlPack; {$UNDEF BOLDCOMCLIENT} @@ -21,12 +24,12 @@ TBoldAsStringRenderer = class; TBoldStringRendererData = class; { TBoldAsStringRenderer prototypes } - TBoldGetAsString = function (Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression): string of object; - TBoldSetAsString = procedure (Element: TBoldElement; NewValue: string; Representation: TBoldRepresentation; Expression: TBoldExpression) of object; - TBoldValidateString = function (Element: TBoldElement; Value: string; Representation: TBoldRepresentation; Expression: TBoldExpression): Boolean of object; - TBoldSetFont = procedure (Element: TBoldElement; AFont: TFont; Representation: TBoldRepresentation; Expression: TBoldExpression) of object; - TBoldSetColor = procedure (Element: TBoldElement; var AColor: TColor; Representation: TBoldRepresentation; Expression: TBoldExpression) of object; - TBoldStringIsChanged = function (RendererData: TBoldStringRendererData; NewValue: string; Representation: TBoldRepresentation; Expression: TBoldExpression): Boolean of object; + TBoldGetAsString = function (aFollower: TBoldFollower): string of object; + TBoldSetAsString = procedure (aFollower: TBoldFollower; const NewValue: string) of object; + TBoldValidateString = function (aFollower: TBoldFollower; const Value: string): Boolean of object; + TBoldSetFont = procedure (aFollower: TBoldFollower; AFont: TFont) of object; + TBoldSetColor = procedure (aFollower: TBoldFollower; var AColor: TColor) of object; + TBoldStringIsChanged = function (aFollower: TBoldFollower; const NewValue: string): Boolean of object; { TBoldStringRendererData } TBoldStringRendererData = class(TBoldRendererData) @@ -42,6 +45,7 @@ TBoldStringRendererData = class(TBoldRendererData) end; { TBoldAsStringRenderer } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldAsStringRenderer = class(TBoldSingleRenderer) private FOnGetAsString: TBoldGetAsString; @@ -51,29 +55,29 @@ TBoldAsStringRenderer = class(TBoldSingleRenderer) fOnSetFont: TBoldSetFont; fOnSetColor: TBoldSetColor; fOnIsChanged: TBoldStringIsChanged; - function DefaultDisplayString: string; + function DefaultDisplayString: string; protected function GetSupportsMulti: Boolean; override; function GetRendererDataClass: TBoldRendererDataClass; override; - function GetAsStringAndSubscribe(Element: TBoldElement; FollowerController: TBoldStringFollowerController; Subscriber: TBoldSubscriber): string; virtual; - procedure SetAsString(Element: TBoldElement; Value: string; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); virtual; + function GetAsStringAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): string; virtual; + procedure SetAsString(aFollower: TBoldFollower; const Value: string); virtual; procedure DrawOnCanvas(Follower: TBoldFollower; Canvas: TCanvas; Rect: TRect; Alignment: TAlignment; Margins: TPoint); override; public class function DefaultRenderer: TBoldAsStringRenderer; class procedure DrawStringOnCanvas(Canvas: TCanvas; Rect: TRect; Alignment: TAlignment; Margins: TPoint; S: string); - function DefaultGetAsStringAndSubscribe(Element: TBoldElement; FollowerController: TBoldStringFollowerController; Subscriber: TBoldSubscriber): string; virtual; - procedure DefaultSetAsString(Element: TBoldElement; Value: string; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); virtual; - function DefaultValidateCharacter(Element: TBoldElement; C: AnsiChar; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; virtual; - function DefaultValidateString(Element: TBoldElement; Value: string; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; virtual; - function DefaultIsChanged(RendererData: TBoldStringRendererData; NewValue: string; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; - function ValidateCharacter(Element: TBoldElement; C: AnsiChar; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; virtual; - function ValidateString(Element: TBoldElement; Value: string; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; virtual; - function IsChanged(RendererData: TBoldStringRendererData; NewValue: string; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; - procedure SetFont(Element: TBoldElement; EffectiveFont, Font: TFont; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); - procedure SetColor(Element: TBoldElement; var EffectiveColor: TColor; Color: TColor; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); - procedure MakeUptodateAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldFollowerController; Subscriber: TBoldSubscriber); override; + function DefaultGetAsStringAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): string; virtual; + procedure DefaultSetAsString(aFollower: TBoldFollower; const Value: string); virtual; + function DefaultValidateCharacter(aFollower: TBoldFollower; C: Char): Boolean; override; + function DefaultValidateString(aFollower: TBoldFollower; const Value: string): Boolean; virtual; + function DefaultIsChanged(aFollower: TBoldFollower; const NewValue: string): Boolean; + function ValidateCharacter(aFollower: TBoldFollower; C: Char): Boolean; override; + function ValidateString(aFollower: TBoldFollower; const Value: string): Boolean; virtual; + function IsChanged(aFollower: TBoldFollower; const NewValue: string): Boolean; + procedure SetFont(aFollower: TBoldFollower; EffectiveFont, Font: TFont); + procedure SetColor(aFollower: TBoldFollower; var EffectiveColor: TColor; Color: TColor); + procedure MakeUptodateAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); override; procedure MultiMakeUpToDateAndSubscribe(Elements: TBoldClientableList; Subscribers: TBoldObjectArray; RendererData: TBoldObjectArray; FollowerController: TBoldFollowerController); - procedure DefaultMakeUptodateAndSetMayModifyAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldStringFollowerController; Subscriber: TBoldSubscriber); virtual; + procedure DefaultMakeUptodateAndSetMayModifyAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); virtual; published property OnGetAsString: TBoldGetAsString read FOnGetAsString write FOnGetAsString; property OnSetAsString: TBoldSetAsString read FOnSetAsString write FOnSetAsString; @@ -88,26 +92,26 @@ TBoldAsStringRenderer = class(TBoldSingleRenderer) TBoldStringFollowerController = class(TBoldSingleFollowerController) private FNilStringRepresentation: string; - function GetRenderer: TBoldAsStringRenderer; - procedure SetRenderer(Value: TBoldAsStringRenderer); - function GetEffectiveAsStringRenderer: TBoldAsStringRenderer; + function GetRenderer: TBoldAsStringRenderer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetRenderer(Value: TBoldAsStringRenderer); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetEffectiveAsStringRenderer: TBoldAsStringRenderer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetNilStringRepresentation(const Value: string); protected function GetSupportsMultiEnsure: Boolean; override; function GetEffectiveRenderer: TBoldRenderer; override; property EffectiveAsStringRenderer: TBoldAsStringRenderer read GetEffectiveAsStringRenderer; - procedure DoMultiMakeUptodateAndSubscribe(Followers: TBoldObjectArray); override; + procedure DoMultiMakeUptodateAndSubscribe(Followers: TBoldFollowerArray); override; public procedure MakeClean(Follower: TBoldFollower); override; - function GetCurrentAsString(Follower: TBoldFollower): string; - procedure SetAsString(Value: string; Follower: TBoldFollower); - function ValidateCharacter(C: AnsiChar; Follower: TBoldFollower): Boolean; - function ValidateString(Value: string; Follower: TBoldFollower): Boolean; - procedure SetFont(EffectiveFont, Font: tFont; Follower: TBoldFollower); - procedure SetColor(var EffectiveColor: tColor; COLOR: tColor; Follower: TBoldFollower); - procedure MayHaveChanged(NewValue: string; Follower: TBoldFollower); + function GetCurrentAsString(Follower: TBoldFollower): string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetAsString(Value: string; Follower: TBoldFollower); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function ValidateCharacter(C: Char; Follower: TBoldFollower): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function ValidateString(Value: string; Follower: TBoldFollower): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetFont(EffectiveFont, Font: tFont; Follower: TBoldFollower); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetColor(var EffectiveColor: tColor; COLOR: tColor; Follower: TBoldFollower); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function MayHaveChanged(const NewValue: string; Follower: TBoldFollower): boolean; procedure DoMakeUptodateAndSubscribe(Follower: TBoldFollower; Subscribe: Boolean); override; - function GetAsString(Element: TBoldElement): string; + function GetAsString(aFollower: TBoldFollower): string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} published property Renderer: TBoldAsStringRenderer read GetRenderer write SetRenderer; property NilStringRepresentation: string read FNilStringRepresentation write SetNilStringRepresentation; @@ -119,12 +123,13 @@ implementation SysUtils, BoldControlPackDefs, {$IFNDEF BOLDCOMCLIENT} - BoldSystem, // IFNDEF BOLDCOMCLIENT + BoldSystem, BoldDomainElement, {$ELSE} - Variants, // IFDEF BOLDCOMCLIENT + Variants, {$ENDIF} - BoldGuiResourceStrings; + BoldGuard, + BoldRev; var DefaultAsStringRenderer: TBoldAsStringRenderer; @@ -161,36 +166,45 @@ function TBoldStringFollowerController.GetCurrentAsString(Follower: TBoldFollowe procedure TBoldStringFollowerController.SetAsString(Value: string; Follower: TBoldFollower); begin - EffectiveAsStringRenderer.SetAsString(Follower.Element, Value, Representation, Expression, VariableList); + EffectiveAsStringRenderer.SetAsString(Follower, Value); end; -function TBoldStringFollowerController.ValidateCharacter(C: AnsiChar; Follower: TBoldFollower): Boolean; +function TBoldStringFollowerController.ValidateCharacter(C: Char; Follower: TBoldFollower): Boolean; begin - Result := EffectiveAsStringRenderer.ValidateCharacter(Follower.Element, C, Representation, Expression, VariableList); + Result := EffectiveAsStringRenderer.ValidateCharacter(Follower, C); end; function TBoldStringFollowerController.ValidateString(Value: string; Follower: TBoldFollower): Boolean; begin - Result := EffectiveAsStringRenderer.ValidateString(Follower.Element, Value, Representation, Expression, VariableList); + Result := EffectiveAsStringRenderer.ValidateString(Follower, Value); end; procedure TBoldStringFollowerController.SetFont(EffectiveFont, Font: tFont; Follower: TBoldFollower); begin - EffectiveAsStringRenderer.SetFont(Follower.Element, EffectiveFont, Font, Representation, Expression, VariableList); + EffectiveAsStringRenderer.SetFont(Follower, EffectiveFont, Font); end; procedure TBoldStringFollowerController.SetColor(var EffectiveColor: tColor; COLOR: tColor; Follower: TBoldFollower); begin - EffectiveAsStringRenderer.SetColor(Follower.Element, EffectiveColor, COLOR, Representation, Expression, VariableList); + EffectiveAsStringRenderer.SetColor(Follower, EffectiveColor, Color); end; -procedure TBoldStringFollowerController.MayHaveChanged(NewValue: string; Follower: TBoldFollower); +function TBoldStringFollowerController.MayHaveChanged(const NewValue: string; Follower: TBoldFollower): boolean; +var + lBoldStringRendererData: TBoldStringRendererData; begin if Follower.State in bfsDisplayable then begin - (Follower.RendererData as TBoldStringRendererData).CurrentStringValue := NewValue; - Follower.ControlledValueChanged(EffectiveAsStringRenderer.IsChanged(Follower.RendererData as TBoldStringRendererData, NewValue, Representation, Expression, VariableList)); - end; + lBoldStringRendererData := Follower.RendererData as TBoldStringRendererData; + lBoldStringRendererData.CurrentStringValue := NewValue; + result := EffectiveAsStringRenderer.IsChanged(Follower, NewValue); + if result then + begin + Follower.ControlledValueChanged; + end; + end + else + result := false; end; procedure TBoldStringFollowerController.MakeClean(Follower: TBoldFollower); @@ -202,7 +216,7 @@ procedure TBoldStringFollowerController.MakeClean(Follower: TBoldFollower); begin if ValidateString(GetCurrentAsString(Follower), Follower) then begin - ReleaseChangedValue(Follower); // note, must do first, since set can change element + ReleaseChangedValue(Follower); SetAsString(GetCurrentAsString(Follower), Follower); end else @@ -214,10 +228,10 @@ procedure TBoldStringFollowerController.MakeClean(Follower: TBoldFollower); el := nil; FailureReason := GetBoldLastFailureReason; if assigned(FailureReason) then - GetBoldLastFailureReason.MessageFormatStr := sStringValidationFailedExtended; - BoldRaiseLastFailure(el, '', sUnknownReason); + GetBoldLastFailureReason.MessageFormatStr := 'String validation failed for %s: %2:s'; + BoldRaiseLastFailure(el, '', 'Unknown reason'); {$ELSE} - raise EBold.Create(sStringValidationFailed); + raise EBold.Create('String validation failed'); {$ENDIF} end; end; @@ -232,11 +246,12 @@ procedure TBoldStringFollowerController.DoMakeUptodateAndSubscribe(Follower: TBo else Subscriber := nil; Renderer := EffectiveRenderer as TBoldAsStringRenderer; - if Assigned(Renderer.OnGetAsString) or Assigned(Renderer.OnSubscribe) or Assigned(Renderer.OnMayModify) then begin - Renderer.MakeUptodateAndSubscribe(Follower.Element, Follower.RendererData, Self, Subscriber); - Follower.RendererData.MayModify := Renderer.MayModify(Follower.Element, Representation, Expression, GetVariableListAndSubscribe(follower.Subscriber), Follower.Subscriber); - end else - renderer.DefaultMakeUptodateAndSetMayModifyAndSubscribe(Follower.Element, Follower.RendererData, Self, Subscriber); + if Assigned(Renderer.OnGetAsString) or Assigned(Renderer.OnSubscribe) or Assigned(Renderer.OnMayModify) then + begin + Renderer.MakeUptodateAndSubscribe(Follower, Subscriber); + end + else + renderer.DefaultMakeUptodateAndSetMayModifyAndSubscribe(Follower, Subscriber); end; procedure TBoldStringFollowerController.SetNilStringRepresentation(const Value: string); @@ -253,7 +268,6 @@ procedure TBoldStringFollowerController.SetNilStringRepresentation(const Value: var Left: Integer; begin - // Adjust for alignment case Alignment of taLeftJustify: Left := Margins.X + Rect.Left; taRightJustify: Left := (Rect.Right - Rect.Left) - Canvas.TextWidth(S) + Rect.Left - 1 - Margins.X; @@ -268,24 +282,18 @@ procedure TBoldAsStringRenderer.DrawOnCanvas(Follower: TBoldFollower; Canvas: TC DrawStringOnCanvas(Canvas, Rect, Alignment, Margins, TBoldStringRendererData(Follower.RendererData).CurrentStringValue); end; -procedure TBoldAsStringRenderer.MakeUpToDateAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldFollowerController; Subscriber: TBoldSubscriber); +procedure TBoldAsStringRenderer.MakeUpToDateAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); var S: string; + lRendererData: TBoldStringRendererData; begin - S := GetAsStringAndSubscribe(Element, FollowerController as TBoldStringFollowerController, Subscriber); - (RendererData as TBoldStringRendererData).OldStringValue := S; - (RendererData as TBoldStringRendererData).CurrentStringValue := S; + S := GetAsStringAndSubscribe(aFollower, Subscriber); + lRendererData := (aFollower.RendererData as TBoldStringRendererData); + lRendererData.OldStringValue := S; + lRendererData.CurrentStringValue := S; end; -function TBoldAsStringRenderer.DefaultDisplayString: string; -begin - if Name <> '' then - Result := '(' + Name + ')' - else - Result := '(' + ClassName + ')'; -end; - -procedure TBoldAsStringRenderer.DefaultMakeUptodateAndSetMayModifyAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldStringFollowerController; Subscriber: TBoldSubscriber); +procedure TBoldAsStringRenderer.DefaultMakeUptodateAndSetMayModifyAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); var {$IFDEF BOLDCOMCLIENT} // defaultMakeUpToDate e: IBoldElement; @@ -293,16 +301,24 @@ procedure TBoldAsStringRenderer.DefaultMakeUptodateAndSetMayModifyAndSubscribe(E E: TBoldIndirectElement; {$ENDIF} S: String; + lFollowerController: TBoldStringFollowerController; + lRendererData: TBoldStringRendererData; + lRepresentation: integer; + lResultElement: TBoldElement; + lGuard: IBoldGuard; begin S := ''; + lRendererData:= aFollower.RendererData as TBoldStringRendererData; if (csDesigning in ComponentState) and (Self <> DefaultRenderer) then begin s := DefaultDisplayString; - RendererData.MayModify := False; +// lRendererData.MayModify := False; end else begin - if Assigned(Element) then + lFollowerController := aFollower.AssertedController as TBoldStringFollowerController; + lRepresentation := lFollowerController.Representation; + if Assigned(aFollower.Element) then begin {$IFDEF BOLDCOMCLIENT} // defaultMakeUpToDate if assigned(Subscriber) then @@ -315,45 +331,50 @@ procedure TBoldAsStringRenderer.DefaultMakeUptodateAndSetMayModifyAndSubscribe(E S := E.StringRepresentation[FollowerController.Representation]; if Assigned(Subscriber) then E.SubscribeToStringRepresentation(FollowerController.Representation, Subscriber.ClientId, Subscriber.SubscriberId, breReEvaluate, false); - RendererData.MayModify := true; + lRendererData.MayModify := true; end else S := FollowerController.NilStringRepresentation {$ELSE} - E := TBoldIndirectElement.Create; - try - Element.EvaluateAndSubscribeToExpression(FollowerController.Expression, Subscriber, E, False, False, FollowerController.GetVariableListAndSubscribe(Subscriber)); - if (e.Value is TBoldObjectReference) and not assigned((e.Value as TBoldObjectReference).BoldObject) then - begin - s := FollowerController.NilStringRepresentation; - if Assigned(Subscriber) then - E.Value.SubscribeToStringRepresentation(FollowerController.Representation, Subscriber, breReEvaluate); - RendererData.MayModify := E.Value.ObserverMayModifyAsString(FollowerController.Representation, Subscriber); - (RendererData as TBoldStringRendererData).MaxStringLength := -1; - end - else if Assigned(E.Value) then - begin - S := E.Value.StringRepresentation[FollowerController.Representation]; - if Assigned(Subscriber) then - E.Value.SubscribeToStringRepresentation(FollowerController.Representation, Subscriber, breReEvaluate); - RendererData.MayModify := E.Value.ObserverMayModifyAsString(FollowerController.Representation, Subscriber); - if (E.Value is TBoldAttribute) and assigned((E.Value as TBoldAttribute).BoldAttributeRTInfo) then - (RendererData as TBoldStringRendererData).MaxStringLength := (E.Value as TBoldAttribute).BoldAttributeRTInfo.Length - else - (RendererData as TBoldStringRendererData).MaxStringLength := -1; - end + lResultElement := aFollower.Value; + if (lResultElement is TBoldObjectReference) and not assigned(TBoldObjectReference(lResultElement).BoldObject) then + begin + s := lFollowerController.NilStringRepresentation; + if Assigned(Subscriber) then + lResultElement.SubscribeToStringRepresentation(lRepresentation, Subscriber, breReEvaluate); +// lRendererData.MayModify := lResultElement.ObserverMayModify(Subscriber); +// lRendererData.MayModify := lResultElement.ObserverMayModifyAsString(lRepresentation, Subscriber); + lRendererData.MaxStringLength := -1; + end + else if Assigned(lResultElement) then + begin + S := lResultElement.StringRepresentation[lRepresentation]; + if Assigned(Subscriber) then + lResultElement.SubscribeToStringRepresentation(lRepresentation, Subscriber, breReEvaluate); +// lRendererData.MayModify := lResultElement.ObserverMayModify(Subscriber); +// lRendererData.MayModify := lResultElement.ObserverMayModifyAsString(lRepresentation, Subscriber); + if (lResultElement is TBoldAttribute) and assigned(TBoldAttribute(lResultElement).BoldAttributeRTInfo) then + lRendererData.MaxStringLength := TBoldAttribute(lResultElement).BoldAttributeRTInfo.Length else - S := FollowerController.NilStringRepresentation - finally - E.Free; - end; + lRendererData.MaxStringLength := -1; +{ if (lResultElement is TBoldDomainElement) and not TBoldDomainElement(lResultElement).BoldDirty then + begin + lRendererData.OldStringValue := S; + end; +} + end + else + S := lFollowerController.NilStringRepresentation; {$ENDIF} end else - S := FollowerController.NilStringRepresentation + begin + S := lFollowerController.NilStringRepresentation; +// lRendererData.MayModify := false; + end; end; - (RendererData as TBoldStringRendererData).OldStringValue := S; - (RendererData as TBoldStringRendererData).CurrentStringValue := S; + lRendererData.OldStringValue := S; + lRendererData.CurrentStringValue := S; end; function TBoldAsStringRenderer.GetRendererDataClass: TBoldRendererDataClass; @@ -361,13 +382,24 @@ function TBoldAsStringRenderer.GetRendererDataClass: TBoldRendererDataClass; Result := TBoldStringRendererData; end; -function TBoldAsStringRenderer.DefaultGetAsStringAndSubscribe(Element: TBoldElement; FollowerController: TBoldStringFollowerController; Subscriber: TBoldSubscriber): string; +function TBoldAsStringRenderer.DefaultDisplayString: string; +begin + if Name <> '' then + Result := '(' + Name + ')' + else + Result := '(' + ClassName + ')'; +end; + +function TBoldAsStringRenderer.DefaultGetAsStringAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): string; var {$IFDEF BOLDCOMCLIENT} // DefaultGet e: IBoldElement; {$ELSE} E: TBoldIndirectElement; {$ENDIF} + lFollowerController: TBoldStringFollowerController; + lResultElement: TBoldElement; + lGuard: IBoldGuard; begin Result := ''; if (csDesigning in ComponentState) and (Self <> DefaultRenderer) then @@ -376,7 +408,8 @@ function TBoldAsStringRenderer.DefaultGetAsStringAndSubscribe(Element: TBoldElem end else begin - if Assigned(Element) then + lFollowerController := aFollower.AssertedController as TBoldStringFollowerController; + if Assigned(aFollower.Element) then begin {$IFDEF BOLDCOMCLIENT} // defaultGet if assigned(Subscriber) then @@ -392,134 +425,136 @@ function TBoldAsStringRenderer.DefaultGetAsStringAndSubscribe(Element: TBoldElem else Result := FollowerController.NILStringRepresentation; {$ELSE} - E := TBoldIndirectElement.Create; - try - Element.EvaluateAndSubscribeToExpression(FollowerController.Expression, Subscriber, E, False, False, FollowerController.GetVariableListAndSubscribe(Subscriber)); - if (e.Value is TBoldObjectReference) and not assigned((e.Value as TBoldObjectReference).BoldObject) then - begin - result := FollowerController.NilStringRepresentation; - if Assigned(Subscriber) then - E.Value.SubscribeToStringRepresentation(FollowerController.Representation, Subscriber, breReEvaluate); - end - else if Assigned(E.Value) then - begin - Result := E.Value.StringRepresentation[FollowerController.Representation]; - if Assigned(Subscriber) then - E.Value.SubscribeToStringRepresentation(FollowerController.Representation, Subscriber, breReEvaluate); - end - else - Result := FollowerController.NILStringRepresentation; - finally - E.Free; + lResultElement := aFollower.Value; + if not Assigned(lResultElement) then + begin + lGuard:= TBoldGuard.Create(E); + E := TBoldIndirectElement.Create; + aFollower.Element.EvaluateAndSubscribeToExpression(lFollowerController.Expression, Subscriber, E, False, False, lFollowerController.GetVariableListAndSubscribe(Subscriber)); + lResultElement := e.Value; end; + if (lResultElement is TBoldObjectReference) and not assigned(TBoldObjectReference(lResultElement).BoldObject) then + begin + result := lFollowerController.NilStringRepresentation; + if Assigned(Subscriber) then + lResultElement.SubscribeToStringRepresentation(lFollowerController.Representation, Subscriber, breReEvaluate); + end + else if Assigned(lResultElement) then + begin + Result := lResultElement.StringRepresentation[lFollowerController.Representation]; + if Assigned(Subscriber) then + lResultElement.SubscribeToStringRepresentation(lFollowerController.Representation, Subscriber, breReEvaluate); + end + else + Result := lFollowerController.NILStringRepresentation; {$ENDIF} end else - Result := FollowerController.NILStringRepresentation; + Result := lFollowerController.NILStringRepresentation; end; end; -procedure TBoldAsStringRenderer.DefaultSetAsString(Element: TBoldElement; Value: string; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); +procedure TBoldAsStringRenderer.DefaultSetAsString(aFollower: TBoldFollower; const Value: string); var ValueElement: TBoldElement; begin - ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); + ValueElement := aFollower.Value; if Assigned(ValueElement) then - ValueElement.StringRepresentation[Representation] := Value + ValueElement.StringRepresentation[aFollower.AssertedController.Representation] := Value else - raise EBold.CreateFmt(sCannotSetStringValue, [ClassName]); + raise EBold.Create('TBoldAsStringRenderer.DefaultSetAsString: Can''t set string value'); end; -function TBoldAsStringRenderer.DefaultValidateCharacter(Element: TBoldElement; C: AnsiChar; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; +function TBoldAsStringRenderer.DefaultValidateCharacter(aFollower: TBoldFollower; C: Char): Boolean; var ValueElement: TBoldElement; begin - ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); + ValueElement := aFollower.Value; if Assigned(ValueElement) then - Result := ValueElement.ValidateCharacter(C, Representation) + Result := ValueElement.ValidateCharacter(C, aFollower.AssertedController.Representation ) else - Result := False; + Result := HasSetValueEventOverrides; end; -function TBoldAsStringRenderer.DefaultValidateString(Element: TBoldElement; Value: string; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; +function TBoldAsStringRenderer.DefaultValidateString(aFollower: TBoldFollower; const Value: string): Boolean; var ValueElement: TBoldElement; begin - ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); + ValueElement := aFollower.Value; if Assigned(ValueElement) then - Result := ValueElement.ValidateString(Value, Representation) + Result := ValueElement.ValidateString(Value, aFollower.AssertedController.Representation) else Result := False; end; -function TBoldAsStringRenderer.GetAsStringAndSubscribe(Element: TBoldElement; FollowerController: TBoldStringFollowerController; Subscriber: TBoldSubscriber): string; +function TBoldAsStringRenderer.GetAsStringAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): string; begin if Assigned(OnSubscribe) and Assigned(Subscriber) then begin - if Assigned(Element) then - OnSubscribe(Element, FollowerController.Representation, FollowerController.Expression, Subscriber); + if Assigned(aFollower.Element) then + OnSubscribe(aFollower, Subscriber); Subscriber := nil; end; if Assigned(OnGetAsString) then - Result := OnGetAsString(Element, FollowerController.Representation, FollowerController.Expression) + Result := OnGetAsString(aFollower) else - Result := DefaultGetAsStringAndSubscribe(Element, FollowerController, Subscriber); + Result := DefaultGetAsStringAndSubscribe(aFollower, Subscriber); end; -procedure TBoldAsStringRenderer.SetAsString(Element: TBoldElement; Value: string; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); +procedure TBoldAsStringRenderer.SetAsString(aFollower: TBoldFollower; const Value: string); begin if Assigned(FOnSetAsString) then - OnSetAsString(Element, Value, Representation, Expression) + OnSetAsString(aFollower, Value) else - DefaultSetAsString(Element, Value, Representation, Expression, VariableList) + DefaultSetAsString(aFollower, Value) end; -function TBoldAsStringRenderer.ValidateCharacter(Element: TBoldElement; C: AnsiChar; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; +function TBoldAsStringRenderer.ValidateCharacter(aFollower: TBoldFollower; C: Char): Boolean; begin if Assigned(FOnValidateCharacter) then - Result := OnValidateCharacter(Element, C, Representation, Expression) + Result := OnValidateCharacter(aFollower, c) else - Result := DefaultValidateCharacter(Element, C, Representation, Expression, VariableList); + Result := DefaultValidateCharacter(aFollower, c); end; -function TBoldAsStringRenderer.ValidateString(Element: TBoldElement; Value: string; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; +function TBoldAsStringRenderer.ValidateString(aFollower: TBoldFollower; const Value: string): Boolean; begin if Assigned(FOnValidateString) then - Result := OnValidateString(Element, Value, Representation, Expression) + Result := OnValidateString(aFollower, Value) else - Result := DefaultValidateString(Element, Value, Representation, Expression, VariableList); + Result := DefaultValidateString(aFollower, Value); end; -procedure TBoldAsStringRenderer.SetFont(Element: TBoldElement; EffectiveFont, Font: tFont; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); +procedure TBoldAsStringRenderer.SetFont(aFollower: TBoldFollower; EffectiveFont, Font: TFont); begin EffectiveFont.Assign(Font); if Assigned(fOnSetFont) then - fOnSetFont(Element, EffectiveFont, Representation, Expression); + fOnSetFont(aFollower, EffectiveFont); end; -procedure TBoldAsStringRenderer.SetColor(Element: TBoldElement; var EffectiveColor: tColor; COLOR: tColor; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); +procedure TBoldAsStringRenderer.SetColor(aFollower: TBoldFollower; var EffectiveColor: TColor; Color: TColor); begin - EffectiveColor := COLOR; + EffectiveColor := Color; if Assigned(fOnSetColor) then - fOnSetColor(Element, EffectiveColor, Representation, Expression); + fOnSetColor(aFollower, EffectiveColor); end; - class function TBoldAsStringRenderer.DefaultRenderer: TBoldAsStringRenderer; +class function TBoldAsStringRenderer.DefaultRenderer: TBoldAsStringRenderer; begin Result := DefaultAsStringRenderer; end; -function TBoldAsStringRenderer.DefaultIsChanged(RendererData: TBoldStringRendererData; NewValue: string; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; +function TBoldAsStringRenderer.DefaultIsChanged(aFollower: TBoldFollower; const NewValue: string): Boolean; begin - Result := NewValue <> RendererData.OldStringValue; + Result := NewValue <> TBoldStringRendererData(aFollower.RendererData).OldStringValue; end; -function TBoldAsStringRenderer.IsChanged(RendererData: TBoldStringRendererData; NewValue: string; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; +function TBoldAsStringRenderer.IsChanged(aFollower: TBoldFollower; const NewValue: string): Boolean; begin if Assigned(fOnIsChanged) then - Result := fOnIsChanged(RendererData, NewValue, Representation, Expression) + Result := fOnIsChanged(aFollower, NewValue) else - Result := DefaultIsChanged(RendererData, NewValue, Representation, Expression, Variablelist); + Result := DefaultIsChanged(aFollower, NewValue); end; { TBoldStringRendererData } @@ -550,32 +585,28 @@ function TBoldStringFollowerController.GetSupportsMultiEnsure: Boolean; end; procedure TBoldStringFollowerController.DoMultiMakeUptodateAndSubscribe( - Followers: TBoldObjectArray); + Followers: TBoldFollowerArray); var Renderer: TBoldAsStringRenderer; Elements: TBoldClientableList; - TempFollower: TBoldFollower; + F: TBoldFollower; Subscribers: TBoldObjectArray; RendererData: TBoldObjectArray; - I: integer; - MaxIndex: integer; begin Assert(SupportsMulti); - MaxIndex := Followers.Count - 1; Renderer := EffectiveRenderer as TBoldAsStringRenderer; - Elements := TBoldClientableList.Create(MaxIndex,[]); - Subscribers := TBoldObjectArray.Create(MaxIndex,[]); - RendererData := TBoldObjectArray.Create(MaxIndex,[]); + Elements := TBoldClientableList.Create(Length(Followers),[]); + Subscribers := TBoldObjectArray.Create(Length(Followers),[]); + RendererData := TBoldObjectArray.Create(Length(Followers),[]); try - for I := 0 to MaxIndex do + for F in Followers do begin - TempFollower := TBoldFollower(Followers[I]); - Elements.Add(Tempfollower.Element); - if TempFollower.State in bfdNeedResubscribe then - Subscribers.Add(TempFollower.Subscriber) + Elements.Add(F.Element); + if F.State in bfdNeedResubscribe then + Subscribers.Add(F.Subscriber) else Subscribers.Add(nil); - RendererData.Add(TempFollower.RendererData); + RendererData.Add(F.RendererData); end; Renderer.MultiMakeUpToDateAndSubscribe(Elements, Subscribers, RendererData, Self); finally @@ -629,9 +660,9 @@ procedure TBoldAsStringRenderer.MultiMakeUpToDateAndSubscribe( {$ENDIF} end; -function TBoldStringFollowerController.GetAsString(Element: TBoldElement): string; +function TBoldStringFollowerController.GetAsString(aFollower: TBoldFollower): string; begin - result := EffectiveAsStringRenderer.GetAsStringAndSubscribe(element, self, nil); + result := EffectiveAsStringRenderer.GetAsStringAndSubscribe(aFollower, nil); end; initialization @@ -641,4 +672,3 @@ finalization FreeAndNil(DefaultAsStringRenderer); end. - diff --git a/Source/BoldAwareGUI/ControlPacks/BoldVariantControlPack.pas b/Source/BoldAwareGUI/ControlPacks/BoldVariantControlPack.pas new file mode 100644 index 00000000..6e17147a --- /dev/null +++ b/Source/BoldAwareGUI/ControlPacks/BoldVariantControlPack.pas @@ -0,0 +1,675 @@ +unit BoldVariantControlPack; + +{ Global compiler directives } +{$include bold.inc} + +{$UNDEF BOLDCOMCLIENT} + +interface + +uses + Graphics, + Classes, + Windows, + BoldDefs, + BoldContainers, + BoldElements, + BoldControlPack, + BoldSubscription, + Variants; + +type + {Forward declaration of classes} + TBoldVariantFollowerController = class; + TBoldCustomAsVariantRenderer = class; + TBoldAsVariantRenderer = class; + TBoldVariantRendererData = class; + + { TBoldAsVariantRenderer prototypes } + TBoldGetAsVariant = function (AFollower: TBoldFollower): Variant of object; + TBoldSetAsVariant = procedure (aFollower: TBoldFollower; const NewValue: Variant) of object; + TBoldValidateVariant = function (aFollower: TBoldFollower; const Value: Variant): Boolean of object; + TBoldSetFont = procedure (aFollower: TBoldFollower; AFont: TFont) of object; + TBoldSetColor = procedure (aFollower: TBoldFollower; var AColor: TColor) of object; + TBoldVariantIsChanged = function (aFollower: TBoldFollower; const NewValue: Variant): Boolean of object; + TBoldValidateString = function (aFollower: TBoldFollower; const Value: string): Boolean of object; + TBoldGetAsString = function (AFollower: TBoldFollower{; Subscriber: TBoldSubscriber}): string of object; + + { TBoldVariantRendererData } + TBoldVariantRendererData = class(TBoldRendererData) + private + fOldVariantValue: Variant; + fCurrentVariantValue: Variant; + fMaxStringLength: integer; + public + constructor Create(OwningFollower: TBoldFollower); override; + property OldVariantValue: Variant read fOldVariantValue write fOldVariantValue; + property CurrentVariantValue: Variant read fCurrentVariantValue write fCurrentVariantValue; + property MaxStringLength: integer read fMaxStringLength write fMaxStringLength; + end; + + { TBoldCustomAsVariantRenderer } + TBoldCustomAsVariantRenderer = class(TBoldSingleRenderer) + private + FOnGetAsVariant: TBoldGetAsVariant; + FOnSetAsVariant: TBoldSetAsVariant; + FOnValidateVariant: TBoldValidateVariant; + fOnSetFont: TBoldSetFont; + fOnSetColor: TBoldSetColor; + fOnIsChanged: TBoldVariantIsChanged; + FOnGetAsString: TBoldGetAsString; + protected + function DefaultDisplayString: string; + function GetSupportsMulti: Boolean; override; + function GetRendererDataClass: TBoldRendererDataClass; override; + function GetAsVariantAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): Variant; virtual; + procedure SetAsVariant(aFollower: TBoldFollower; const Value: Variant); virtual; + procedure DrawOnCanvas(Follower: TBoldFollower; Canvas: TCanvas; Rect: TRect; Alignment: TAlignment; Margins: TPoint); override; + function HasSetValueEventOverrides: boolean; override; + public + class function DefaultRenderer: TBoldCustomAsVariantRenderer; virtual; + class procedure DrawValueOnCanvas(Canvas: TCanvas; Rect: TRect; Alignment: TAlignment; Margins: TPoint; const aValue: Variant); + procedure Assign(Source: TPersistent); override; + procedure AssignTo(Dest: TPersistent); override; + function EffectiveRenderer: TBoldCustomAsVariantRenderer; virtual; + function DefaultGetAsVariantAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): Variant; virtual; + procedure DefaultSetAsVariant(aFollower: TBoldFollower; const Value: Variant); virtual; + function DefaultValidateVariant(aFollower: TBoldFollower; const Value: Variant): Boolean; virtual; + function DefaultIsChanged(aFollower: TBoldFollower; const NewValue: Variant): Boolean; virtual; + function DefaultGetAsString(AFollower: TBoldFollower): string; + function ValidateVariant(aFollower: TBoldFollower; const Value: Variant): Boolean; virtual; + function IsChanged(aFollower: TBoldFollower; const NewValue: Variant): Boolean; + function GetAsString(aFollower: TBoldFollower): string; + procedure SetFont(aFollower: TBoldFollower; EffectiveFont, Font: TFont); + procedure SetColor(aFollower: TBoldFollower; var EffectiveColor: TColor; Color: TColor); + procedure MakeUptodateAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); override; +// procedure MultiMakeUpToDateAndSubscribe(Elements: TBoldClientableList; Subscribers: TBoldObjectArray; RendererData: TBoldObjectArray; FollowerController: TBoldFollowerController); + procedure DefaultMakeUptodateAndSetMayModifyAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); virtual; + + property OnGetAsVariant: TBoldGetAsVariant read FOnGetAsVariant write FOnGetAsVariant; + property OnSetAsVariant: TBoldSetAsVariant read FOnSetAsVariant write FOnSetAsVariant; + property OnValidateVariant: TBoldValidateVariant read FOnValidateVariant write FOnValidateVariant; + property OnSetFont: TBoldSetFont read fOnSetFont write fOnSetFont; + property OnSetColor: TBoldSetColor read fOnSetColor write fOnSetColor; + property OnIsChanged: TBoldVariantIsChanged read fOnIsChanged write fOnIsChanged; + property OnGetAsString: TBoldGetAsString read fOnGetAsString write fOnGetAsString; + end; + + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] + TBoldAsVariantRenderer = class(TBoldCustomAsVariantRenderer) + published + property OnGetAsVariant; + property OnSetAsVariant; + property OnValidateVariant; + property OnSetFont; + property OnSetColor; + property OnIsChanged; + property OnGetAsString; + end; + + { TBoldVariantFollowerController } + TBoldVariantFollowerController = class(TBoldSingleFollowerController) + private + FNilRepresentation: Variant; + function GetRenderer: TBoldCustomAsVariantRenderer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetRenderer(Value: TBoldCustomAsVariantRenderer); + function GetEffectiveAsVariantRenderer: TBoldCustomAsVariantRenderer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetNilRepresentation(const Value: Variant); + function IsNilRepresentationStored: boolean; + protected + function GetSupportsMultiEnsure: Boolean; override; + function GetEffectiveRenderer: TBoldRenderer; override; + property EffectiveAsVariantRenderer: TBoldCustomAsVariantRenderer read GetEffectiveAsVariantRenderer; + procedure DoMultiMakeUptodateAndSubscribe(Followers: TBoldFollowerArray); override; + procedure DoAssign(Source: TPersistent); override; + public + constructor Create(aOwningComponent: TComponent); reintroduce; + procedure MakeClean(Follower: TBoldFollower); override; + function GetCurrentAsVariant(Follower: TBoldFollower): Variant; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetAsVariant(const Value: Variant; Follower: TBoldFollower); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function ValidateVariant(const Value: Variant; Follower: TBoldFollower): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function ValidateCharacter(C: Char; aFollower: TBoldFollower): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetFont(EffectiveFont, Font: TFont; Follower: TBoldFollower); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetColor(var EffectiveColor: TColor; Color: TColor; Follower: TBoldFollower); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function MayHaveChanged(const NewValue: Variant; Follower: TBoldFollower): boolean; + procedure DoMakeUptodateAndSubscribe(Follower: TBoldFollower; Subscribe: Boolean); override; + function GetAsVariant(aFollower: TBoldFollower): Variant; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetAsString(aFollower: TBoldFollower): String; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + published + property Renderer: TBoldCustomAsVariantRenderer read GetRenderer write SetRenderer; + property NilRepresentation: Variant read FNilRepresentation write SetNilRepresentation stored IsNilRepresentationStored; + end; + +implementation + +uses + SysUtils, + BoldControlPackDefs, + BoldSystem, + BoldDomainElement, + BoldGuiResourceStrings, + BoldGuard, + BoldValueInterfaces; + +var + DefaultAsVariantRenderer: TBoldCustomAsVariantRenderer; + +const +// These should be moved to BoldGuiResourceStrings.pas and perhaps rephrased + sVariantValidationFailedExtended = 'Validation failed for %s: %2:s'; + sVariantValidationFailed = 'Validation failed'; + sCannotSetVariantValue = '%s.DefaultSetAsVariant: Can''t set variant value'; + sUnknownReason = 'Unknown reason'; + +type + TBoldFollowerControllerAccess = class(TBoldFollowerController); + +{ TBoldVariantFollowerController } + +constructor TBoldVariantFollowerController.Create(aOwningComponent: TComponent); +begin + FNilRepresentation := Null; + inherited; +end; + +procedure TBoldVariantFollowerController.DoAssign(Source: TPersistent); +begin + inherited; + FNilRepresentation := TBoldVariantFollowerController(Source).NilRepresentation; +end; + +procedure TBoldVariantFollowerController.DoMakeUptodateAndSubscribe( + Follower: TBoldFollower; Subscribe: Boolean); +var + renderer: TBoldCustomAsVariantRenderer; + Subscriber: TBoldSubscriber; +begin + If Subscribe then + Subscriber := Follower.Subscriber + else + Subscriber := nil; + Renderer := EffectiveRenderer as TBoldCustomAsVariantRenderer; + if Assigned(Renderer.OnGetAsVariant) or Assigned(Renderer.OnSubscribe) or Assigned(Renderer.OnMayModify) then + Renderer.MakeUptodateAndSubscribe(Follower, Subscriber) + else + renderer.DefaultMakeUptodateAndSetMayModifyAndSubscribe(Follower, Subscriber); +end; + +procedure TBoldVariantFollowerController.DoMultiMakeUptodateAndSubscribe( + Followers: TBoldFollowerArray); +begin + Assert(SupportsMulti); +end; + +function TBoldVariantFollowerController.GetAsString( + aFollower: TBoldFollower): String; +begin + result := EffectiveAsVariantRenderer.GetAsString(aFollower); +end; + +function TBoldVariantFollowerController.GetAsVariant( + aFollower: TBoldFollower): Variant; +begin + result := EffectiveAsVariantRenderer.GetAsVariantAndSubscribe(aFollower, aFollower.Subscriber); +end; + +function TBoldVariantFollowerController.GetCurrentAsVariant( + Follower: TBoldFollower): Variant; +begin + Result := (Follower.RendererData as TBoldVariantRendererData).CurrentVariantValue; +end; + +function TBoldVariantFollowerController.GetRenderer: TBoldCustomAsVariantRenderer; +begin + Result := UntypedRenderer as TBoldCustomAsVariantRenderer; +end; + +function TBoldVariantFollowerController.GetEffectiveAsVariantRenderer: TBoldCustomAsVariantRenderer; +begin + Result := Renderer; + if not Assigned(Result) then + Result := TBoldCustomAsVariantRenderer.DefaultRenderer; +end; + +function TBoldVariantFollowerController.GetEffectiveRenderer: TBoldRenderer; +begin + Result := EffectiveAsVariantRenderer; +end; + +function TBoldVariantFollowerController.GetSupportsMultiEnsure: Boolean; +begin + Result := (EffectiveRenderer = DefaultAsVariantRenderer) and (pos('+', expression) = 0); +end; + +procedure TBoldVariantFollowerController.MakeClean( + Follower: TBoldFollower); +var + el: TBoldDomainElement; + FailureReason: TBoldFailureReason; + lValue: Variant; +begin + lValue := GetCurrentAsVariant(Follower); + if EffectiveAsVariantRenderer.IsChanged(Follower, lValue) then + begin + if ValidateVariant(lValue, Follower) then + begin + ReleaseChangedValue(Follower); // note, must do first, since set can change element + SetAsVariant(lValue, Follower); + end + else + begin + if follower.Element is TBoldDomainElement then + el := follower.Element as TBoldDomainElement + else + el := nil; + FailureReason := GetBoldLastFailureReason; + if assigned(FailureReason) then + GetBoldLastFailureReason.MessageFormatStr := sVariantValidationFailedExtended; + BoldRaiseLastFailure(el, '', sUnknownReason); + end; + end + else + ReleaseChangedValue(Follower); +end; + +function TBoldVariantFollowerController.MayHaveChanged( + const NewValue: Variant; Follower: TBoldFollower): boolean; +var + lBoldVariantRendererData: TBoldVariantRendererData; +begin + if Follower.State in bfsDisplayable then + begin + lBoldVariantRendererData := Follower.RendererData as TBoldVariantRendererData; + lBoldVariantRendererData.CurrentVariantValue := NewValue; + result := EffectiveAsVariantRenderer.IsChanged(Follower, NewValue); + if result then + begin + Follower.ControlledValueChanged; + end; + end + else + result := false; +end; + +procedure TBoldVariantFollowerController.SetAsVariant(const Value: Variant; + Follower: TBoldFollower); +begin + EffectiveAsVariantRenderer.SetAsVariant(Follower, Value); +end; + +procedure TBoldVariantFollowerController.SetColor( + var EffectiveColor: TColor; Color: TColor; Follower: TBoldFollower); +begin + EffectiveAsVariantRenderer.SetColor(Follower, EffectiveColor, Color); +end; + +procedure TBoldVariantFollowerController.SetFont(EffectiveFont, + Font: TFont; Follower: TBoldFollower); +begin + EffectiveAsVariantRenderer.SetFont(Follower, EffectiveFont, Font); +end; + +function TBoldVariantFollowerController.IsNilRepresentationStored: boolean; +begin + result := not VarIsNull(FNilRepresentation); +end; + +procedure TBoldVariantFollowerController.SetNilRepresentation( + const Value: Variant); +begin + if (FNilRepresentation <> Value) then + begin + FNilRepresentation := Value; + Changed; + end; +end; + +procedure TBoldVariantFollowerController.SetRenderer( + Value: TBoldCustomAsVariantRenderer); +begin + Assert(not Assigned(Value) or (Value is TBoldCustomAsVariantRenderer), Value.Classname + ' is not a ' + TBoldCustomAsVariantRenderer.ClassName); + UntypedRenderer := Value; +end; + +function TBoldVariantFollowerController.ValidateVariant( + const Value: Variant; Follower: TBoldFollower): Boolean; +begin + Result := EffectiveAsVariantRenderer.ValidateVariant(Follower, Value); +end; + +function TBoldVariantFollowerController.ValidateCharacter(C: Char; aFollower: TBoldFollower): Boolean; +begin + Result := EffectiveAsVariantRenderer.ValidateCharacter(aFollower, c); +end; + +{ TBoldCustomAsVariantRenderer } + +procedure TBoldCustomAsVariantRenderer.Assign(Source: TPersistent); +begin + inherited; + With Source as TBoldCustomAsVariantRenderer do + begin + self.OnGetAsVariant := OnGetAsVariant; + self.OnSetAsVariant := OnSetAsVariant; + self.OnValidateVariant := OnValidateVariant; + self.OnSetFont := OnSetFont; + self.OnSetColor := OnSetColor; + self.OnIsChanged := OnIsChanged; + self.OnValidateCharacter := OnValidateCharacter; + end; +end; + +procedure TBoldCustomAsVariantRenderer.AssignTo(Dest: TPersistent); +begin + if Dest is TBoldCustomAsVariantRenderer then + with Dest as TBoldCustomAsVariantRenderer do + begin + OnGetAsVariant := self.OnGetAsVariant; + OnSetAsVariant := self.OnSetAsVariant; + OnValidateVariant := self.OnValidateVariant; + OnSetFont := self.OnSetFont; + OnSetColor := self.OnSetColor; + OnIsChanged := self.OnIsChanged; + OnValidateCharacter := self.OnValidateCharacter; + end + else + inherited; +end; + +function TBoldCustomAsVariantRenderer.DefaultDisplayString: string; +begin + if Name <> '' then + Result := '(' + Name + ')' + else + Result := '(' + ClassName + ')'; +end; + +function TBoldCustomAsVariantRenderer.DefaultGetAsVariantAndSubscribe( + aFollower: TBoldFollower; Subscriber: TBoldSubscriber + ): Variant; +var + lFollowerController: TBoldVariantFollowerController; + lResultElement: TBoldElement; +begin + Result := ''; + if (csDesigning in ComponentState) and (Self <> DefaultRenderer) then + begin + Result := DefaultDisplayString; + end + else + begin + lFollowerController := aFollower.AssertedController as TBoldVariantFollowerController; + lResultElement := aFollower.Value; + if Assigned(lResultElement) then + begin + if (lResultElement is TBoldObjectReference) and not assigned((lResultElement as TBoldObjectReference).BoldObject) then + begin + result := lFollowerController.NilRepresentation; + if Assigned(Subscriber) then + lResultElement.SubscribeToStringRepresentation(lFollowerController.Representation, Subscriber, breReEvaluate); + end + else if Assigned(lResultElement) then + begin + Result := lResultElement.AsVariant; + if Assigned(Subscriber) then + lResultElement.SubscribeToStringRepresentation(lFollowerController.Representation, Subscriber, breReEvaluate); + if VarIsNull(Result) then + Result := lFollowerController.NilRepresentation; + end + else + Result := lFollowerController.NilRepresentation; + end + else + Result := lFollowerController.NilRepresentation; + end; +end; + +function TBoldCustomAsVariantRenderer.DefaultIsChanged(aFollower: TBoldFollower; + const NewValue: Variant): Boolean; +var + lOldValue: variant; +begin + lOldValue := TBoldVariantRendererData(aFollower.RendererData).OldVariantValue; + Result := not (((VarIsNumeric(NewValue) and VarIsNumeric(lOldValue)) or (VarType(NewValue) = VarType(lOldValue))) and + (NewValue = lOldValue)); +end; + +procedure TBoldCustomAsVariantRenderer.DefaultMakeUptodateAndSetMayModifyAndSubscribe( + aFollower: TBoldFollower; Subscriber: TBoldSubscriber); +var + lValue: Variant; + lFollowerController: TBoldVariantFollowerController; + lRendererData: TBoldVariantRendererData; + lRepresentation: integer; + lResultElement: TBoldElement; +begin + lRendererData:= aFollower.RendererData as TBoldVariantRendererData; + if (csDesigning in ComponentState) and (Self <> DefaultRenderer) then + begin + lValue := DefaultDisplayString; + end + else + begin + lFollowerController := aFollower.AssertedController as TBoldVariantFollowerController; + lRepresentation := lFollowerController.Representation; + lResultElement := aFollower.Value; + if (lResultElement is TBoldObjectReference) and not assigned((lResultElement as TBoldObjectReference).BoldObject) then + begin + lValue := lFollowerController.NilRepresentation; + if Assigned(Subscriber) then + lResultElement.SubscribeToStringRepresentation(lRepresentation, Subscriber, breReEvaluate); + lRendererData.MaxStringLength := -1; + end + else if Assigned(lResultElement) then + begin + lValue := lResultElement.AsVariant; + if VarIsNull(lValue) then + lValue := lFollowerController.NilRepresentation; + if Assigned(Subscriber) then + lResultElement.SubscribeToStringRepresentation(lRepresentation, Subscriber, breReEvaluate); + if (lResultElement is TBoldAttribute) and assigned((lResultElement as TBoldAttribute).BoldAttributeRTInfo) then + lRendererData.MaxStringLength := (lResultElement as TBoldAttribute).BoldAttributeRTInfo.Length + else + lRendererData.MaxStringLength := -1; + end + else + lValue := lFollowerController.NilRepresentation + end; + lRendererData.OldVariantValue := lValue; + lRendererData.CurrentVariantValue := lValue; +end; + +class function TBoldCustomAsVariantRenderer.DefaultRenderer: TBoldCustomAsVariantRenderer; +begin + Result := DefaultAsVariantRenderer; +end; + +procedure TBoldCustomAsVariantRenderer.DefaultSetAsVariant( + aFollower: TBoldFollower; const Value: Variant); +var + ValueElement: TBoldElement; +begin + ValueElement := aFollower.Value; + if Assigned(ValueElement) then + ValueElement.AsVariant := Value + else + raise EBold.CreateFmt(sCannotSetVariantValue, [ClassName]); +end; + +function TBoldCustomAsVariantRenderer.DefaultValidateVariant( + aFollower: TBoldFollower; const Value: Variant): Boolean; +var + ValueElement: TBoldElement; +begin + ValueElement := aFollower.Value; + if Assigned(ValueElement) then + result := ValueElement.ValidateVariant(Value, TBoldFollowerControllerAccess(aFollower.Controller).Representation) + else + Result := true; +end; + +procedure TBoldCustomAsVariantRenderer.DrawOnCanvas(Follower: TBoldFollower; + Canvas: TCanvas; Rect: TRect; Alignment: TAlignment; Margins: TPoint); +begin + if (not Follower.Displayable) and (Follower.State <> bfsInactiveInvalidElement) then + Follower.EnsureDisplayable; + DrawValueOnCanvas(Canvas, Rect, Alignment, Margins, TBoldVariantRendererData(Follower.RendererData).CurrentVariantValue); +end; + +class procedure TBoldCustomAsVariantRenderer.DrawValueOnCanvas(Canvas: TCanvas; + Rect: TRect; Alignment: TAlignment; Margins: TPoint; const aValue: Variant); +var + Left: Integer; + s: string; +begin + s := aValue; + // Adjust for alignment + case Alignment of + taLeftJustify: Left := Margins.X + Rect.Left; + taRightJustify: Left := (Rect.Right - Rect.Left) - Canvas.TextWidth(S) + Rect.Left - 1 - Margins.X; + else + Left := Rect.Left + ((Rect.Right - Rect.Left) - Canvas.TextWidth(S)) div 2; + end; + Canvas.TextRect(Rect, Left, Rect.Top + Margins.Y, S); +end; + +function TBoldCustomAsVariantRenderer.EffectiveRenderer: TBoldCustomAsVariantRenderer; +begin + result := self; +end; + +function TBoldCustomAsVariantRenderer.GetAsVariantAndSubscribe( + aFollower: TBoldFollower; Subscriber: TBoldSubscriber + ): Variant; +begin + if Assigned(OnSubscribe) and Assigned(Subscriber) then + begin + if Assigned(aFollower.Element) then + OnSubscribe(aFollower, Subscriber); + Subscriber := nil; + end; + if Assigned(OnGetAsVariant) then + Result := OnGetAsVariant(aFollower) + else + Result := DefaultGetAsVariantAndSubscribe(aFollower, Subscriber); +end; + +function TBoldCustomAsVariantRenderer.DefaultGetAsString( + AFollower: TBoldFollower): string; +begin + // what about Subscriber should it be a param ? + try + result := VarToStr(GetAsVariantAndSubscribe(AFollower, nil)); + except + on EVariantError do + Result := ''; + end; +end; + +function TBoldCustomAsVariantRenderer.GetAsString( + aFollower: TBoldFollower): string; +begin + if Assigned(FOnGetAsString) then + result := FOnGetAsString(AFollower) + else + result := DefaultGetAsString(AFollower); +end; + +function TBoldCustomAsVariantRenderer.GetRendererDataClass: TBoldRendererDataClass; +begin + Result := TBoldVariantRendererData; +end; + +function TBoldCustomAsVariantRenderer.GetSupportsMulti: Boolean; +begin + Result := False; +end; + +function TBoldCustomAsVariantRenderer.HasSetValueEventOverrides: boolean; +begin + result := Assigned(FOnSetAsVariant); +end; + +function TBoldCustomAsVariantRenderer.IsChanged(aFollower: TBoldFollower; + const NewValue: Variant): Boolean; +begin + if Assigned(fOnIsChanged) then + Result := fOnIsChanged(aFollower, NewValue) + else + Result := DefaultIsChanged(aFollower, NewValue); +end; + + +procedure TBoldCustomAsVariantRenderer.MakeUpToDateAndSubscribe +(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); +var + lValue: Variant; + lRendererData: TBoldVariantRendererData; +begin + lValue := GetAsVariantAndSubscribe(aFollower, Subscriber); + lRendererData := (aFollower.RendererData as TBoldVariantRendererData); + lRendererData.OldVariantValue := lValue; + lRendererData.CurrentVariantValue := lValue; +end; + +{procedure TBoldCustomAsVariantRenderer.MultiMakeUpToDateAndSubscribe( + Elements: TBoldClientableList; Subscribers, + RendererData: TBoldObjectArray; + FollowerController: TBoldFollowerController); +begin +// do nothing +end;} + +procedure TBoldCustomAsVariantRenderer.SetAsVariant(aFollower: TBoldFollower; + const Value: Variant); +begin + if Assigned(FOnSetAsVariant) then + OnSetAsVariant(aFollower, Value) + else + DefaultSetAsVariant(aFollower, Value) +end; + +procedure TBoldCustomAsVariantRenderer.SetColor(aFollower: TBoldFollower; + var EffectiveColor: TColor; Color: TColor); +begin + EffectiveColor := Color; + if Assigned(fOnSetColor) then + fOnSetColor(aFollower, EffectiveColor); +end; + +procedure TBoldCustomAsVariantRenderer.SetFont(aFollower: TBoldFollower; + EffectiveFont, Font: TFont); +begin + EffectiveFont.Assign(Font); + if Assigned(fOnSetFont) then + fOnSetFont(aFollower, EffectiveFont); +end; + +function TBoldCustomAsVariantRenderer.ValidateVariant(aFollower: TBoldFollower; + const Value: Variant): Boolean; +begin + if Assigned(FOnValidateVariant) then + Result := OnValidateVariant(aFollower, Value) + else + Result := DefaultValidateVariant(aFollower, Value); +end; + +{ TBoldVariantRendererData } + +constructor TBoldVariantRendererData.Create(OwningFollower: TBoldFollower); +begin + inherited; + fMaxStringLength := -1; + OldVariantValue := Null; + CurrentVariantValue := Null; +end; + +initialization + DefaultAsVariantRenderer := TBoldAsVariantRenderer.Create(nil); + +finalization + FreeAndNil(DefaultAsVariantRenderer); + +end. + + diff --git a/Source/BoldAwareGUI/ControlPacks/BoldViewerControlPack.pas b/Source/BoldAwareGUI/ControlPacks/BoldViewerControlPack.pas index f3d2226d..22be855f 100644 --- a/Source/BoldAwareGUI/ControlPacks/BoldViewerControlPack.pas +++ b/Source/BoldAwareGUI/ControlPacks/BoldViewerControlPack.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldViewerControlPack; {$UNDEF BOLDCOMCLIENT} @@ -32,10 +35,10 @@ TBoldAbstractViewAdapter = class; TBoldGetAsViewer = procedure (Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; var AbstractViewAdapter: TBoldAbstractViewAdapter) of object; {$ENDIF} {$IFDEF BOLD_DELPHI} - TBoldGetAsViewer = function (Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression): TBoldAbstractViewAdapter of object; + TBoldGetAsViewer = function (aFollower: TBoldFollower): TBoldAbstractViewAdapter of object; {$ENDIF} - TBoldSetAsViewer = procedure (Element: TBoldElement; Value: TBoldAbstractViewAdapter; Representation: TBoldRepresentation; Expression: TBoldExpression) of object; - TBoldViewerIsChanged = function (RendererData: TBoldViewerRendererData; NewValue: TBoldAbstractViewAdapter; Representation: TBoldRepresentation; Expression: TBoldExpression): Boolean of object; + TBoldSetAsViewer = procedure (aFollower: TBoldFollower; Value: TBoldAbstractViewAdapter) of object; + TBoldViewerIsChanged = function (aFollower: TBoldFollower; NewValue: TBoldAbstractViewAdapter): Boolean of object; { TBoldViewerRendererData } TBoldViewerRendererData = class(TBoldRendererData) @@ -50,6 +53,7 @@ TBoldViewerRendererData = class(TBoldRendererData) end; { TBoldAsViewerRenderer } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldAsViewerRenderer = class(TBoldSingleRenderer) private FOnGetAsViewer: TBoldGetAsViewer; @@ -57,15 +61,16 @@ TBoldAsViewerRenderer = class(TBoldSingleRenderer) fOnIsChanged: TBoldViewerIsChanged; protected function GetRendererDataClass: TBoldRendererDataClass; override; - function GetAsViewerAndSubscribe(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): TBoldAbstractViewAdapter; virtual; - procedure SetAsViewer(Element: TBoldElement; Value: TBoldAbstractViewAdapter; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); virtual; + function GetAsViewerAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): TBoldAbstractViewAdapter; virtual; + procedure SetAsViewer(aFollower: TBoldFollower; Value: TBoldAbstractViewAdapter); virtual; + function HasSetValueEventOverrides: boolean; override; public class function DefaultRenderer: TBoldAsViewerRenderer; - function DefaultGetAsViewerAndSubscribe(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): TBoldAbstractViewAdapter; virtual; - procedure DefaultSetAsViewer(Element: TBoldElement; Value: TBoldAbstractViewAdapter; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); virtual; - function DefaultIsChanged(RendererData: TBoldViewerRendererData; NewValue: TBoldAbstractViewAdapter; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; - function IsChanged(RendererData: TBoldViewerRendererData; NewValue: TBoldAbstractViewAdapter; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; - procedure MakeUptodateAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldFollowerController; Subscriber: TBoldSubscriber); override; + function DefaultGetAsViewerAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): TBoldAbstractViewAdapter; virtual; + procedure DefaultSetAsViewer(aFollower: TBoldFollower; Value: TBoldAbstractViewAdapter); virtual; + function DefaultIsChanged(aFollower: TBoldFollower; NewValue: TBoldAbstractViewAdapter): Boolean; + function IsChanged(aFollower: TBoldFollower; NewValue: TBoldAbstractViewAdapter): Boolean; + procedure MakeUptodateAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); override; published property OnGetAsViewer: TBoldGetAsViewer read FOnGetAsViewer write FOnGetAsViewer; property OnSetAsViewer: TBoldSetAsViewer read FOnSetAsViewer write FOnSetAsViewer; @@ -92,8 +97,6 @@ TBoldViewerFollowerController = class(TBoldSingleFollowerController) {-- TBoldAbstractViewAdapter --} TBoldViewAdapterClass = class of TBoldAbstractViewAdapter; - - // BCB does not support abstract class methods TBoldAbstractViewAdapter = class(TBoldMemoryManagedObject) public constructor Create; virtual; @@ -104,19 +107,19 @@ TBoldAbstractViewAdapter = class(TBoldMemoryManagedObject) function Empty: Boolean; virtual; abstract; procedure Clear; virtual; abstract; function HasChanged: Boolean; virtual; abstract; - class function CanReadContent(const ContentType: string): Boolean; virtual; + class function CanReadContent(const ContentType: string): Boolean; virtual; function ContentType: string; virtual; abstract; - class function Description: string; virtual; // How to handle Localizastion? + class function Description: string; virtual; {Clipboard} procedure CopyToClipboard; virtual; abstract; - class function CanPasteFromClipboard(const AcceptedContentType: string): Boolean; virtual; + class function CanPasteFromClipboard(const AcceptedContentType: string): Boolean; virtual; procedure PasteFromClipboard; virtual; abstract; {Streams} procedure LoadFromStream(Stream: TStream); virtual; abstract; procedure SaveToStream(Stream: TStream); virtual; abstract; {Files} - class function DefaultExtension: string; virtual; - class function FileFilter: string; virtual; // How to handle Localizastion? + class function DefaultExtension: string; virtual; + class function FileFilter: string; virtual; class function CanLoadFromFile(const Filename: string): Boolean; virtual; procedure LoadFromFile(const Filename: string); virtual; abstract; procedure SaveToFile(const Filename: string); virtual; abstract; @@ -131,9 +134,9 @@ implementation uses SysUtils, - BoldGuiResourceStrings, BoldUtils, - BoldImageBitmap; //FIXME Temp! + BoldImageBitmap, + BoldGuard; var DefaultAsViewerRenderer: TBoldAsViewerRenderer; @@ -159,13 +162,13 @@ procedure TBoldViewerRendererData.SetViewAdapter(Value: TBoldAbstractViewAdapter { TBoldAsViewerRenderer } -procedure TBoldAsViewerRenderer.MakeUpToDateAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldFollowerController; Subscriber: TBoldSubscriber); +procedure TBoldAsViewerRenderer.MakeUpToDateAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); var - Controller: TBoldViewerFollowerController; + lRendererData: TBoldViewerRendererData; begin - Controller := FollowerController as TBoldViewerFollowerController; - (RendererData as TBoldViewerRendererData).ViewAdapter := GetAsViewerAndSubscribe(Element, Controller.Representation, Controller.Expression, Controller.GetVariableListAndSubscribe(Subscriber), Subscriber); - (RendererData as TBoldViewerRendererData).HasChanged := False; + lRendererData := aFollower.RendererData as TBoldViewerRendererData; + lRendererData.ViewAdapter := GetAsViewerAndSubscribe(aFollower, Subscriber); + lRendererData.HasChanged := False; end; class function TBoldAsViewerRenderer.DefaultRenderer: TBoldAsViewerRenderer; @@ -178,15 +181,21 @@ function TBoldAsViewerRenderer.GetRendererDataClass: TBoldRendererDataClass; Result := TBoldViewerRendererData; end; -function TBoldAsViewerRenderer.DefaultGetAsViewerAndSubscribe(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): TBoldAbstractViewAdapter; +function TBoldAsViewerRenderer.HasSetValueEventOverrides: boolean; +begin + result := Assigned(FOnSetAsViewer); +end; + +function TBoldAsViewerRenderer.DefaultGetAsViewerAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): TBoldAbstractViewAdapter; var e: TBoldElement; - Stream: TStream; - {$IFDEF BOLDCOMCLIENT} // defaultGet + {$IFDEF BOLDCOMCLIENT} attr: IBoldAttribute; {$ELSE} IndirectElement: TBoldIndirectElement; blob: TBABlob; + lResultElement: TBoldElement; + lGuard: IBoldGuard; {$ENDIF} function GetViewer: TBoldAbstractViewAdapter; @@ -204,9 +213,9 @@ function TBoldAsViewerRenderer.DefaultGetAsViewerAndSubscribe(Element: TBoldElem begin Result := nil; - if Assigned(Element) then + if Assigned(aFollower.Element) then begin - {$IFDEF BOLDCOMCLIENT} // defaultGet + {$IFDEF BOLDCOMCLIENT} if assigned(Subscriber) then e := Element.EvaluateAndSubscribeToExpression(Expression, Subscriber.ClientId, Subscriber.SubscriberId, false, false) else @@ -227,55 +236,51 @@ function TBoldAsViewerRenderer.DefaultGetAsViewerAndSubscribe(Element: TBoldElem end; end else - raise EBold.CreateFmt(sViewerNotAvailable, [attr.StringRepresentation[brShort]]) + raise EBold.CreateFmt('Viewer not available (%s)', [attr.StringRepresentation[brShort]]) end else Result := nil; {$ELSE} - IndirectElement := TBoldIndirectElement.Create; - try - Element.EvaluateAndSubscribeToExpression(Expression, Subscriber, IndirectElement, False, false, VariableList); - e := IndirectElement.Value; - if e is TBABlob then + lResultElement := aFollower.Value; + if not Assigned(lResultElement) then + begin + lGuard:= TBoldGuard.Create(IndirectElement); + IndirectElement := TBoldIndirectElement.Create; + aFollower.Element.EvaluateAndSubscribeToExpression(aFollower.AssertedController.Expression, Subscriber, IndirectElement, False, False, aFollower.Controller.GetVariableListAndSubscribe(Subscriber)); + lResultElement := IndirectElement.Value; + end; + if lResultElement is TBABlob then + begin + blob := TBABlob(lResultElement); + if not Blob.IsNull then begin - blob := TBABlob(e); - if not Blob.IsNull then + e := Blob; + Result := GetViewer; + if Assigned(Result) then begin - Result := GetViewer; - if Assigned(Result) then - begin - Stream := blob.CreateBlobStream(bmRead); - try - Result.LoadFromStream(Stream); - finally - Stream.Free; - end; - end - else - raise EBold.CreateFmt(sViewerNotAvailable, [Blob.ContentType]) + Result.LoadFromStream(blob.AsStream); end else - Result := nil; - end; - finally - IndirectElement.Free; + raise EBold.CreateFmt('Viewer not available (%s)', [Blob.ContentType]) + end + else + Result := nil; end; {$ENDIF} end; end; -procedure TBoldAsViewerRenderer.DefaultSetAsViewer(Element: TBoldElement; Value: TBoldAbstractViewAdapter; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); +procedure TBoldAsViewerRenderer.DefaultSetAsViewer(aFollower: TBoldFollower; Value: TBoldAbstractViewAdapter); var ValueElement: TBoldElement; - Stream: TStream; - {$IFDEF BOLDCOMCLIENT} // defaultSet + {$IFDEF BOLDCOMCLIENT} Attr: IBoldAttribute; {$ENDIF} begin - ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); + ValueElement := aFollower.Value; if Assigned(ValueElement) then begin - {$IFDEF BOLDCOMCLIENT} // DefaultSet + {$IFDEF BOLDCOMCLIENT} ValueElement.QueryInterface(IBoldAttribute, Attr); if Assigned(Value) then begin @@ -293,28 +298,23 @@ procedure TBoldAsViewerRenderer.DefaultSetAsViewer(Element: TBoldElement; Value: {$ELSE} if Assigned(Value) then begin - Stream := (ValueElement as TBABlob).CreateBlobStream(bmWrite); - try - Value.SaveToStream(Stream); - (ValueElement as TBABlob).ContentType := Value.ContentType; - finally - Stream.Free; - end; + Value.SaveToStream((ValueElement as TBABlob).AsStream); + (ValueElement as TBABlob).ContentType := Value.ContentType; end else (ValueElement as TBABlob).SetToNull; {$ENDIF} end else - raise EBold.CreateFmt(sCannotSetValue, [ClassName]); + raise EBold.CreateFmt('%s.DefaultSetAsViewer: Can''t set value', [ClassName]); end; -function TBoldAsViewerRenderer.GetAsViewerAndSubscribe(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList; Subscriber: TBoldSubscriber): TBoldAbstractViewAdapter; +function TBoldAsViewerRenderer.GetAsViewerAndSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber): TBoldAbstractViewAdapter; begin if Assigned(OnSubscribe) and Assigned(Subscriber) then begin - if Assigned(Element) then - OnSubscribe(Element, Representation, Expression, Subscriber); + if Assigned(aFollower.Element) then + OnSubscribe(aFollower, Subscriber); Subscriber := nil; end; if Assigned(OnGetAsViewer) then @@ -324,32 +324,32 @@ function TBoldAsViewerRenderer.GetAsViewerAndSubscribe(Element: TBoldElement; Re OnGetAsViewer(Element, Representation, Expression, Result); {$ENDIF} {$IFDEF BOLD_DELPHI} - Result := OnGetAsViewer(Element, Representation, Expression); + Result := OnGetAsViewer(aFollower); {$ENDIF} end else - Result := DefaultGetAsViewerAndSubscribe(Element, Representation, Expression, VariableList, Subscriber); + Result := DefaultGetAsViewerAndSubscribe(aFollower, Subscriber); end; -procedure TBoldAsViewerRenderer.SetAsViewer(Element: TBoldElement; Value: TBoldAbstractViewAdapter; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); +procedure TBoldAsViewerRenderer.SetAsViewer(aFollower: TBoldFollower; Value: TBoldAbstractViewAdapter); begin if Assigned(FOnSetAsViewer) then - OnSetAsViewer(Element, Value, Representation, Expression) + OnSetAsViewer(aFollower, Value) else - DefaultSetAsViewer(Element, Value, Representation, Expression, VariableList); + DefaultSetAsViewer(aFollower, Value); end; -function TBoldAsViewerRenderer.DefaultIsChanged(RendererData: TBoldViewerRendererData; NewValue: TBoldAbstractViewAdapter; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; +function TBoldAsViewerRenderer.DefaultIsChanged(aFollower: TBoldFollower; NewValue: TBoldAbstractViewAdapter): Boolean; begin - Result := (RendererData.HasChanged) or (Assigned(NewValue) and NewValue.HasChanged); + Result := (TBoldViewerRendererData(aFollower.RendererData).HasChanged) or (Assigned(NewValue) and NewValue.HasChanged); end; -function TBoldAsViewerRenderer.IsChanged(RendererData: TBoldViewerRendererData; NewValue: TBoldAbstractViewAdapter; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; +function TBoldAsViewerRenderer.IsChanged(aFollower: TBoldFollower; NewValue: TBoldAbstractViewAdapter): Boolean; begin if Assigned(fOnIsChanged) then - Result := fOnIsChanged(RendererData, NewValue, Representation, Expression) + Result := fOnIsChanged(aFollower, NewValue) else - Result := DefaultIsChanged(RendererData, NewValue, Representation, Expression, VariableList); + Result := DefaultIsChanged(aFollower, NewValue); end; { TBoldViewerFollowerController } @@ -384,15 +384,23 @@ function TBoldViewerFollowerController.GetCurrentViewer(Follower: TBoldFollower) procedure TBoldViewerFollowerController.SetAsViewer(Value: TBoldAbstractViewAdapter; Follower: TBoldFollower); begin - EffectiveAsViewerRenderer.SetAsViewer(Follower.Element, Value, Representation, Expression, VariableList); + EffectiveAsViewerRenderer.SetAsViewer(Follower, Value); end; procedure TBoldViewerFollowerController.MayHaveChanged(NewValue: TBoldAbstractViewAdapter; Follower: TBoldFollower); +var + lIsChanged: boolean; + lRendererData: TBoldViewerRendererData; begin if Follower.State in bfsDisplayable then begin - (Follower.RendererData as TBoldViewerRendererData).ViewAdapter := NewValue; - Follower.ControlledValueChanged(EffectiveAsViewerRenderer.IsChanged(Follower.RendererData as TBoldViewerRendererData, NewValue, Representation, Expression, VariableList)); + lRendererData := Follower.RendererData as TBoldViewerRendererData; + lRendererData.ViewAdapter := NewValue; + lIsChanged := EffectiveAsViewerRenderer.IsChanged(Follower, NewValue); + if lIsChanged then + begin + Follower.ControlledValueChanged; + end; end; end; @@ -406,7 +414,6 @@ procedure TBoldViewerFollowerController.MakeClean(Follower: TBoldFollower); constructor TBoldAbstractViewAdapter.Create; begin - // Left for subclasses to implement end; class procedure TBoldAbstractViewAdapter.RegisterViewAdapter(ViewAdapterClass: TBoldViewAdapterClass); @@ -467,6 +474,5 @@ initialization finalization FreeAndNil(DefaultAsViewerRenderer); FreeAndNil(ViewAdapterList); - + end. - diff --git a/Source/BoldAwareGUI/Core/BoldExceptionHandlers.pas b/Source/BoldAwareGUI/Core/BoldExceptionHandlers.pas index b3f0d500..c87a66c8 100644 --- a/Source/BoldAwareGUI/Core/BoldExceptionHandlers.pas +++ b/Source/BoldAwareGUI/Core/BoldExceptionHandlers.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldExceptionHandlers; interface @@ -12,14 +15,17 @@ interface TBoldExceptionHandler = class; { prototypes } - TBoldApplyExceptionEvent = procedure (E: Exception; Component: TComponent; Elem: TBoldElement; var Discard: Boolean) of object; + TBoldApplyExceptionEvent = procedure (E: Exception; Component: TComponent; Elem: TBoldElement; var Discard: Boolean; var HandledByUser: boolean) of object; TBoldDisplayExceptionEvent = procedure (E: Exception; Component: TComponent; Elem: TBoldElement) of object; { TBoldExceptionHandler } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldExceptionHandler = class(TComponent) private fOnApplyException: TBoldApplyExceptionEvent; fOnDisplayException: TBoldDisplayExceptionEvent; + fGlobal: boolean; + procedure SetGlobal(const Value: boolean); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; @@ -29,14 +35,13 @@ TBoldExceptionHandler = class(TComponent) published property OnApplyException: TBoldApplyExceptionEvent read fOnApplyException write fOnApplyException; property OnDisplayException: TBoldDisplayExceptionEvent read fOnDisplayException write fOnDisplayException; - end; + property Global: boolean read fGlobal write SetGlobal default false; + end; implementation - uses - Controls, - BoldUtils; + BoldRev; var G_BoldExceptionHandlers: TList = nil; @@ -64,56 +69,35 @@ destructor TBoldExceptionHandler.Destroy; end; class function TBoldExceptionHandler.FindExceptionHandler(Component: TComponent): TBoldExceptionHandler; -function OwningComponent(Component: TComponent): TComponent; -begin -//Find topmost owning component - Result := Component; - while Assigned(Result) and Assigned(Result.Owner) do - Result := Result.Owner; -end; - -function ParentControl(Component: TComponent): TWinControl; -begin -//Find topmost parent control - Result := nil; - if Component is TWinControl then - begin - Result := TWinControl(Component); - while Assigned(Result.Parent) do - Result := Result.Parent; - end; -end; - var i: integer; - ExceptionHandlerOwner: TComponent; begin - //Find matching exception handler - result := nil; - if assigned(G_BoldExceptionHandlers) then + if assigned(G_BoldExceptionHandlers) and (G_BoldExceptionHandlers.Count > 0) then + begin for i := 0 to G_BoldExceptionHandlers.Count - 1 do begin - ExceptionHandlerOwner := TBoldExceptionHandler(G_BoldExceptionHandlers[i]).Owner; - if (ExceptionHandlerOwner = OwningComponent(Component)) or - (ExceptionHandlerOwner = ParentControl(Component)) then - begin - result := TBoldExceptionHandler(G_BoldExceptionHandlers[i]); + result := TBoldExceptionHandler(G_BoldExceptionHandlers[i]); + if (result.Owner = Component.Owner) then exit; - end; end; + for i := 0 to G_BoldExceptionHandlers.Count - 1 do + begin + result := TBoldExceptionHandler(G_BoldExceptionHandlers[i]); + if Result.Global then + exit; + end; + end; + result := nil; end; procedure TBoldExceptionHandler.HandleApplyException(E: Exception; Component: TComponent; Elem: TBoldElement; var Discard: Boolean; var HandledByUser: boolean); begin - // Note: Discard must be set by caller, as there might be no matching exception handler - // to set discard! - HandledByUser := Assigned(fOnApplyException); - if HandledByUser then - OnApplyException(E, Component, Elem, Discard); + if Assigned(fOnApplyException) then + OnApplyException(E, Component, Elem, Discard, HandledByUser); end; -procedure TBoldExceptionHandler.HandleDisplayException(E: Exception; +procedure TBoldExceptionHandler.HandleDisplayException(E: Exception; Component: TComponent; Elem: TBoldElement; var HandledByUser: boolean); begin HandledByUser := Assigned(fOnDisplayException); @@ -121,6 +105,19 @@ procedure TBoldExceptionHandler.HandleDisplayException(E: Exception; OnDisplayException(E, Component, Elem); end; +procedure TBoldExceptionHandler.SetGlobal(const Value: boolean); +var + i: integer; +begin + if Value = Global then + exit; + if value and assigned(G_BoldExceptionHandlers) then + for i := 0 to G_BoldExceptionHandlers.Count - 1 do + if TBoldExceptionHandler(G_BoldExceptionHandlers[i]).Global then + exit; + fGlobal := Value; +end; + initialization finalization diff --git a/Source/BoldAwareGUI/Core/BoldGUI.pas b/Source/BoldAwareGUI/Core/BoldGUI.pas index 5711b7b7..2e36b957 100644 --- a/Source/BoldAwareGUI/Core/BoldGUI.pas +++ b/Source/BoldAwareGUI/Core/BoldGUI.pas @@ -1,18 +1,22 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldGUI; interface uses + // VCL Classes, - Menus, - Forms, Controls, - BoldSystem, - BoldDefs, - BoldControlPackDefs, + Forms, + Menus, + + // Bold BoldBase, + BoldControlPackDefs, BoldElements, - BoldControlPack; + BoldSystem; type TBoldGUIHandler = class; @@ -46,7 +50,6 @@ implementation uses SysUtils, - BoldUtils, BoldSystemRT; var @@ -118,7 +121,6 @@ function TBoldGUIHandler.DraggedObjectsAssignable(element: TBoldElement; dropMod procedure TBoldGUIHandler.DoPopUp; begin - // FIXME fill in items in popup menu, etc, etc end; function TBoldGUIHandler.FindHostingForm(Component: TComponent): TForm; @@ -126,23 +128,28 @@ function TBoldGUIHandler.FindHostingForm(Component: TComponent): TForm; temp: TComponent; Control: TControl; begin - result := nil; - if Component is TControl then - begin - Control := Component as TControl; - while assigned(Control) and not (Control is TForm) do - Control := Control.Parent; - if Control is TForm then - result := Control as TForm; - end; - - if not assigned(result) then + if Component is TForm then + result := Component as TForm + else begin - temp := Component; - while assigned(temp) and not (temp is TForm) do - temp := temp.Owner; - if temp is TForm then - result := temp as TForm; + result := nil; + if Component is TControl then + begin + Control := Component as TControl; + while assigned(Control) and not (Control is TForm) do + Control := Control.Parent; + if Control is TForm then + result := Control as TForm; + end; + + if not assigned(result) then + begin + temp := Component; + while assigned(temp) and not (temp is TForm) do + temp := temp.Owner; + if temp is TForm then + result := temp as TForm; + end; end; end; @@ -160,6 +167,7 @@ function TBoldGUIHandler.TryToFocusHostingForm(Component: TComponent): Boolean; end; initialization + BoldPopupMenu := TPopupMenu.Create(nil); BoldPopupMenu.OnPopup := BoldGUIHandler.DoPopUp; diff --git a/Source/BoldAwareGUI/Core/BoldGuiResourceStrings.pas b/Source/BoldAwareGUI/Core/BoldGuiResourceStrings.pas index ee3c725c..fc1c690b 100644 --- a/Source/BoldAwareGUI/Core/BoldGuiResourceStrings.pas +++ b/Source/BoldAwareGUI/Core/BoldGuiResourceStrings.pas @@ -1,3 +1,13 @@ + +///////////////////////////////////////////////////////// +// // +// Bold for Delphi // +// Copyright (c) 1996-2002 Boldsoft AB // +// (c) 2002-2005 Borland Software Corp // +// // +///////////////////////////////////////////////////////// + + unit BoldGuiResourceStrings; interface diff --git a/Source/BoldAwareGUI/FormGen/BoldAFPDefault.pas b/Source/BoldAwareGUI/FormGen/BoldAFPDefault.pas index f3cab180..66070a58 100644 --- a/Source/BoldAwareGUI/FormGen/BoldAFPDefault.pas +++ b/Source/BoldAwareGUI/FormGen/BoldAFPDefault.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAFPDefault; interface @@ -37,6 +40,8 @@ TBoldDefaultSystemAutoFormProvider = class; TBoldDefaultAttributeListAutoFormProvider = class; TBoldDefaultObjectListAutoFormProvider = class; + TFormAFPDefault = class(TForm); + {---TBoldDefaultFormProvider---} TBoldDefaultFormProvider = class(TBoldUserFormProvider) private @@ -197,7 +202,7 @@ TRoleMenu = class(TPopupMenu) var BoldShowConstraintsInAutoFormGrids: boolean = true; - BoldShowHistoryTabInAutoForms: boolean = true; + BoldShowHistoryTabInAutoForms: boolean = false; implementation @@ -206,6 +211,7 @@ implementation uses SysUtils, Dialogs, + {$IFDEF BOLD_DELPHI16_OR_LATER}UITypes,{$ENDIF} BoldGuiResourceStrings, BoldUtils, BoldBase, @@ -222,7 +228,11 @@ implementation BoldEdit, BoldStringControlPack, BoldCondition, - BoldId; + BoldId, + BoldIndex, + BoldIndexableList, + BoldMetaElementList, + BoldDomainElement; const BOXMARGIN = 8; @@ -366,11 +376,18 @@ procedure TMethodButton.Click; {--TBoldAFEdit---} procedure TBoldAFEdit.DblClick; +var + AForm : TForm; begin if Assigned(BoldHandle) and (BoldHandle.Value is TBoldObjectReference) and assigned((BoldHandle.Value as TBoldObjectReference).BoldObject) then - AutoFormProviderRegistry.FormForElement(TBoldObjectReference(BoldHandle.Value).BoldObject).Show; + begin + AForm := AutoFormProviderRegistry.FormForElement(TBoldObjectReference(BoldHandle.Value).BoldObject); + if Assigned(AForm) then begin + AForm.Show; + end; + end; end; {---TAFPPageControl---} @@ -423,17 +440,22 @@ class procedure TBoldDefaultFormProvider.DefaultFormDragOver(Sender, Source: TOb class procedure TBoldDefaultFormProvider.DefaultFormOnClose(Sender: TObject; var Action: TCloseAction); var Form: TForm; + AFormIndex : Integer; StoredCloseEvent: TCloseEvent; begin Action := caFree; - if Sender is TForm then - begin + if Sender is TForm then begin Form := Sender as TForm; Form.ActiveControl.Perform(CM_EXIT, 0, 0); - StoredCloseEvent := G_BoldActiveAutoForms.Entries[G_BoldActiveAutoForms.IndexOfForm(Form)].OnClose; - if Assigned(StoredCloseEvent) then - StoredCloseEvent(Sender, Action); - G_BoldActiveAutoForms.RemoveByForm(Form); + + AFormIndex := G_BoldActiveAutoForms.IndexOfForm(Form); + if (AFormIndex > -1) and (AFormIndex < G_BoldActiveAutoForms.Count) then begin + StoredCloseEvent := G_BoldActiveAutoForms.Entries[AFormIndex].OnClose; + if Assigned(StoredCloseEvent) then begin + StoredCloseEvent(Sender, Action); + end; + G_BoldActiveAutoForms.RemoveByForm(Form); + end; end; end; @@ -458,7 +480,7 @@ procedure TBoldDefaultFormProvider.PostGenerateAutoForm; function TBoldDefaultFormProvider.GetFormClass: TFormClass; begin - Result := TForm; + Result := TFormAFPDefault; end; procedure TBoldDefaultFormProvider.PreGenerateAutoForm; @@ -489,11 +511,24 @@ procedure TBoldDefaultFormProvider.PostEnsureForm; begin Form.Position := poDefaultPosOnly; Form.BoundsRect := Rect(0, 0, 440, 360); + Form.Constraints.MinHeight := MINFORMHEIGHT; end; procedure TBoldDefaultFormProvider.EnsureForm; begin - inherited; +// inherited; + // No inherited, because form needs to be created with CreateNew. + // In this way, no resources are needed (because its not inherited from TForm anymore) + if Assigned(FormClass) then + begin + if FormClass.InheritsFrom(TFormAFPDefault) then + Form := FormClass.CreateNew(Application) // TFormAFPDefault descendants have no .dfm + else + Form := FormClass.Create(Application); + end + else + Form := nil; + if Assigned(Form) then begin G_BoldActiveAutoForms.AddPair(Form, Element); @@ -922,6 +957,9 @@ function TBoldDefaultObjectAutoFormProvider.GetGoodStringRepresentationForSingle end; end; +type + TWinControlAccess = class(TWinControl); + procedure TBoldDefaultObjectAutoFormProvider.EnsureSingleMemberControls; var TabSheet: TTabSheet; @@ -945,6 +983,8 @@ procedure TBoldDefaultObjectAutoFormProvider.EnsureSingleMemberControls; TabSheet := CreateTabSheet(ClassTypeInfo.ModelName, MakeComponentName('Tab', ClassTypeInfo, nil)); // do not localize ScrollBox := CreateScrollBox(TabSheet); + ScrollBox.Align := alNone; + ScrollBox.SetBounds(0, 0, ScrollBox.Parent.Width, 10000{ScrollBox.Parent.Height}); MaxLabelWidth := GetLargestWidth; Box1NextLeft := CONTROLMARGIN; @@ -966,12 +1006,12 @@ procedure TBoldDefaultObjectAutoFormProvider.EnsureSingleMemberControls; (Orientation = orHorizontal) then begin Inc(Box1NextTop, 24); - Box1NextLeft := 10; + Box1NextLeft := CONTROLMARGIN; end; Left := Box1NextLeft; Top := Box1NextTop + 4; Parent := ScrollBox; - Inc(Box1NextLeft, Width + 10); + Inc(Box1NextLeft, Width + CONTROLMARGIN); end; if Member.BoldType.ConformsTo((Member.BoldType.SystemTypeInfo as TBoldSystemTypeInfo).AttributeTypeInfoByExpressionName['ValueSet']) then // do not localize @@ -1016,7 +1056,7 @@ procedure TBoldDefaultObjectAutoFormProvider.EnsureSingleMemberControls; ExpressionHandle.RootHandle := Self.BoldHandle; ExpressionHandle.Expression := Member.ExpressionName; ExpressionHandle.Name := MakeComponentName('Handle', ClassTypeInfo, Member); // do not localize - BoldEdit.Color := clInactiveCaptionText; + BoldEdit.Color := clBtnShadow; BoldEdit.ReadOnly := true; BoldEdit.BoldHandle := ExpressionHandle; BoldEdit.BoldProperties.DragMode := bdgSelection; @@ -1057,6 +1097,11 @@ procedure TBoldDefaultObjectAutoFormProvider.EnsureSingleMemberControls; else Form.Height := Box1NextTop + 100 + PANELHEIGHT; + Form.Constraints.MinWidth := MaxLabelWidth + CONTROLMARGIN * 2 + 100; + + TWinControlAccess(Form).AdjustSize; + ScrollBox.Align := alClient; + // Move all handles and stuff to the bottom of the window. Box1NextLeft := CONTROLMARGIN; for i := 0 to Form.ComponentCount - 1 do @@ -1129,7 +1174,7 @@ class procedure TBoldDefaultObjectAutoFormProvider.BoldAsStringRenderer1SetColor Element.EvaluateExpression(Expression, Result); if (Result.Value is TBoldMember) and not (Result.Value as TBoldMember).CanModify then - AColor := clInactiveCaptionText; + AColor := clBtnShadow; finally Result.Free; end; @@ -1201,12 +1246,17 @@ procedure TRoleButton.MouseDown(Button: TMouseButton; Shift: TShiftState; procedure TRoleButton.NavigateToSingleRole(Sender: TObject); var anObject: TBoldObject; + AForm : TForm; begin if Assigned(BoldHandle) and (BoldHandle.Value is TBoldObjectReference) then begin anObject := (BoldHandle.Value as TBoldObjectReference).BoldObject; - if Assigned(anObject) then - AutoFormProviderRegistry.FormForElement(anObject).Show; + if Assigned(anObject) then begin + AForm := AutoFormProviderRegistry.FormForElement(anObject); + if Assigned(AForm) then begin + AForm.Show; + end; + end; end end; @@ -1299,7 +1349,11 @@ procedure TAutoFormList.AddPair(Form: TForm; Element: TBoldElement); function TAutoFormList.GetEntries( const index: integer): TAutoFormListEntry; begin - Result := TAutoFormListEntry(Items[index]); + if index < Count then begin + Result := TAutoFormListEntry(Items[index]); + end else begin + Result := nil; + end; end; function TAutoFormList.GetForms(const index: integer): TForm; @@ -1324,8 +1378,14 @@ function TAutoFormList.IndexOfElement(anObject: TObject): integer; end; procedure TAutoFormList.RemoveByForm(Form: TForm); +var + i: Integer; begin - Delete(IndexOfForm(Form)); + i := IndexOfForm(Form); + if i > -1 then begin + Entries[i].Free; + Delete(i); + end; end; constructor TBoldDefaultFormProvider.Create(BoldElement: TBoldElement); @@ -1709,7 +1769,7 @@ function TBoldDefaultObjectAutoFormProvider.CompareObjectsOnTimeStamp( initialization G_BoldActiveAutoForms := TAutoFormList.Create; fReadOnlyStringRenderer := TBoldAsStringRenderer.Create(nil); - fReadOnlyStringRenderer.OnSetColor := TBoldDefaultObjectAutoFormProvider.BoldAsStringRenderer1SetColor; +// fReadOnlyStringRenderer.OnSetColor := TBoldDefaultObjectAutoFormProvider.BoldAsStringRenderer1SetColor; //FIX AutoFormProviderRegistry.RegisterProvider(bvtClass, TBoldObject, TBoldDefaultObjectAutoFormProvider); AutoFormProviderRegistry.RegisterProvider(bvtSystem, TBoldSystem, TBoldDefaultSystemAutoFormProvider); diff --git a/Source/BoldAwareGUI/FormGen/BoldAFPDefault.res b/Source/BoldAwareGUI/FormGen/BoldAFPDefault.res new file mode 100644 index 00000000..7239ab29 Binary files /dev/null and b/Source/BoldAwareGUI/FormGen/BoldAFPDefault.res differ diff --git a/Source/BoldAwareGUI/FormGen/BoldAFPPluggable.pas b/Source/BoldAwareGUI/FormGen/BoldAFPPluggable.pas index 34b1fd4e..482f2fa3 100644 --- a/Source/BoldAwareGUI/FormGen/BoldAFPPluggable.pas +++ b/Source/BoldAwareGUI/FormGen/BoldAFPPluggable.pas @@ -26,6 +26,7 @@ TBoldInstallableFormsRegistry = class; TBoldHandleLocatorStyle = (hfByName, hfByType); {---TBoldPlaceableAFP---} + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldPlaceableAFP = class(TComponent) private fOnGetFormClass: TBoldGetFormClassEvent; @@ -240,7 +241,11 @@ procedure TBoldPluggableAFP.EnsureHandle; if DefaultBehaviour then inherited else + begin BoldHandle := RetrieveHandle; + if not Assigned(BoldHandle) then + inherited; + end; end; procedure TBoldPluggableAFP.EnsureComponents; diff --git a/Source/BoldAwareGUI/FormGen/BoldAFPPluggableReg.pas b/Source/BoldAwareGUI/FormGen/BoldAFPPluggableReg.pas index c489c6d2..ffb969a4 100644 --- a/Source/BoldAwareGUI/FormGen/BoldAFPPluggableReg.pas +++ b/Source/BoldAwareGUI/FormGen/BoldAFPPluggableReg.pas @@ -6,13 +6,13 @@ procedure Register; implementation +{$R BoldAFPPluggableReg.res} + uses Classes, BoldAFPPluggable, BoldIDEConsts; -{$R *.res} - procedure Register; begin RegisterComponents(BOLDPAGENAME_MISC, [TBoldPlaceableAFP]); diff --git a/Source/BoldAwareGUI/FormGen/BoldAFPPluggableReg.res b/Source/BoldAwareGUI/FormGen/BoldAFPPluggableReg.res new file mode 100644 index 00000000..24d4660c Binary files /dev/null and b/Source/BoldAwareGUI/FormGen/BoldAFPPluggableReg.res differ diff --git a/Source/BoldAwareGUI/IDE/BoldAwareGuiReg.pas b/Source/BoldAwareGUI/IDE/BoldAwareGuiReg.pas index 9bf8ca99..865c12f4 100644 --- a/Source/BoldAwareGUI/IDE/BoldAwareGuiReg.pas +++ b/Source/BoldAwareGUI/IDE/BoldAwareGuiReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAwareGuiReg; {$UNDEF BOLDCOMCLIENT} @@ -9,29 +12,29 @@ procedure Register; implementation uses - SysUtils, + ActnList, + Actions, Classes, DesignIntf, BoldDefs, BoldAbstractPropertyEditors, BoldPropertyEditors, BoldGridPropertyEditors, -{$IFNDEF BOLDCOMCLIENT} // uses - BoldHandles, // IFNDEF BOLDCOMCLIENT - BoldExceptionHandlers, // IFNDEF BOLDCOMCLIENT - BoldAbstractListHandle, // IFNDEF BOLDCOMCLIENT - BoldComboBoxPropertyEditors, // IFNDEF BOLDCOMCLIENT - BoldControlPackPropertyEditors, // IFNDEF BOLDCOMCLIENT - - BoldMLRenderers, // fixthis // IFNDEF BOLDCOMCLIENT - BoldDataSet, // IFNDEF BOLDCOMCLIENT - BoldDataSetPropertyEditors, // IFNDEF BOLDCOMCLIENT - BoldDragDropTarget, // IFNDEF BOLDCOMCLIENT +{$IFNDEF BOLDCOMCLIENT} + BoldHandles, + BoldExceptionHandlers, + BoldAbstractListHandle, + BoldComboBoxPropertyEditors, + BoldControlPackPropertyEditors, + + BoldMLRenderers, + BoldDragDropTarget, {$ENDIF} BoldPropertiesControllerPropertyEditors, BoldPropertiesController, BoldStringsPropertyController, BoldControlPack, + BoldVariantControlPack, BoldGenericListControlPack, BoldStringControlPack, BoldCheckBoxStateControlPack, @@ -54,59 +57,50 @@ implementation BoldImage, BoldComboBox, BoldPageControl, + BoldAction, BoldIDEConsts; {$R BoldAwareGUIReg.res} procedure RegisterEditors; begin - //TBoldRenderer RegisterPropertyEditor(TypeInfo(TBoldSubscribe), nil, '', TBoldElementSubscribeMethodProperty); RegisterPropertyEditor(TypeInfo(TBoldHoldsChangedValue), nil, '', TBoldHoldsChangedValueMethodProperty); RegisterPropertyEditor(TypeInfo(TBoldReleaseChangedValue), nil, '', TBoldReleaseChangedValueMethodProperty); RegisterPropertyEditor(TypeInfo(TBoldMayModify), nil, '', TBoldMayModifyMethodProperty); - {$IFNDEF BOLDCOMCLIENT} // register editors + {$IFNDEF BOLDCOMCLIENT} + + + RegisterPropertyEditor(TypeInfo(TBoldElementHandle), TPersistent, 'BoldHandle', TBoldComponentPropertyIndicateMissing); + RegisterPropertyEditor(TypeInfo(TBoldAbstractListHandle), TBoldComboBox, 'BoldListHandle', TBoldComponentPropertyIndicateMissing); - // Register property editors - // All properties of type TBoldElementHandle named BoldHandle will be displayed RED if prop not set - RegisterPropertyEditor(TypeInfo(TBoldElementHandle), TPersistent, 'BoldHandle', TBoldComponentPropertyIndicateMissing); // do not localize - RegisterPropertyEditor(TypeInfo(TBoldAbstractListHandle), TBoldComboBox, 'BoldListHandle', TBoldComponentPropertyIndicateMissing); // do not localize + RegisterPropertyEditor(TypeInfo(integer), TBoldFollowerController, 'Representation', TBoldRepresentationProperty); + RegisterPropertyEditor(TypeInfo(TBoldRenderer), TBoldFollowerController, 'Renderer', TBoldRendererComponentProperty); - RegisterPropertyEditor(TypeInfo(integer), TBoldFollowerController, 'Representation', TBoldRepresentationProperty); // do not localize - RegisterPropertyEditor(TypeInfo(TBoldRenderer), TBoldFollowerController, 'Renderer', TBoldRendererComponentProperty); // do not localize - // Note: registering for TPersistent screws up, as all string-properties will get an ellipsis! - // v the below line doesn't work, but is left as a reminder. - // RegisterPropertyEditor(TypeInfo(TBoldExpression), TPersistent, '', TBoldOCLExpressionProperty); - // ^ the above line doesn't work, but is left as a reminder. - RegisterPropertyEditor(TypeInfo(TBoldExpression), TBoldFollowerController, 'Expression', TBoldOCLExpressionForFollowerControllersProperty); // do not localize + + RegisterPropertyEditor(TypeInfo(TBoldExpression), TBoldFollowerController, 'Expression', TBoldOCLExpressionForFollowerControllersProperty); RegisterPropertyEditor(TypeInfo(TBoldSingleFollowerController), nil, '', TBoldSingleFollowerControllerEditor); RegisterPropertyEditor(TypeInfo(TBoldTreeFollowerController), nil, '', TBoldTreeFollowerControllerEditor); - - //TBoldAsStringRenderer RegisterPropertyEditor(TypeInfo(TBoldGetAsString), nil, '', TBoldGetAsStringMethodProperty); - //TBoldAsCheckBoxRenderer RegisterPropertyEditor(TypeInfo(TBoldGetAsCheckBoxState), nil, '', TBoldGetAsCheckBoxStateMethodProperty); - //TBoldAsIntegerRenderer RegisterPropertyEditor(TypeInfo(TBoldGetAsIntegerEvent), nil, '', TBoldGetAsIntegerEventMethodProperty); - //TBoldAsFloatRenderer RegisterPropertyEditor(TypeInfo(TBoldGetAsFloatEvent), nil, '', TBoldGetAsFloatEventMethodProperty); - //TBoldAsViewerRenderer RegisterPropertyEditor(TypeInfo(TBoldGetAsViewer), nil, '', TBoldGetAsViewerMethodProperty); - RegisterPropertyEditor(TypeInfo(String), TBoldNodeDescription, 'ContextTypeName', TBoldTypeNameSelectorPropertyForTreeFollowerController); // do not localize - - RegisterPropertyEditor(TypeInfo(String), TBoldGenericListPart, 'ControllerExpression', TBoldOCLExpressionForGenericListPart); // do not localize - RegisterPropertyEditor(TypeInfo(String), TBoldGenericListPart, 'ElementExpression', TBoldOCLExpressionForGenericListPart); // do not localize + RegisterPropertyEditor(TypeInfo(String), TBoldNodeDescription, 'ContextTypeName', TBoldTypeNameSelectorPropertyForTreeFollowerController); - RegisterPropertyEditor(TypeInfo(String), TBoldComboBox, 'BoldSetValueExpression', TBoldOCLExpressionForComboBoxSetValueExpression); // do not localize - RegisterPropertyEditor(TypeInfo(String), TBoldDropTarget, 'NodeSelectionExpression', TBoldOCLExpressionForOCLComponent); // do not localize + RegisterPropertyEditor(TypeInfo(String), TBoldGenericListPart, 'ControllerExpression', TBoldOCLExpressionForGenericListPart); + RegisterPropertyEditor(TypeInfo(String), TBoldGenericListPart, 'ElementExpression', TBoldOCLExpressionForGenericListPart); - // Register Component editors + RegisterPropertyEditor(TypeInfo(String), TBoldComboBox, 'BoldSetValueExpression', TBoldOCLExpressionForComboBoxSetValueExpression); + RegisterPropertyEditor(TypeInfo(String), TBoldDropTarget, 'NodeSelectionExpression', TBoldOCLExpressionForOCLComponent); + RegisterPropertyEditor(TypeInfo(TBoldGetAsVariant), nil, '', TBoldGetAsVariantMethodProperty); {Renderer editors} + RegisterComponentEditor(TBoldAsVariantRenderer, TBoldAsVariantRendererEditor); RegisterComponentEditor(TBoldAsStringRenderer, TBoldAsStringRendererEditor); RegisterComponentEditor(TBoldAsCheckboxStateRenderer, TBoldAsCheckboxStateRendererEditor); RegisterComponentEditor(TBoldAsIntegerRenderer, TBoldAsIntegerRendererEditor); @@ -126,25 +120,21 @@ procedure RegisterEditors; {$ENDIF} RegisterComponentEditor(TBoldCustomGrid, TBoldColumnsEditor); RegisterComponentEditor(TBoldPropertiesController,TBoldPropertiesControllerComponentEditor); - RegisterPropertyEditor(TypeInfo(String), TBoldDrivenProperty, 'PropertyName', TPropertyNameProperty); // do not localize - RegisterPropertyEditor(TypeInfo(TComponent), TBoldDrivenProperty, 'VCLComponent', TVCLComponentProperty); // do not localize -{$IFNDEF BOLDCOMCLIENT} // registerEditors - RegisterComponentEditor(TBoldAbstractDataset, TBoldDataSetEditor); -{$ENDIF} + RegisterPropertyEditor(TypeInfo(String), TBoldDrivenProperty, 'PropertyName', TPropertyNameProperty); + RegisterPropertyEditor(TypeInfo(TComponent), TBoldDrivenProperty, 'VCLComponent', TVCLComponentProperty); end; procedure RegisterComponentsOnPalette; begin -{$IFNDEF BOLDCOMCLIENT} // RegisterComponents +{$IFNDEF BOLDCOMCLIENT} RegisterComponents(BOLDPAGENAME_MISC, [ - TBoldDataSet, TBoldExceptionHandler ]); {$ENDIF} -{$IFDEF BOLDCOMCLIENT} // RegisterComponents - RegisterComponents(BOLDPAGENAME_COMCONTROLS, +{$IFDEF BOLDCOMCLIENT} + RegisterComponents('Bold COM Controls', {$ELSE} RegisterComponents(BOLDPAGENAME_CONTROLS, {$ENDIF} @@ -167,12 +157,12 @@ procedure RegisterComponentsOnPalette; TBoldImage, TBoldPropertiesController, TBoldStringsPropertyController, - //Renderers TBoldAsStringRenderer, TBoldAsCheckboxStateRenderer, TBoldAsIntegerRenderer, + TBoldAsVariantRenderer, TBoldAsFloatRenderer, - {$IFNDEF BOLDCOMCLIENT} // Register Components + {$IFNDEF BOLDCOMCLIENT} TBoldAsMLStringRenderer, TBoldDropTarget, {$ENDIF} @@ -180,10 +170,20 @@ procedure RegisterComponentsOnPalette; ]); end; +procedure RegisterActionsInDelphi; +begin + RegisterActions(BOLDACTIONGROUPNAME, + [ + TBoldAction + ], nil); +end; + + procedure Register; begin - RegisterComponentsOnPalette; + RegisterComponentsOnPalette; RegisterEditors; + RegisterActionsInDelphi; end; end. diff --git a/Source/BoldAwareGUI/IDE/BoldAwareGuiReg.res b/Source/BoldAwareGUI/IDE/BoldAwareGuiReg.res new file mode 100644 index 00000000..a5890c78 Binary files /dev/null and b/Source/BoldAwareGUI/IDE/BoldAwareGuiReg.res differ diff --git a/Source/BoldAwareGUI/IDE/BoldComboBoxPropertyEditors.pas b/Source/BoldAwareGUI/IDE/BoldComboBoxPropertyEditors.pas index bd44a13e..6f0c44f5 100644 --- a/Source/BoldAwareGUI/IDE/BoldComboBoxPropertyEditors.pas +++ b/Source/BoldAwareGUI/IDE/BoldComboBoxPropertyEditors.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComboBoxPropertyEditors; interface @@ -17,7 +20,6 @@ implementation uses SysUtils, - BoldGuiResourceStrings, BoldDefs, BoldComboBox; @@ -32,7 +34,7 @@ function TBoldOCLExpressionForComboBoxSetValueExpression.GetContextType( else Result := nil else - raise EBold.CreateFmt(sComponentNotComboBox, [ClassName]); + raise EBold.CreateFmt('%s.GetContextType: Incoming component is not a BoldComboBox', [ClassName]); end; end. diff --git a/Source/BoldAwareGUI/IDE/BoldControlPackPropertyEditors.pas b/Source/BoldAwareGUI/IDE/BoldControlPackPropertyEditors.pas index 6252d8c1..7bb2d366 100644 --- a/Source/BoldAwareGUI/IDE/BoldControlPackPropertyEditors.pas +++ b/Source/BoldAwareGUI/IDE/BoldControlPackPropertyEditors.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldControlPackPropertyEditors; interface @@ -37,12 +40,12 @@ TBoldTypeNameSelectorPropertyForTreeFollowerController = class(TBoldTypeNameSe function GetApprovedTypes: TBoldValueTypes; override; function GetContextType(Component: TPersistent): TBoldSystemTypeInfo; override; public - //procedure Edit; override; end; {---TBoldSingleFollowerControllerEditor---} TBoldSingleFollowerControllerEditor = class(TBoldClassProperty) public + function GetValue: string; override; function GetAttributes: TPropertyAttributes; override; procedure Edit; override; end; @@ -97,7 +100,7 @@ TBoldAsCheckBoxStateRendererEditor = class(TBoldComponentDblClickEditor) {---TBoldGetAsStringMethodProperty---} TBoldGetAsStringMethodProperty = class(TBoldOTAModifyingMethodProperty) public - function TextToInsert: string; override; + function ImplementationTextToInsert: string; override; function GetDeltaLines: integer; override; function GetColPos: integer; override; end; @@ -105,7 +108,7 @@ TBoldGetAsStringMethodProperty = class(TBoldOTAModifyingMethodProperty) {---TBoldGetAsCheckBoxStateMethodProperty---} TBoldGetAsCheckBoxStateMethodProperty = class(TBoldOTAModifyingMethodProperty) public - function TextToInsert: string; override; + function ImplementationTextToInsert: string; override; function GetDeltaLines: integer; override; function GetColPos: integer; override; end; @@ -113,7 +116,7 @@ TBoldGetAsCheckBoxStateMethodProperty = class(TBoldOTAModifyingMethodProperty) {---TBoldGetAsIntegerEventMethodProperty---} TBoldGetAsIntegerEventMethodProperty = class(TBoldOTAModifyingMethodProperty) public - function TextToInsert: string; override; + function ImplementationTextToInsert: string; override; function GetDeltaLines: integer; override; function GetColPos: integer; override; end; @@ -121,7 +124,7 @@ TBoldGetAsIntegerEventMethodProperty = class(TBoldOTAModifyingMethodProperty) {---TBoldGetAsFloatEventMethodProperty---} TBoldGetAsFloatEventMethodProperty = class(TBoldOTAModifyingMethodProperty) public - function TextToInsert: string; override; + function ImplementationTextToInsert: string; override; function GetDeltaLines: integer; override; function GetColPos: integer; override; end; @@ -129,7 +132,7 @@ TBoldGetAsFloatEventMethodProperty = class(TBoldOTAModifyingMethodProperty) {---TBoldGetAsViewerMethodProperty---} TBoldGetAsViewerMethodProperty = class(TBoldOTAModifyingMethodProperty) public - function TextToInsert: string; override; + function ImplementationTextToInsert: string; override; function GetDeltaLines: integer; override; function GetColPos: integer; override; end; @@ -137,22 +140,36 @@ TBoldGetAsViewerMethodProperty = class(TBoldOTAModifyingMethodProperty) { TBoldHoldsChangedValueMethodProperty } TBoldHoldsChangedValueMethodProperty = class(TBoldOneLinerWithEvalMethodProperty) public - function TextToInsert: string; override; + function ImplementationTextToInsert: string; override; end; { TBoldReleaseChangedValueMethodProperty } TBoldReleaseChangedValueMethodProperty = class(TBoldOneLinerWithEvalMethodProperty) public - function TextToInsert: string; override; + function ImplementationTextToInsert: string; override; end; { TBoldMayModifyMethodProperty } TBoldMayModifyMethodProperty = class(TBoldOneLinerWithEvalMethodProperty) public - function TextToInsert: string; override; + function ImplementationTextToInsert: string; override; function GetDeltaLines: integer; override; end; + {---TBoldAsVariantRendererEditor---} + TBoldAsVariantRendererEditor = class(TBoldComponentDblClickEditor) + protected + function GetDefaultMethodName: string; override; + end; + + {---TBoldGetAsVariantMethodProperty---} + TBoldGetAsVariantMethodProperty = class(TBoldOTAModifyingMethodProperty) + public + function ImplementationTextToInsert: string; override; + function GetDeltaLines: integer; override; + function GetColPos: integer; override; + end; + implementation uses @@ -160,7 +177,6 @@ implementation BoldUtils, TypInfo, Controls, - BoldGuiResourceStrings, BoldControlPack, BoldTreeView, BoldDefs, @@ -179,6 +195,21 @@ function TBoldSingleFollowerControllerEditor.GetAttributes: TPropertyAttributes; Result := inherited GetAttributes + [paDialog] - [paMultiSelect]; end; +function TBoldSingleFollowerControllerEditor.GetValue: string; +var + P: TPersistent; +begin + p := TPersistent(GetOrdValue); + if Assigned(P) and (P is TBoldFollowerController) then + begin + Result := TBoldFollowerControllerHack(P).Expression; + if Result = '' then + Result := '('+TBoldFollowerControllerHack(P).EffectiveRenderer.Name+')'; + end + else + Result := inherited GetValue; +end; + procedure TBoldSingleFollowerControllerEditor.Edit; var FollowerController: TBoldSingleFollowerController; @@ -206,31 +237,31 @@ procedure TBoldSingleFollowerControllerEditor.Edit; {---TBoldAsStringRendererEditor---} function TBoldAsStringRendererEditor.GetDefaultMethodName: string; begin - Result := 'OnGetAsString'; // do not localize + Result := 'OnGetAsString'; end; {---TBoldAsIntegerRendererEditor---} function TBoldAsIntegerRendererEditor.GetDefaultMethodName: string; begin - Result := 'OnGetAsInteger'; // do not localize + Result := 'OnGetAsInteger'; end; {---TBoldAsCheckBoxStateRendererEditor---} function TBoldAsCheckBoxStateRendererEditor.GetDefaultMethodName: string; begin - Result := 'OnGetAsCheckBoxState';// do not localize + Result := 'OnGetAsCheckBoxState'; end; {---TBoldGetAsStringMethodProperty---} -function TBoldGetAsStringMethodProperty.TextToInsert: string; +function TBoldGetAsStringMethodProperty.ImplementationTextToInsert: string; begin Result := ''; {$IFDEF BOLD_DELPHI} - Result := ' Result := '''';' + BOLDCRLF; // do not localize + Result := ' Result := '''';' + BOLDCRLF; {$ENDIF} - Result := Result + Format(' if %s(Element) %s', [BOLDSYM_ASSIGNED, BOLDSYM_THEN]) + BOLDCRLF; // do not localize - Result := Result + Format(' %s', [BOLDSYM_BEGIN]) + BOLDCRLF + BOLDCRLF; // do not localize - Result := Result + Format(' %s', [BOLDSYM_END]); // do not localize + Result := Result + Format(' if %s(AFollower.Element) %s', [BOLDSYM_ASSIGNED, BOLDSYM_THEN]) + BOLDCRLF; + Result := Result + Format(' %s', [BOLDSYM_BEGIN]) + BOLDCRLF + BOLDCRLF; + Result := Result + Format(' %s', [BOLDSYM_END]); end; function TBoldGetAsStringMethodProperty.GetDeltaLines: integer; @@ -244,13 +275,13 @@ function TBoldGetAsStringMethodProperty.GetColPos: integer; end; {---TBoldGetAsCheckBoxStateMethodProperty---} -function TBoldGetAsCheckBoxStateMethodProperty.TextToInsert: string; +function TBoldGetAsCheckBoxStateMethodProperty.ImplementationTextToInsert: string; begin Result := ''; {$IFDEF BOLD_DELPHI} - Result := ' Result := cbGrayed;' + BOLDCRLF; // do not localize + Result := ' Result := cbGrayed;' + BOLDCRLF; {$ENDIF} - Result := Result + Format(' if %s(Element) %s', [BOLDSYM_ASSIGNED, BOLDSYM_THEN]) + BOLDCRLF; // do not localize + Result := Result + Format(' if %s(AFollower.Element) %s', [BOLDSYM_ASSIGNED, BOLDSYM_THEN]) + BOLDCRLF; Result := Result + Format(' %s', [BOLDSYM_BEGIN]) + BOLDCRLF + BOLDCRLF; Result := Result + Format(' %s', [BOLDSYM_END]); end; @@ -266,13 +297,13 @@ function TBoldGetAsCheckBoxStateMethodProperty.GetColPos: integer; end; {---TBoldGetAsIntegerEventMethodProperty---} -function TBoldGetAsIntegerEventMethodProperty.TextToInsert: string; +function TBoldGetAsIntegerEventMethodProperty.ImplementationTextToInsert: string; begin Result := ''; {$IFDEF BOLD_DELPHI} - Result := ' Result := 0;' + BOLDCRLF; // do not localize + Result := ' Result := 0;' + BOLDCRLF; {$ENDIF} - Result := Result + Format(' if %s(Element) %s', [BOLDSYM_ASSIGNED, BOLDSYM_THEN]) + BOLDCRLF; // do not localize + Result := Result + Format(' if %s(AFollower.Element) %s', [BOLDSYM_ASSIGNED, BOLDSYM_THEN]) + BOLDCRLF; Result := Result + Format(' %s', [BOLDSYM_BEGIN]) + BOLDCRLF + BOLDCRLF; Result := Result + Format(' %s', [BOLDSYM_END]); end; @@ -289,23 +320,23 @@ function TBoldGetAsIntegerEventMethodProperty.GetColPos: integer; {--- TBoldHoldsChangedValueMethodProperty ---} -function TBoldHoldsChangedValueMethodProperty.TextToInsert: string; +function TBoldHoldsChangedValueMethodProperty.ImplementationTextToInsert: string; begin - result := Format(' Element%sEvaluateExpressionAsDirectElement(%s%s).RegisterModifiedValueHolder(Subscriber);', // do not localize + result := Format(' AFollower.Element%sEvaluateExpressionAsDirectElement(%s%s).RegisterModifiedValueHolder(AFollower.Subscriber);', [BOLDSYM_POINTERDEREFERENCE, BOLDSYM_QUOTECHAR, BOLDSYM_QUOTECHAR]); end; {--- TBoldReleaseChangedValueMethodProperty ---} -function TBoldReleaseChangedValueMethodProperty.TextToInsert: string; +function TBoldReleaseChangedValueMethodProperty.ImplementationTextToInsert: string; begin - result := Format(' Element%sEvaluateExpressionAsDirectElement(%s%s).UnRegisterModifiedValueHolder(Subscriber);', // do not localize + result := Format(' AFollower.Element%sEvaluateExpressionAsDirectElement(%s%s).UnRegisterModifiedValueHolder(AFollower.Subscriber);', [BOLDSYM_POINTERDEREFERENCE, BOLDSYM_QUOTECHAR, BOLDSYM_QUOTECHAR]); end; -function TBoldMayModifyMethodProperty.TextToInsert: string; +function TBoldMayModifyMethodProperty.ImplementationTextToInsert: string; begin - result := Format(' %sresult %s Element%sEvaluateExpressionAsDirectElement(%s%s).ObserverMayModify(subscriber);', // do not localize + result := Format(' %sresult %s AFollower.Element%sEvaluateExpressionAsDirectElement(%s%s).ObserverMayModify(AFollower.subscriber);', [BOLDSYM_TYPEINTEGER, BOLDSYM_ASSIGNMENT, BOLDSYM_POINTERDEREFERENCE, BOLDSYM_QUOTECHAR, BOLDSYM_QUOTECHAR]); Result := Result + BOLDSYM_RETURNRESULT; end; @@ -316,13 +347,13 @@ function TBoldMayModifyMethodProperty.GetDeltaLines: integer; end; {---TBoldGetAsViewerMethodProperty---} -function TBoldGetAsViewerMethodProperty.TextToInsert: string; +function TBoldGetAsViewerMethodProperty.ImplementationTextToInsert: string; begin Result := ''; {$IFDEF BOLD_DELPHI} - Result := ' Result := nil;' + BOLDCRLF; // do not localize + Result := ' Result := nil;' + BOLDCRLF; {$ENDIF} - Result := Result + Format(' if %s(Element) %s', [BOLDSYM_ASSIGNED, BOLDSYM_THEN]) + BOLDCRLF; // do not localize + Result := Result + Format(' if %s(AFollower.Element) %s', [BOLDSYM_ASSIGNED, BOLDSYM_THEN]) + BOLDCRLF; Result := Result + Format(' %s', [BOLDSYM_BEGIN]) + BOLDCRLF + BOLDCRLF; Result := Result + Format(' %s', [BOLDSYM_END]); end; @@ -367,7 +398,7 @@ function TBoldRepresentationProperty.GetValue: string; I := GetOrdValue; S := IntToStr(I); with TBoldFollowerControllerHack(P).EffectiveRenderer do - if Representations.Values[S] <> '' then + if Representations.Values[S]<>'' then Result := Format('%d=%s', [I, Representations.Values[S]]) else Result := inherited GetValue; @@ -391,13 +422,13 @@ procedure TBoldRepresentationProperty.SetValue(const value: string); function TBoldRendererComponentProperty.GetValue: string; begin Result := Designer.GetComponentName(TComponent(GetOrdValue)); - if (Result = '') then - Result := '(default)'; // do not localize + if (Result='') then + Result := '(default)'; end; procedure TBoldRendererComponentProperty.GetValues(Proc: TGetStrProc); begin - Proc('(default)'); // do not localize + Proc('(default)'); Designer.GetComponentNames(GetTypeData(GetPropType), Proc); end; @@ -405,13 +436,13 @@ procedure TBoldRendererComponentProperty.SetValue(const Value: string); var Component: TComponent; begin - if (Value = '') or (Value[1] = '(') then + if (Value = '') or (Value[1]='(') then Component := nil else begin Component := Designer.GetComponent(Value); if not (Component is GetTypeData(GetPropType)^.ClassType) then - raise EPropertyError.Create(sInvalidPropertyValue); + raise EPropertyError.Create('Invalid property value'); end; SetOrdValue(Longint(Component)); end; @@ -429,7 +460,7 @@ procedure TBoldNodeDescriptionEditor.ExecuteVerb(Index: Integer); function TBoldNodeDescriptionEditor.GetVerb(Index: Integer): string; begin - Result := sEditNodeDescriptions; + Result := '&Edit Node Descriptions...'; end; function TBoldNodeDescriptionEditor.GetVerbCount: Integer; @@ -483,7 +514,7 @@ function TBoldTypeNameSelectorPropertyForTreeFollowerController.GetContextType( function TBoldAsFloatRendererEditor.GetDefaultMethodName: string; begin - Result := 'OnGetAsFloat'; // do not localize + Result := 'OnGetAsFloat'; end; { TBoldGetAsFloatEventMethodProperty } @@ -498,13 +529,13 @@ function TBoldGetAsFloatEventMethodProperty.GetDeltaLines: integer; Result := -1; end; -function TBoldGetAsFloatEventMethodProperty.TextToInsert: string; +function TBoldGetAsFloatEventMethodProperty.ImplementationTextToInsert: string; begin Result := ''; {$IFDEF BOLD_DELPHI} - Result := ' Result := 0;' + BOLDCRLF; // do not localize + Result := ' Result := 0;' + BOLDCRLF; {$ENDIF} - Result := Result + Format(' if %s(Element) %s', [BOLDSYM_ASSIGNED, BOLDSYM_THEN]) + BOLDCRLF; // do not localize + Result := Result + Format(' if %s(AFollower.Element) %s', [BOLDSYM_ASSIGNED, BOLDSYM_THEN]) + BOLDCRLF; Result := Result + Format(' %s', [BOLDSYM_BEGIN]) + BOLDCRLF + BOLDCRLF; Result := Result + Format(' %s', [BOLDSYM_END]); end; @@ -523,7 +554,7 @@ procedure TBoldTreeFollowerControllerEditor.Edit; Designer.Modified; end else - raise EPropertyError.Create(sInvalidPropertyValue); + raise EPropertyError.Create('Invalid property value'); end; function TBoldTreeFollowerControllerEditor.GetAttributes: TPropertyAttributes; @@ -531,4 +562,36 @@ function TBoldTreeFollowerControllerEditor.GetAttributes: TPropertyAttributes; Result := inherited GetAttributes + [paDialog] - [paMultiSelect]; end; +{ TBoldAsVariantRendererEditor } + +function TBoldAsVariantRendererEditor.GetDefaultMethodName: string; +begin + Result := 'OnGetAsVariant'; // do not localize +end; + +{ TBoldGetAsVariantMethodProperty } + +function TBoldGetAsVariantMethodProperty.GetColPos: integer; +begin + Result := 5; +end; + +function TBoldGetAsVariantMethodProperty.GetDeltaLines: integer; +begin + Result := -1; +end; + +function TBoldGetAsVariantMethodProperty.ImplementationTextToInsert: string; +begin + Result := ''; +{$IFDEF BOLD_DELPHI} + Result := ' Result := Null;' + BOLDCRLF; // do not localize +{$ENDIF} + Result := Result + Format(' if %s(AFollower.Element) %s', [BOLDSYM_ASSIGNED, BOLDSYM_THEN]) + BOLDCRLF; // do not localize + Result := Result + Format(' %s', [BOLDSYM_BEGIN]) + BOLDCRLF + BOLDCRLF; // do not localize + Result := Result + Format(' %s', [BOLDSYM_END]); // do not localize +end; + +initialization + end. diff --git a/Source/BoldAwareGUI/IDE/BoldDataSetPropertyEditors.pas b/Source/BoldAwareGUI/IDE/BoldDataSetPropertyEditors.pas deleted file mode 100644 index b3edb4e9..00000000 --- a/Source/BoldAwareGUI/IDE/BoldDataSetPropertyEditors.pas +++ /dev/null @@ -1,96 +0,0 @@ -unit BoldDataSetPropertyEditors; - -interface - -uses - DesignEditors, - DesignIntf; - -type - { forward declarations } - TBoldDataSetEditor = class; - - { TBoldDataSetEditor } - TBoldDataSetEditor = class(TComponentEditor) - private - procedure GetPropEditProc(const Prop: IProperty); - protected - procedure EditFields; - procedure ClearFields; - procedure CreateDefaultFields; - public - procedure ExecuteVerb(Index: Integer); override; - function GetVerb(Index: Integer): string; override; - function GetVerbCount: Integer; override; - end; - -implementation - -uses - BoldGuiResourceStrings, - BoldDataset, - TypInfo; - -type - TBoldExposedAbstractDataSet = class(TBoldAbstractDataset); - -{ TBoldDataSetEditor } - -procedure TBoldDataSetEditor.CreateDefaultFields; -begin - if Component is TBoldAbstractDataSet and - Assigned(TBoldExposedAbstractDataSet(Component).BoldHandle) then - with TBoldAbstractDataSet(Component) do - CreateDefaultFields; -end; - -procedure TBoldDataSetEditor.ClearFields; -begin - if Component is TBoldAbstractDataSet then - with TBoldExposedAbstractDataSet(Component) do - DeleteAllFields; -end; - -procedure TBoldDataSetEditor.ExecuteVerb(Index: Integer); -begin - case Index of - 0: EditFields; - 1: CreateDefaultFields; - 2: ClearFields; - end; -end; - -function TBoldDataSetEditor.GetVerb(Index: Integer): string; -begin - case Index of - 0: Result := sFieldsEditor; - 1: Result := sCreateDefaultFields; - 2: Result := sClearAllFields; - end; -end; - -function TBoldDataSetEditor.GetVerbCount: Integer; -begin - Result := 3; -end; - -procedure TBoldDataSetEditor.EditFields; -var - Components: IDesignerSelections; -begin - Components := TDesignerSelections.Create; - Components.Add(Component); - - GetComponentProperties(Components, - [tkClass], - Designer, - GetPropEditProc, nil); -end; - -procedure TBoldDataSetEditor.GetPropEditProc(const Prop: IProperty); -begin - if Prop.GetName = 'FieldDescriptions' then // do not localize - Prop.Edit; -end; - -end. diff --git a/Source/BoldAwareGUI/IDE/BoldGridPropertyEditors.pas b/Source/BoldAwareGUI/IDE/BoldGridPropertyEditors.pas index 6f099e88..b76179e8 100644 --- a/Source/BoldAwareGUI/IDE/BoldGridPropertyEditors.pas +++ b/Source/BoldAwareGUI/IDE/BoldGridPropertyEditors.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldGridPropertyEditors; {$UNDEF BOLDCOMCLIENT} @@ -28,7 +31,6 @@ TBoldColumnsEditor = class(TComponentEditor) implementation uses - BoldGuiResourceStrings, SysUtils, BoldGrid, TypInfo; @@ -39,7 +41,7 @@ TBoldExposedCustomGrid = class(TBoldCustomGrid); {---TBoldColumnsEditor---} procedure TBoldColumnsEditor.EditPropertyColumns(const PropertyEditor: IProperty); begin - if AnsiSameText(PropertyEditor.GetName, 'Columns') then // do not localize + if SameText(PropertyEditor.GetName, 'Columns') then PropertyEditor.Edit; end; @@ -74,7 +76,6 @@ procedure TBoldColumnsEditor.EmptyColumns; begin DeleteAllColumns; AddColumn; - // This is done because the grid screws up the column widths AddColumn; Columns[1].Free; end; @@ -92,9 +93,9 @@ procedure TBoldColumnsEditor.ExecuteVerb(Index: Integer); function TBoldColumnsEditor.GetVerb(Index: Integer): string; begin case index of - 0: Result := sEditColumns; - 1: Result := sCreateDefaultColumns; - 2: Result := sClearAllColumns; + 0: Result := '&Edit Columns'; + 1: Result := 'Create Default Columns'; + 2: Result := 'Clear all Columns'; end; end; @@ -103,4 +104,5 @@ function TBoldColumnsEditor.GetVerbCount: Integer; Result := 3; end; + end. diff --git a/Source/BoldAwareGUI/IDE/BoldNodeDescriptionEditor.pas b/Source/BoldAwareGUI/IDE/BoldNodeDescriptionEditor.pas index 7aa48b78..cd541468 100644 --- a/Source/BoldAwareGUI/IDE/BoldNodeDescriptionEditor.pas +++ b/Source/BoldAwareGUI/IDE/BoldNodeDescriptionEditor.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldNodeDescriptionEditor; interface @@ -14,13 +17,11 @@ interface DesignEditors, DesignIntf, BoldNodeControlPack, -// BoldTreeView, Menus, BoldSubscription, ImgList; type -// TBoldCustomTreeViewHack = class(TBoldCustomTreeView) -// end; + TFormNodeEditor = class(TForm) TreeView: TTreeView; @@ -74,7 +75,6 @@ implementation uses SysUtils, - BoldGuiResourceStrings, BoldDefs, BoldControlPack, BoldGenericListControlPack; @@ -225,7 +225,6 @@ procedure TFormNodeEditor.UpdateTree; end; begin - //Init list pointer to first node CurrentNode := TreeView.items.GetFirstNode; Inc(FUpdateCount); @@ -256,7 +255,7 @@ procedure TFormNodeEditor.UpdateTree; end; end; PurgeEnd; - RootNode.Expand(False); //CHANGED + RootNode.Expand(False); finally Dec(FUpdateCount); end; @@ -284,7 +283,7 @@ procedure TFormNodeEditor.UpdateNode(Node: TTreeNode); {Add subscrption} if TObject(Node.Data) is TBoldFollowerController then begin - TBoldFollowerController(Node.Data).AddSmallSubscription(FSubscriber, [beDestroying, beValueChanged], breReEvaluate); //CHANGED + TBoldFollowerController(Node.Data).AddSmallSubscription(FSubscriber, [beDestroying, beValueChanged], breReEvaluate); end; {Update caption and icon} if TObject(Node.Data) is TComponent then @@ -294,7 +293,7 @@ procedure TFormNodeEditor.UpdateNode(Node: TTreeNode); else if TObject(Node.Data) is TBoldTreeFollowerController then begin TBoldTreeFollowerController(Node.Data).AddSmallSubscription(FSubscriber, [beDestroying, beValueChanged], breReEvaluate); - SetTextAndImage( 'Root', 8); // do not localize + SetTextAndImage( 'Root', 8); end else if TObject(Node.Data) is TBoldNodeDescription then begin @@ -313,7 +312,7 @@ procedure TFormNodeEditor.UpdateNode(Node: TTreeNode); ImageIndex := 2 else ImageIndex := 4; - SetTextAndImage(Format('Parts[%d] Element: ''%s'' Controller: ''%s''', [Index, ElementExpression, ControllerExpression]), ImageIndex); // do not localize + SetTextAndImage(Format('Parts[%d] Element: ''%s'' Controller: ''%s''', [Index, ElementExpression, ControllerExpression]), ImageIndex); end; end else @@ -488,4 +487,6 @@ procedure TFormNodeEditor.cmdSortClick(Sender: TObject); UpdateTree; end; +initialization + end. diff --git a/Source/BoldAwareGUI/IDE/BoldPropertiesControllerPropertyEditors.pas b/Source/BoldAwareGUI/IDE/BoldPropertiesControllerPropertyEditors.pas index 9499dd24..c9295f64 100644 --- a/Source/BoldAwareGUI/IDE/BoldPropertiesControllerPropertyEditors.pas +++ b/Source/BoldAwareGUI/IDE/BoldPropertiesControllerPropertyEditors.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPropertiesControllerPropertyEditors; interface @@ -5,31 +8,25 @@ interface uses Classes, DesignEditors, - DesignIntf, + DesignIntf, BoldAbstractPropertyEditors; type - // A Property editor for the PropertyName property. - // It lists all meaningful properties of "Component" including properties of "sub-components" - // It has currently some trouble with collections and will not show panels[0] for example - { TPropertyNameProperty } + + TPropertyNameProperty = class(TBoldStringProperty) public function GetAttributes: TPropertyAttributes; override; procedure GetValues(Proc: TGetStrProc); override; end; - // A Property editor for VCLComponent property - // It is based on the TComponentProperty which lists all components of the form - // In addition to those it will also list the form so we can control its properties ! - { TVCLComponentProperty } + TVCLComponentProperty = class(TBoldComponentProperty) public procedure GetValues(Proc: TGetStrProc); override; procedure SetValue(const Value: string); override; end; - { TBoldPropertiesControllerComponentEditor } TBoldPropertiesControllerComponentEditor = class(TDefaultEditor) protected procedure EditProperty(const PropertyEditor: IProperty; var Continue: Boolean); override; @@ -43,7 +40,6 @@ implementation uses SysUtils, - BoldGuiResourceStrings, TypInfo, BoldControlsDefs, BoldPropertiesController; @@ -72,9 +68,9 @@ procedure TPropertyNameProperty.GetValues(Proc: TGetStrProc); for I := 0 to Count - 1 do begin if Path = '' then - NewPath := PropList[I]^.Name + NewPath := String(PropList[I]^.Name) else - NewPath := Path + '.' + PropList[I]^.Name; + NewPath := Path + '.' + String(PropList[I]^.Name); if (PropList[I]^.PropType^.Kind <> tkClass) then begin @@ -84,7 +80,7 @@ procedure TPropertyNameProperty.GetValues(Proc: TGetStrProc); else begin if Assigned(LastObject) then - NewObj := TObject(GetOrdProp(LastObject, PropList[I]^.Name)); + NewObj := TObject(GetOrdProp(LastObject, String(PropList[I]^.Name))); if NewObj is TCollection then for J := 0 to TCollection(NewObj).Count - 1 do @@ -102,7 +98,7 @@ procedure TPropertyNameProperty.GetValues(Proc: TGetStrProc); begin if PropCount < 1 then exit; - SelectedComponent := GetComponent(0) as TBoldDrivenProperty; //we don't allow multiselect + SelectedComponent := GetComponent(0) as TBoldDrivenProperty; if Assigned(SelectedComponent) and Assigned(SelectedComponent.VCLComponent) then DeclareProperties(SelectedComponent.VCLComponent,SelectedComponent.VCLComponent.ClassInfo,''); end; @@ -111,7 +107,7 @@ procedure TPropertyNameProperty.GetValues(Proc: TGetStrProc); procedure TVCLComponentProperty.GetValues(Proc: TGetStrProc); begin - Proc(TBoldDrivenProperty(GetComponent(0)).PropertiesController.Owner.Name); // Add the Form's name to available components + Proc(TBoldDrivenProperty(GetComponent(0)).PropertiesController.Owner.Name); inherited; end; @@ -119,7 +115,6 @@ procedure TVCLComponentProperty.SetValue(const Value: string); var Component: TComponent; begin - // Special case for the form if Value = TBoldDrivenProperty(GetComponent(0)).PropertiesController.Owner.Name then begin Component := TBoldDrivenProperty(GetComponent(0)).PropertiesController.Owner; @@ -133,7 +128,7 @@ procedure TVCLComponentProperty.SetValue(const Value: string); procedure TBoldPropertiesControllerComponentEditor.EditProperty(const PropertyEditor: IProperty; var Continue: Boolean); begin - if PropertyEditor.GetName = 'DrivenProperties' then //do not localize + if PropertyEditor.GetName = 'DrivenProperties' then begin PropertyEditor.Edit; Continue := False; @@ -151,7 +146,7 @@ procedure TBoldPropertiesControllerComponentEditor.ExecuteVerb(Index: Integer); function TBoldPropertiesControllerComponentEditor.GetVerb(Index: Integer): string; begin case Index of - 0: Result := sEditDrivenProperties; + 0: Result := 'Edit driven properties...'; end; end; diff --git a/Source/BoldQAwareGUI/BoldControls/BoldQEdit.pas b/Source/BoldQAwareGUI/BoldControls/BoldQEdit.pas index 5665b1f5..e73298c9 100644 --- a/Source/BoldQAwareGUI/BoldControls/BoldQEdit.pas +++ b/Source/BoldQAwareGUI/BoldControls/BoldQEdit.pas @@ -132,6 +132,7 @@ TBoldCustomEdit = class(TCustomEdit, IBoldOCLComponent) end; {---TBoldEdit---} + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldEdit = class(TBoldCustomEdit) public {$IFNDEF T2H} @@ -205,7 +206,6 @@ implementation uses SysUtils, - BoldRev, BoldUtils; { TBoldComboButton } diff --git a/Source/BoldQAwareGUI/BoldControls/BoldQLabel.pas b/Source/BoldQAwareGUI/BoldControls/BoldQLabel.pas index 4b5745eb..99b5f8b0 100644 --- a/Source/BoldQAwareGUI/BoldControls/BoldQLabel.pas +++ b/Source/BoldQAwareGUI/BoldControls/BoldQLabel.pas @@ -67,6 +67,7 @@ TBoldCustomLabel = class(TCustomLabel, IBoldOCLComponent) end; { TBoldLabel } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldLabel = class(TBoldCustomLabel) public {$IFNDEF T2H} @@ -116,7 +117,6 @@ implementation uses SysUtils, - BoldRev, BoldUtils; type @@ -278,6 +278,5 @@ function TBoldCustomLabel.GetVariableList: TBoldExternalVariableList; result := BoldProperties.VariableList; end; -initialization end. diff --git a/Source/BoldQAwareGUI/ControlPacks/BoldQControlPack.pas b/Source/BoldQAwareGUI/ControlPacks/BoldQControlPack.pas index e217d3c4..1fecac24 100644 --- a/Source/BoldQAwareGUI/ControlPacks/BoldQControlPack.pas +++ b/Source/BoldQAwareGUI/ControlPacks/BoldQControlPack.pas @@ -342,7 +342,6 @@ function BoldTestType(element: TObject; TypeOrInterface: TClass): Boolean; implementation uses - BoldRev, BoldUtils, BoldExceptionHandlers, {$IFNDEF BOLDCOMCLIENT} // uses diff --git a/Source/BoldQAwareGUI/ControlPacks/BoldQElementHandleFollower.pas b/Source/BoldQAwareGUI/ControlPacks/BoldQElementHandleFollower.pas index 48d9cf06..467e8574 100644 --- a/Source/BoldQAwareGUI/ControlPacks/BoldQElementHandleFollower.pas +++ b/Source/BoldQAwareGUI/ControlPacks/BoldQElementHandleFollower.pas @@ -46,7 +46,6 @@ implementation uses SysUtils, - BoldRev, BoldUtils, BoldDefs; @@ -146,6 +145,5 @@ procedure TBoldElementHandleFollower.SetFollowerValueCurrent(value: Boolean); end; -initialization end. diff --git a/Source/BoldQAwareGUI/ControlPacks/BoldQStringControlPack.pas b/Source/BoldQAwareGUI/ControlPacks/BoldQStringControlPack.pas index 89583d46..22136df2 100644 --- a/Source/BoldQAwareGUI/ControlPacks/BoldQStringControlPack.pas +++ b/Source/BoldQAwareGUI/ControlPacks/BoldQStringControlPack.pas @@ -48,6 +48,7 @@ TBoldStringRendererData = class(TBoldRendererData) end; { TBoldAsStringRenderer } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldAsStringRenderer = class(TBoldSingleRenderer) private FOnGetAsString: TBoldGetAsString; @@ -122,7 +123,6 @@ implementation uses SysUtils, - BoldRev, BoldUtils; var diff --git a/Source/BoldQAwareGUI/Core/BoldQGUI.pas b/Source/BoldQAwareGUI/Core/BoldQGUI.pas index ca42b3f2..712ca9de 100644 --- a/Source/BoldQAwareGUI/Core/BoldQGUI.pas +++ b/Source/BoldQAwareGUI/Core/BoldQGUI.pas @@ -46,7 +46,6 @@ implementation uses SysUtils, - BoldRev, BoldUtils, BoldSystemRT; diff --git a/Source/ClientGuiCom/BoldControls/BoldAwareGuiComReg.rc b/Source/ClientGuiCom/BoldControls/BoldAwareGuiComReg.rc new file mode 100644 index 00000000..88b657da --- /dev/null +++ b/Source/ClientGuiCom/BoldControls/BoldAwareGuiComReg.rc @@ -0,0 +1,34 @@ +TBoldAsCheckBoxStateRendererCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldAsCheckBoxStateRendererCom.bmp +TBoldAsFloatRendererCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldAsFloatRendererCom.bmp +TBoldAsIntegerRendererCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldAsIntegerRendererCom.bmp +TBoldAsViewerRendererCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldAsViewerRendererCom.bmp +TBoldAsStringRendererCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldAsStringRendererCom.bmp +TBoldAsMLStringRendererCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldAsMLStringRendererCom.bmp +TBoldCaptionControllerCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldCaptionControllerCom.bmp +TBoldChartCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldChartCom.bmp +TBoldCheckBoxCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldCheckBoxCom.bmp +TBoldComboBoxCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldComboBoxCom.bmp +TBoldControlGridCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldControlGridCom.bmp +TBoldEditCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldEditCom.bmp +TBoldGridCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldGridCom.bmp +TBoldImageCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldImageCom.bmp +TBoldLabelCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldLabelCom.bmp +TBoldListBoxCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldListBoxCom.bmp +TBoldListViewCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldListViewCom.bmp +TBoldMemoCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldMemoCom.bmp +TBoldNavigatorCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldNavigatorCom.bmp +TBoldProgressBarCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldProgressBarCom.bmp +TBoldRadioGroupCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldRadioGroupCom.bmp +TBoldRendererCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldRendererCom.bmp +TBoldRichEditCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldRichEditCom.bmp +TBoldTimePickerCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldTimePickerCom.bmp +TBoldTrackBarCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldTrackBarCom.bmp +TBoldTreeViewCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldTreeViewCom.bmp +TBoldXCVTreeViewCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldXCVTreeViewCom.bmp +TBoldDataSetCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldDataSetCom.bmp +TBoldDropTargetCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldDropTargetCom.bmp +TBoldPageControlCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldPageControlCom.bmp +TBoldPropertiesControllerCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldPropertiesControllerCom.bmp +TBoldStringsPropertyControllerCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldStringsPropertyControllerCom.bmp +TBoldExceptionHandlerCom BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldExceptionHandlerCom.bmp + \ No newline at end of file diff --git a/Source/ClientGuiCom/BoldControls/BoldAwareGuiComReg.res b/Source/ClientGuiCom/BoldControls/BoldAwareGuiComReg.res new file mode 100644 index 00000000..98825a08 Binary files /dev/null and b/Source/ClientGuiCom/BoldControls/BoldAwareGuiComReg.res differ diff --git a/Source/ClientGuiCom/BoldControls/BoldCaptionControllerCom.pas b/Source/ClientGuiCom/BoldControls/BoldCaptionControllerCom.pas index d97f1d3e..6c630b5e 100644 --- a/Source/ClientGuiCom/BoldControls/BoldCaptionControllerCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldCaptionControllerCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldCaptionControllerCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -7,7 +10,7 @@ interface uses Classes, Controls, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after + BoldEnvironmentVCL, BoldHandlesCom, BoldElementHandleFollowerCom, BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, @@ -111,7 +114,7 @@ procedure TBoldCustomCaptionControllerCom.SetCaption(s: TCaption); (s <> TrackedCaption) then begin fCaption := s; - TrackedCaption := Caption; //TrackedCaption ensures valid fTrackControl + TrackedCaption := Caption; end; end; @@ -120,7 +123,7 @@ procedure TBoldCustomCaptionControllerCom.SetTrackControl(Control: TWinControl); if Control <> fTrackControl then begin fTrackControl := Control; - Caption := Caption; //Update caption if new Control; + Caption := Caption; end; end; @@ -187,4 +190,3 @@ function TBoldCustomCaptionControllerCom.GetVariableList: IBoldExternalVariableL initialization end. - diff --git a/Source/ClientGuiCom/BoldControls/BoldCheckBoxCom.pas b/Source/ClientGuiCom/BoldControls/BoldCheckBoxCom.pas index 9ec9a400..0b339a5a 100644 --- a/Source/ClientGuiCom/BoldControls/BoldCheckBoxCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldCheckBoxCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldCheckBoxCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -5,16 +8,19 @@ interface uses - Messages, + // VCL Classes, Controls, + Messages, StdCtrls, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after - BoldHandlesCom, - BoldElementHandleFollowerCom, - BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, + + // Bold + BoldCheckboxStateControlPackCom, + BoldClientElementSupport, + BoldComObjectSpace_TLB, BoldControlPackCom, - BoldCheckboxStateControlPackCom; + BoldElementHandleFollowerCom, + BoldHandlesCom; type TBoldCustomCheckBoxCom = class; @@ -116,7 +122,6 @@ implementation uses SysUtils, - BoldRev, BoldDefs, BoldControlPackDefs; diff --git a/Source/ClientGuiCom/BoldControls/BoldComboBoxCom.pas b/Source/ClientGuiCom/BoldControls/BoldComboBoxCom.pas index 637fbbc6..099a6de1 100644 --- a/Source/ClientGuiCom/BoldControls/BoldComboBoxCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldComboBoxCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComboBoxCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -5,32 +8,29 @@ interface uses - Windows, - Messages, + // VCL Classes, - Graphics, Controls, - SysUtils, + Graphics, Menus, + Messages, StdCtrls, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after - BoldDefs, - BoldControlsDefs, - BoldHandlesCom, - BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, + SysUtils, + Windows, + + // Bold BoldAbstractListHandleCom, - BoldElementHandleFollowerCom, - BoldListHandleFollowerCom, + BoldComObjectSpace_TLB, BoldComponentValidatorCom, BoldControlPackCom, + BoldControlsDefs, + BoldDefs, + BoldElementHandleFollowerCom, + BoldHandlesCom, + BoldListHandleFollowerCom, BoldListListControlPackCom, BoldStringControlPackCom; -{TODO 3 -ofrha -cfeature: WM_PAINT} -{TODO 3 -ofrha -cbug: Alignment not compleatly implemented} -{TODO 3 -ofrha -ccheckme: CB_GETEXTENDEDUI} -{TODO 3 -ofrha -cbug: AfterMakeUptodate when DroppedDown} - type {Forward declarations of all classes} TBoldCustomComboBoxCom = class; @@ -135,7 +135,6 @@ TBoldCustomComboBoxCom = class(TCustomComboBox, IBoldValidateableComponentCom) property EffectiveFont: TFont read GetEffectiveFont; property EffectiveReadOnly: Boolean read FEffectiveReadOnly; property Font: TFont read FFont write SetFont stored IsFontStored; -// property Items write SetItems; property ReadOnly: Boolean read FReadOnly write SetReadOnly default False; property Text: string read GetText write SetText; public @@ -162,12 +161,11 @@ TBoldComboBoxCom = class(TBoldCustomComboBoxCom) property BoldSetValueExpression; property BoldSelectChangeAction; property OnSelectChanged; - property CharCase; {Must be published before ReadOnly} //From TBoldCutomCombBox + property CharCase; {Must be published before ReadOnly} property ReadOnly; {Properties in standard TComboBox} - property Style; {Must be published before Items} {TODO 3 -ofrha -cbug: Create own styles!} + property Style; {Must be published before Items} property Anchors; - // property BiDiMode; property Color; property Constraints; property Ctl3D; @@ -177,10 +175,8 @@ TBoldComboBoxCom = class(TBoldCustomComboBoxCom) property DropDownCount; property Enabled; property Font; -// property ImeMode; -// property ImeName; + property ItemHeight; -// property Items; property MaxLength; property ParentBiDiMode; property ParentColor; @@ -192,7 +188,6 @@ TBoldComboBoxCom = class(TBoldCustomComboBoxCom) property Sorted; property TabOrder; property TabStop; -// property Text; Text is only public! property Visible; property OnChange; property OnClick; @@ -218,7 +213,6 @@ TBoldComboBoxCom = class(TBoldCustomComboBoxCom) implementation uses - BoldRev, BoldExceptionHandlersCom, BoldReferenceHandleCom, {$IFNDEF BOLDCOMCLIENT} @@ -252,7 +246,6 @@ procedure TBoldCustomComboBoxCom._RowAfterMakeUptoDate(Follower: TBoldFollowerCo if (index > -1) and (index < Items.Count) then Items[index] := TBoldStringFollowerControllerCom(Follower.Controller).GetCurrentAsString(Follower); Invalidate; - // forces a redisplay of the edit-area, the windows component might go blank if the active row is removed and then reinserted fHandleFollower.Follower.MarkValueOutOfDate; end; @@ -260,10 +253,8 @@ procedure TBoldCustomComboBoxCom._AfterMakeUptoDate(Follower: TBoldFollowerCom); var NewText: string; begin -// Code below removed to avoid closeup when moving in dropped down combo. suggested by Hans Karlsen -// if not (Style = csSimple) and DroppedDown then -// PostMessage(Handle, CB_SHOWDROPDOWN, 0, 0); //FIXME Bad solution! CloseUp if changed while dropped down! + UpdateEffectiveColor; UpdateEffectiveReadOnly; @@ -337,7 +328,7 @@ procedure TBoldCustomComboBoxCom.ComboWndProc(var Message: TMessage; ComboWnd: H if (Style = csSimple) and (ComboWnd <> EditHandle) then if EffectiveReadOnly then Exit; end; - fIsEditEvent := True; // Flag to know we're already in the event + fIsEditEvent := True; inherited ComboWndProc(Message, ComboWnd, ComboProc); fIsEditEvent := False; end; @@ -499,7 +490,7 @@ procedure TBoldCustomComboBoxCom.KeyPress(var Key: Char); begin if (Style <> csDropDownList) and (BoldSelectChangeAction <> bdcsSetReference) and - not BoldProperties.ValidateCharacter(Key, Follower) then + not BoldProperties.ValidateCharacter(AnsiChar(Key), Follower) then begin MessageBeep(0); Key := BOLDNULL; @@ -535,7 +526,6 @@ procedure TBoldCustomComboBoxCom.SetCharCase(const Value: TEditCharCase); begin if CharCase <> Value then begin - //FIXME Investigate and fix problems with CharCase and non readonly inherited CharCase := Value; end; end; @@ -561,7 +551,6 @@ procedure TBoldCustomComboBoxCom.SetEffectiveReadOnly(Value: Boolean); end; procedure TBoldCustomComboBoxCom.SetEffectiveText(Value: string); -// This mess is needed prevent flickering and allow changes to Text before the controls handle is allocated! /frha var I: Integer; Redraw: Boolean; @@ -612,7 +601,7 @@ procedure TBoldCustomComboBoxCom.SetFocused(Value: Boolean); procedure TBoldCustomComboBoxCom.SetFont(Value: TFont); begin FFont.Assign(Value); -end; +end; procedure TBoldCustomComboBoxCom.SetReadOnly(Value: Boolean); begin @@ -639,14 +628,14 @@ procedure TBoldCustomComboBoxCom.UpdateEffectiveColor; NewColor: TColor; begin NewColor := Color; - BoldProperties.SetColor(NewColor, Color, Follower); //FIXME FC should only take ONE color and a Follower! /frha + BoldProperties.SetColor(NewColor, Color, Follower); inherited Color := NewColor; end; procedure TBoldCustomComboBoxCom.UpdateEffectiveFont; begin EffectiveFont.Assign(Font); - BoldProperties.SetFont(EffectiveFont, Font, Follower); //FIXME FC should only take ONE font and a Follower! /frha + BoldProperties.SetFont(EffectiveFont, Font, Follower); end; procedure TBoldCustomComboBoxCom.UpdateEffectiveReadOnly; @@ -659,7 +648,6 @@ procedure TBoldCustomComboBoxCom.UpdateEffectiveReadOnly; procedure TBoldCustomComboBoxCom.WMPaint(var Message: TWMPaint); begin - //FIXME Own painting with call to renderers paint isn't done yet... inherited; end; @@ -667,9 +655,7 @@ procedure TBoldCustomComboBoxCom.WndProc(var Message: TMessage); var CallInherited: Boolean; ElementToAssignTo: IBoldElement; - {$IFNDEF BOLDCOMCLIENT} Discard: Boolean; - {$ENDIF} begin CallInherited := True; if not (csDesigning in ComponentState) then @@ -686,13 +672,13 @@ procedure TBoldCustomComboBoxCom.WndProc(var Message: TMessage); Follower.DiscardChange; if Assigned(BoldHandle) and Assigned(BoldHandle.value) then begin - {$IFDEF BOLDCOMCLIENT} // BoldSetValueExpression + {$IFDEF BOLDCOMCLIENT} if trim(BoldSetValueExpression) <> '' then ElementToAssignTo := BoldHandle.Value.EvaluateExpression(BoldSetValueExpression) else elementToAssignTo := BoldHandle.Value; if assigned(ElementToAssignTo) then - ElementToAssignTo.AssignElement(SelectedElement); // checkme take from follwer instead? + ElementToAssignTo.AssignElement(SelectedElement); {$ELSE} if trim(BoldSetValueExpression) <> '' then ElementToAssignTo := BoldHandle.Value.EvaluateExpressionAsDirectElement(BoldSetValueExpression) @@ -700,11 +686,10 @@ procedure TBoldCustomComboBoxCom.WndProc(var Message: TMessage); elementToAssignTo := BoldHandle.Value; if assigned(ElementToAssignTo) and ElementToAssignTo.Mutable and - // must check the element (and not the follower) since we might have a BoldSetValueExpression... (not (elementToAssignTo is IBoldMember) or IBoldMember(ElementTOAssignTo).CanModify) then try - ElementToAssignTo.Assign(SelectedElement); // checkme take from follwer instead? + ElementToAssignTo.Assign(SelectedElement); except on E: Exception do begin @@ -740,7 +725,6 @@ procedure TBoldCustomComboBoxCom.WndProc(var Message: TMessage); end; if assigned(OnSelectChanged) then fOnSelectChanged(Self); -// Code below removed to avoid closing dropdown, suggested by Hans Karlsen if (not CallInherited) and (Style <> csSimple) and not fIsEditEvent then @@ -757,7 +741,7 @@ procedure TBoldCustomComboBoxCom.WndProc(var Message: TMessage); CB_SHOWDROPDOWN: if (Message.WParam=0) and EffectiveReadOnly then - _AfterMakeUptoDate(Follower); {Restore text} //FIXME Maybe an UpdateEffectiveText? + _AfterMakeUptoDate(Follower); {Restore text} end; end; if CallInherited then @@ -819,7 +803,6 @@ function TBoldCustomComboBoxCom.GetContextForBoldRowProperties: IBoldElementType {$IFNDEF BOLDCOMCLIENT} function TBoldCustomComboBoxCom.ValidateComponent(ComponentValidator: TBoldComponentValidatorCom; NamePrefix: String): Boolean; begin - // We want to evaluate everything. Thus suboptimized expressions. Result := ComponentValidator.ValidateExpressionInContext( BoldProperties.Expression, GetContextForBoldProperties, @@ -847,8 +830,7 @@ function TBoldCustomComboBoxCom.ComboAllowsTextEditing( BoldProperties: TBoldStringFollowerControllerCom; Follower: TBoldFollowerCom): Boolean; begin - // this method is primarily intended for subclasses to stop editing of string-attributes - // due to bad combo configuration (needed at SVT) + result := true; end; @@ -863,5 +845,4 @@ function TBoldCustomComboBoxCom.HandleApplyException(E: Exception; Elem: IBoldEl ExceptionHandler.HandleApplyException(E, self, Elem, Discard, Result); end; -initialization end. diff --git a/Source/ClientGuiCom/BoldControls/BoldDragDropTargetCom.pas b/Source/ClientGuiCom/BoldControls/BoldDragDropTargetCom.pas index 48bd05c1..4bc18d45 100644 --- a/Source/ClientGuiCom/BoldControls/BoldDragDropTargetCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldDragDropTargetCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDragDropTargetCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -7,7 +10,7 @@ interface Classes, Controls, ExtCtrls, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after + BoldEnvironmentVCL, BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, {$IFNDEF BOLDCOMCLIENT} BoldComObjectSpace_TLB, @@ -50,8 +53,8 @@ TBoldDropTargetCom = class(TImage, IBoldOCLComponentCom) property Element: IBoldElement read GetElement; procedure Notification(AComponent: TComponent; Operation: TOperation); override; public - constructor Create(owner: TComponent); override; - destructor Destroy; override; + constructor create(owner: TComponent); override; + destructor destroy; override; procedure DoStartDrag(var DragObject: TDragObject); override; procedure DoEndDrag(Target:TObject; X, Y: Integer); override; procedure MouseDown(BUTTON: TMouseButton; Shift: TShiftState; X, Y: Integer); override; @@ -115,7 +118,7 @@ constructor TBoldDropTargetCom.create(owner: TComponent); AfterMakeUptoDate(fHandleFollower.Follower); end; -destructor TBoldDropTargetCom.Destroy; +destructor TBoldDropTargetCom.destroy; begin FreeAndNil(FHandleFollower); FreeAndNil(FRepresentations); @@ -151,12 +154,9 @@ procedure TBoldDropTargetCom.DragDrop(Source: TObject; X, Y: Integer); procedure TBoldDropTargetCom.DragOver(Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); begin - // First set the hard accept value Accept := IsDropTarget and CanAcceptDraggedObject; - // Then, if we accept, invoke user code if Accept and Assigned(OnDragOver) then OnDragOver(Self, Source, X, Y, State, Accept); - // Make sure we only accept if hard conditions are true. Accept := Accept and IsDropTarget and CanAcceptDraggedObject; end; @@ -185,7 +185,6 @@ function TBoldDropTargetCom.GetCurrentNodeDescription: TBoldNodeDescriptionCom; begin ie := TBoldIndirectElement.create; try - // this code should move to the treeview support classes (or is it already there???) Element.EvaluateAndSubscribeToExpression(NodeSelectionExpression, fHandleFollower.Follower.Subscriber, ie); if ie.value is IBoldList then begin list := ie.value as IBoldList; @@ -317,5 +316,4 @@ procedure TBoldDropTargetCom.SetRepresentations(Value: TBoldTreeFollowerControll FRepresentations.Assign(Value); end; -initialization end. diff --git a/Source/ClientGuiCom/BoldControls/BoldEditCom.pas b/Source/ClientGuiCom/BoldControls/BoldEditCom.pas index b13e7b7f..7b15c307 100644 --- a/Source/ClientGuiCom/BoldControls/BoldEditCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldEditCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldEditCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -5,20 +8,23 @@ interface uses + // VCL + Buttons, Classes, - StdCtrls, Controls, - Windows, - Messages, - Menus, Graphics, - Buttons, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after - BoldControlsDefs, - BoldHandlesCom, - BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, + Menus, + Messages, + StdCtrls, + Windows, + + // Bold + BoldClientElementSupport, + BoldComObjectSpace_TLB, BoldControlPackCom, + BoldControlsDefs, BoldElementHandleFollowerCom, + BoldHandlesCom, BoldStringControlPackCom; type @@ -48,7 +54,7 @@ TBoldCustomEditCom = class(TCustomEdit, IBoldOCLComponentCom) procedure SetExpression(Expression: String); function GetExpression: String; function GetVariableList: IBoldExternalVariableList; - + function GetBoldHandle: TBoldElementHandleCom; procedure SetBoldHandle(value: TBoldElementHandleCom); function GetFollower: TBoldFollowerCom; @@ -99,7 +105,7 @@ TBoldCustomEditCom = class(TCustomEdit, IBoldOCLComponentCom) property BeepOnInvalidKey: boolean read fBeepOnInvalidKey write fBeepOnInvalidKey default True; property Button: TSpeedButton read GetButton; - property ButtonControl: TWinControl read fBtnControl; //NOTE Do not publish. + property ButtonControl: TWinControl read fBtnControl; property EffectiveReadOnly: Boolean read GetEffectiveReadOnly; property EffectiveFont: TFont read GetEffectiveFont; property EffectiveColor: TColor read GetEffectiveColor write SetEffectiveColor; @@ -143,20 +149,16 @@ TBoldEditCom = class(TBoldCustomEditCom) property Anchors; property AutoSelect; property AutoSize; -// property BiDiMode; property BorderStyle; property CharCase; -// property Color; property Constraints; property Ctl3D; property DragCursor; property DragKind; property DragMode; property Enabled; -// property Font; property HideSelection; -// property ImeMode; -// property ImeName; + property MaxLength; property ParentColor; property ParentCtl3D; @@ -164,11 +166,9 @@ TBoldEditCom = class(TBoldCustomEditCom) property ParentShowHint; property PasswordChar; property PopupMenu; -// property ReadOnly; property ShowHint; property TabOrder; property TabStop; -// property Text; property Visible; property OnChange; property OnClick; @@ -196,11 +196,10 @@ implementation uses BoldControlPackDefs, SysUtils, - BoldRev, - Forms, // bssingle - {$IFNDEF BOLDCOMCLIENT} // uses - BoldComObjectSpace_TLB, // For Specialized Drag/Drop in EditBox - BoldGUI, // For Specialized Drag/Drop in EditBox + Forms, + {$IFNDEF BOLDCOMCLIENT} + BoldComObjectSpace_TLB, + BoldGUI, BoldReferenceHandleCom, BoldRootedHandlesCom, {$ENDIF} @@ -272,7 +271,7 @@ procedure TBoldCustomEditCom.DoEndDrag(Target: TObject; X, Y: Integer); procedure TBoldCustomEditCom.DragOver(Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); begin - {$IFNDEF BOLDCOMCLIENT} //dragdrop + {$IFNDEF BOLDCOMCLIENT} if (BoldProperties.DropMode = bdpReplace) and (assigned(BoldHandle)) and (not assigned(BoldHandle.Value) or (BoldHandle.Value is IBoldObject)) and @@ -291,7 +290,7 @@ procedure TBoldCustomEditCom.DragOver(Source: TObject; X, Y: Integer; State: TDr procedure TBoldCustomEditCom.DragDrop(Source: TObject; X, Y: Integer); begin - {$IFNDEF BOLDCOMCLIENT} //dragdrop + {$IFNDEF BOLDCOMCLIENT} if (BoldProperties.DropMode = bdpReplace) and (assigned(BoldHandle)) and (not assigned(BoldHandle.Value) or (BoldHandle.Value is IBoldObject)) and @@ -378,7 +377,7 @@ procedure TBoldCustomEditCom.SetEffectiveColor(v: TColor); inherited Color := v; end; -procedure TBoldCustomEditCom.SetText(value: string); //CHECKME Remove? Text is not published any longer! +procedure TBoldCustomEditCom.SetText(value: string); begin if not (csLoading in ComponentState) then if not EffectiveReadOnly then @@ -413,12 +412,12 @@ procedure TBoldCustomEditCom.KeyPress(var Key: Char); begin inherited KeyPress(Key); if (Key in [#32..#255]) and - not BoldProperties.ValidateCharacter(Key, Follower) then + not BoldProperties.ValidateCharacter(AnsiChar(Key), Follower) then begin InvalidKey(Key); Key := BOLDNULL; end - else if Key = #1 then // CTRL-A + else if Key = #1 then begin SelectAll; end @@ -665,7 +664,6 @@ procedure TBoldCustomEditCom.SetEditRect; var Loc: TRect; begin -// SendMessage(Handle, EM_GETRECT, 0, LongInt(@Loc)); Loc.Bottom := ClientHeight+1; Loc.Right := ClientWidth-1; Loc.Top := 0; @@ -684,15 +682,13 @@ procedure TBoldCustomEditCom.SetEditRect; end; procedure TBoldCustomEditCom.WMSize(var message: TWMSize); -//var -// MinHeight: Integer; + begin inherited; -// if (csDesigning in ComponentState) then -// FGrid.SetBounds(0, Height + 1, 10, 10); -// MinHeight := GetMinHeight; -// if Height < MinHeight then Height := MinHeight -// else begin + + + + if Assigned(fBtnControl) and Assigned(fButton) then SetEditRect; end; @@ -708,7 +704,6 @@ procedure TBoldCustomEditCom.SetButtonStyle(const Value: TBoldEditButtonStyle); begin if Assigned(fBtnControl) then fBtnControl.Visible := False; - //NOTE Skip destruction of button and recreation of control in runtime to eliminate flicker. if (csDesigning in ComponentState) then RecreateWnd; end @@ -747,7 +742,6 @@ procedure TBoldComboButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin with TBoldCustomEditCom(Parent.Parent) do - //CHECKME We may need to skip the change of focus if the popupcontrol is visible! if (Handle <> GetFocus) and CanFocus then begin SetFocus; @@ -761,8 +755,7 @@ procedure TBoldComboButton.MouseDown(Button: TMouseButton; Shift: TShiftState; procedure TBoldComboButton.MouseMove(Shift: TShiftState; X, Y: Integer); begin inherited MouseMove (Shift, X, Y); -// if (ssLeft in Shift) and (GetCapture = Parent.Handle) then -// MouseDragToGrid(Self, TDBLookupCombo(Parent.Parent).FGrid, X, Y); + end; function TBoldCustomEditCom.GetBoldHandle: TBoldElementHandleCom; @@ -800,5 +793,5 @@ function TBoldCustomEditCom.GetVariableList: IBoldExternalVariableList; end; initialization - + end. diff --git a/Source/ClientGuiCom/BoldControls/BoldGridCom.pas b/Source/ClientGuiCom/BoldControls/BoldGridCom.pas index b1e9ecc1..fb662b63 100644 --- a/Source/ClientGuiCom/BoldControls/BoldGridCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldGridCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldGridCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -5,33 +8,31 @@ interface uses + // VCL {$IFDEF DELPHI6_OR_LATER} - Types, // IFDEF DELPHI6_OR_LATER + Types, {$ELSE} - Windows, // else-part of IFDEF DELPHI6_OR_LATER + Windows, {$ENDIF} - Messages, - Graphics, + Classes, Controls, + Graphics, Grids, Menus, - StdCtrls, - Classes, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after - {$IFNDEF BOLDCOMCLIENT} // uses + + // Bold + {$IFNDEF BOLDCOMCLIENT} BoldComObjectSpace_TLB, {$ENDIF} - BoldCommonBitmaps, - BoldControlPackDefs, - BoldControlsDefs, - BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, BoldAbstractListHandleCom, - BoldListHandleFollowerCom, - BoldControlPackCom, + BoldComClient, + BoldComObjectSpace_TLB, + BoldComponentValidatorCom, BoldControllerListControlPackCom, + BoldControlPackCom, + BoldControlsDefs, + BoldListHandleFollowerCom, BoldListListControlPackCom, - BoldComponentValidatorCom, - BoldSubscription, BoldStringControlPackCom; type @@ -95,7 +96,6 @@ TBoldGridColumnsCom = class(TCollection) end; { TBoldColumnTitleCom } - // Borrowed from TDBGrid TBoldColumnTitleCom = class(TPersistent) private fAlignment: TAlignment; @@ -267,11 +267,9 @@ TBoldCustomGridCom = class(TCustomGrid, IBoldValidateableComponentCom) procedure SetOptions(val: TGridOptions); procedure SetSelection(aRow: Integer; Shift: TShiftState; ForceClearOfOtherRows: Boolean; IgnoreToggles: Boolean); procedure TypeMayHaveChanged; - // DRAW FUNCTIONS function CellFont(Column: TBoldGridColumnCom): TFont; function GetString(GridCol, DataRow: Integer): string; function HighlightCell(AState: TGridDrawState; aRow: integer): Boolean; - // EDIT FUNCTIONS procedure _AfterMakeCellUptoDate(Follower: TBoldFollowerCom); procedure _DeleteRow(index: Integer; owningFollower: TBoldFollowerCom); procedure _InsertRow(Follower: TBoldFollowerCom); @@ -393,7 +391,7 @@ TBoldCustomGridCom = class(TCustomGrid, IBoldValidateableComponentCom) procedure DisplayAllCells; function AsClipBoardText: String; procedure ActivateAllCells; - property ColCount;// read GetColCount; + property ColCount; property CellText[col, row: integer]: string read GetCellText; property MutableList: IBoldList read GetMutableList; end; @@ -431,7 +429,7 @@ TBoldGridCom = class(TBoldCustomGridCom) property Color; property Constraints; property Columns; - {$IFNDEF BCB} // for some reason, the below line gives an error in the generated .hpp-file + {$IFNDEF BCB} property Ctl3d; {$ENDIF} property DefaultColWidth; @@ -484,7 +482,6 @@ TBoldGridCom = class(TBoldCustomGridCom) end; { TBoldInplaceEditCom } - // Used to access Font property of InplaceEditor TBoldInplaceEditCom = class(TInplaceEdit) private {$IFNDEF BOLDCOMCLIENT} @@ -530,21 +527,23 @@ TBoldInplaceEditCom = class(TInplaceEdit) implementation uses + Messages, + StdCtrls, SysUtils, Forms, - {$IFNDEF BOLDCOMCLIENT} // uses + {$IFNDEF BOLDCOMCLIENT} {!! DO NOT REMOVE !! BoldAttributes ,} {!! DO NOT REMOVE !! BoldSystemRT ,} BoldAFP, BoldGUI, {$ENDIF} -// BoldGridRTColEditorCom - BoldEnvironment, - BoldRev, + BoldCommonBitmaps, + BoldControlPackDefs, BoldDefs, + BoldEnvironment, BoldListControlPackCom, - TypInfo, - BoldMath; + BoldMath, + TypInfo; const ColumnTitleValues = [cvTitleColor..cvTitleFont]; @@ -619,7 +618,6 @@ procedure TBoldInplaceEditCom.BoundsChanged; var R: TRect; begin - // This method replaces ancestor method, as it doesn't seem to do the right thING Assert(Assigned(Grid)); R := Rect(2, 2, TBoldCustomGridCom(Grid).Columns[TBoldCustomGridCom(Grid).Col].Width - 2, Height); SendMessage(Handle, EM_SETRECTNP, 0, LongInt(@R)); @@ -632,10 +630,9 @@ procedure TBoldInplaceEditCom.KeyPress(var Key: Char); begin inherited KeyPress(Key); Grid := TBoldCustomGridCom(Owner); - // when editing, clear all other selected rows Grid.SetSelection(grid.DataRow(grid.Row), [], true, false); if (Key in [#32..#255]) and - not Grid.Columns[Grid.Col].BoldProperties.ValidateCharacter(Key, Grid.CurrentCellFollower) then + not Grid.Columns[Grid.Col].BoldProperties.ValidateCharacter(AnsiChar(Key), Grid.CurrentCellFollower) then begin MessageBeep(0); Key := BOLDNULL; @@ -774,7 +771,7 @@ procedure TBoldColumnTitleCom._FontChanged(Sender: TObject); Exclude(fColumn.fAssignedValues, cvTitleFont) else Include(fColumn.fAssignedValues, cvTitleFont); - Changed; // ??? + Changed; end; function TBoldColumnTitleCom.GetAlignment: TAlignment; @@ -937,7 +934,6 @@ constructor TBoldGridColumnCom.Create(theCollection: TCollection); end; destructor TBoldGridColumnCom.Destroy; - // CollectionItem removes itself from collection when destroyed begin if fGrid.fFixedColumn = self then fGrid.fFixedColumn := nil; @@ -955,7 +951,6 @@ destructor TBoldGridColumnCom.Destroy; procedure TBoldGridColumnCom.Assign(Source: TPersistent); -// Code mainly from DBGrids var SourceCol: TBoldGridColumnCom; begin @@ -976,12 +971,11 @@ procedure TBoldGridColumnCom.Assign(Source: TPersistent); if cvAlignment in SourceCol.AssignedValues then Alignment := SourceCol.Alignment; Title := SourceCol.Title; -// if cvReadOnly in SourceCol.AssignedValues then -// ReadOnly := SourceCol.ReadOnly; -// DropDownRows := SourceCol.DropDownRows; -// ButtonStyle := SourceCol.ButtonStyle; -// PickList := SourceCol.PickList; -// PopupMenu := SourceCol.PopupMenu; + + + + + finally if Assigned(Collection) then Collection.EndUpdate; @@ -1012,8 +1006,7 @@ procedure TBoldGridColumnCom.RestoreDefaults; FTitle.RestoreDefaults; FAssignedValues := []; RefreshDefaultFont; -// FreeAndNil(FPickList); -// ButtonStyle := cbsAuto; + Changed(FontAssigned); end; @@ -1159,7 +1152,6 @@ constructor TBoldCustomGridCom.Create(AOwner: TComponent); fBoldProperties.BeforeMakeUptoDate := _BeforeMakeListUptoDate; fBoldProperties.OnGetContextType := GetHandleStaticType; fHandleFollower := TBoldListHandleFollowerCom.Create(Owner, fBoldProperties); - // fHandleFollower.OnHandleIndexChanged := HandleIndexChanged; FColumns := CreateColumns; fAnchor := 0; Options := [goFixedVertLine, goFixedHorzLine, goVertLine, @@ -1209,7 +1201,7 @@ procedure TBoldCustomGridCom.TypeMayHaveChanged; {$ENDIF} begin if BoldEffectiveEnvironment.RunningInIDE and (not Assigned(BoldHandle.List) or (BoldHandle.List.Count = 0)) then - Exit; // only update at runtime if there are values, avoids update on every UML model change. + Exit; NewListElementType := GetHandleListElementType; if (NewListElementType <> fCurrentListElementType) then @@ -1242,12 +1234,11 @@ procedure TBoldCustomGridCom.DeleteAllColumns; Columns[ColCount - 1].Free; if columns.count = 0 then AddColumn; - // ensure column 0 EnsureOneFixedCol; end; procedure TBoldCustomGridCom.CreateDefaultColumns; -{$IFNDEF BOLDCOMCLIENT} // defaultcolumns +{$IFNDEF BOLDCOMCLIENT} var i: integer; ListElementType: IBoldElementTypeInfo; @@ -1266,7 +1257,7 @@ procedure TBoldCustomGridCom.CreateDefaultColumns; {$ENDIF} begin - {$IFNDEF BOLDCOMCLIENT} // defaultcolumns + {$IFNDEF BOLDCOMCLIENT} ListElementType := GetHandleListElementType; DeleteAllColumns; UsedFirstCol := false; @@ -1370,7 +1361,6 @@ procedure TBoldCustomGridCom.ColumnMoved(FromIndex, ToIndex: Longint); begin Columns.MoveColumn(FromIndex, ToIndex); inherited ColumnMoved(FromIndex, ToIndex); - // Redraw affected columns for Col := MinIntValue([FromIndex, ToIndex]) to MaxIntValue([FromIndex, ToIndex]) do Columns.Update(Columns[Col]); end; @@ -1406,21 +1396,17 @@ procedure TBoldCustomGridCom.EnsureOneFixedCol; not fIsEnsuringFixedCol then begin fIsEnsuringFixedCol := true; - // there must be atleast one column more than the fixed column while Columns.Count < 2 do if not FirstIsOK then Columns.Insert(0) else Columns.Add; - - // see if the existing first column can be used as our fixed column... if not FirstIsOk then Columns.Insert(0); fFixedColumn := Columns[0]; - // make this column the fixed column. fFixedColumn.BoldProperties.Expression := ''; - fFixedColumn.Title.Caption := ''; // Clear the title + fFixedColumn.Title.Caption := ''; fFixedColumn.Color := Self.FixedColor; if not (csDesigning in componentstate) then fFixedColumn.BoldProperties.Renderer := fFirstColumnRenderer; @@ -1460,13 +1446,11 @@ function TBoldCustomGridCom.CreateEditor: TInplaceEdit; end; procedure TBoldCustomGridCom.EditStop; - // Same as OnExit for each cell var CellFollower: TBoldFollowerCom; begin CellFollower := CurrentCellFollower; - // if the grid is changed under our feet (for example because it is sorted, and we just changed the sort order) - // then ignore the edit stop + if assigned(CellFollower) and (CellFollower.Controller.ApplyPolicy = bapExit) then CellFollower.Apply; @@ -1486,9 +1470,8 @@ function TBoldCustomGridCom.GetEditText(GridCol, GridRow: Longint): string; end; procedure TBoldCustomGridCom.SetEditText(GridCol, GridRow: Longint; const Value: string); - // called for each change == OnChange begin - if not (csDesigning in ComponentState) and Editormode and assigned(CurrentCellFollower) then // CHECKME heeded? + if not (csDesigning in ComponentState) and Editormode and assigned(CurrentCellFollower) then TBoldStringFollowerControllerCom(CurrentCellFollower.Controller).MayHaveChanged(Value, CurrentCellFollower) end; @@ -1510,7 +1493,7 @@ procedure TBoldCustomGridCom.DblClick; else if BoldProperties.DefaultDblClick and Assigned(CurrentBoldElement) then begin - {$IFDEF BOLDCOMCLIENT} // autoform + {$IFDEF BOLDCOMCLIENT} AutoForm := nil; {$ELSE} AutoForm := AutoFormProviderRegistry.FormForElement(CurrentBoldElement); @@ -1586,8 +1569,6 @@ procedure TBoldCustomGridCom.SetSelection(aRow: Integer; Shift: TShiftState; For Exit; fIsMultiSelecting := MultiSelect and ((ssShift in Shift) or (ssCtrl in Shift)); - - // Clear previous selection, Select one item if not ((ssShift in Shift) or (ssCtrl in Shift)) or not MultiSelect then begin if (not Follower.SubFollowers[aRow].Selected) or ForceClearOfOtherRows then @@ -1596,22 +1577,15 @@ procedure TBoldCustomGridCom.SetSelection(aRow: Integer; Shift: TShiftState; For fBoldProperties.SetSelected(Follower, aRow, True); end; end; - - // Select range from first selected item if (ssShift in Shift) and MultiSelect then begin fBoldProperties.SelectRange(Follower, aRow); end; - - - // Toggle selection on current item if (ssCtrl in Shift) and MultiSelect and (not IgnoreToggles) then begin fBoldProperties.ToggleSelected(Follower, aRow); end; - // At this point we would rather have invalidated col 0, - // but that does not yield desired redraw WHEN THE GRID SCROLLS. Invalidate; AdjustActiveRange; @@ -1700,9 +1674,8 @@ function TBoldCustomGridCom.DefaultTitlePopup(Col: Integer): TPopupMenu; M.Caption := '&Close Popup'; M.name := '__mnuBoldGridCancel'; Items.Add(M); - // Additional possibilities: - // M := nil; - // * Alignment + + end; end; Result := TheDefaultTitlePopup; @@ -1753,11 +1726,10 @@ procedure TBoldCustomGridCom.MouseUp(BUTTON: TMouseButton; Shift: TShiftState; X if (Button = mbLeft) then begin if not fIsDragging then - SetSelection(DataRow(Row), Shift, true, false) // Call setselection with currentrow and shiftstate + SetSelection(DataRow(Row), Shift, true, false) else begin - // starting a drag on a nonselected row with ctrl pressed should select the row - // odd behaviour cuases VCL to clear the shiftstate when we expect a ssCTRL, so we check the MouseDownstate instead + if not selected[DataRow(Row)] and (ssCtrl in fLastMouseDownShiftState) then SetSelection(DataRow(Row), fLastMouseDownShiftState, true, false) end; @@ -1793,14 +1765,13 @@ procedure TBoldCustomGridCom.MouseDown(BUTTON: TMouseButton; Shift: TShiftState; {$ENDIF} inherited; - // Top Left cell marks all rows - // FIXME FIXEDROW handling + if (fLastMouseDownGridCoord.y <> -1) and (fLastMouseDownGridCoord.Y = TitleRow) then begin if fLastMouseDownGridCoord.X = Pred(FixedCols) then begin fBoldProperties.SelectAll(Follower, True); - ReallyInvalidateCol(Pred(FixedCols)); // FIXME InvalidateCol doesn't invalidate last when scrolling + ReallyInvalidateCol(Pred(FixedCols)); AdjustActiveRange; end else @@ -1810,17 +1781,15 @@ procedure TBoldCustomGridCom.MouseDown(BUTTON: TMouseButton; Shift: TShiftState; fLastMouseDownScreenCoord := Point(-1, -1); end; end - else //mark clicked row + else begin - if (Button = mbLeft) and (fLastMouseDownGridCoord.Y >= FixedRows) then // if clicking outside datacells, y is -1 + if (Button = mbLeft) and (fLastMouseDownGridCoord.Y >= FixedRows) then begin Row := fLastMouseDownGridCoord.Y; - // if the click is in column 0 and it is already selected, don't reselect anything if not ((fLastMouseDownGridCoord.x = pred(FixedCols)) and Selected[fLastMouseDownGridCoord.y]) then - SetSelection(DataRow(Row), Shift, false, true) // SetSelection Invalidates entire grid + SetSelection(DataRow(Row), Shift, false, true) end; end; - // drag if on col 0 if (Button = mbLeft) and (fLastMouseDownGridCoord.X = Pred(FixedCols)) then begin try @@ -1846,20 +1815,22 @@ procedure TBoldCustomGridCom.KeyDown(var KEY: Word; Shift: TShiftState); if (Key = VK_DELETE) and (Shift = []) then begin - ShowEditor; - InplaceEditor.Text := ''; - SetEditText(Col, Row, ''); + if (goEditing in Options) and not (BoldHandle.List.Count = 0) then begin + ShowEditor; + InplaceEditor.Text := ''; + SetEditText(Col, Row, ''); + end; end; - + if (Row = RowCount - 1) and (KEY = 40) then {40 = KeyDown} begin if AddNewAtEnd and (fBoldProperties.NilElementMode<>neAddLast) then begin BoldHandle.List.AddNew; - Follower.EnsureDisplayable; // Force control to get in sync with Object Layer + Follower.EnsureDisplayable; end else - KEY := 0; // Avoid walking below last row + KEY := 0; end; {$IFNDEF BOLDCOMCLIENT} if not (Key in RowMovementKeys) and not (Key in [VK_LEFT, VK_RIGHT]) and ColumnIsCheckBox(Col) then @@ -1871,13 +1842,12 @@ procedure TBoldCustomGridCom.KeyDown(var KEY: Word; Shift: TShiftState); procedure TBoldCustomGridCom.KeyUp(var KEY: Word; Shift: TShiftState); begin - if KEY in [33..40] then //PGUP..DOWN + if KEY in [33..40] then begin - //FIXME: It *is* possible to make non-consecutive selections with keyboard. - // I think the algorithm has to be rewritten to accommodate this. - // Also: Check how Delphi/Windows implements keyboard selections (keys/combinations) - Exclude(Shift, ssCtrl); // Cannot make non-consecutive selections with keyboard - SetSelection(DataRow(Row), Shift, true, true); // Call setselection with currentrow and shiftstate + + + Exclude(Shift, ssCtrl); + SetSelection(DataRow(Row), Shift, true, true); end; inherited; end; @@ -1889,7 +1859,6 @@ function TBoldCustomGridCom.GetString(GridCol, DataRow: Integer): string; else begin EnsureRowActive(DataRow); - // if a cell's controller has not be created yet then you'll get an AV (ex: setting the CWAdjust flag) if Assigned(CellFollowers[GridCol, DataRow]) and Assigned(CellFollowers[GridCol, DataRow].Controller) then Result := TBoldStringFollowerControllerCom(CellFollowers[GridCol, DataRow].Controller).GetCurrentAsString(CellFollowers[GridCol, DataRow]); end; @@ -1942,15 +1911,14 @@ procedure TBoldCustomGridCom.AdjustCol(Col: Integer); procedure TBoldCustomGridCom.ColWidthsChanged; begin inherited; - // By including TopLeftChanged, [caAllowGrow, caAllowShrink] - // effectively freezes the column width - // TopLeftChanged; + + end; function TBoldCustomGridCom.CanEditAcceptKey(KEY: Char): Boolean; begin Result := Assigned(CurrentCellFollower) and - TBoldStringFollowerControllerCom(CurrentCellFollower.Controller).ValidateCharacter(KEY, CurrentCellFollower); + TBoldStringFollowerControllerCom(CurrentCellFollower.Controller).ValidateCharacter(AnsiChar(Key), CurrentCellFollower); end; function TBoldCustomGridCom.CanEditModify: Boolean; @@ -1966,7 +1934,6 @@ function TBoldCustomGridCom.CanEditShow: Boolean; begin Result := (inherited CanEditShow) and Assigned(CurrentCellFollower) and not Columns[Col].ColReadOnly; - // editable if we have a write-allowing renderer or a lookup-handle result := result and (CurrentCellFollower.RendererData.MayModify {$IFNDEF BOLDCOMCLIENT} or assigned(Columns[Col].LookupHandle) @@ -2004,8 +1971,7 @@ procedure TBoldCustomGridCom.DrawCell(ACol, aRow: Longint; ARect: TRect; AState: FrameFlags1, FrameFlags2: DWORD; begin -// if (csDesigning in ComponentState) and (aRow > 0) then -// Exit; //FIXME Removed to test Grids in designtime + aListRow := DataRow(aRow); if (ACol > Columns.Count - 1) then @@ -2037,7 +2003,7 @@ procedure TBoldCustomGridCom.DrawCell(ACol, aRow: Longint; ARect: TRect; AState: begin if (aRow = TitleRow) then {Title row} begin - if Assigned(DrawColumn.Title) then // Attempts to redraw before column is done creating + if Assigned(DrawColumn.Title) then begin Font.Assign(DrawColumn.Title.Font); Align := DrawColumn.Title.Alignment; @@ -2049,7 +2015,6 @@ procedure TBoldCustomGridCom.DrawCell(ACol, aRow: Longint; ARect: TRect; AState: begin with Columns[ACol].BoldProperties do begin - // Render font and color SetFont(Canvas.Font, CellFont(DrawColumn), CellFollowers[ACol, aListRow]); SetColor(cl, DrawColumn.Color, CellFollowers[ACol, aListRow]) end; @@ -2127,8 +2092,8 @@ procedure TBoldCustomGridCom._DeleteRow(index: Integer; owningFollower: TBoldFol procedure TBoldCustomGridCom.SetCurrentRow(DataRow: Integer); begin - Row := GridRow(MaxIntValue([0, DataRow])); // Need to make sure we never focus on row 0 - ReallyInvalidateCol(0); // Need to redraw first column FIXME let renderer to this too + Row := GridRow(MaxIntValue([0, DataRow])); + ReallyInvalidateCol(0); end; function TBoldCustomGridCom.GetRowFollower(DataRow: Integer): TBoldFollowerCom; @@ -2180,12 +2145,9 @@ procedure TBoldCustomGridCom._AfterMakeListUptoDate(Follower: TBoldFollowerCom); RowCount := FixedRows + 1 else RowCount := Follower.SubFollowerCount + FixedRows; - - // if exactly one row has been inserted, then select it. if AutoSelectNewRows and (fSubFollowerCountBeforeMakeUpToDate = Follower.SubFollowerCount - 1) then begin - // perhaps this is a bit overkill, but it works. anyone with a better suggestion? BoldHandle.CurrentIndex := fLastInsertedRowIndex; Follower.CurrentIndex := fLastInsertedRowIndex; SetCurrentRow(Follower.CurrentIndex); @@ -2207,8 +2169,6 @@ procedure TBoldCustomGridCom._AfterMakeListUptoDate(Follower: TBoldFollowerCom); AdjustActiveRange; if fInvalidateFrom <> MAXINT then InvalidateFromRow(fInvalidateFrom); - - // setting the currentRow will reset the LeftCol if GridRow(Follower.CurrentIndex) < RowCount then begin OldLeftCol := LeftCol; @@ -2242,7 +2202,7 @@ function TBoldCustomGridCom.GetFollower: TBoldFollowerCom; procedure TBoldCustomGridCom._BeforeMakeListUpToDate(Follower: TBoldFollowerCom); begin - TypeMayHaveChanged; // IMPROVEME, subscribe to listidentitychanged instead. + TypeMayHaveChanged; fMakingListUpToDate := True; AdjustActiveRange; fInvalidateFrom := MAXINT; @@ -2311,8 +2271,7 @@ function TBoldInplaceEditCom.GetDestElement(CellFollower: TBoldFollowerCom; Colu result := nil; if assigned(cellFollower) and assigned(CellFollower.Element) then begin - // if the event is active, then return the element in the grid, otherwise - // see if we get any useful element from the cell. + if assigned(Column.OnLookupChange) then result := CellFollower.Element else @@ -2466,14 +2425,11 @@ procedure TBoldCustomGridCom._FontChanged(Sender: TObject); end; function TBoldCustomGridCom.GetEditLimit: Integer; -{$IFNDEF BOLDCOMCLIENT} var El: IBoldElement; -{$ENDIF} begin result := 0; {$IFNDEF BOLDCOMCLIENT} - // set the maxlength of the editor; El := TBoldInplaceEditCom(InplaceEditor).GetDestElement(CurrentCellFollower, Columns[Col]); if (el is TBAString) and assigned((el as TBAString).BoldAttributeRTInfo) then Result := (el as TBAString).BoldAttributeRTInfo.Length; @@ -2564,7 +2520,6 @@ procedure TBoldGridCheckBoxPainterRenderer.CheckBoxClick(BUTTON: TMouseButton; S begin GridCoord := GRid.MouseCoord(X, Y); CellRect.Left := 0; - // sum the column widths of the fixed cols and then the visible cols. for i := 0 to Grid.FixedCols - 1 do CellRect.Left := CellRect.Left + Grid.Columns[i].Width + Grid.GridLineWidth; for i := GRid.LeftCol to GridCoord.x - 1 do @@ -2783,7 +2738,7 @@ procedure TBoldGridColumnCom.SetIndex(Value: Integer); begin fGrid.fBoldColumnsProperties.Move(index, value); inherited; - fGrid.Invalidate; // Fixes a bug in Borland grid to invalidate col that does not handle scrolled grids + fGrid.Invalidate; end; procedure TBoldCustomGridCom.ReallyInvalidateCol(Column: integer); @@ -2923,7 +2878,6 @@ function TBoldCustomGridCom.AsClipBoardText: String; var Col, Row: integer; begin - // as the grid is optimizing the active followers, we need to activate them manually ActivateAllCells; Result := ''; for row := 0 to RowCount - 1 do @@ -2975,13 +2929,11 @@ function TBoldGridColumnCom.ColumnHasCheckBoxOverrides: Boolean; function TBoldGridColumnCom.GetCurrentCheckBoxState( Follower: TBoldFollowerCom): TCheckBoxState; begin - // will only be called if ColumnHasCheckBoxOverrides returns true result := cbGrayed; end; procedure TBoldGridColumnCom.SetCurrentCheckBoxState(Follower: TBoldFollowerCom; NewValue: TCheckBoxState); begin - // will only be called if ColumnHasCheckBoxOverrides returns true end; function TBoldGridColumnCom.GetLookupContext: IBoldElementTypeInfo; @@ -3043,7 +2995,6 @@ procedure TBoldCustomGridCom.GetActiveRange(var FirstActive, LastActive: integer begin firstActive := DataRow(TopRow) - 1; LastActive := DataRow(TopRow + VisibleRowCount) + 1; - // extend range to include all selected elements for i := 0 to FirstActive - 1 do if Selected[i] then begin @@ -3073,7 +3024,6 @@ procedure TBoldCustomGridCom.EnsureRowActive(DataRow: integer); else if DataRow > LastActive then LastActive := DataRow; BoldProperties.SetActiveRange(Follower, firstActive, lastActive, 10); - // this can fail if the FollowerHandle is invalid... Follower.EnsureDisplayable; end; end; @@ -3097,7 +3047,7 @@ procedure TBoldCustomGridCom.DisplayAllCells; BoldProperties.SelectAll(Follower, true); Invalidate; AdjustActiveRange; - EnsureActiveCellFollowerExpressions; {TODO: Remove? AdjustActiveRange already calls this method, why call it again??} + EnsureActiveCellFollowerExpressions; Follower.EnsureDisplayable; BoldProperties.SelectAll(Follower, false); BoldProperties.SetSelected(Follower, DataRow(Row), true); @@ -3120,6 +3070,3 @@ procedure TBoldCustomGridCom.EnsureActiveCellFollowerExpressions; initialization end. - - - diff --git a/Source/ClientGuiCom/BoldControls/BoldGridRTColEditorCom.pas b/Source/ClientGuiCom/BoldControls/BoldGridRTColEditorCom.pas index 99a58c35..355db346 100644 --- a/Source/ClientGuiCom/BoldControls/BoldGridRTColEditorCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldGridRTColEditorCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldGridRTColEditorCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -12,7 +15,7 @@ interface Classes, BoldDefs, BoldGridCom, - {$IFNDEF BOLDCOMCLIENT} // uses + {$IFNDEF BOLDCOMCLIENT} BoldOclPropEditor, {$ENDIF} {!! DO NOT REMOVE !! BoldSystemRT ,} @@ -69,7 +72,6 @@ implementation uses SysUtils, - BoldRev, BoldUtils; {$R *.dfm} @@ -192,12 +194,12 @@ procedure TfrmRTColEditorCom.cmdDeleteColumnClick(Sender: TObject); procedure TfrmRTColEditorCom.PropertyKeyPress(Sender: TObject; var Key: Char); begin if not Assigned(CurrentGridColumn) then - Key := BOLDNULL; + Key := BOLDNULL; end; procedure TfrmRTColEditorCom.cmdOCLEditorClick(Sender: TObject); begin - {$IFNDEF BOLDCOMCLIENT} // ocleditor + {$IFNDEF BOLDCOMCLIENT} with TBoldOCLPropEditForm.Create(nil) do try Context := EGrid.GetHandleListElementType; diff --git a/Source/ClientGuiCom/BoldControls/BoldImageBitmapCom.pas b/Source/ClientGuiCom/BoldControls/BoldImageBitmapCom.pas index df54f88c..6ab0fb4b 100644 --- a/Source/ClientGuiCom/BoldControls/BoldImageBitmapCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldImageBitmapCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldImageBitmapCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -5,7 +8,7 @@ interface uses - Windows, // Delphi Units + Windows, Classes, Graphics, Clipbrd, @@ -29,7 +32,7 @@ TBoldViewBitmapAdapterCom = class(TBoldAbstractViewAdapterCom) function HasChanged: Boolean; override; class function CanReadContent(const ContentType: string): Boolean; override; function ContentType: string; override; - class function Description: string; override; // How to handle Localizastion? + class function Description: string; override; {Clipboard} procedure CopyToClipboard; override; class function CanPasteFromClipboard(const AcceptedContentType: string): Boolean; override; @@ -39,7 +42,7 @@ TBoldViewBitmapAdapterCom = class(TBoldAbstractViewAdapterCom) procedure SaveToStream(Stream: TStream); override; {Files} class function DefaultExtension: string; override; - class function FileFilter: string; override; // How to handle Localizastion? + class function FileFilter: string; override; class function CanLoadFromFile(const Filename: string): Boolean; override; procedure LoadFromFile(const Filename: string); override; procedure SaveToFile(const Filename: string); override; @@ -230,5 +233,5 @@ function TBoldViewBitmapAdapterCom.Height: Integer; initialization TBoldViewBitmapAdapterCom.RegisterViewAdapter(TBoldViewBitmapAdapterCom); - + end. diff --git a/Source/ClientGuiCom/BoldControls/BoldImageCom.pas b/Source/ClientGuiCom/BoldControls/BoldImageCom.pas index 6c4888b0..2b986fe6 100644 --- a/Source/ClientGuiCom/BoldControls/BoldImageCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldImageCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldImageCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -10,8 +13,8 @@ interface Classes, Graphics, Controls, - Forms, // TBorderStyle - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after + Forms, + BoldEnvironmentVCL, BoldControlsDefs, BoldHandlesCom, BoldElementHandleFollowerCom, @@ -38,7 +41,7 @@ TBoldImageCom = class(TCustomControl, IBoldOCLComponentCom) fQuickDraw: Boolean; fScale: Double; fDisplayRect: TRect; - FOnResize: TNotifyEvent; + FOnResize: TNotifyEvent; function GetContextType: IBoldElementTypeInfo; procedure SetExpression(Expression: String); function GetExpression: String; @@ -95,7 +98,6 @@ TBoldImageCom = class(TCustomControl, IBoldOCLComponentCom) property Scale: Integer read GetScale write SetScale default 100; property Center: Boolean read fCenter write fCenter; property QuickDraw: Boolean read fQuickDraw write fQuickDraw; -// property ContentType: string //Use this property to specify property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle; property OnResize: TNotifyEvent read FOnResize write FOnResize; {Standard properties} @@ -138,7 +140,6 @@ implementation uses SysUtils, - BoldRev, BoldDefs, BoldControlPackDefs; @@ -205,7 +206,6 @@ function TBoldImageCom.GetViewer: TBoldAbstractViewAdapterCom; procedure TBoldImageCom.SetViewer(Value: TBoldAbstractViewAdapterCom); begin fBoldProperties.MayHaveChanged(Value, Follower); -// Invalidate; end; procedure TBoldImageCom.SetBorderStyle(Value: TBorderStyle); @@ -314,12 +314,10 @@ procedure TBoldImageCom.WMSize(var Message: TMessage); procedure TBoldImageCom.CMTextChanged(var Message: TMessage); begin inherited; -// FIXME Invalidate to redraw Caption when there is no picture end; procedure TBoldImageCom.WMEraseBkgnd(var Message: TWMEraseBkgnd); begin -//Ignore erase background to prevent flicker end; {} @@ -447,7 +445,7 @@ procedure TBoldImageCom.Paint; if (csDesigning in ComponentState) then S := '(' + Name + ')' else - S := ''; //FIXME Some text in runtime? + S := ''; Size := TextExtent(S); R := ClientRect; TextRect(R, (R.Right - Size.cx) div 2, (R.Bottom - Size.cy) div 2, S); @@ -536,8 +534,7 @@ procedure TBoldImageCom.PasteFromClipboard; aViewer: TBoldAbstractViewAdapterCom; function GetViewer: TBoldAbstractViewAdapterCom; - // FixMe: Could be a classmethod on TBoldAbstractViewAdapterCom - // reuse in method above aswell /JoHo + var I: Integer; begin @@ -601,5 +598,4 @@ function TBoldImageCom.GetVariableList: IBoldExternalVariableList; result := BoldProperties.VariableList; end; -initialization end. diff --git a/Source/ClientGuiCom/BoldControls/BoldImageJPEGCom.pas b/Source/ClientGuiCom/BoldControls/BoldImageJPEGCom.pas index bc0de2b2..895068a1 100644 --- a/Source/ClientGuiCom/BoldControls/BoldImageJPEGCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldImageJPEGCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldImageJPEGCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -30,7 +33,7 @@ TBoldViewJPEGAdapterCom = class(TBoldAbstractViewAdapterCom) function HasChanged: Boolean; override; class function CanReadContent(const ContentType: string): Boolean; override; function ContentType: string; override; - class function Description: string; override; // How to handle Localizastion? + class function Description: string; override; {Clipboard} procedure CopyToClipboard; override; class function CanPasteFromClipboard(const AcceptedContentType: string): Boolean; override; @@ -40,7 +43,7 @@ TBoldViewJPEGAdapterCom = class(TBoldAbstractViewAdapterCom) procedure SaveToStream(Stream: TStream); override; {Files} class function DefaultExtension: string; override; - class function FileFilter: string; override; // How to handle Localizastion? + class function FileFilter: string; override; class function CanLoadFromFile(const Filename: string): Boolean; override; procedure LoadFromFile(const Filename: string); override; procedure SaveToFile(const Filename: string); override; @@ -135,7 +138,7 @@ class function TBoldViewJPEGAdapterCom.CanPasteFromClipboard(const AcceptedConte type THack = class(TJPEGImage) - end; //FIX to access NewBitmap so LoadFromClipboardFormat does not return an exception. + end; procedure TBoldViewJPEGAdapterCom.PasteFromClipboard; var diff --git a/Source/ClientGuiCom/BoldControls/BoldLabelCom.pas b/Source/ClientGuiCom/BoldControls/BoldLabelCom.pas index a4ed459a..2631ce31 100644 --- a/Source/ClientGuiCom/BoldControls/BoldLabelCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldLabelCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLabelCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -5,17 +8,20 @@ interface uses - Messages, + // VCL Classes, - Graphics, Controls, + Graphics, + Messages, StdCtrls, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after - BoldHandlesCom, + + // Bold + BoldClientElementSupport, + BoldComObjectSpace_TLB, BoldControlPackCom, - BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, - BoldStringControlPackCom, - BoldElementHandleFollowerCom; + BoldElementHandleFollowerCom, + BoldHandlesCom, + BoldStringControlPackCom; type {Forward declaration of classes} @@ -121,7 +127,6 @@ implementation uses SysUtils, - BoldRev, BoldControlPackDefs; type @@ -139,7 +144,7 @@ constructor TBoldCustomLabelCom.Create(AOwner: TComponent); fMyFont.OnChange := _FontChanged; fMyColor := EffectiveColor; if (csDesigning in ComponentState) then - ParentColor := True; //CHECKME This should not be necesary... + ParentColor := True; end; destructor TBoldCustomLabelCom.Destroy; @@ -237,7 +242,6 @@ procedure TBoldCustomLabelCom.AfterMakeUptoDate(Follower: TBoldFollowerCom); begin if (csDesigning in ComponentState) then begin - // caption during design-time with BoldProperties do if Assigned(Renderer) then NewText := Format('%s.%s', [Renderer.name, Expression]) @@ -247,7 +251,6 @@ procedure TBoldCustomLabelCom.AfterMakeUptoDate(Follower: TBoldFollowerCom); NewText := name; end else - // Caption at run-time newText := BoldProperties.GetCurrentAsString(Follower); if Text <> newText then @@ -257,7 +260,7 @@ procedure TBoldCustomLabelCom.AfterMakeUptoDate(Follower: TBoldFollowerCom); ec := EffectiveColor; BoldProperties.SetColor(ec, Color, Follower); EffectiveColor := ec; -end; +end; function TBoldCustomLabelCom.GetText: TCaption; begin @@ -325,6 +328,4 @@ procedure TBoldCustomLabelCom.DragDrop(Source: TObject; X, Y: Integer); BoldProperties.DragDrop(Follower, follower.Element, 0); end; -initialization end. - diff --git a/Source/ClientGuiCom/BoldControls/BoldListBoxCom.pas b/Source/ClientGuiCom/BoldControls/BoldListBoxCom.pas index 5f6d80af..209777b3 100644 --- a/Source/ClientGuiCom/BoldControls/BoldListBoxCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldListBoxCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldListBoxCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -5,28 +8,28 @@ interface uses + // VCL Classes, - StdCtrls, Controls, - Windows, - Menus, Graphics, + Menus, Messages, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after - BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, - {$IFNDEF BOLDCOMCLIENT} // uses + StdCtrls, + Windows, + + // Bold + {$IFNDEF BOLDCOMCLIENT} BoldComObjectSpace_TLB, BoldAFP, {$ENDIF} BoldAbstractListHandleCom, + BoldClientElementSupport, + BoldComObjectSpace_TLB, BoldControlPackCom, BoldListHandleFollowerCom, BoldListListControlPackCom, BoldStringControlPackCom; -// CHECKME is a destroywind needed that saves the extra list. -// when is DestroyWnd actually called. - type {Forward declarations of all classes} TBoldCustomListBoxCom = class; @@ -173,9 +176,8 @@ implementation uses SysUtils, Forms, - BoldRev, - {$IFNDEF BOLDCOMCLIENT} // uses - BoldGui, // IFNDEF BOLDCOMCLIENT + {$IFNDEF BOLDCOMCLIENT} + BoldGui, {$ENDIF} BoldControlPackDefs, BoldListControlPackCom; @@ -210,7 +212,6 @@ destructor TBoldCustomListBoxCom.Destroy; procedure TBoldCustomListBoxCom._BeforeMakeUptoDate(Follower: TBoldFollowerCom); begin - // Will fetch all if assigned(BoldHandle) and assigned(Boldhandle.list) then BoldHandle.list.EnsureRange(0, BoldHandle.list.Count-1); Items.BeginUpdate; @@ -231,7 +232,6 @@ procedure TBoldCustomListBoxCom.SetAlignment(Value: TAlignment); if Value <> FAlignment then begin FAlignment := Value; - // Enough to invalidate drawing surface Invalidate; end; end; @@ -249,7 +249,7 @@ function TBoldCustomListBoxCom.GetItemIndex: Integer; procedure TBoldCustomListBoxCom.SetItemIndex(Value: Integer); begin fHandleFollower.SetFollowerIndex(value); - inherited ItemIndex := Value; // FIXME; + inherited ItemIndex := Value; end; procedure TBoldCustomListBoxCom.SetBoldProperties(Value: TBoldListAsFollowerListControllerCom); @@ -274,18 +274,13 @@ procedure TBoldCustomListBoxCom.SetSelection(aRow: Integer; Shift: TShiftState); begin if aRow = -1 then Exit; - // Clear previous selection, Select one item if not ((ssShift in Shift) or (ssCtrl in Shift)) or not MultiSelect then begin fBoldProperties.SelectAll(Follower, False); fBoldProperties.SetSelected(Follower, aRow, True); end; - - // Select range from first selected item if (ssShift in Shift) and MultiSelect then fBoldProperties.SelectRange(Follower, aRow); - - // Toggle selection on current item if (ssCtrl in Shift) and MultiSelect then fBoldProperties.ToggleSelected(Follower, aRow); Invalidate; @@ -311,7 +306,7 @@ procedure TBoldCustomListBoxCom.DblClick; inherited else if BoldProperties.DefaultDblClick and Assigned(CurrentBoldElement) then begin - {$IFDEF BOLDCOMCLIENT} // autoform + {$IFDEF BOLDCOMCLIENT} Autoform := nil; {$ELSE} AutoForm := AutoFormProviderRegistry.FormForElement(CurrentBoldElement); @@ -371,7 +366,6 @@ function TBoldCustomListBoxCom.GetCurrentBoldElement: IBoldElement; function TBoldCustomListBoxCom.GetBoldList: IBoldList; begin - //CHECKME We may have to remove this because the list is not necessarily equal with the rendered list!!! /FH if Assigned(BoldHandle) then Result := BoldHandle.List else @@ -394,11 +388,10 @@ procedure TBoldCustomListBoxCom._RowAfterMakeUptoDate(Follower: TBoldFollowerCom var index: Integer; begin -// This shouldn't be needed... -// if Assigned(BoldHandle) then -// inherited ItemIndex := BoldHandle.CurrentIndex; + + index := Follower.index; - if (index > -1) and (index < Items.Count) then //FIXME: How come index sometimes is > Items.Count? + if (index > -1) and (index < Items.Count) then Items[index] := TBoldStringFollowerControllerCom(Follower.Controller).GetCurrentAsString(Follower); end; @@ -428,10 +421,10 @@ function TBoldCustomListBoxCom.GetSelectedCount: Integer; I: Integer; begin Result := 0; - if MultiSelect then // if not MultiSelect SelCount is always -1! + if MultiSelect then Result := SelCount else - for I := 0 to Items.Count - 1 do // Set result to 1 if something is selected + for I := 0 to Items.Count - 1 do if Selected[I] then begin Result := 1; @@ -441,10 +434,10 @@ function TBoldCustomListBoxCom.GetSelectedCount: Integer; procedure TBoldCustomListBoxCom.KeyUp(var Key: Word; Shift: TShiftState); begin - if Key in [33..40] then //PGUP..DOWN + if Key in [33..40] then begin - Exclude(Shift, ssCtrl); // Cannot make non-consecutive selections with keyboard - SetSelection(ItemIndex, Shift); // Call setselection with currentrow and shiftstate + Exclude(Shift, ssCtrl); + SetSelection(ItemIndex, Shift); end; inherited; end; @@ -452,7 +445,7 @@ procedure TBoldCustomListBoxCom.KeyUp(var Key: Word; Shift: TShiftState); procedure TBoldCustomListBoxCom.CNDrawItem(var Message: TWMDrawItem); var State: TOwnerDrawState; - SignedItemId: integer; // this variable is used to suppress warning from D4 when comparing signed and unsigned values + SignedItemId: integer; begin with Message.DrawItemStruct^ do begin @@ -465,7 +458,6 @@ procedure TBoldCustomListBoxCom.CNDrawItem(var Message: TWMDrawItem); SignedItemId := -1; end; if Assigned(BoldHandle) and (SigneditemID = Follower.CurrentIndex) then - //FIXME Apperens of selected and current... Canvas.DrawFocusRect(rcItem); end; end; @@ -478,7 +470,6 @@ procedure TBoldCustomListBoxCom.DefaultSetFontAndColor(index: Integer); BoldRowProperties.SetFont(Canvas.Font, Font, Follower.SubFollowers[index]); BoldRowProperties.SetColor(ec, Color, Follower.SubFollowers[index]); Canvas.Brush.Color := ec; - // Selected state yields default highlight colors SubFollower := Follower.SubFollowers[index]; if assigned(Subfollower) and Subfollower.Selected then with Canvas do @@ -498,9 +489,7 @@ procedure TBoldCustomListBoxCom.MeasureItem(index: Integer; var Height: Integer) var S: string; begin - // Need to get the font to use BoldRowProperties.SetFont(Canvas.Font, Font, Follower.SubFollowers[index]); - // And measure using current data S := ''; if Assigned(Follower) and Assigned(Follower.Controller) then @@ -509,14 +498,11 @@ procedure TBoldCustomListBoxCom.MeasureItem(index: Integer; var Height: Integer) Height := 2 + Abs(Canvas.Font.Height) else Height := Canvas.TextHeight(S); - - // Now allow user to remeasure, using updated height-value inherited; end; procedure TBoldCustomListBoxCom.WMSize(var Message: TWMSize); begin - // Redraw when resising if aligment is not taLeftJustify inherited; if Alignment <> taLeftJustify then Invalidate; @@ -596,4 +582,3 @@ procedure TBoldCustomListBoxCom.InternalSetSelected(index: integer; v: Boolean); initialization end. - diff --git a/Source/ClientGuiCom/BoldControls/BoldMemoCom.pas b/Source/ClientGuiCom/BoldControls/BoldMemoCom.pas index 827475f1..81da7330 100644 --- a/Source/ClientGuiCom/BoldControls/BoldMemoCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldMemoCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldMemoCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -5,18 +8,21 @@ interface uses - Windows, + // VCL Classes, - Graphics, Controls, - StdCtrls, + Graphics, Menus, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after - BoldHandlesCom, - BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, + StdCtrls, + Windows, + + // Bold + BoldClientElementSupport, + BoldComObjectSpace_TLB, BoldControlPackCom, - BoldStringControlPackCom, - BoldElementHandleFollowerCom; + BoldElementHandleFollowerCom, + BoldHandlesCom, + BoldStringControlPackCom; type TBoldCustomMemoCom = class; @@ -151,7 +157,6 @@ implementation uses SysUtils, - BoldRev, BoldDefs, BoldControlPackDefs; @@ -181,7 +186,7 @@ destructor TBoldCustomMemoCom.Destroy; end; bapDemand: Follower.DiscardChange; end; - + FreeAndNil(fHandleFollower); FreeAndNil(fCanvas); FreeAndNil(fBoldProperties); @@ -319,12 +324,12 @@ procedure TBoldCustomMemoCom.KeyPress(var Key: Char); begin inherited KeyPress(Key); if (Key in [#32..#255]) and - not BoldProperties.ValidateCharacter(Key, Follower) then + not BoldProperties.ValidateCharacter(AnsiChar(Key), Follower) then begin MessageBeep(0); Key := BOLDNULL; end; - + if Key = BOLDESC then begin Follower.DiscardChange; @@ -370,7 +375,9 @@ procedure TBoldCustomMemoCom.AfterMakeUptoDate(Follower: TBoldFollowerCom); RendererDataMaxLength := (Follower.RendererData as TBoldStringRendererDataCom).MaxStringLength; if RendererDataMaxLength <> -1 then - EffectiveMaxLength := RendererDataMaxLength; + EffectiveMaxLength := RendererDataMaxLength + else + EffectiveMaxLength := MaxLength; if (MaxLength > 0) and (MaxLength < EffectiveMaxLength) then EffectiveMaxLength := MaxLength; @@ -387,7 +394,7 @@ procedure TBoldCustomMemoCom.CMEnter(var Message: TCMEnter); procedure TBoldCustomMemoCom.CMExit(var Message: TCMExit); begin if (Follower.Controller.ApplyPolicy = bapExit) then - Follower.Apply; + Follower.Apply; SetFocused(False); DoExit; end; @@ -428,4 +435,3 @@ function TBoldCustomMemoCom.GetVariableList: IBoldExternalVariableList; initialization end. - diff --git a/Source/ClientGuiCom/BoldControls/BoldNavigatorCom.pas b/Source/ClientGuiCom/BoldControls/BoldNavigatorCom.pas index fed9c93e..d4f6027f 100644 --- a/Source/ClientGuiCom/BoldControls/BoldNavigatorCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldNavigatorCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldNavigatorCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 14:59:57} @@ -5,25 +8,22 @@ interface uses + // VCL Windows, Messages, Classes, Controls, - ExtCtrls, - Buttons, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after - BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, - {$IFNDEF BOLDCOMCLIENT} // uses + + // Bold + {$IFNDEF BOLDCOMCLIENT} BoldComObjectSpace_TLB, {$ENDIF} - BoldDefs, + BoldComObjectSpace_TLB, BoldNavigatorDefs, BoldAbstractListHandleCom, BoldListHandleFollowerCom, BoldStringControlPackCom, BoldControlPackCom, - BoldCommonBitmaps, - BoldListControlPackCom, BoldListListControlPackCom; type @@ -96,7 +96,7 @@ TBoldCustomNavigatorCom = class(TBoldNavigateBtnImageIndexOwner) public constructor Create(AOwner: TComponent); override; destructor Destroy; override; - procedure Assign(Source: TPersistent); override; + procedure assign(Source: TPersistent); override; procedure BtnClick(index: TBoldNavigateBtn); procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; end; @@ -152,16 +152,19 @@ TBoldNavigatorCom = class(TBoldCustomNavigatorCom) implementation uses - SysUtils, - BoldRev, + // VCL + Buttons, Dialogs, + ExtCtrls, + SysUtils, + + // Bold + BoldDefs, + BoldCommonBitmaps, {!! DO NOT REMOVE !! BoldSystemRT ,} - BoldUtils, - BoldGuiResourceStringsCom, - BoldControlsDefs; + BoldGuiResourceStringsCom; var -// BtnTypeName: array[TBoldNavigateBtn] of PChar = ('FIRST', 'PRIOR', 'NEXT', 'LAST', 'INSERT', 'DELETE', 'MOVEUP', 'MOVEDOWN'); //Do not localize BtnHintId: array[TBoldNavigateBtn] of Pointer = (@SNavHintFirst, @SNavHintPrior, @SNavHintNext, @SNavHintLast, @SNavHintNew, @SNavHintDelete, @SNavHintMoveUp, @SNavHintMoveDown); procedure TBoldCustomNavigatorCom.InitHints; @@ -202,8 +205,7 @@ procedure TBoldCustomNavigatorCom.SetHints(Value: TStrings); procedure TBoldCustomNavigatorCom.GetChildren(Proc: TGetChildProc; ROOT: TComponent); begin - // Implementation is empty to prevent control - // from behaving like a TPanel + end; procedure TBoldCustomNavigatorCom.SetVisible(Value: TBoldButtonSet); @@ -501,7 +503,6 @@ procedure TBoldCustomNavigatorCom.BtnClick(index: TBoldNavigateBtn); if BoldDeleteMode = dmDefault then begin - // Delete from classlists, remove from other lists if assigned(BoldHandle.ObjectList) and (BoldHandle.ObjectList.OwningElement is IBoldSystem) then EffectiveDeleteMode := dmDelete else @@ -514,7 +515,6 @@ procedure TBoldCustomNavigatorCom.BtnClick(index: TBoldNavigateBtn); begin if assigned(RoleRTInfo) then begin - // linkobjects will be deleted... other objects will be unlinked if RoleRTInfo.RoleType = rtLinkRole then EffectiveDeleteMode := dmDelete else @@ -580,7 +580,7 @@ procedure TBoldCustomNavigatorCom.BtnClick(index: TBoldNavigateBtn); nbInsert: CurrentIndex := List.IndexOf(MutableList.AddNew); nbDelete: - Delete(fConfirmDelete); //FIXME Localize + Delete(fConfirmDelete); nbMoveUp: List.Move(CurrentIndex, CurrentIndex - 1); nbMoveDown: @@ -617,8 +617,8 @@ procedure TBoldCustomNavigatorCom.InitButtons; end; FixButtonGlyphs; InitHints; - Buttons[nbPrior].NavStyle := Buttons[nbPrior].NavStyle + [nsAllowTimer]; - Buttons[nbNext].NavStyle := Buttons[nbNext].NavStyle + [nsAllowTimer]; +// Buttons[nbPrior].NavStyle := Buttons[nbPrior].NavStyle + [nsAllowTimer]; +// Buttons[nbNext].NavStyle := Buttons[nbNext].NavStyle + [nsAllowTimer]; end; procedure TBoldCustomNavigatorCom.SetActiveButtons; @@ -739,5 +739,3 @@ procedure TBoldCustomNavigatorCom.SetImages(const Value: TImageList); initialization end. - - diff --git a/Source/ClientGuiCom/BoldControls/BoldPageControlCom.pas b/Source/ClientGuiCom/BoldControls/BoldPageControlCom.pas index b8aa1372..3432f9e0 100644 --- a/Source/ClientGuiCom/BoldControls/BoldPageControlCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldPageControlCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPageControlCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -7,7 +10,7 @@ interface uses Classes, Controls, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after + BoldEnvironmentVCL, BoldHandlesCom, BoldControlPackCom, BoldElementHandleFollowerCom, @@ -32,8 +35,8 @@ TBoldPageControlCom = class(TPageControl) property Follower: TBoldFollowerCom read GetFollower; public { Public declarations } - constructor Create(owner: TComponent); override; - destructor Destroy; override; + constructor create(owner: TComponent); override; + destructor destroy; override; published { Published declarations } property BoldHandle: TBoldElementHandleCom read GetBoldHandle write SetBoldHandle; @@ -44,7 +47,6 @@ implementation uses SysUtils, - BoldRev, BoldUtils; { TBoldPageControlCom } @@ -58,7 +60,7 @@ constructor TBoldPageControlCom.create(owner: TComponent); fBoldProperties.OnGetContextType := _GetContextType; end; -destructor TBoldPageControlCom.Destroy; +destructor TBoldPageControlCom.destroy; begin FreeAndNil(fHandleFollower); FreeAndNil(fBoldProperties); diff --git a/Source/ClientGuiCom/BoldControls/BoldProgressBarCom.pas b/Source/ClientGuiCom/BoldControls/BoldProgressBarCom.pas index 0e65a787..3e5ef227 100644 --- a/Source/ClientGuiCom/BoldControls/BoldProgressBarCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldProgressBarCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldProgressBarCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 14:59:57} @@ -5,16 +8,19 @@ interface uses + // VCL Classes, - Controls, ComCtrls, + Controls, Menus, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after - BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, - BoldHandlesCom, + + // Bold + BoldClientElementSupport, + BoldComObjectSpace_TLB, BoldControlPackCom, - BoldNumericControlPackCom, - BoldElementHandleFollowerCom; + BoldElementHandleFollowerCom, + BoldHandlesCom, + BoldNumericControlPackCom; type { forward declarations } @@ -63,9 +69,7 @@ implementation BoldControlPackDefs, BoldDefs, SysUtils, - BoldRev, - BoldGuiResourceStringsCom, - BoldControlsDefs; + BoldGuiResourceStringsCom; { TBoldProgressBarCom } constructor TBoldProgressBarCom.Create(AOwner: TComponent); @@ -204,5 +208,4 @@ function TBoldProgressBarCom.GetVariableList: IBoldExternalVariableList; result := BoldProperties.VariableList; end; -initialization end. diff --git a/Source/ClientGuiCom/BoldControls/BoldPropertiesControllerCom.pas b/Source/ClientGuiCom/BoldControls/BoldPropertiesControllerCom.pas index 84b55839..8e866052 100644 --- a/Source/ClientGuiCom/BoldControls/BoldPropertiesControllerCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldPropertiesControllerCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPropertiesControllerCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -6,7 +9,7 @@ interface uses Classes, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after + BoldEnvironmentVCL, BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, BoldHandlesCom, BoldControlPackCom, @@ -98,9 +101,8 @@ implementation TypInfo, BoldControlPackDefs, BoldControlsDefs, - BoldRev, {$IFNDEF BOLDCOMCLIENT} - BoldComObjectSpace_TLB, // IFNDEF BOLDCOMCLIENT + BoldComObjectSpace_TLB, {$ENDIF} Variants, BoldGuard; @@ -177,20 +179,16 @@ constructor TBoldDrivenPropertyCom.Create(Collection: TCollection); end; procedure TBoldDrivenPropertyCom.EnsureValidPropertyName; -// Searches through the list of properties of the assigned component to check that PropertyName -// is valid for this particular component type. If not, it empties Property Name. -// This is called by the Component property setter SetVCLComponent. -// This is not used anymore at the moment. It was easy when we did not cater for property paths ! + + + var PropList: TPropList; Count, I: Integer; Found: Boolean; begin - // At least clear the property when we clear the component if not Assigned(VCLComponent) then PropertyName := ''; - - // Original code below exit; Found := False; I := 0; @@ -211,7 +209,6 @@ procedure TBoldDrivenPropertyCom.SetVCLComponent(const Value: TComponent); var AllowHookUnHook: Boolean; begin - //We don't support the two way update for collections of more than one driven property AllowHookUnHook := assigned(value) and not ((csDesigning in Value.ComponentState) or (Collection.Count > 1)); @@ -237,7 +234,6 @@ procedure TBoldDrivenPropertyCom.SetReadOnly(const Value: Boolean); end; procedure TBoldDrivenPropertyCom.DoOnExit(Sender: TObject); -// Event that we have assigned as the OnExit of VCLComponent (Hooked) begin if (not ReadOnly) and PropertiesController.BoldProperties.MayModify(PropertiesController.HandleFollower.Follower) then begin @@ -245,18 +241,15 @@ procedure TBoldDrivenPropertyCom.DoOnExit(Sender: TObject); if PropertiesController.BoldProperties.ApplyPolicy = bapExit then PropertiesController.HandleFollower.Follower.Apply; end; - //Call the original event if Assigned(FOnExit) then FOnExit(Sender); end; procedure TBoldDrivenPropertyCom.HookOnExit; -// This method, replaces any existing OnExit event of VCLComponent with ours var DoOnExitMethod: TNotifyEvent; begin - // We could have simply used TWinControl(VCLComponent).OnExit := ... if only it was not protected ! - // Has the VCLComponent got an OnExit event ? + if Assigned(VCLComponent) and Assigned(GetPropInfo(VCLComponent.ClassInfo, 'OnExit')) then begin FOnExit := TNotifyEvent(Typinfo.GetMethodProp(VCLComponent, 'OnExit')); @@ -267,7 +260,6 @@ procedure TBoldDrivenPropertyCom.HookOnExit; procedure TBoldDrivenPropertyCom.UnhookOnExit; begin - // Reassign the original event if Assigned(VCLComponent) and Assigned(GetPropInfo(VCLComponent.ClassInfo, 'OnExit')) then Typinfo.SetMethodProp(VCLComponent, 'OnExit', TMethod(FOnExit)); end; @@ -311,11 +303,10 @@ function TBoldDrivenPropertyCom.GetPropertiesController: TBoldPropertiesControll procedure TBoldDrivenPropertyCom.ConvertRelativeProp(StartInstance: TObject; PropNamePath: String; var LastObject: TObject; var PropName: String); -// This method will follow the objects specified in the PropNamePath starting from StartInstance -// and set the LastObject and PropName -// E.g: ConvertRelativeProp(Label1,'FocusControl.Font.Size') will return -// LastObject points to instance of Font -// LastProp : Size + + + + var I, ColIndex, OpenBracketPos: Integer; @@ -325,22 +316,19 @@ procedure TBoldDrivenPropertyCom.ConvertRelativeProp(StartInstance: TObject; begin BoldGuard := TBoldGuard.Create(Path); Path := TStringList.Create; - - //convert . notation to commas so we can use CommaText function Path.CommaText := StringReplace(PropNamePath, '.', ',', [rfReplaceAll]); LastObject := StartInstance; for I := 0 to Path.Count - 1 do begin - // The path may very well follow unassigned links. This check prevents an AV if not Assigned(LastObject) then Exit; PathItem := Path[I]; OpenBracketPos := Pos('[', PathItem); if OpenBracketPos = 0 then begin - if (I < Path.Count - 1) //Special case for when the last property is of tkClass we don't want - //to loose LastObject to be in fact the Previous before Last ! + if (I < Path.Count - 1) + and (GetPropInfo(LastObject.ClassInfo, PathItem)^.PropType^.Kind = tkClass) then begin LastObject := TObject(Typinfo.GetOrdProp(LastObject, PathItem)) @@ -370,16 +358,13 @@ procedure TBoldDrivenPropertyCom.SetRelativePropValue(StartInstance: TObject; TypeKind: TTypeKind; PropInfo: PPropInfo; begin - // No property specified if PropNamePath = '' then Exit; ConvertRelativeProp(StartInstance, PropNamePath, LastObject, PropName); - // Property path followed unassigned links if not Assigned(LastObject) then Exit; PropInfo := GetPropInfo(LastObject.ClassInfo, PropName); - // Property name misspelled if not Assigned(PropInfo) then Exit; TypeKind := PropInfo^.PropType^.Kind; @@ -393,14 +378,11 @@ procedure TBoldDrivenPropertyCom.SetRelativePropValue(StartInstance: TObject; {$ENDIF} end else - // Handle nil equivalents for various property types case TypeKind of tkEnumeration: VarValue := 0; tkInteger: VarValue := 0; else VarValue := PropertiesController.BoldProperties.NilStringRepresentation; end; - - // Special case for booleans that don't seem to be handled properly by SetPropValue if VarType(VarValue) = varBoolean then begin if VarValue then @@ -411,7 +393,6 @@ procedure TBoldDrivenPropertyCom.SetRelativePropValue(StartInstance: TObject; if TypeKind = tkClass then begin - // Special case for objects PropertyObj := TObject(Typinfo.GetOrdProp(LastObject, PropName)); if PropertyObj is TStrings then begin @@ -433,7 +414,6 @@ procedure TBoldDrivenPropertyCom.SetRelativePropValue(StartInstance: TObject; end; end else if TypeKind = tkInteger then - // This is needed to handle an error in TypInfo when setting CARDINAL properties try SetOrdProp(LastObject, PropName, VarValue) except diff --git a/Source/ClientGuiCom/BoldControls/BoldRichEditCom.pas b/Source/ClientGuiCom/BoldControls/BoldRichEditCom.pas index 131d89d1..f0a5a541 100644 --- a/Source/ClientGuiCom/BoldControls/BoldRichEditCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldRichEditCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldRichEditCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -309,7 +312,7 @@ procedure TBoldCustomRichEditCom.KeyPress(var Key: Char); begin inherited KeyPress(Key); if (Key in [#32..#255]) and - not BoldProperties.ValidateCharacter(Key, Follower) then + not BoldProperties.ValidateCharacter(AnsiChar(Key), Follower) then begin MessageBeep(0); Key := BOLDNULL; diff --git a/Source/ClientGuiCom/BoldControls/BoldStringsPropertyControllerCom.pas b/Source/ClientGuiCom/BoldControls/BoldStringsPropertyControllerCom.pas index 8f0589d6..d0bc8f15 100644 --- a/Source/ClientGuiCom/BoldControls/BoldStringsPropertyControllerCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldStringsPropertyControllerCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldStringsPropertyControllerCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -6,7 +9,7 @@ interface uses Classes, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after + BoldEnvironmentVCL, BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, BoldAbstractListHandleCom, BoldControlPackCom, @@ -82,7 +85,6 @@ implementation SysUtils, BoldListControlPackCom, BoldDefs, - BoldRev, TypInfo; {-- TBoldStringsPropertyControllerCom ----------------------------------------------------------} @@ -92,7 +94,7 @@ constructor TBoldStringsPropertyControllerCom.Create(AOwner: TComponent); inherited; fBoldRowProperties := TBoldStringFollowerControllerCom.Create(Self); fBoldRowProperties.AfterMakeUptoDate := _ItemAfterMakeUptoDate; - fBoldRowProperties.BeforeMakeUptoDate := _ItemBeforeMakeUptoDate; + fBoldRowProperties.BeforeMakeUptoDate := _ItemBeforeMakeUptoDate; fBoldRowProperties.OnGetContextType := GetContextType; fBoldProperties := TBoldListAsFollowerListControllerCom.Create(Self, fBoldRowProperties); with fBoldProperties do @@ -136,7 +138,7 @@ procedure TBoldStringsPropertyControllerCom.Notification(AComponent: TComponent; if Assigned(VCLComponent) and (not (csDestroying in ComponentState)) then if (AComponent = VCLComponent) and (Operation = opRemove) then VCLComponent := nil; -end; +end; procedure TBoldStringsPropertyControllerCom._ListAfterMakeUptoDate(Follower: TBoldFollowerCom); var @@ -222,7 +224,6 @@ function TBoldStringsPropertyControllerCom.GetContextType: IBoldElementTypeInfo; function TBoldStringsPropertyControllerCom.GetStringsProperty: TStrings; begin - // fixme code for properties not at top level Result := nil; if Assigned(VCLComponent) and (PropertyName <> '') then begin @@ -251,7 +252,6 @@ procedure TBoldStringsPropertyControllerCom._ItemBeforeMakeUptoDate(Follower: TB procedure TBoldStringsPropertyControllerCom.SetVCLComponent(const Value: TComponent); begin - //FIXME: Add code to validate PropertyName in new component fVCLComponent := Value; if Assigned(fVCLComponent) then FreeNotification(fVCLComponent); diff --git a/Source/ClientGuiCom/BoldControls/BoldTrackBarCom.pas b/Source/ClientGuiCom/BoldControls/BoldTrackBarCom.pas index d13363cf..b9595e7e 100644 --- a/Source/ClientGuiCom/BoldControls/BoldTrackBarCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldTrackBarCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldTrackBarCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 14:59:57} @@ -13,7 +16,7 @@ interface CommCtrl, Menus, BoldDefs, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after + BoldEnvironmentVCL, BoldControlPackDefs, BoldHandlesCom, BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, @@ -71,7 +74,6 @@ implementation uses SysUtils, - BoldRev, BoldUtils, BoldGuiResourceStringsCom, BoldControlsDefs; @@ -255,5 +257,4 @@ function TBoldTrackBarCom.GetVariableList: IBoldExternalVariableList; result := BoldProperties.VariableList; end; -initialization end. diff --git a/Source/ClientGuiCom/BoldControls/BoldTreeViewCom.pas b/Source/ClientGuiCom/BoldControls/BoldTreeViewCom.pas index 40c14b25..b901046f 100644 --- a/Source/ClientGuiCom/BoldControls/BoldTreeViewCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldTreeViewCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldTreeViewCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -5,29 +8,26 @@ interface uses - Windows, - Messages, + // VCL Classes, - Graphics, - Menus, - Controls, ComCtrls, CommCtrl, - BoldEnvironmentVCL, // Make sure VCL environement loaded, and finalized after - {$IFNDEF BOLDCOMCLIENT} // uses - BoldComObjectSpace_TLB, // IFNDEF BOLDCOMCLIENT - BoldGui, // IFNDEF BOLDCOMCLIENT + Controls, + Menus, + Windows, + + // Bold + {$IFNDEF BOLDCOMCLIENT} + BoldComObjectSpace_TLB, + BoldGui, {$ENDIF} - BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, - BoldHandlesCom, + BoldComObjectSpace_TLB, + BoldComponentValidatorCom, + BoldControlPackCom, BoldControlsDefs, - BoldControlPackDefs, BoldElementHandleFollowerCom, - BoldControlPackCom, - BoldNumericControlPackCom, - BoldStringControlPackCom, BoldGenericListControlPackCom, - BoldComponentValidatorCom, + BoldHandlesCom, BoldNodeControlPackCom; type @@ -47,7 +47,7 @@ TBoldTreeNodeCom = class(TTreeNode) procedure UpdateIcon; function GetTreeView: TBoldTreeViewCom; public - destructor Destroy; override; + destructor destroy; override; function ExistsInParent: Boolean; property Follower: TBoldFollowerCom read FFollower write FFollower; property NodeDescription: TBoldNodeDescriptionCom read GetNodeDescription; @@ -239,22 +239,22 @@ TBoldTreeViewCom = class(TBoldCustomTreeViewCom) {$ENDIF} end; - - implementation uses + // VCL + Graphics, SysUtils, - BoldRev, - BoldUtils; + BoldControlPackDefs, + BoldNumericControlPackCom, + BoldStringControlPackCom; {---TBoldTreeNodeCom---} function TBoldTreeNodeCom.GetNodeDescription: TBoldNodeDescriptionCom; var I: Integer; begin - // Check if cache is accurate. if Assigned(FNodeDescription) and (FNodeDescription.NodeFollowerController = Follower.Controller) then begin Result := FNodeDescription; @@ -347,12 +347,10 @@ procedure TBoldCustomTreeViewCom.SetMaxLevels(Value: Integer); begin for I := 0 to Follower.SubFollowerCount-1 do begin - //Update this node if (Follower.SubFollowers[I].Controller as TBoldNodeFollowerControllerCom).HideNodeWithNoChildren then DoInsertHiddenNode(Follower.SubFollowers[I]) else SetNodeState(TBoldTreeNodeCom(Follower.SubFollowers[I].ControlData)); - //Recurse through subfollowers if Follower.SubFollowers[I].Active and (Follower.SubFollowers[I].SubFollowerCount>=BoldNodeListIndex) and Follower.SubFollowers[I].SubFollowers[BoldNodeListIndex].Active then DoList(Level+1, Follower.SubFollowers[I].SubFollowers[BoldNodeListIndex]) end; @@ -462,13 +460,11 @@ procedure TBoldCustomTreeViewCom.SetSelected(Value: TBoldTreeNodeCom); procedure TBoldCustomTreeViewCom.BeginUpdate; begin -// Items.BeginUpdate; Inc(FUpdateCount); end; procedure TBoldCustomTreeViewCom.EndUpdate; begin -// Items.EndUpdate; Dec(FUpdateCount); end; @@ -503,8 +499,6 @@ procedure TBoldCustomTreeViewCom.DisplayIcon(Follower: TBoldFollowerCom); SelectedIndex := SelectedImageIndex else SelectedIndex := ImageIndex; - - // Make a multiselected node appear selected even thjough the treeview does not know this if Follower.Selected and not node.Selected then ImageIndex := SelectedIndex; @@ -529,9 +523,8 @@ function TBoldCustomTreeViewCom.CreateNode: TTreeNode; procedure TBoldCustomTreeViewCom.AfterMakeUptoDate(Follower: TBoldFollowerCom); begin - // for some reason, the pointer to this event seems to get lost after a while. - // the variables below might contain space pointers outside of an update operation - // if this method is not executed. + + fSelectedNodePreUpdate := nil; fSelectedElementPreUpdate := nil; fSelectedNodeDescriptionPreUpdate := nil; @@ -612,16 +605,14 @@ procedure TBoldCustomTreeViewCom.DoInsertHiddenNode(Follower: TBoldFollowerCom); Follower.Active := True; (Follower.Controller as TBoldNodeFollowerControllerCom).SetActiveRange(Follower, BoldNodeListIndex, BoldNodeListIndex); Follower.EnsureDisplayable; - //If EnsureDisplayable creates childnodes they will create a node to this follower too. if (Level <= AutoExpandLevels) and Assigned(Follower.ControlData) then - (Follower.ControlData as TBoldTreeNodeCom).Expand(False); //CHECKME behövs detta? + (Follower.ControlData as TBoldTreeNodeCom).Expand(False); finally EndUpdate; end; end else begin - //Dont show it if we can't show any children! Follower.Active := False; if Assigned(Follower.ControlData) then begin @@ -641,7 +632,6 @@ procedure TBoldCustomTreeViewCom.SetNodeState(Node: TBoldTreeNodeCom); Controller := (Follower.Controller as TBoldNodeFollowerControllerCom); if Controller.HideNodeWithNoChildren then begin - //Nodes with HideNodeWithNoChildren is always fully shown Controller.SetActiveRange(Follower, BoldNodeListIndex, BoldNodeTextIndex); end else @@ -673,7 +663,6 @@ procedure TBoldCustomTreeViewCom.SetNodeState(Node: TBoldTreeNodeCom); if ((Follower.SubFollowerCount = 0) or (not Follower.SubFollowers[BoldNodeListIndex].Active)) then begin - //Only set node in "ExpandOnDemand" mode if it's not expanded already! Node.HasChildren := (Controller.Items[BoldNodeListIndex] as TBoldGenericListControllerCom).CanHaveSubFollowers; Controller.SetActiveRange(Follower, BoldNodeIconIndex, BoldNodeTextIndex); Follower.EnsureDisplayable; @@ -682,7 +671,6 @@ procedure TBoldCustomTreeViewCom.SetNodeState(Node: TBoldTreeNodeCom); end else begin - //Don't allow expansion Node.DeleteChildren; (Follower.Controller as TBoldNodeFollowerControllerCom).SetActiveRange(Follower, BoldNodeIconIndex, BoldNodeTextIndex); Follower.EnsureDisplayable; @@ -754,7 +742,7 @@ procedure TBoldCustomTreeViewCom.KeyPress(var Key: Char); begin inherited KeyPress(Key); if Assigned(FEditFollower) and (Key > #32) and - not (FEditFollower.Controller as TBoldStringFollowerControllerCom).ValidateCharacter(Key, FEditFollower) then + not (FEditFollower.Controller as TBoldStringFollowerControllerCom).ValidateCharacter(AnsiChar(Key), FEditFollower) then begin MessageBeep(0); Key := #0; @@ -800,7 +788,6 @@ procedure TBoldCustomTreeViewCom.MouseUp(Button: TMouseButton; Shift: TShiftStat HitTests: THitTests; begin HitTests := GetHitTestInfoAt(x, y); - // skip the MouseUp if this is a drag... if abs(x - fMouseDownPos.x) + abs(y - fMouseDownPos.y) < Mouse.DragThreshold then begin if (Button = mbLeft) and (htOnItem in HitTests) then @@ -829,7 +816,6 @@ procedure TBoldCustomTreeViewCom.MouseDown(Button: TMouseButton; Shift: TShiftSt if (Button = mbLeft) and (htOnItem in HitTests) then UpdateMultiSelect(fMouseDownNode, Shift, DirMouseDown); - // for some reason, the shiftstate is not preserved until mouse up fMouseDownShiftState := Shift; inherited; end; @@ -1037,7 +1023,6 @@ function TBoldCustomTreeViewCom.ValidateComponent(ComponentValidator: TBoldCompo BaseName: String; Context: IBoldElementTypeInfo; begin - // We want to evaluate everything. Thus suboptimized expressions. Result := True; Context := GetContextType; ComponentValidator.ValidateExpressionInContext('', Context, NamePrefix + name); @@ -1089,7 +1074,6 @@ procedure TBoldCustomTreeViewCom.SetMultiSelect(NewValue: Boolean); procedure TBoldCustomTreeViewCom.UpdateMultiSelect(Node: TBoldTreeNodeCom; Shift: TShiftState; MouseDirection: TBoldMouseDirection); procedure RestoreLastSelectedNode; begin - // restore the selectedstate of the previous node... if assigned(fLastSelectedNode) and (fLastSelectedNode <> Node) then fLastSelectedNode.SetSelected(fLastSelectedNode.Follower.Selected); end; @@ -1106,9 +1090,8 @@ procedure TBoldCustomTreeViewCom.UpdateMultiSelect(Node: TBoldTreeNodeCom; Shift if (MouseDirection = DirMouseDown) and Node.Follower.Selected then begin - // a MouseDown occured on a node that was already selected, - // make sure that the previous node is not unselected until - // mouseup if this is a drag. + + RestoreLastSelectedNode; end; @@ -1262,7 +1245,6 @@ procedure TBoldCustomTreeViewCom._CustomDrawItem(Sender: TCustomTreeView; Node: TextController: TBoldStringFollowerControllerCom; begin Follower := (Node as TBoldTreeNodeCom).Follower; -// TextController := (Follower.Controller as TBoldNodeFollowerControllerCom).Items[2] as TBoldStringFollowerControllerCom; TextController := (Follower.Controller as TBoldNodeFollowerControllerCom).TextFollowerController; if not (cdsSelected in State) then begin @@ -1272,5 +1254,4 @@ procedure TBoldCustomTreeViewCom._CustomDrawItem(Sender: TCustomTreeView; Node: end; end; -initialization end. diff --git a/Source/ClientGuiCom/BoldControls/BoldTreeViewConfigCom.pas b/Source/ClientGuiCom/BoldControls/BoldTreeViewConfigCom.pas index a25c0d08..f55e7d17 100644 --- a/Source/ClientGuiCom/BoldControls/BoldTreeViewConfigCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldTreeViewConfigCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldTreeViewConfigCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -9,8 +12,8 @@ interface BoldGenericListControlPackCom, BoldNodeControlPackCom, {!! DO NOT REMOVE !! BoldSystemRT ,} - {$IFDEF BOLDCOMCLIENT} // uses - BoldComObjectSpace_TLB, // to get the ObjectSpace interfaces + {$IFDEF BOLDCOMCLIENT} + BoldComObjectSpace_TLB, {$ENDIF} BoldTreeViewCom; @@ -20,10 +23,9 @@ implementation uses SysUtils, - BoldRev, BoldUtils; -{$IFDEF BOLDCOMCLIENT} // BoldGenericTreeView +{$IFDEF BOLDCOMCLIENT} procedure BoldGenericTreeView(SystemTypeInfo: IBoldSystemTypeInfo; TreeView: TBoldTreeViewCom); begin end; @@ -120,5 +122,4 @@ procedure BoldGenericTreeView(SystemTypeInfo: IBoldSystemTypeInfo; TreeView: TBo {$ENDIF} -initialization end. diff --git a/Source/ClientGuiCom/BoldControls/BoldXCVTreeViewCom.pas b/Source/ClientGuiCom/BoldControls/BoldXCVTreeViewCom.pas index 12a1cfb9..761fabc9 100644 --- a/Source/ClientGuiCom/BoldControls/BoldXCVTreeViewCom.pas +++ b/Source/ClientGuiCom/BoldControls/BoldXCVTreeViewCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldXCVTreeViewCom; interface diff --git a/Source/ClientGuiCom/ControlPacks/BoldCheckboxStateControlPackCom.pas b/Source/ClientGuiCom/ControlPacks/BoldCheckboxStateControlPackCom.pas index e59746bf..cb5cafe4 100644 --- a/Source/ClientGuiCom/ControlPacks/BoldCheckboxStateControlPackCom.pas +++ b/Source/ClientGuiCom/ControlPacks/BoldCheckboxStateControlPackCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldCheckboxStateControlPackCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -5,11 +8,12 @@ interface uses - StdCtrls, // TCheckBoxState - BoldDefs, - BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, + StdCtrls, + BoldClientElementSupport, + BoldComClient, + BoldComObjectSpace_TLB, BoldControlPackCom, - BoldSubscription; + BoldDefs; type @@ -48,7 +52,7 @@ TBoldAsCheckBoxStateRendererCom = class(TBoldSingleRendererCom) class function DefaultGetAsCheckBoxStateAndSubscribe(Element: IBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList; Subscriber: TBoldComClientSubscriber): TCheckBoxState; virtual; class procedure DefaultSetAsCheckBoxState(Element: IBoldElement; newValue: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList); virtual; class function DefaultValidateCheckBoxState(Element: IBoldElement; Value: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList): Boolean; virtual; - procedure MakeUptodateAndSubscribe(Element: IBoldElement; RendererData: TBoldFollowerDataCom; FollowerController: TBoldFollowerControllerCom; Subscriber: TBoldComClientSubscriber); override; + procedure MakeUpToDateAndSubscribe(Element: IBoldElement; RendererData: TBoldFollowerDataCom; FollowerController: TBoldFollowerControllerCom; Subscriber: TBoldComClientSubscriber); override; function DefaultIsChanged(RendererData: TBoldCheckBoxRendererDataCom; NewValue: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList): Boolean; function GetAsCheckBoxStateAndSubscribe(Element: IBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList; Subscriber: TBoldComClientSubscriber): TCheckBoxState; virtual; procedure SetAsCheckBoxState(Element: IBoldElement; Value: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList); virtual; @@ -84,9 +88,7 @@ implementation uses SysUtils, - BoldRev, - BoldControlPackDefs, - BoldAttributes; + BoldControlPackDefs; var DefaultAsCheckBoxStateRenderer: TBoldAsCheckBoxStateRendererCom; @@ -142,7 +144,7 @@ procedure TBoldCheckBoxStateFollowerControllerCom.MayHaveChanged(NewValue: TChec procedure TBoldCheckBoxStateFollowerControllerCom.MakeClean(Follower: TBoldFollowerCom); begin - ReleaseChangedValue(Follower); // note, must do first, since set can change element + ReleaseChangedValue(Follower); SetAsCheckBoxState(GetCurrentAsCheckBoxState(Follower), Follower); end; @@ -160,7 +162,7 @@ procedure TBoldAsCheckBoxStateRendererCom.MakeUpToDateANdSubscribe(Element: IBol class function TBoldAsCheckBoxStateRendererCom.DefaultGetAsCheckBoxStateAndSubscribe(Element: IBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList; Subscriber: TBoldComClientSubscriber): TCheckBoxState; var - {$IFDEF BOLDCOMCLIENT} // DefaultGet + {$IFDEF BOLDCOMCLIENT} e: IBoldElement; Attribute: IBoldAttribute; {$ELSE} @@ -170,7 +172,7 @@ class function TBoldAsCheckBoxStateRendererCom.DefaultGetAsCheckBoxStateAndSubsc Result := cbGrayed; if Assigned(Element) then begin - {$IFDEF BOLDCOMCLIENT} // defaultGet + {$IFDEF BOLDCOMCLIENT} if assigned(Subscriber) then e := Element.EvaluateAndSubscribeToExpression(Expression, Subscriber.ClientId, Subscriber.SubscriberId, false, false) else @@ -206,12 +208,12 @@ class function TBoldAsCheckBoxStateRendererCom.DefaultGetAsCheckBoxStateAndSubsc class procedure TBoldAsCheckBoxStateRendererCom.DefaultSetAsCheckBoxState(Element: IBoldElement; newValue: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList); var ValueElement: IBoldElement; - {$IFDEF BOLDCOMCLIENT} // defaulSet + {$IFDEF BOLDCOMCLIENT} Attribute: IBoldAttribute; {$ENDIF} begin ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); - {$IFDEF BOLDCOMCLIENT} // defaultSet + {$IFDEF BOLDCOMCLIENT} if valueElement.QueryInterface(IBoldAttribute, Attribute) = S_OK then begin if NewValue = cbGrayed then @@ -302,5 +304,5 @@ initialization finalization FreeAndNil(DefaultAsCheckBoxStateRenderer); - + end. diff --git a/Source/ClientGuiCom/ControlPacks/BoldControlPackCom.pas b/Source/ClientGuiCom/ControlPacks/BoldControlPackCom.pas index 6203ceed..2c0f20df 100644 --- a/Source/ClientGuiCom/ControlPacks/BoldControlPackCom.pas +++ b/Source/ClientGuiCom/ControlPacks/BoldControlPackCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldControlPackCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 14:59:57} @@ -9,7 +12,7 @@ interface SysUtils, Controls, {$IFDEF BOLD_DELPH6_OR_LATER} - Types, // IFDEF BOLD_DELPH6_OR_LATER + Types, {$ENDIF} Menus, Graphics, @@ -53,7 +56,6 @@ TBoldFollowerSubscriberCom = class(TBoldComClientSubscriber) end; { TBoldFollowerDataCom } - // Abstract class, concrete versions defined with typed renderer TBoldFollowerDataCom = class(TBoldMemoryManagedObject) private fOwningFollower: TBoldFollowerCom; @@ -140,7 +142,6 @@ TBoldFollowerCom = class(TBoldQueueable) private fIndex: Integer; fOwningFollower: TBoldFollowerCom; -// fSelected: Boolean; fState: TBoldFollowerState; fElement: IBoldElement; fRendererData: TBoldFollowerDataCom; @@ -164,9 +165,9 @@ TBoldFollowerCom = class(TBoldQueueable) procedure AddToDisplayList; override; procedure Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); {The following two are virtual to allow overriden in the old hierarchy} - procedure MakeUptodateAndSubscribe; // Displays, i.e. moves from B.O. to RendereData, also resubscribes if needed + procedure MakeUptodateAndSubscribe; class procedure MultiMakeUptodateAndSubscribe(Followers: TBoldObjectArray); - procedure MakeClean; // Applies, i.e. moves from rendererdata to B.O. + procedure MakeClean; {State handling} procedure MarkDirty; procedure MarkClean; @@ -285,7 +286,6 @@ TBoldFollowerControllerCom = class(TBoldSubscribablePersistent) published property DragMode: TBoldDragMode read FDragMode write FDragMode default bdgNone; property DropMode: TBoldDropMode read FDropMode write FDropMode default bdpNone; - // property Popup: TBoldPopupCom read fPopup write fPopup; end; { TBoldSingleRendererCom } @@ -312,7 +312,7 @@ TBoldSingleFollowerControllerCom = class(TBoldFollowerControllerCom) { TBoldPopupCom } TBoldPopupCom = class(TPersistent) private - FEnable: Boolean; // FIXME notify owner of change here + FEnable: Boolean; FInsertNew: Boolean; FDelete: TBoldPopupDeleteType; FMove: Boolean; @@ -326,7 +326,7 @@ TBoldPopupCom = class(TPersistent) property Move: Boolean read FMove write FMove default False; end; -{$IFDEF BOLDCOMCLIENT} // List/InterfaceArray +{$IFDEF BOLDCOMCLIENT} type TBoldClientableListCom = TBoldInterfaceArray; @@ -341,10 +341,9 @@ function BoldTestType(element: TObject; TypeOrInterface: TClass): Boolean; implementation uses - BoldRev, BoldExceptionHandlersCom, BoldGuiResourceStringsCom, -{$IFNDEF BOLDCOMCLIENT} // uses +{$IFNDEF BOLDCOMCLIENT} BoldComObjectSpace_TLB, {!! DO NOT REMOVE !! BoldSystemRT ,} BoldGUI, @@ -361,7 +360,7 @@ implementation var DefaultRenderer: TBoldRendererCom; -{$IFDEF BOLDCOMCLIENT} // BoldTestType +{$IFDEF BOLDCOMCLIENT} function BoldTestType(element: IUnknown; const TypeOrInterface: TGUID): Boolean; var Res: IUnknown; @@ -611,7 +610,6 @@ procedure TBoldRendererCom.SetRepresentations(Value: TStrings); end; function TBoldRendererCom.StoreRepresentations: Boolean; - // Don't store the stringlist if it's empty or if it's equal to the default representation stringlist. begin Result := False; if Assigned(FRepresentations) and (FRepresentations.Count > 0) then @@ -627,7 +625,7 @@ class function TBoldRendererCom.GetExpressionAsDirectElement(Element: IBoldEleme begin Result := nil; if Assigned(Element) then - {$IFDEF BOLDCOMCLIENT} // GetAsDirectElement // FIXME: VariableList is lost + {$IFDEF BOLDCOMCLIENT} Result := Element.EvaluateExpression(Expression); {$ELSE} Result := Element.EvaluateExpressionAsDirectElement(Expression, VariableList); @@ -661,7 +659,7 @@ function TBoldRendererCom.DefaultMayModify(Element: IBoldElement; Representation begin ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); if Assigned(ValueElement) then - {$IFDEF BOLDCOMCLIENT} // DefaultMayModify // fixme + {$IFDEF BOLDCOMCLIENT} result := ValueElement.mutable {$ELSE} Result := ValueElement.ObserverMayModify(Subscriber) @@ -671,7 +669,7 @@ function TBoldRendererCom.DefaultMayModify(Element: IBoldElement; Representation end; procedure TBoldRendererCom.DefaultHoldsChangedValue(Element: IBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList; Subscriber: TBoldComClientSubscriber); -{$IFNDEF BOLDCOMCLIENT} // DefaultHoldsChangedValue +{$IFNDEF BOLDCOMCLIENT} var ValueElement: IBoldElement; begin @@ -687,7 +685,7 @@ procedure TBoldRendererCom.DefaultHoldsChangedValue(Element: IBoldElement; Repre {$ENDIF} procedure TBoldRendererCom.DefaultReleaseChangedValue(Element: IBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList; Subscriber: TBoldComClientSubscriber); -{$IFNDEF BOLDCOMCLIENT} // defaultReleaseChangedValue +{$IFNDEF BOLDCOMCLIENT} var ValueElement: IBoldElement; begin @@ -706,8 +704,7 @@ function TBoldRendererCom.MayModify(Element: IBoldElement; Representation: TBold Assigned(Element) then Result := OnMayModify(Element, Representation, Expression, Subscriber) else if HasEventOverrides then - // this forces readonly of renderers that has an OnSubscribeEvent but no OnMayModify - // OnMayModify is mandatory for a writeable renderer. + result := false else Result := DefaultMayModify(Element, Representation, Expression, VariableList, Subscriber) @@ -722,7 +719,7 @@ procedure TBoldRendererCom.HoldsChangedValue(Element: IBoldElement; Representati begin if Assigned(FOnHoldsChangedValue) then OnHoldsChangedValue(Element, Representation, Expression, Subscriber) - else + else DefaultHoldsChangedValue(Element, Representation, Expression, VariableList, Subscriber) end; @@ -735,14 +732,14 @@ procedure TBoldRendererCom.ReleaseChangedValue(Element: IBoldElement; Representa end; procedure TBoldRendererCom.DefaultStartDrag(Element: IBoldElement; DragMode: TBoldDragMode; RendererData: TBoldFollowerDataCom); -{$IFNDEF BOLDCOMCLIENT} // DragDrop +{$IFNDEF BOLDCOMCLIENT} var Obj: IBoldObject; -{$ENDIF} +{$ENDIF} begin - {$IFNDEF BOLDCOMCLIENT} // DragDrop + {$IFNDEF BOLDCOMCLIENT} if BoldGUIHandler.DraggedObjects.Count <> 0 then - raise EBold.CreateFmt(SDraggedObjectsNotCleared, [ClassName]); + raise EBold.Create(SDraggedObjectsNotCleared); if DragMode = bdgSelection then begin @@ -761,14 +758,14 @@ procedure TBoldRendererCom.DefaultStartDrag(Element: IBoldElement; DragMode: TBo procedure TBoldRendererCom.DefaultEndDrag(DragMode: TBoldDragMode; InternalDrag: Boolean); begin - {$IFNDEF BOLDCOMCLIENT} // dragdrop + {$IFNDEF BOLDCOMCLIENT} BoldGUIHandler.DraggedObjects.Clear; {$ENDIF} end; function TBoldRendererCom.DefaultDragOver(Element: IBoldElement; DropMode: TBoldDropMode; InternalDrag: Boolean; RendererData: TBoldFollowerDataCom; dropindex: Integer): Boolean; begin - {$IFDEF BOLDCOMCLIENT} // dragdrop + {$IFDEF BOLDCOMCLIENT} result := false; {$ELSE} Result := Assigned(Element) and Element.ObserverMayModify(Self) and @@ -778,7 +775,7 @@ function TBoldRendererCom.DefaultDragOver(Element: IBoldElement; DropMode: TBold end; procedure TBoldRendererCom.DefaultDragDrop(Element: IBoldElement; DropMode: TBoldDropMode; dropindex: Integer); -{$IFNDEF BOLDCOMCLIENT} // dragdrop +{$IFNDEF BOLDCOMCLIENT} var i: integer; offset, @@ -1009,7 +1006,7 @@ procedure TBoldFollowerCom.SetActive(Value: Boolean); begin Assert(State <> bfsInactiveInvalidElement); SetState(bfsActivating); - MakeUptodateAndSubscribe; //CHECKME This could cause errors if an owning follower is in bfsOutOfDate + MakeUptodateAndSubscribe; MarkClean; end else @@ -1064,9 +1061,9 @@ procedure TBoldFollowerCom.DiscardChange; procedure TBoldFollowerCom.Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); begin -{$IFNDEF BOLDCOMCLIENT} // CHECKME +{$IFNDEF BOLDCOMCLIENT} if (OriginalEvent = beDestroying) and (Originator = Element) then - FElement := nil; //CHECKME Is this necesary? /frha + FElement := nil; {$ENDIF} case RequestedEvent of breReEvaluate: @@ -1116,9 +1113,9 @@ procedure TBoldFollowerCom.ControlledValueChanged(IsChanged: Boolean); begin AssertedController.HoldsChangedValue(Self); MarkDirty; - end; - if AssertedController.ApplyPolicy = bapChange then - Apply; + if AssertedController.ApplyPolicy = bapChange then + Apply; + end end else begin @@ -1129,9 +1126,8 @@ procedure TBoldFollowerCom.ControlledValueChanged(IsChanged: Boolean); procedure TBoldFollowerCom.SetElement(theElement: IBoldElement); begin - // if the fElement is nil and the new element is nil aswell we still need - // to mark the follower out of date since other properties of the controller - // might have changed (especially the nilstringrepresentation) + + if not assigned(theElement) or (theElement <> fElement) then begin fElement := theElement; @@ -1146,7 +1142,7 @@ procedure TBoldFollowerCom.MarkValueOutOfDate; bfsEmpty, bfsCurrent, bfsDirty: SetState(bfsValueOutOfDate); bfsInactiveValidElement, bfsValueOutOfDate, - bfsSubscriptionOutOfDate, bfsActivating: // FIXME bfsActivating is a temporary fix for the delayd fetch problem + bfsSubscriptionOutOfDate, bfsActivating: {no action} else raise EBoldInternal.CreateFmt('%s.MarkOutOfDate: Follower state error', [ClassName]); @@ -1162,12 +1158,9 @@ procedure TBoldFollowerCom.MarkSubscriptionOutOfDate; bfsSubscriptionOutOfDate, bfsActivating : {no action}; - // these two should not happen, but it is safe to ignore them - // a bug in the grid seems to cause these when the grid is not displayed - // right after creation (if it is on an invisible pagecontrol) + bfsInactiveValidElement, bfsInactiveInvalidElement: begin - // DebugCode below - can safely be removed SetState(State);{no action} end else @@ -1202,7 +1195,7 @@ procedure TBoldFollowerCom.SetState(Value: TBoldFollowerState); {action when leaving state} case State of bfsValueOutOfDate, bfsSubscriptionOutOfDate: {bfsOutOfDate} - RemoveFromDisplayList; + RemoveFromDisplayList(false); bfsDirty: RemoveFromApplyList; end; @@ -1276,7 +1269,6 @@ procedure TBoldFollowerCom.Display; on E: Exception do begin if assigned(Controller) and Controller.HandleDisplayException(E, Element) then - // don't re-raise else begin if assigned(Controller) then @@ -1300,12 +1292,11 @@ procedure TBoldFollowerCom.EnsureMulti; try Controller.MultiMakeEnsure(Followers); except - ; // silence any exceptions + ; end end; procedure TBoldFollowerCom.EnsureDisplayable; -//EnsureDisplayable may only be called when within Display or when ALL owning followers not is in bfsOutOfDate! begin if not Displayable then begin @@ -1341,10 +1332,9 @@ procedure TBoldFollowerCom.Apply; function TBoldPopupCom.GetMenu(CONTROL: TControl; Element: IBoldElement): TPopupMenu; begin Result := nil; - {$IFNDEF BOLDCOMCLIENT} // popup + {$IFNDEF BOLDCOMCLIENT} BoldGUIHandler.PopupElement := Element; BoldGUIHandler.PopupControl := CONTROL; - // fixme build actual menu if not Enable then Result := BoldPopupMenu; {$ENDIF} @@ -1395,7 +1385,6 @@ procedure TBoldFollowerCom.SetCurrentIndex(index: integer); procedure TBoldFollowerDataCom.SetCurrentSubFollowerIndex(index: integer); begin - // just ignore; end; function TBoldFollowerControllerCom.GetContextType: IBoldElementTypeInfo; @@ -1467,7 +1456,7 @@ function TBoldFollowerControllerCom.GetVariableListAndSubscribe(Subscriber: TBol result := GetVariableList; {$IFNDEF BOLDCOMCLIENT} if assigned(Subscriber) and assigned(Variables) then - Variables.SubscribeToHandles(Subscriber); + Variables.SubscribeToHandles(Subscriber, Expression); {$ENDIF} end; @@ -1511,7 +1500,7 @@ class procedure TBoldFollowerCom.MultiMakeUptodateAndSubscribe( for I := 0 to Followers.Count - 1 do if TBoldFollowerCom(Followers[i]).State in bfdNeedResubscribe then begin - TBoldFollowerCom(Followers[i]).Subscriber.CancelAllSubscriptions; // CHECKME ever needed? + TBoldFollowerCom(Followers[i]).Subscriber.CancelAllSubscriptions; Controller.AddSmallSubscription(TBoldFollowerCom(Followers[i]).Subscriber, [beValueChanged, beDestroying], breControllerChanged); end; Controller.MultiMakeUptodateAndSubscribe(Followers); @@ -1571,7 +1560,6 @@ function TBoldFollowerControllerCom.HandleApplyException(E: Exception; Elem: IBo procedure TBoldFollowerControllerCom.CleanRendererData(RendererData: TBoldFollowerDataCom); begin - // do nothing end; function TBoldFollowerControllerCom.HandleDisplayException(E: Exception; @@ -1658,4 +1646,3 @@ finalization FreeAndNil(DefaultRenderer); end. - diff --git a/Source/ClientGuiCom/ControlPacks/BoldControllerListControlPackCom.pas b/Source/ClientGuiCom/ControlPacks/BoldControllerListControlPackCom.pas index 470b1af8..8f23f47f 100644 --- a/Source/ClientGuiCom/ControlPacks/BoldControllerListControlPackCom.pas +++ b/Source/ClientGuiCom/ControlPacks/BoldControllerListControlPackCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldControllerListControlPackCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -7,7 +10,7 @@ interface uses Classes, BoldControlPackDefs, - BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, + BoldComObjectSpace_TLB, BoldControlPackCom, BoldListControlPackCom; @@ -79,7 +82,7 @@ procedure TBoldControllerListCom.DoMakeUptodateAndSubscribe(Follower: TBoldFollo inherited DoMakeUptodateAndSubscribe(Follower, Subscribe); (EffectiveRenderer as TBoldControllerListAsFollowerListRendererCom).MakeUptodate(Follower, Follower.Element); if Subscribe and Assigned(Follower.Element) then - {$IFDEF BOLDCOMCLIENT} // MakeUpToDate + {$IFDEF BOLDCOMCLIENT} Follower.Element.SubscribeToExpression('', Follower.Subscriber.ClientId, Follower.Subscriber.SubscriberId, False, true); {$ELSE} Follower.Element.SubscribeToExpression('', Follower.Subscriber, False); @@ -128,7 +131,7 @@ function TBoldControllerListCom.GetEffectiveRenderer: TBoldRendererCom; function TBoldControllerListCom.GetEffectiveDisplayPropertyListRenderer: TBoldControllerListAsFollowerListRendererCom; begin - Result := TBoldControllerListAsFollowerListRendererCom.DefaultRenderer; // currently always uses default. + Result := TBoldControllerListAsFollowerListRendererCom.DefaultRenderer; end; {---TBoldControllerListAsFollowerListRendererCom---} @@ -158,4 +161,3 @@ finalization FreeAndNil(DefaultDisplayPropertyListRenderer); end. - diff --git a/Source/ClientGuiCom/ControlPacks/BoldDateTimeControlPackCom.pas b/Source/ClientGuiCom/ControlPacks/BoldDateTimeControlPackCom.pas index d6583fda..692b4a4e 100644 --- a/Source/ClientGuiCom/ControlPacks/BoldDateTimeControlPackCom.pas +++ b/Source/ClientGuiCom/ControlPacks/BoldDateTimeControlPackCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDateTimeControlPackCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -5,10 +8,11 @@ interface uses - BoldDefs, - BoldSubscription, - BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, - BoldControlPackCom; + BoldClientElementSupport, + BoldComClient, + BoldComObjectSpace_TLB, + BoldControlPackCom, + BoldDefs; type { Forward declarations } @@ -65,7 +69,6 @@ TBoldDateTimeFollowerControllerCom = class(TBoldSingleFollowerControllerCom) function GetEffectiveRenderer: TBoldRendererCom; override; property EffectiveAsDateTimeRenderer: TBoldAsDateTimeRendererCom read GetEffectiveAsDateTimeRenderer; public -// procedure Assign(Source: TPersistent); override; function GetCurrentAsDateTime(Follower: TBoldFollowerCom): TDateTime; procedure MakeClean(Follower: TBoldFollowerCom); override; procedure MayHaveChanged(NewValue: TDateTime; Follower: TBoldFollowerCom); @@ -78,10 +81,7 @@ implementation uses SysUtils, - BoldRev, - BoldControlPackDefs, - {!! DO NOT REMOVE !! BoldAttributes ,} - BoldGuard; + BoldControlPackDefs; var DefaultAsDateTimeRenderer: TBoldAsDateTimeRendererCom = nil; @@ -98,15 +98,14 @@ function TBoldAsDateTimeRendererCom.GetRendererDataClass: TBoldRendererDataClass end; function TBoldAsDateTimeRendererCom.DefaultMayModify(Element: IBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList; Subscriber: TBoldComClientSubscriber): Boolean; -{$IFNDEF BOLDCOMCLIENT} // defaultMayModify +{$IFNDEF BOLDCOMCLIENT} var ValueElement: IBoldElement; -{$ENDIF} +{$ENDIF} begin - {$IFDEF BOLDCOMCLIENT} // defaultMayModify + {$IFDEF BOLDCOMCLIENT} result := inherited DefaultMayModify(Element, Representation, Expression, VariableList, Subscriber); {$ELSE} - // Note! We don't call inherited DefaultMayModify to prevent evaluation of expression two times! ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); result := (ValueElement is TBAMoment) and ValueElement.ObserverMayModify(Subscriber); {$ENDIF} @@ -114,7 +113,7 @@ function TBoldAsDateTimeRendererCom.DefaultMayModify(Element: IBoldElement; Repr function TBoldAsDateTimeRendererCom.DefaultGetAsDateTimeAndSubscribe(Element: IBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList; Subscriber: TBoldComClientSubscriber): TDateTime; var - {$IFDEF BOLDCOMCLIENT} // DefaultGet + {$IFDEF BOLDCOMCLIENT} el: IBoldElement; attr: IBoldAttribute; {$ELSE} @@ -125,7 +124,7 @@ function TBoldAsDateTimeRendererCom.DefaultGetAsDateTimeAndSubscribe(Element: IB Result := 0; if Assigned(Element) then begin - {$IFDEF BOLDCOMCLIENT} //defaultGet + {$IFDEF BOLDCOMCLIENT} if assigned(Subscriber) then el := Element.EvaluateAndSubscribeToExpression(Expression, Subscriber.ClientId, Subscriber.SubscriberId, false, false) else @@ -158,13 +157,13 @@ function TBoldAsDateTimeRendererCom.DefaultGetAsDateTimeAndSubscribe(Element: IB procedure TBoldAsDateTimeRendererCom.DefaultSetAsDateTime(Element: IBoldElement; const Value: TDateTime; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList); var - {$IFDEF BOLDCOMCLIENT} // defaultSet + {$IFDEF BOLDCOMCLIENT} Attr: IBoldAttribute; {$ENDIF} ValueElement: IBoldElement; begin ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); - {$IFDEF BOLDCOMCLIENT} // defaultSet + {$IFDEF BOLDCOMCLIENT} if assigned(ValueElement) and (ValueElement.QueryInterface(IBoldAttribute, Attr) = S_OK) then Attr.AsVariant := Value else @@ -260,7 +259,7 @@ function TBoldDateTimeFollowerControllerCom.GetEffectiveAsDateTimeRenderer: TBol if Assigned(Renderer) then Result := Renderer else - Result := DefaultAsDateTimeRenderer; //FIXME + Result := DefaultAsDateTimeRenderer; end; procedure TBoldDateTimeFollowerControllerCom.MakeClean(Follower: TBoldFollowerCom); @@ -286,7 +285,7 @@ procedure TBoldDateTimeFollowerControllerCom.MayHaveChanged(NewValue: TDateTime; (Follower.RendererData as TBoldDateTimeRendererDataCom).CurrentDateTimeValue := NewValue; Follower.ControlledValueChanged(EffectiveAsDateTimeRenderer.IsChanged(Follower.RendererData as TBoldDateTimeRendererDataCom, NewValue, Representation, Expression, VariableList)); end; -end; +end; initialization DefaultAsDateTimeRenderer := TBoldAsDateTimeRendererCom.Create(nil); diff --git a/Source/ClientGuiCom/ControlPacks/BoldElementHandleFollowerCom.pas b/Source/ClientGuiCom/ControlPacks/BoldElementHandleFollowerCom.pas index 1e38dbb3..115ea1f6 100644 --- a/Source/ClientGuiCom/ControlPacks/BoldElementHandleFollowerCom.pas +++ b/Source/ClientGuiCom/ControlPacks/BoldElementHandleFollowerCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldElementHandleFollowerCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -44,11 +47,9 @@ TBoldElementHandleFollowerCom = class(TBoldQueueable) implementation uses - SysUtils, - BoldRev, - BoldUtils, BoldControlPackDefs, - BoldDefs; + BoldDefs, + SysUtils; { TBoldElementHandleFollowerCom } @@ -83,7 +84,6 @@ procedure TBoldElementHandleFollowerCom.SetBoldHandle(value: TBoldElementHandleC if (value <> BoldHandle) then begin fBoldHandle := Value; - // will force subscription on Handle FollowerValueCurrent := false; end; end; @@ -130,7 +130,7 @@ procedure TBoldElementHandleFollowerCom.SetFollowerValueCurrent(value: Boolean); begin if Value then begin - RemoveFromDisplayList; + RemoveFromDisplayList(false); PropagateValue; Subscribe; end @@ -146,6 +146,4 @@ procedure TBoldElementHandleFollowerCom.SetFollowerValueCurrent(value: Boolean); end; -initialization end. - diff --git a/Source/ClientGuiCom/ControlPacks/BoldFloatControlPackCom.pas b/Source/ClientGuiCom/ControlPacks/BoldFloatControlPackCom.pas index 1d7234b3..2c31dd5e 100644 --- a/Source/ClientGuiCom/ControlPacks/BoldFloatControlPackCom.pas +++ b/Source/ClientGuiCom/ControlPacks/BoldFloatControlPackCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldFloatControlPackCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -65,7 +68,6 @@ TBoldFloatFollowerControllerCom = class(TBoldSingleFollowerControllerCom) property EffectiveAsFloatRenderer: TBoldAsFloatRendererCom read GetEffectiveAsFloatRenderer; function GetEffectiveRenderer: TBoldRendererCom; override; public -// procedure Assign(Source: TPersistent); override; function GetCurrentAsFloat(Follower: TBoldFollowerCom): double; procedure MakeClean(Follower: TBoldFollowerCom); override; procedure MayHaveChanged(NewValue: double; Follower: TBoldFollowerCom); @@ -78,10 +80,9 @@ implementation uses SysUtils, - BoldRev, BoldUtils, {!! DO NOT REMOVE !! BoldAttributes ,} - BoldControlPackDefs, + BoldControlPackDefs, BoldGuard; var @@ -99,15 +100,14 @@ function TBoldAsFloatRendererCom.GetRendererDataClass: TBoldRendererDataClassCom end; function TBoldAsFloatRendererCom.DefaultMayModify(Element: IBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList; Subscriber: TBoldComClientSubscriber): Boolean; -{$IFNDEF BOLDCOMCLIENT} // defaultMayModify +{$IFNDEF BOLDCOMCLIENT} var ValueElement: IBoldElement; {$ENDIF} begin - {$IFDEF BOLDCOMCLIENT} // defaultMayModify + {$IFDEF BOLDCOMCLIENT} result := inherited DefaultMayModify(Element, Representation, Expression, VariableList, Subscriber); {$ELSE} - // Note! We don't call inherited DefaultMayModify to prevent evaluation of expression two times! ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); result := ((ValueElement is TBAFloat) or (ValueElement is TBADateTime)) and ValueElement.ObserverMayModify(Subscriber) {$ENDIF} @@ -115,7 +115,7 @@ function TBoldAsFloatRendererCom.DefaultMayModify(Element: IBoldElement; Represe function TBoldAsFloatRendererCom.DefaultGetAsFloatAndSubscribe(Element: IBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList; Subscriber: TBoldComClientSubscriber): double; var - {$IFDEF BOLDCOMCLIENT} // defaultGet + {$IFDEF BOLDCOMCLIENT} el: IBoldElement; attr: IBoldAttribute; {$ELSE} @@ -126,7 +126,7 @@ function TBoldAsFloatRendererCom.DefaultGetAsFloatAndSubscribe(Element: IBoldEle Result := 0; if Assigned(Element) then begin - {$IFDEF BOLDCOMCLIENT} // defaultGet + {$IFDEF BOLDCOMCLIENT} if assigned(Subscriber) then el := Element.EvaluateAndSubscribeToExpression(Expression, Subscriber.ClientId, Subscriber.SubscriberId, false, false) else @@ -159,12 +159,12 @@ function TBoldAsFloatRendererCom.DefaultGetAsFloatAndSubscribe(Element: IBoldEle procedure TBoldAsFloatRendererCom.DefaultSetAsFloat(Element: IBoldElement; const Value: double; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList); var ValueElement: IBoldElement; - {$IFDEF BOLDCOMCLIENT} // defaultSet + {$IFDEF BOLDCOMCLIENT} attr: IBoldAttribute; {$ENDIF} begin ValueElement := GetExpressionAsDirectElement(Element, Expression , VariableList); - {$IFDEF BOLDCOMCLIENT} // defaultSet + {$IFDEF BOLDCOMCLIENT} if assigned(ValueElement) and (ValueElement.QueryInterface(IBoldAttribute, attr) = S_OK) then Attr.AsVariant := Value else diff --git a/Source/ClientGuiCom/ControlPacks/BoldGenericListControlPackCom.pas b/Source/ClientGuiCom/ControlPacks/BoldGenericListControlPackCom.pas index fef43bf1..bc1efc06 100644 --- a/Source/ClientGuiCom/ControlPacks/BoldGenericListControlPackCom.pas +++ b/Source/ClientGuiCom/ControlPacks/BoldGenericListControlPackCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldGenericListControlPackCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -5,12 +8,16 @@ interface uses + // VCL Classes, - BoldDefs, - BoldSubscription, - BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, + + // Bold + BoldComClient, + BoldComObjectSpace_TLB, BoldControlPackCom, - BoldListControlPackCom; + BoldDefs, + BoldListControlPackCom, + BoldSubscription; type { forward declarations } @@ -30,9 +37,9 @@ TBoldFollowerListWithOwnedListCom = class; TGetFollowerControllerEventCom = function (Element: IBoldElement; Subscriber: TBoldComClientSubscriber; GetFollowerControllerByName: TGetFollowerControllerByNameEventCom): TBoldFollowerControllerCom of object; {$ENDIF} - {$IFNDEF BOLDCOMCLIENT} // GetElementEvent + {$IFNDEF BOLDCOMCLIENT} TGetElementEvent = procedure (Sender: TBoldGenericListPartCom; Element: IBoldElement; Subscriber: TBoldComClientSubscriber; ResultElement: TBoldIndirectElement; Resubscribe: Boolean) of object; - {$ENDIF} + {$ENDIF} { TBoldFollowerListWithOwnedListCom } TBoldFollowerListWithOwnedListCom = class (TBoldFollowerListCom) @@ -51,7 +58,7 @@ TBoldGenericListPartCom = class(TCollectionItem) FElementExpression: TBoldExpression; FControllerExpression: TBoldExpression; FInterpretAsList: Boolean; - {$IFNDEF BOLDCOMCLIENT} // GetElementEvent + {$IFNDEF BOLDCOMCLIENT} FOnGetElement: TGetElementEvent; {$ENDIF} FOnGetFollowerController: TGetFollowerControllerEventCom; @@ -68,9 +75,9 @@ TBoldGenericListPartCom = class(TCollectionItem) property Publisher: TBoldPublisher read GetPublisher; public constructor Create(Collection: TCollection); override; - destructor Destroy; override; + destructor destroy; override; procedure Assign(Source: TPersistent); override; - {$IFDEF BOLDCOMCLIENT} // GetElementEvent + {$IFDEF BOLDCOMCLIENT} function GetElement(Element: IBoldElement; Subscriber: TBoldComClientSubscriber; Resubscribe: Boolean): IBoldElement; {$ELSE} procedure DefaultGetElement(Element: IBoldElement; Subscriber: TBoldComClientSubscriber; ResultElement: TBoldIndirectElement; Resubscribe: Boolean); @@ -85,7 +92,7 @@ TBoldGenericListPartCom = class(TCollectionItem) property InterpretAsList: Boolean read FInterpretAsList write SetInterpretAsList; property Name: String read fName write fName; property Enabled: Boolean read fEnabled write SetEnabled default true; - {$IFNDEF BOLDCOMCLIENT} // GetElementEvent + {$IFNDEF BOLDCOMCLIENT} property OnGetElement: TGetElementEvent read FOnGetElement write FOnGetElement; {$ENDIF} property OnGetFollowerController: TGetFollowerControllerEventCom read FOnGetFollowerController write FOnGetFollowerController; @@ -145,15 +152,12 @@ TBoldGenericListControllerCom = class(TBoldAsFollowerListControllerCom) implementation uses - SysUtils, - BoldRev, - BoldUtils, - BoldContainers, - BoldControlPackDefs, - {$IFNDEF BOLDCOMCLIENT} // uses + {$IFNDEF BOLDCOMCLIENT} BoldComObjectSpace_TLB, {$ENDIF} - BoldNodeControlPackCom; + SysUtils, + BoldContainers, + BoldControlPackDefs; var DefaultGenericAsListRenderer: TBoldGenericAsListRendererCom; @@ -197,7 +201,7 @@ procedure TBoldGenericListPartCom.Assign(Source: TPersistent); ElementExpression := TBoldGenericListPartCom(Source).ElementExpression; ControllerExpression := TBoldGenericListPartCom(Source).ControllerExpression; InterpretAsList := TBoldGenericListPartCom(Source).InterpretAsList; - {$IFNDEF BOLDCOMCLIENT} // GetElementEvent + {$IFNDEF BOLDCOMCLIENT} OnGetElement := TBoldGenericListPartCom(Source).OnGetElement; {$ENDIF} OnGetFollowerController := TBoldGenericListPartCom(Source).OnGetFollowerController; @@ -233,7 +237,7 @@ procedure TBoldGenericListPartCom.SetInterpretAsList(Value: Boolean); end; end; -{$IFDEF BOLDCOMCLIENT} // GetElementEvent +{$IFDEF BOLDCOMCLIENT} function TBoldGenericListPartCom.GetElement(Element: IBoldElement; Subscriber: TBoldComClientSubscriber; Resubscribe: Boolean): IBoldElement; begin if Assigned(Element) then @@ -268,7 +272,7 @@ procedure TBoldGenericListPartCom.GetElement(Element: IBoldElement; Subscriber: function TBoldGenericListPartCom.DefaultGetFollowerController(Element: IBoldElement; Subscriber: TBoldComClientSubscriber; GetFollowerControllerByName: TGetFollowerControllerByNameEventCom): TBoldFollowerControllerCom; var -{$IFDEF BOLDCOMCLIENT} // DefaultGet +{$IFDEF BOLDCOMCLIENT} e: IBoldElement; {$ELSE} E: TBoldIndirectElement; @@ -296,7 +300,7 @@ function LoopList(List: IBoldList): TBoldFollowerControllerCom; begin Result := nil; - {$IFDEF BOLDCOMCLIENT} // DefaultGet + {$IFDEF BOLDCOMCLIENT} e := Element.EvaluateAndSubscribeToExpression(ControllerExpression, Subscriber.ClientId, Subscriber.SubscriberId, False, false); if Assigned(E) then begin @@ -466,7 +470,7 @@ procedure TBoldGenericAsListRendererCom.MakeUptodate(Follower: TBoldFollowerCom; {$IFDEF BOLDCOMCLIENT} begin element := part.GetElement(Follower.Element, Follower.Subscriber, False); - result := assigned(element); // fixme: true or false? + result := assigned(element); end; {$ELSE} var @@ -499,7 +503,7 @@ procedure TBoldGenericAsListRendererCom.MakeUptodate(Follower: TBoldFollowerCom; DestList.AddOwnedElement(Element); if Assigned(Element) then begin - {$IFDEF BOLDCOMCLIENT} // listconverting + {$IFDEF BOLDCOMCLIENT} Element.QueryInterface(IBoldList, SourceList); {$ELSE} if element is IBoldList then @@ -553,7 +557,7 @@ procedure TBoldGenericListPartCom.SetEnabled(const Value: Boolean); end; end; -destructor TBoldGenericListPartCom.Destroy; +destructor TBoldGenericListPartCom.destroy; begin if assigned(fPublisher) then fPublisher.NotifySubscribersAndClearSubscriptions(self); diff --git a/Source/ClientGuiCom/ControlPacks/BoldListControlPackCom.pas b/Source/ClientGuiCom/ControlPacks/BoldListControlPackCom.pas index fe4be017..7e61c427 100644 --- a/Source/ClientGuiCom/ControlPacks/BoldListControlPackCom.pas +++ b/Source/ClientGuiCom/ControlPacks/BoldListControlPackCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldListControlPackCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -5,13 +8,11 @@ interface uses - BoldDefs, Classes, - BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, - {$IFNDEF BOLDCOMCLIENT} // uses + BoldComObjectSpace_TLB, + {$IFNDEF BOLDCOMCLIENT} BoldComObjectSpace_TLB, {$ENDIF} - BoldSubscription, BoldControlPackCom; type @@ -65,7 +66,6 @@ TBoldFollowerListCom = class(TBoldFollowerDataCom) function GetSelectedCount: Integer; procedure SetSelected(index: Integer; V: Boolean); function GetSelected(index: Integer): Boolean; -// procedure UnselectPrev; procedure Insert(ListFollowerController: TBoldAsFollowerListControllerCom; Index: Integer; Follower: TBoldFollowerCom); procedure Delete(ListFollowerController: TBoldAsFollowerListControllerCom; index: Integer); protected @@ -99,7 +99,7 @@ implementation uses SysUtils, - BoldRev, + BoldSubscription, BoldUtils; {---TBoldAsFollowerListControllerCom---} @@ -135,7 +135,7 @@ procedure TBoldAsFollowerListControllerCom.DoAfterDeleteItem(index: Integer; Own procedure TBoldAsFollowerListControllerCom.SetActiveRange(Follower: TBoldFollowerCom; FirstActive, LastActive: Integer; RangeBuffer: Integer = 1); begin - if Assigned(EffectiveRenderer) then // may be nil after finalization + if Assigned(EffectiveRenderer) then (EffectiveRenderer as TBoldAsFollowerListRendererCom).SetActiveRange(Follower, FirstActive, LastActive, RangeBuffer); end; @@ -368,6 +368,4 @@ procedure TBoldAsFollowerListControllerCom.CleanRendererData(RendererData: TBold (RendererData as TBoldFollowerListCom).PurgeEnd(self, 0); end; -initialization end. - diff --git a/Source/ClientGuiCom/ControlPacks/BoldListHandleFollowerCom.pas b/Source/ClientGuiCom/ControlPacks/BoldListHandleFollowerCom.pas index 343dbd39..7f8bc34e 100644 --- a/Source/ClientGuiCom/ControlPacks/BoldListHandleFollowerCom.pas +++ b/Source/ClientGuiCom/ControlPacks/BoldListHandleFollowerCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldListHandleFollowerCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -14,8 +17,6 @@ interface BoldListListControlPackCom, BoldAbstractListHandleCom; -// Note, Currently subscibes to value-identity-change via element of handle, until -// subscribability has been added to the handle. type { forward declarations } @@ -45,15 +46,13 @@ TBoldListHandleFollowerCom = class(TBoldQueueable) property Follower: TBoldFollowerCom read fFollower; constructor Create(MatchObject: TObject; Controller: TBoldAbstractListAsFollowerListControllerCom); destructor Destroy; override; - end; + end; implementation uses SysUtils, BoldControlPackDefs, - BoldRev, - BoldUtils, BoldDefs; { TBoldElementHandleFollowerCom } @@ -84,7 +83,7 @@ constructor TBoldListHandleFollowerCom.Create(MatchObject: TObject; destructor TBoldListHandleFollowerCom.Destroy; begin FreeAndNil(fFollower); - FreeAndNil(fSubscriber); + FreeAndNil(fSubscriber); inherited; end; @@ -94,7 +93,6 @@ procedure TBoldListHandleFollowerCom.SetBoldHandle( if (value <> BoldHandle) then begin fBoldHandle := Value; - // will force subscription on Handle FollowerValueCurrent := false; end; end; @@ -134,8 +132,8 @@ procedure TBoldListHandleFollowerCom.SetFollowerValueCurrent(value: Boolean); begin if Assigned(BoldHandle) then begin - BoldHandle.AddSmallSubscription(Subscriber, [beValueIdentityChanged], breListIdentityChanged); // FIXME - BoldHandle.AddSmallSubscription(Subscriber, [beValueIdentityChanged], breHandleIndexChanged); // FIXME + BoldHandle.AddSmallSubscription(Subscriber, [beValueIdentityChanged], breListIdentityChanged); + BoldHandle.AddSmallSubscription(Subscriber, [beValueIdentityChanged], breHandleIndexChanged); end; end; @@ -151,7 +149,7 @@ procedure TBoldListHandleFollowerCom.SetFollowerValueCurrent(value: Boolean); if Value then begin PropagateValue; - RemoveFromDisplayList; + RemoveFromDisplayList(false); Subscribe; end else @@ -179,6 +177,4 @@ procedure TBoldListHandleFollowerCom.SetFollowerIndex(index: integer); end; -initialization end. - diff --git a/Source/ClientGuiCom/ControlPacks/BoldListListControlPackCom.pas b/Source/ClientGuiCom/ControlPacks/BoldListListControlPackCom.pas index 8c102635..1ef31c81 100644 --- a/Source/ClientGuiCom/ControlPacks/BoldListListControlPackCom.pas +++ b/Source/ClientGuiCom/ControlPacks/BoldListListControlPackCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldListListControlPackCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -6,10 +9,11 @@ interface uses Classes, - BoldDefs, - BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, - BoldControlPackDefs, + + // Bold + BoldComObjectSpace_TLB, BoldControlPackCom, + BoldControlPackDefs, BoldListControlPackCom; type @@ -42,8 +46,7 @@ TBoldAbstractListAsFollowerListControllerCom = class(TBoldAsFollowerListContro property NilElementMode: TBoldNilElementMode read fNilElementMode write SetNilElementMode; public constructor Create(aOwningComponent: TComponent; FollowerController: TBoldFollowerControllerCom); -// procedure DragDrop(Follower: TBoldFollowerCom; ReceivingElement: IBoldElement; dropindex: Integer); override; -// function DragOver(Follower: TBoldFollowerCom; ReceivingElement: IBoldElement; dropindex: Integer): Boolean; override; + function GetListIndex(Follower: TBoldFollowerCom): Integer; function ListIndexToIndex(Follower: TBoldFollowerCom; ListIndex: Integer): integer; function ListIndex(index: integer): integer; @@ -75,13 +78,11 @@ implementation uses SysUtils, - BoldRev, - BoldUtils, - {$IFNDEF BOLDCOMCLIENT} // uses + {$IFNDEF BOLDCOMCLIENT} BoldComObjectSpace_TLB, BoldGUI, {$ENDIF} - BoldMath; + BoldRev; var DefaultListAsFollowerListRenderer: TBoldListAsFollowerListRendererCom; @@ -135,7 +136,7 @@ procedure TBoldAbstractListAsFollowerListControllerCom.DoMakeUptodateAndSubscrib begin inherited DoMakeUptodateAndSubscribe(Follower, Subscribe); (EffectiveRenderer as TBoldListAsFollowerListRendererCom).MakeUptodate(Follower, fFollowerController); - {$IFDEF BOLDCOMCLIENT} // MakeUptodateAndSubscribe + {$IFDEF BOLDCOMCLIENT} if Subscribe and Assigned(Follower.Element) then Follower.Element.SubscribeToExpression('', Follower.Subscriber.ClientId, Follower.Subscriber.SubscriberId, false, false); {$ELSE} @@ -291,7 +292,7 @@ procedure TBoldListAsFollowerListRendererCom.MakeUptodate(Follower: TBoldFollowe unk := SourceVariant[SourceIndex]; ElementInterface := unk as IBoldElement; AddElement(ElementInterface); - end + end {$ENDIF} else begin @@ -305,12 +306,12 @@ procedure TBoldListAsFollowerListRendererCom.MakeUptodate(Follower: TBoldFollowe end; procedure TBoldListAsFollowerListRendererCom.DefaultStartDrag(Element: IBoldElement; DragMode: TBoldDragMode; RendererData: TBoldFollowerDataCom); -{$IFNDEF BOLDCOMCLIENT} // dragdrop - DefaultStartDrag +{$IFNDEF BOLDCOMCLIENT} var FollowerList: TBoldFollowerListCom; {$ENDIF} begin - {$IFNDEF BOLDCOMCLIENT} // dragdrop - DefaultStartDrag + {$IFNDEF BOLDCOMCLIENT} if (DragMode = bdgSelection) then begin if BoldGUIHandler.DraggedObjects.Count <> 0 then @@ -324,16 +325,16 @@ procedure TBoldListAsFollowerListRendererCom.DefaultStartDrag(Element: IBoldElem function TBoldListAsFollowerListRendererCom.DefaultDragOver(Element: IBoldElement; DropMode: TBoldDropMode; InternalDrag: Boolean; RendererData: TBoldFollowerDataCom; dropindex: Integer): Boolean; begin - {$IFNDEF BOLDCOMCLIENT} // dragdrop - DefaultDragOver + {$IFNDEF BOLDCOMCLIENT} Result := (BoldGUIHandler.DraggedObjects.Count > 0) and - BoldGUIHandler.DraggedObjectsAssignable(Element, DropMode); // FIXME move here + BoldGUIHandler.DraggedObjectsAssignable(Element, DropMode); {$ELSE} result := false; {$ENDIF} end; procedure TBoldListAsFollowerListRendererCom.DefaultDragDrop(Element: IBoldElement; DropMode: TBoldDropMode; dropindex: Integer); -{$IFNDEF BOLDCOMCLIENT} // dragdrop - DefaultDragDrop +{$IFNDEF BOLDCOMCLIENT} var prevIndex, Offset, @@ -344,7 +345,7 @@ procedure TBoldListAsFollowerListRendererCom.DefaultDragDrop(Element: IBoldEleme (* if (NilElementMode=neInsertFirst) then Offset := 1 - else*) //FIXME + else*) Offset := 0; case DropMode of bdpInsert: @@ -376,7 +377,6 @@ procedure TBoldListAsFollowerListRendererCom.DefaultDragDrop(Element: IBoldEleme bdpAppend: for I := 0 to BoldGUIHandler.DraggedObjects.Count - 1 do - // Dupe checking by the ObjectList ObjectList.Add(BoldGUIHandler.DraggedObjects[I]); bdpReplace: @@ -399,7 +399,7 @@ function TBoldAbstractListAsFollowerListControllerCom.ListIndexToIndex(Follower: function TBoldAbstractListAsFollowerListControllerCom.ListIndex(index: integer): integer; begin if index = MaxInt then - result := index // otherwise the result will overflow to -maxint + result := index else if NilElementMode = neInsertFirst then Result := index + 1 else @@ -411,6 +411,5 @@ initialization finalization FreeAndNil(DefaultListAsFollowerListRenderer); - + end. - diff --git a/Source/ClientGuiCom/ControlPacks/BoldNodeControlPackCom.pas b/Source/ClientGuiCom/ControlPacks/BoldNodeControlPackCom.pas index 16ad2044..56db26bf 100644 --- a/Source/ClientGuiCom/ControlPacks/BoldNodeControlPackCom.pas +++ b/Source/ClientGuiCom/ControlPacks/BoldNodeControlPackCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldNodeControlPackCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 14:59:57} @@ -6,17 +9,13 @@ interface uses Classes, - BoldDefs, - BoldControlPackDefs, BoldControlPackCom, BoldStringControlPackCom, BoldNumericControlPackCom, - BoldListControlPackCom, BoldControllerListControlPackCom, BoldGenericListControlPackCom, - BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, + BoldComObjectSpace_TLB; {!! DO NOT REMOVE !! BoldSystemRT ,} - BoldSubscription; type { Forward declarations } @@ -143,9 +142,11 @@ implementation uses SysUtils, - BoldRev, + BoldControlPackDefs, + BoldDefs, BoldGuiResourceStringsCom, - BoldUtils; + BoldListControlPackCom, + BoldSubscription; {-- TBoldTreeFollowerControllerCom --} @@ -320,7 +321,6 @@ function TBoldNodeDescriptionCom.GetBoldNodeFollowerControllerClass:TBoldNodeFol destructor TBoldNodeDescriptionCom.Destroy; begin - // FIXME ??? FreePublisher; //CHECKME Is this really needed? FreeAndNil(FNodeFollowerController); inherited Destroy; end; @@ -442,7 +442,7 @@ procedure TBoldNodeFollowerControllerCom.SetHideNodeWithNoChildren(Value: Boolea destructor TBoldNodeFollowerControllerCom.Destroy; begin - FreePublisher; //CHECKME Is this really needed? + FreePublisher; inherited Destroy; end; @@ -499,7 +499,4 @@ function TBoldNodeDescriptionCom.GetContextType: IBoldElementTypeInfo; result := nil; end; -initialization end. - - diff --git a/Source/ClientGuiCom/ControlPacks/BoldNumericControlPackCom.pas b/Source/ClientGuiCom/ControlPacks/BoldNumericControlPackCom.pas index f5703dc2..85d7d0f1 100644 --- a/Source/ClientGuiCom/ControlPacks/BoldNumericControlPackCom.pas +++ b/Source/ClientGuiCom/ControlPacks/BoldNumericControlPackCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldNumericControlPackCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 14:59:57} @@ -5,15 +8,13 @@ interface uses - BoldDefs, - BoldSubscription, - BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, - BoldControlPackCom; - -//TODO: Implement AsFloatRenderer. -//TODO: Find default numeric representation for class + BoldClientElementSupport, + BoldComClient, + BoldComObjectSpace_TLB, + BoldControlPackCom, + BoldDefs; -type +type {Forward declarations} TBoldIntegerRendererDataCom = class; TBoldAsIntegerRendererCom = class; @@ -50,7 +51,7 @@ TBoldAsIntegerRendererCom = class(TBoldSingleRendererCom) class function DefaultRenderer: TBoldAsIntegerRendererCom; function DefaultIsChanged(RendererData: TBoldIntegerRendererDataCom; const NewValue: Integer; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList): Boolean; function DefaultMayModify(Element: IBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList; Subscriber: TBoldComClientSubscriber): Boolean; override; - procedure MakeUptodateAndSubscribe(Element: IBoldElement; RendererData: TBoldFollowerDataCom; FollowerController: TBoldFollowerControllerCom; Subscriber: TBoldComClientSubscriber); override; + procedure MakeUpToDateAndSubscribe(Element: IBoldElement; RendererData: TBoldFollowerDataCom; FollowerController: TBoldFollowerControllerCom; Subscriber: TBoldComClientSubscriber); override; function IsChanged(RendererData: TBoldIntegerRendererDataCom; const NewValue: Integer; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList): Boolean; published property OnGetAsInteger: TBoldGetAsIntegerEventCom read FOnGetAsInteger write FOnGetAsInteger; @@ -80,8 +81,6 @@ implementation uses SysUtils, - BoldRev, - BoldUtils, BoldGuiResourceStringsCom, {!! DO NOT REMOVE !! BoldAttributes ,} BoldControlPackDefs; @@ -101,11 +100,10 @@ function TBoldAsIntegerRendererCom.GetRendererDataClass: TBoldRendererDataClassC end; function TBoldAsIntegerRendererCom.DefaultMayModify(Element: IBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList; Subscriber: TBoldComClientSubscriber): Boolean; -{$IFNDEF BOLDCOMCLIENT} // defaultMayModify +{$IFNDEF BOLDCOMCLIENT} var ValueElement: IBoldElement; begin - // Note! We don't call inherited DefaultMayModify to prevent evaluation of expression two times! ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); result := (ValueElement is TBANumeric) and ValueElement.ObserverMayModify(Subscriber) end; @@ -117,7 +115,7 @@ function TBoldAsIntegerRendererCom.DefaultMayModify(Element: IBoldElement; Repre function TBoldAsIntegerRendererCom.DefaultGetAsIntegerAndSubscribe(Element: IBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList; Subscriber: TBoldComClientSubscriber): Integer; var - {$IFDEF BOLDCOMCLIENT} // defaultGet + {$IFDEF BOLDCOMCLIENT} el: IBoldElement; attr: IBoldAttribute; {$ELSE} @@ -127,7 +125,7 @@ function TBoldAsIntegerRendererCom.DefaultGetAsIntegerAndSubscribe(Element: IBol Result := 0; if Assigned(Element) then begin - {$IFDEF BOLDCOMCLIENT} // defaultGet + {$IFDEF BOLDCOMCLIENT} if assigned(Subscriber) then el := Element.EvaluateAndSubscribeToExpression(Expression, Subscriber.ClientId, Subscriber.SubscriberId, false, false) else @@ -159,12 +157,12 @@ function TBoldAsIntegerRendererCom.DefaultGetAsIntegerAndSubscribe(Element: IBol procedure TBoldAsIntegerRendererCom.DefaultSetAsInteger(Element: IBoldElement; const Value: Integer; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList); var ValueElement: IBoldElement; - {$IFDEF BOLDCOMCLIENT} // defaultSet + {$IFDEF BOLDCOMCLIENT} Attr: IBoldAttribute; {$ENDIF} begin ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); - {$IFDEF BOLDCOMCLIENT} // defaultSet + {$IFDEF BOLDCOMCLIENT} if assigned(ValueElement) and (ValueElement.QueryInterface(IBoldAttribute, attr) = S_OK) then attr.AsVariant := Value else @@ -248,7 +246,7 @@ function TBoldIntegerFollowerControllerCom.GetEffectiveAsIntegerRenderer: TBoldA if Assigned(Renderer) then Result := Renderer else - Result := DefaultAsIntegerRenderer; //FIXME + Result := DefaultAsIntegerRenderer; end; procedure TBoldIntegerFollowerControllerCom.MakeClean(Follower: TBoldFollowerCom); @@ -283,4 +281,3 @@ finalization FreeAndNil(DefaultAsIntegerRenderer); end. - diff --git a/Source/ClientGuiCom/ControlPacks/BoldStringControlPackCom.pas b/Source/ClientGuiCom/ControlPacks/BoldStringControlPackCom.pas index 2367cb47..333a194e 100644 --- a/Source/ClientGuiCom/ControlPacks/BoldStringControlPackCom.pas +++ b/Source/ClientGuiCom/ControlPacks/BoldStringControlPackCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldStringControlPackCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -5,14 +8,18 @@ interface uses - Graphics, + // VCL Classes, + Graphics, Windows, - BoldDefs, + + // Bold + BoldClientElementSupport, + BoldComClient, + BoldComObjectSpace_TLB, BoldContainers, - BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, BoldControlPackCom, - BoldSubscription; + BoldDefs; type {Forward declaration of classes} @@ -70,7 +77,7 @@ TBoldAsStringRendererCom = class(TBoldSingleRendererCom) function IsChanged(RendererData: TBoldStringRendererDataCom; NewValue: string; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList): Boolean; procedure SetFont(Element: IBoldElement; EffectiveFont, Font: TFont; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList); procedure SetColor(Element: IBoldElement; var EffectiveColor: TColor; Color: TColor; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList); - procedure MakeUptodateAndSubscribe(Element: IBoldElement; RendererData: TBoldFollowerDataCom; FollowerController: TBoldFollowerControllerCom; Subscriber: TBoldComClientSubscriber); override; + procedure MakeUpToDateAndSubscribe(Element: IBoldElement; RendererData: TBoldFollowerDataCom; FollowerController: TBoldFollowerControllerCom; Subscriber: TBoldComClientSubscriber); override; procedure MultiMakeUpToDateAndSubscribe(Elements: TBoldClientableListCom; Subscribers: TBoldObjectArray; RendererData: TBoldObjectArray; FollowerController: TBoldFollowerControllerCom); procedure DefaultMakeUptodateAndSetMayModifyAndSubscribe(Element: IBoldElement; RendererData: TBoldFollowerDataCom; FollowerController: TBoldStringFollowerControllerCom; Subscriber: TBoldComClientSubscriber); virtual; published @@ -101,7 +108,7 @@ TBoldStringFollowerControllerCom = class(TBoldSingleFollowerControllerCom) function GetCurrentAsString(Follower: TBoldFollowerCom): string; procedure SetAsString(Value: string; Follower: TBoldFollowerCom); function ValidateCharacter(C: AnsiChar; Follower: TBoldFollowerCom): Boolean; - function ValidateString(Value: string; Follower: TBoldFollowerCom): Boolean; + function ValidateString(const Value: string; Follower: TBoldFollowerCom): Boolean; procedure SetFont(EffectiveFont, Font: tFont; Follower: TBoldFollowerCom); procedure SetColor(var EffectiveColor: tColor; COLOR: tColor; Follower: TBoldFollowerCom); procedure MayHaveChanged(NewValue: string; Follower: TBoldFollowerCom); @@ -116,12 +123,13 @@ implementation uses SysUtils, + BoldSubscription, BoldControlPackDefs, {$IFNDEF BOLDCOMCLIENT} - BoldComObjectSpace_TLB, // IFNDEF BOLDCOMCLIENT + BoldComObjectSpace_TLB, BoldDomainElement, {$ELSE} - Variants, // IFDEF BOLDCOMCLIENT + Variants, {$ENDIF} BoldRev; @@ -168,7 +176,7 @@ function TBoldStringFollowerControllerCom.ValidateCharacter(C: AnsiChar; Followe Result := EffectiveAsStringRenderer.ValidateCharacter(Follower.Element, C, Representation, Expression, VariableList); end; -function TBoldStringFollowerControllerCom.ValidateString(Value: string; Follower: TBoldFollowerCom): Boolean; +function TBoldStringFollowerControllerCom.ValidateString(const Value: string; Follower: TBoldFollowerCom): Boolean; begin Result := EffectiveAsStringRenderer.ValidateString(Follower.Element, Value, Representation, Expression, VariableList); end; @@ -201,7 +209,7 @@ procedure TBoldStringFollowerControllerCom.MakeClean(Follower: TBoldFollowerCom) begin if ValidateString(GetCurrentAsString(Follower), Follower) then begin - ReleaseChangedValue(Follower); // note, must do first, since set can change element + ReleaseChangedValue(Follower); SetAsString(GetCurrentAsString(Follower), Follower); end else @@ -252,7 +260,6 @@ procedure TBoldStringFollowerControllerCom.SetNilStringRepresentation(const Valu var Left: Integer; begin - // Adjust for alignment case Alignment of taLeftJustify: Left := Margins.X + Rect.Left; taRightJustify: Left := (Rect.Right - Rect.Left) - Canvas.TextWidth(S) + Rect.Left - 1 - Margins.X; @@ -278,7 +285,7 @@ procedure TBoldAsStringRendererCom.MakeUpToDateAndSubscribe(Element: IBoldElemen procedure TBoldAsStringRendererCom.DefaultMakeUptodateAndSetMayModifyAndSubscribe(Element: IBoldElement; RendererData: TBoldFollowerDataCom; FollowerController: TBoldStringFollowerControllerCom; Subscriber: TBoldComClientSubscriber); var - {$IFDEF BOLDCOMCLIENT} // defaultMakeUpToDate + {$IFDEF BOLDCOMCLIENT} e: IBoldElement; {$ELSE} E: TBoldIndirectElement; @@ -298,12 +305,12 @@ procedure TBoldAsStringRendererCom.DefaultMakeUptodateAndSetMayModifyAndSubscrib begin if Assigned(Element) then begin - {$IFDEF BOLDCOMCLIENT} // defaultMakeUpToDate + {$IFDEF BOLDCOMCLIENT} if assigned(Subscriber) then e := Element.EvaluateAndSubscribeToExpression(FollowerController.Expression, Subscriber.ClientId, Subscriber.SubscriberId, False, false) else e := Element.EvaluateExpression(FollowerController.Expression); - + if Assigned(E) then begin S := E.StringRepresentation[FollowerController.Representation]; @@ -357,7 +364,7 @@ function TBoldAsStringRendererCom.GetRendererDataClass: TBoldRendererDataClassCo function TBoldAsStringRendererCom.DefaultGetAsStringAndSubscribe(Element: IBoldElement; FollowerController: TBoldStringFollowerControllerCom; Subscriber: TBoldComClientSubscriber): string; var - {$IFDEF BOLDCOMCLIENT} // DefaultGet + {$IFDEF BOLDCOMCLIENT} e: IBoldElement; {$ELSE} E: TBoldIndirectElement; @@ -375,7 +382,7 @@ function TBoldAsStringRendererCom.DefaultGetAsStringAndSubscribe(Element: IBoldE begin if Assigned(Element) then begin - {$IFDEF BOLDCOMCLIENT} // defaultGet + {$IFDEF BOLDCOMCLIENT} if assigned(Subscriber) then e := Element.EvaluateAndSubscribeToExpression(FollowerController.Expression, Subscriber.ClientId, Subscriber.SubscriberId, False, false) else @@ -638,4 +645,3 @@ finalization FreeAndNil(DefaultAsStringRenderer); end. - diff --git a/Source/ClientGuiCom/ControlPacks/BoldViewerControlPackCom.pas b/Source/ClientGuiCom/ControlPacks/BoldViewerControlPackCom.pas index bfec242e..a8999738 100644 --- a/Source/ClientGuiCom/ControlPacks/BoldViewerControlPackCom.pas +++ b/Source/ClientGuiCom/ControlPacks/BoldViewerControlPackCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldViewerControlPackCom; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -65,7 +68,7 @@ TBoldAsViewerRendererCom = class(TBoldSingleRendererCom) procedure DefaultSetAsViewer(Element: IBoldElement; Value: TBoldAbstractViewAdapterCom; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList); virtual; function DefaultIsChanged(RendererData: TBoldViewerRendererDataCom; NewValue: TBoldAbstractViewAdapterCom; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList): Boolean; function IsChanged(RendererData: TBoldViewerRendererDataCom; NewValue: TBoldAbstractViewAdapterCom; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: IBoldExternalVariableList): Boolean; - procedure MakeUptodateAndSubscribe(Element: IBoldElement; RendererData: TBoldFollowerDataCom; FollowerController: TBoldFollowerControllerCom; Subscriber: TBoldComClientSubscriber); override; + procedure MakeUpToDateAndSubscribe(Element: IBoldElement; RendererData: TBoldFollowerDataCom; FollowerController: TBoldFollowerControllerCom; Subscriber: TBoldComClientSubscriber); override; published property OnGetAsViewer: TBoldGetAsViewerCom read FOnGetAsViewer write FOnGetAsViewer; property OnSetAsViewer: TBoldSetAsViewerCom read FOnSetAsViewer write FOnSetAsViewer; @@ -92,8 +95,6 @@ TBoldViewerFollowerControllerCom = class(TBoldSingleFollowerControllerCom) {-- TBoldAbstractViewAdapterCom --} TBoldViewAdapterClassCom = class of TBoldAbstractViewAdapterCom; - - // BCB does not support abstract class methods TBoldAbstractViewAdapterCom = class(TBoldMemoryManagedObject) public constructor Create; virtual; @@ -104,19 +105,19 @@ TBoldAbstractViewAdapterCom = class(TBoldMemoryManagedObject) function Empty: Boolean; virtual; abstract; procedure Clear; virtual; abstract; function HasChanged: Boolean; virtual; abstract; - class function CanReadContent(const ContentType: string): Boolean; virtual; + class function CanReadContent(const ContentType: string): Boolean; virtual; function ContentType: string; virtual; abstract; - class function Description: string; virtual; // How to handle Localizastion? + class function Description: string; virtual; {Clipboard} procedure CopyToClipboard; virtual; abstract; - class function CanPasteFromClipboard(const AcceptedContentType: string): Boolean; virtual; + class function CanPasteFromClipboard(const AcceptedContentType: string): Boolean; virtual; procedure PasteFromClipboard; virtual; abstract; {Streams} procedure LoadFromStream(Stream: TStream); virtual; abstract; procedure SaveToStream(Stream: TStream); virtual; abstract; {Files} - class function DefaultExtension: string; virtual; - class function FileFilter: string; virtual; // How to handle Localizastion? + class function DefaultExtension: string; virtual; + class function FileFilter: string; virtual; class function CanLoadFromFile(const Filename: string): Boolean; virtual; procedure LoadFromFile(const Filename: string); virtual; abstract; procedure SaveToFile(const Filename: string); virtual; abstract; @@ -131,9 +132,8 @@ implementation uses SysUtils, - BoldRev, BoldUtils, - BoldImageBitmapCom; //FIXME Temp! + BoldImageBitmapCom; var DefaultAsViewerRenderer: TBoldAsViewerRendererCom; @@ -182,7 +182,7 @@ function TBoldAsViewerRendererCom.DefaultGetAsViewerAndSubscribe(Element: IBoldE var e: IBoldElement; Stream: TStream; - {$IFDEF BOLDCOMCLIENT} // defaultGet + {$IFDEF BOLDCOMCLIENT} attr: IBoldAttribute; {$ELSE} IndirectElement: TBoldIndirectElement; @@ -206,7 +206,7 @@ function TBoldAsViewerRendererCom.DefaultGetAsViewerAndSubscribe(Element: IBoldE Result := nil; if Assigned(Element) then begin - {$IFDEF BOLDCOMCLIENT} // defaultGet + {$IFDEF BOLDCOMCLIENT} if assigned(Subscriber) then e := Element.EvaluateAndSubscribeToExpression(Expression, Subscriber.ClientId, Subscriber.SubscriberId, false, false) else @@ -268,14 +268,14 @@ procedure TBoldAsViewerRendererCom.DefaultSetAsViewer(Element: IBoldElement; Val var ValueElement: IBoldElement; Stream: TStream; - {$IFDEF BOLDCOMCLIENT} // defaultSet + {$IFDEF BOLDCOMCLIENT} Attr: IBoldAttribute; {$ENDIF} begin ValueElement := GetExpressionAsDirectElement(Element, Expression, VariableList); if Assigned(ValueElement) then begin - {$IFDEF BOLDCOMCLIENT} // DefaultSet + {$IFDEF BOLDCOMCLIENT} ValueElement.QueryInterface(IBoldAttribute, Attr); if Assigned(Value) then begin @@ -406,7 +406,6 @@ procedure TBoldViewerFollowerControllerCom.MakeClean(Follower: TBoldFollowerCom) constructor TBoldAbstractViewAdapterCom.Create; begin - // Left for subclasses to implement end; class procedure TBoldAbstractViewAdapterCom.RegisterViewAdapter(ViewAdapterClass: TBoldViewAdapterClassCom); @@ -467,6 +466,5 @@ initialization finalization FreeAndNil(DefaultAsViewerRenderer); FreeAndNil(ViewAdapterList); - + end. - diff --git a/Source/ClientGuiCom/Core/BoldExceptionHandlersCom.pas b/Source/ClientGuiCom/Core/BoldExceptionHandlersCom.pas index c6bdca6f..eca5dda7 100644 --- a/Source/ClientGuiCom/Core/BoldExceptionHandlersCom.pas +++ b/Source/ClientGuiCom/Core/BoldExceptionHandlersCom.pas @@ -1,10 +1,13 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldExceptionHandlersCom; interface uses Classes, - BoldComObjectSpace_TLB, BoldClientElementSupport, BoldComClient, + BoldComObjectSpace_TLB, SysUtils; type @@ -29,14 +32,12 @@ TBoldExceptionHandlerCom = class(TComponent) published property OnApplyException: TBoldApplyExceptionEventCom read fOnApplyException write fOnApplyException; property OnDisplayException: TBoldDisplayExceptionEventCom read fOnDisplayException write fOnDisplayException; - end; + end; implementation uses - BoldRev, - BoldUtils, - Controls; + BoldRev; var G_BoldExceptionHandlers: TList = nil; @@ -64,48 +65,23 @@ destructor TBoldExceptionHandlerCom.Destroy; end; class function TBoldExceptionHandlerCom.FindExceptionHandler(Component: TComponent): TBoldExceptionHandlerCom; -function OwningComponent(Component: TComponent): TComponent; -begin -//Find topmost owning component - Result := Component; - while Assigned(Result) and Assigned(Result.Owner) do - Result := Result.Owner; -end; -function ParentControl(Component: TComponent): TWinControl; -begin -//Find topmost parent control - Result := nil; - if Component is TWinControl then - begin - Result := TWinControl(Component); - while Assigned(Result.Parent) do - Result := Result.Parent; - end; -end; var i: integer; - ExceptionHandlerOwner: TComponent; begin - //Find matching exception handler result := nil; if assigned(G_BoldExceptionHandlers) then for i := 0 to G_BoldExceptionHandlers.Count - 1 do - begin - ExceptionHandlerOwner := TBoldExceptionHandlerCom(G_BoldExceptionHandlers[i]).Owner; - if (ExceptionHandlerOwner = OwningComponent(Component)) or - (ExceptionHandlerOwner = ParentControl(Component)) then + if TBoldExceptionHandlerCom(G_BoldExceptionHandlers[i]).Owner = Component.Owner then begin result := TBoldExceptionHandlerCom(G_BoldExceptionHandlers[i]); exit; end; - end; end; procedure TBoldExceptionHandlerCom.HandleApplyException(E: Exception; Component: TComponent; Elem: IBoldElement; var Discard: Boolean; var HandledByUser: boolean); begin - // Note: Discard must be set by caller, as there might be no matching exception handler - // to set discard! + HandledByUser := Assigned(fOnApplyException); if HandledByUser then OnApplyException(E, Component, Elem, Discard); diff --git a/Source/ClientGuiCom/Core/BoldGuiResourceStringsCom.pas b/Source/ClientGuiCom/Core/BoldGuiResourceStringsCom.pas index 87263300..80347fd3 100644 --- a/Source/ClientGuiCom/Core/BoldGuiResourceStringsCom.pas +++ b/Source/ClientGuiCom/Core/BoldGuiResourceStringsCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldGuiResourceStringsCom; interface @@ -19,8 +22,6 @@ interface SCannotChangeStateWithModifiedValue = 'Can''t Change State with Modified Value'; SValueReadOnly = 'Can''t change value. Value is read only'; - -// Navigator hints SNavHintFirst = 'First'; SNavHintPrior = 'Prior'; SNavHintNext = 'Next'; @@ -32,8 +33,6 @@ interface implementation -uses - BoldRev; initialization diff --git a/Source/ClientGuiCom/IDE/BoldAwareGuiComReg.pas b/Source/ClientGuiCom/IDE/BoldAwareGuiComReg.pas index 4ba8e757..359e2d1c 100644 --- a/Source/ClientGuiCom/IDE/BoldAwareGuiComReg.pas +++ b/Source/ClientGuiCom/IDE/BoldAwareGuiComReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAwareGuiComReg; {$DEFINE BOLDCOMCLIENT} {Clientified 2002-08-05 13:13:02} @@ -9,24 +12,23 @@ procedure Register; implementation uses - BoldRev, Classes, DesignIntf, BoldDefs, BoldAbstractPropertyEditors, BoldComPropertyEditors, BoldGridPropertyEditorsCom, -{$IFNDEF BOLDCOMCLIENT} // uses - BoldHandlesCom, // IFNDEF BOLDCOMCLIENT - BoldExceptionHandlersCom, // IFNDEF BOLDCOMCLIENT - BoldAbstractListHandleCom, // IFNDEF BOLDCOMCLIENT - BoldComboBoxPropertyEditors, // IFNDEF BOLDCOMCLIENT - BoldControlPackPropertyEditors, // IFNDEF BOLDCOMCLIENT - - BoldMLRenderersCom, // fixthis // IFNDEF BOLDCOMCLIENT - BoldDataSetCom, // IFNDEF BOLDCOMCLIENT - BoldDataSetPropertyEditors, // IFNDEF BOLDCOMCLIENT - BoldDragDropTargetCom, // IFNDEF BOLDCOMCLIENT +{$IFNDEF BOLDCOMCLIENT} + BoldHandlesCom, + BoldExceptionHandlersCom, + BoldAbstractListHandleCom, + BoldComboBoxPropertyEditors, + BoldControlPackPropertyEditors, + + BoldMLRenderersCom, + BoldDataSetCom, + BoldDataSetPropertyEditors, + BoldDragDropTargetCom, {$ENDIF} BoldPropertiesControllerPropertyEditorsCom, BoldPropertiesControllerCom, @@ -60,16 +62,14 @@ implementation procedure RegisterEditors; begin - //TBoldRendererCom RegisterPropertyEditor(TypeInfo(TBoldSubscribeCom), nil, '', TBoldElementCOMSubscribeMethodProperty); RegisterPropertyEditor(TypeInfo(TBoldHoldsChangedValueCom), nil, '', TBoldCOMMethodNoPurposeProperty); RegisterPropertyEditor(TypeInfo(TBoldReleaseChangedValueCom), nil, '', TBoldCOMMethodNoPurposeProperty); RegisterPropertyEditor(TypeInfo(TBoldMayModifyCom), nil, '', TBoldCOMMethodNoPurposeProperty); - {$IFNDEF BOLDCOMCLIENT} // register editors + {$IFNDEF BOLDCOMCLIENT} + - // Register property editors - // All properties of type TBoldElementHandleCom named BoldHandle will be displayed RED if prop not set RegisterPropertyEditor(TypeInfo(TBoldElementHandleCom), TPersistent, 'BoldHandle', TBoldComponentPropertyIndicateMissing); RegisterPropertyEditor(TypeInfo(TBoldAbstractListHandleCom), TBoldComboBoxCom, 'BoldListHandleCom', TBoldComponentPropertyIndicateMissing); @@ -77,25 +77,17 @@ procedure RegisterEditors; RegisterPropertyEditor(TypeInfo(integer), TBoldFollowerControllerCom, 'Representation', TBoldRepresentationProperty); RegisterPropertyEditor(TypeInfo(TBoldRendererCom), TBoldFollowerControllerCom, 'Renderer', TBoldRendererComponentProperty); - // Note: registering for TPersistent screws up, as all string-properties will get an ellipsis! - // v the below line doesn't work, but is left as a reminder. - // RegisterPropertyEditor(TypeInfo(TBoldExpression), TPersistent, '', TBoldOCLExpressionProperty); - // ^ the above line doesn't work, but is left as a reminder. + + RegisterPropertyEditor(TypeInfo(TBoldExpression), TBoldFollowerControllerCom, 'Expression', TBoldOCLExpressionForFollowerControllersProperty); RegisterPropertyEditor(TypeInfo(TBoldSingleFollowerControllerCom), nil, '', TBoldSingleFollowerControllerEditor); RegisterPropertyEditor(TypeInfo(TBoldTreeFollowerControllerCom), nil, '', TBoldTreeFollowerControllerEditor); - - //TBoldAsStringRendererCom RegisterPropertyEditor(TypeInfo(TBoldGetAsStringCom), nil, '', TBoldGetAsStringMethodProperty); - //TBoldAsCheckBoxRenderer RegisterPropertyEditor(TypeInfo(TBoldGetAsCheckBoxStateCom), nil, '', TBoldGetAsCheckBoxStateMethodProperty); - //TBoldAsIntegerRendererCom RegisterPropertyEditor(TypeInfo(TBoldGetAsIntegerEventCom), nil, '', TBoldGetAsIntegerEventMethodProperty); - //TBoldAsFloatRendererCom RegisterPropertyEditor(TypeInfo(TBoldGetAsFloatEventCom), nil, '', TBoldGetAsFloatEventMethodProperty); - //TBoldAsViewerRendererCom RegisterPropertyEditor(TypeInfo(TBoldGetAsViewerCom), nil, '', TBoldGetAsViewerMethodProperty); RegisterPropertyEditor(TypeInfo(String), TBoldNodeDescriptionCom, 'ContextTypeName', TBoldTypeNameSelectorPropertyForTreeFollowerController); @@ -104,8 +96,6 @@ procedure RegisterEditors; RegisterPropertyEditor(TypeInfo(String), TBoldComboBoxCom, 'BoldSetValueExpression', TBoldOCLExpressionForComboBoxSetValueExpression); RegisterPropertyEditor(TypeInfo(String), TBoldDropTargetCom, 'NodeSelectionExpression', TBoldOCLExpressionForOCLComponent); - - // Register Component editors {Renderer editors} RegisterComponentEditor(TBoldAsStringRendererCom, TBoldAsStringRendererEditor); RegisterComponentEditor(TBoldAsCheckBoxStateRendererCom, TBoldAsCheckboxStateRendererEditor); @@ -128,14 +118,14 @@ procedure RegisterEditors; RegisterComponentEditor(TBoldPropertiesControllerCom,TBoldPropertiesControllerComponentEditorCom); RegisterPropertyEditor(TypeInfo(String), TBoldDrivenPropertyCom, 'PropertyName', TPropertyNamePropertyCom); RegisterPropertyEditor(TypeInfo(TComponent), TBoldDrivenPropertyCom, 'VCLComponent', TVCLComponentPropertyCom); -{$IFNDEF BOLDCOMCLIENT} // registerEditors +{$IFNDEF BOLDCOMCLIENT} RegisterComponentEditor(TBoldAbstractDataset, TBoldDataSetEditor); {$ENDIF} end; procedure RegisterComponentsOnPalette; begin -{$IFNDEF BOLDCOMCLIENT} // RegisterComponents +{$IFNDEF BOLDCOMCLIENT} RegisterComponents(BOLDPAGENAME_MISC, [ TBoldDataSetCom, @@ -143,7 +133,7 @@ procedure RegisterComponentsOnPalette; ]); {$ENDIF} -{$IFDEF BOLDCOMCLIENT} // RegisterComponents +{$IFDEF BOLDCOMCLIENT} RegisterComponents('Bold COM Controls', {$ELSE} RegisterComponents(BOLDPAGENAME_CONTROLS, @@ -167,12 +157,11 @@ procedure RegisterComponentsOnPalette; TBoldImageCom, TBoldPropertiesControllerCom, TBoldStringsPropertyControllerCom, - //Renderers TBoldAsStringRendererCom, TBoldAsCheckBoxStateRendererCom, TBoldAsIntegerRendererCom, TBoldAsFloatRendererCom, - {$IFNDEF BOLDCOMCLIENT} // Register Components + {$IFNDEF BOLDCOMCLIENT} TBoldAsMLStringRendererCom, TBoldDropTargetCom, {$ENDIF} @@ -182,10 +171,8 @@ procedure RegisterComponentsOnPalette; procedure Register; begin - begin - RegisterComponentsOnPalette; - RegisterEditors; - end; + RegisterComponentsOnPalette; + RegisterEditors; end; end. diff --git a/Source/ClientGuiCom/IDE/BoldAwareGuiComReg.res b/Source/ClientGuiCom/IDE/BoldAwareGuiComReg.res new file mode 100644 index 00000000..98825a08 Binary files /dev/null and b/Source/ClientGuiCom/IDE/BoldAwareGuiComReg.res differ diff --git a/Source/ClientGuiCom/IDE/BoldCOMPropertyEditors.pas b/Source/ClientGuiCom/IDE/BoldCOMPropertyEditors.pas index b955d181..cb79cec2 100644 --- a/Source/ClientGuiCom/IDE/BoldCOMPropertyEditors.pas +++ b/Source/ClientGuiCom/IDE/BoldCOMPropertyEditors.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldCOMPropertyEditors; interface @@ -24,8 +27,6 @@ TBoldCOMMethodNoPurposeProperty = class(TBoldOneLinerWithEvalMethodProperty) implementation -uses - BoldRev; { TBoldCOMMethodNoPurposeProperty } diff --git a/Source/ClientGuiCom/IDE/BoldGridPropertyEditorsCom.pas b/Source/ClientGuiCom/IDE/BoldGridPropertyEditorsCom.pas index 873c45d6..53ee9202 100644 --- a/Source/ClientGuiCom/IDE/BoldGridPropertyEditorsCom.pas +++ b/Source/ClientGuiCom/IDE/BoldGridPropertyEditorsCom.pas @@ -1,18 +1,31 @@ -// MANUALLY UPDATED + +{ Global compiler directives } +{$include bold.inc} unit BoldGridPropertyEditorsCom; interface uses + {$IFDEF BOLD_DELPHI5_OR_LATER} + Contnrs, + {$ENDIF} + {$IFDEF BOLD_DELPHI6_OR_LATER} DesignIntf, DesignEditors, + {$ELSE} + DsgnIntf, + {$ENDIF} TypInfo; type { TBoldColumnsEditor } TBoldColumnsEditorCom = class(TComponentEditor) private + {$IFDEF BOLD_DELPHI6_OR_LATER} procedure EditPropertyColumns(const PropertyEditor: IProperty); + {$ELSE} + procedure EditPropertyColumns(PropertyEditor: TPropertyEditor); + {$ENDIF} public procedure EmptyColumns; procedure CreateDefaultColumns; @@ -26,7 +39,6 @@ implementation uses SysUtils, - BoldRev, BoldUtils, BoldGridCom; @@ -35,7 +47,11 @@ TBoldExposedCustomGridCom = class(TBoldCustomGridCom); {---TBoldColumnsEditor---} +{$IFDEF BOLD_DELPHI6_OR_LATER} procedure TBoldColumnsEditorCom.EditPropertyColumns(const PropertyEditor: IProperty); +{$ELSE} +procedure TBoldColumnsEditorCom.EditPropertyColumns(PropertyEditor: TPropertyEditor); +{$ENDIF} begin if SameText(PropertyEditor.GetName, 'Columns') then PropertyEditor.Edit; @@ -43,18 +59,30 @@ procedure TBoldColumnsEditorCom.EditPropertyColumns(const PropertyEditor: IPrope procedure TBoldColumnsEditorCom.Edit; var +{$IFDEF BOLD_DELPHI6_OR_LATER} Components: IDesignerSelections; +{$ELSE} + Components: TDesignerSelectionList; +{$ENDIF} begin +{$IFDEF BOLD_DELPHI6_OR_LATER} Components := TDesignerSelections.Create; +{$ELSE} + Components := TDesignerSelectionList.Create; +{$ENDIF} try Components.Add(Component); GetComponentProperties(Components, tkProperties, Designer, - EditPropertyColumns, - nil); + EditPropertyColumns + {$IFDEF BOLD_DELPHI6_OR_LATER}, nil{$ENDIF}); finally + {$IFDEF BOLD_DELPHI6_OR_LATER} Components := nil; + {$ELSE} + Components.Free; + {$ENDIF} end; end; @@ -72,7 +100,6 @@ procedure TBoldColumnsEditorCom.EmptyColumns; begin DeleteAllColumns; AddColumn; - // This is done because the grid screws up the column widths AddColumn; Columns[1].Free; end; @@ -83,7 +110,7 @@ procedure TBoldColumnsEditorCom.ExecuteVerb(Index: Integer); case Index of 0: Edit; 1:{ CreateDefaultColumns; - 2: }EmptyColumns; // manual fix + 2: }EmptyColumns; end; end; @@ -92,14 +119,13 @@ function TBoldColumnsEditorCom.GetVerb(Index: Integer): string; case index of 0: Result := '&Edit Columns'; 1:{ Result := 'Create Default Columns'; - 2: }Result := 'Clear all Columns'; // manual fix + 2: }Result := 'Clear all Columns'; end; end; function TBoldColumnsEditorCom.GetVerbCount: Integer; begin - Result := 2; // manual fix + Result := 2; end; -initialization end. diff --git a/Source/ClientGuiCom/IDE/BoldPropertiesControllerPropertyEditorsCom.pas b/Source/ClientGuiCom/IDE/BoldPropertiesControllerPropertyEditorsCom.pas index d96f31a7..9c3fdc69 100644 --- a/Source/ClientGuiCom/IDE/BoldPropertiesControllerPropertyEditorsCom.pas +++ b/Source/ClientGuiCom/IDE/BoldPropertiesControllerPropertyEditorsCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPropertiesControllerPropertyEditorsCom; interface @@ -5,22 +8,19 @@ interface uses Classes, DesignEditors, - DesignIntf, + DesignIntf, BoldAbstractPropertyEditors; type - // A Property editor for the PropertyName property. - // It lists all meaningful properties of "Component" including properties of "sub-components" - // It has currently some trouble with collections and will not show panels[0] for example + + TPropertyNamePropertyCom = class(TBoldStringProperty) public function GetAttributes: TPropertyAttributes; override; procedure GetValues(Proc: TGetStrProc); override; end; - // A Property editor for VCLComponent property - // It is based on the TComponentProperty which lists all components of the form - // In addition to those it will also list the form so we can control its properties ! + TVCLComponentPropertyCom = class(TBoldComponentProperty) public procedure GetValues(Proc: TGetStrProc); override; @@ -40,7 +40,6 @@ implementation uses SysUtils, - BoldRev, TypInfo, BoldControlsDefs, BoldPropertiesControllerCom; @@ -99,7 +98,7 @@ procedure TPropertyNamePropertyCom.GetValues(Proc: TGetStrProc); begin if PropCount < 1 then exit; - SelectedComponent := GetComponent(0) as TBoldDrivenPropertyCom; //we don't allow multiselect + SelectedComponent := GetComponent(0) as TBoldDrivenPropertyCom; if Assigned(SelectedComponent) and Assigned(SelectedComponent.VCLComponent) then DeclareProperties(SelectedComponent.VCLComponent,SelectedComponent.VCLComponent.ClassInfo,''); end; @@ -108,7 +107,7 @@ procedure TPropertyNamePropertyCom.GetValues(Proc: TGetStrProc); procedure TVCLComponentPropertyCom.GetValues(Proc: TGetStrProc); begin - Proc(TBoldDrivenPropertyCom(GetComponent(0)).PropertiesController.Owner.Name); // Add the Form's name to available components + Proc(TBoldDrivenPropertyCom(GetComponent(0)).PropertiesController.Owner.Name); inherited; end; @@ -116,7 +115,6 @@ procedure TVCLComponentPropertyCom.SetValue(const Value: string); var Component: TComponent; begin - // Special case for the form if Value = TBoldDrivenPropertyCom(GetComponent(0)).PropertiesController.Owner.Name then begin Component := TBoldDrivenPropertyCom(GetComponent(0)).PropertiesController.Owner; @@ -157,5 +155,4 @@ function TBoldPropertiesControllerComponentEditorCom.GetVerbCount: Integer; Result := 1; end; -initialization end. diff --git a/Source/ClientHandlesCom/Core/BoldAbstractListHandleCom.pas b/Source/ClientHandlesCom/Core/BoldAbstractListHandleCom.pas index cf69da82..dd9f8c4a 100644 --- a/Source/ClientHandlesCom/Core/BoldAbstractListHandleCom.pas +++ b/Source/ClientHandlesCom/Core/BoldAbstractListHandleCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAbstractListHandleCom; interface @@ -50,7 +53,6 @@ implementation uses SysUtils, - BoldComHandlesConst, BoldDefs; {-- TBoldAbstractListHandleCom ------------------------------------------------} @@ -117,7 +119,7 @@ procedure TBoldAbstractListHandleCom.Next; if GetHasNext then CurrentIndex := CurrentIndex + 1 else - raise EBold.Create(sNoNextElement); + raise EBold.Create('No next element'); end; procedure TBoldAbstractListHandleCom.Prior; @@ -125,13 +127,13 @@ procedure TBoldAbstractListHandleCom.Prior; if GetHasPrior then CurrentIndex := CurrentIndex - 1 else - raise EBold.Create(sNoPrevElement); + raise EBold.Create('No previous element'); end; procedure TBoldAbstractListHandleCom.RemoveCurrentElement; begin if CurrentIndex = -1 then - raise EBold.Create(sNoCurrentElement) + raise EBold.Create('No current element') else if HasHandleOnServer then List.RemoveByIndex(CurrentIndex); @@ -154,4 +156,6 @@ function TBoldAbstractListHandleCom.GetMutableList: IBoldList; result := nil; end; +initialization + end. diff --git a/Source/ClientHandlesCom/Core/BoldClientElementSupport.pas b/Source/ClientHandlesCom/Core/BoldClientElementSupport.pas index c9757be1..b447e35e 100644 --- a/Source/ClientHandlesCom/Core/BoldClientElementSupport.pas +++ b/Source/ClientHandlesCom/Core/BoldClientElementSupport.pas @@ -1,12 +1,16 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldClientElementSupport; interface - uses BoldSubscription, BoldComObjectSpace_TLB; type + + TBoldElementCompareCom = function (Item1, Item2: IBoldElement): Integer of object; TBoldElementSubscribeCom = procedure (Element: IBoldElement; Subscriber: TBoldSubscriber) of object; TBoldElementFilterCom = function (Element: IBoldElement): Boolean of object; @@ -24,8 +28,11 @@ interface property ContextType: IBoldElementTypeInfo read GetContextType; property Expression: String read GetExpression write SetExpression; end; - + implementation + +initialization + end. diff --git a/Source/ClientHandlesCom/Core/BoldCursorHandleCom.pas b/Source/ClientHandlesCom/Core/BoldCursorHandleCom.pas index 316d2432..3ea90b15 100644 --- a/Source/ClientHandlesCom/Core/BoldCursorHandleCom.pas +++ b/Source/ClientHandlesCom/Core/BoldCursorHandleCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldCursorHandleCom; interface @@ -36,8 +39,6 @@ implementation BoldComObjectSpace, BoldComObjectSpace_TLB, BoldDefs, - ComHandlesConst, - BoldComHandlesConst, BoldComUtils; { TBoldCursorHandleCom } @@ -50,16 +51,13 @@ destructor TBoldCursorHandleCom.Destroy; procedure TBoldCursorHandleCom.ClearAllValues; begin - // from TBoldElementHandleCom FDynamicBoldType := nil; FStaticBoldType := nil; FStaticSystemTypeInfo := nil; FValue := nil; FHandleId := 0; - // from TBoldNonSystemHandleCom - // from TBoldRootedHandleCom + FStaticRootType := nil; - // from TBoldAbstractListHandleCom FCount := 0; FCurrentBoldObject := nil; FCurrentIndex := -1; @@ -79,7 +77,7 @@ procedure TBoldCursorHandleCom.SetAutoFirst(Value: Boolean); if Value <> AutoFirst then begin if not OwnsHandleOnServer then - raise EBold.Create(sAutoFirstIsReadOnly); + raise EBold.Create('AutoFirst is read-only'); FAutoFirst := Value; LocalValueChanged; end; @@ -102,16 +100,16 @@ procedure TBoldCursorHandleCom.ValuesFromServer; FListElementType, NamedValues); - FHandleId := BoldGetNamedValue(NamedValues, nv_HandleId); - FCount := BoldGetNamedValue(NamedValues, nv_Count); + FHandleId := BoldGetNamedValue(NamedValues, 'HandleId'); + FCount := BoldGetNamedValue(NamedValues, 'Count'); if not OwnsHandleOnServer then begin - FEnabled := BoldGetNamedValue(NamedValues, nv_Enabled); - FRootTypeName := BoldGetNamedValue(NamedValues, nv_RootTypeName); - FSubscribe := BoldGetNamedValue(NamedValues, nv_Subscribe); - FCurrentIndex := BoldGetNamedValue(NamedValues, nv_CurrentIndex); - FAutoFirst := BoldGetNamedValue(NamedValues, nv_AutoFirst); + FEnabled := BoldGetNamedValue(NamedValues, 'Enabled'); + FRootTypeName := BoldGetNamedValue(NamedValues, 'RootTypeName'); + FSubscribe := BoldGetNamedValue(NamedValues, 'Subscribe'); + FCurrentIndex := BoldGetNamedValue(NamedValues, 'CurrentIndex'); + FAutoFirst := BoldGetNamedValue(NamedValues, 'AutoFirst'); end else AdjustCurrentIndex; @@ -142,13 +140,13 @@ procedure TBoldCursorHandleCom.ValuesToServer; else RootHandleId := 0; NamedValues := BoldCreateNamedValues( - [nv_StaticSystemHandle, - nv_Enabled, - nv_RootHandle, - nv_RootTypeName, - nv_Subscribe, - nv_CurrentIndex, - nv_AutoFirst], + ['StaticSystemHandle', + 'Enabled', + 'RootHandle', + 'RootTypeName', + 'Subscribe', + 'CurrentIndex', + 'AutoFirst'], [StaticSystemHandleId, FEnabled, RootHandleId, @@ -161,7 +159,7 @@ procedure TBoldCursorHandleCom.ValuesToServer; function TBoldCursorHandleCom.ServerHandleClassName: string; begin - result := ServerHandleClassName_CursorHandle; + result := 'TBoldCursorHandle'; end; constructor TBoldCursorHandleCom.Create(Owner: TComponent); @@ -180,4 +178,6 @@ procedure TBoldCursorHandleCom.AdjustCurrentIndex; fCurrentIndex := fList.Count-1; end; +initialization + end. diff --git a/Source/ClientHandlesCom/Core/BoldDerivedHandleCom.pas b/Source/ClientHandlesCom/Core/BoldDerivedHandleCom.pas index 058af4f3..bb0afc98 100644 --- a/Source/ClientHandlesCom/Core/BoldDerivedHandleCom.pas +++ b/Source/ClientHandlesCom/Core/BoldDerivedHandleCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDerivedHandleCom; interface @@ -25,7 +28,6 @@ implementation uses BoldComObjectSpace, BoldComObjectSpace_TLB, - ComHandlesConst, BoldComUtils; {-- TBoldDerivedHandleCom --------------------------------------------------------} @@ -38,16 +40,13 @@ destructor TBoldDerivedHandleCom.Destroy; procedure TBoldDerivedHandleCom.ClearAllValues; begin - // from TBoldElementHandleCom FDynamicBoldType := nil; FStaticBoldType := nil; FStaticSystemTypeInfo := nil; FValue := nil; FHandleId := 0; - // from TBoldNonSystemHandleCom - // from TBoldRootedHandleCom + FStaticRootType := nil; - // from TBoldDerivedHandleCom end; @@ -70,12 +69,12 @@ procedure TBoldDerivedHandleCom.ValuesFromServer; DummyList, DummyListType, NamedValues); - FHandleId := BoldGetNamedValue(NamedValues, nv_HandleId); + FHandleId := BoldGetNamedValue(NamedValues,'HandleId'); if not OwnsHandleOnServer then begin - FEnabled := BoldGetNamedValue(NamedValues, nv_Enabled); - FRootTypeName := BoldGetNamedValue(NamedValues, nv_RootTypeName); - FSubscribe := BoldGetNamedValue(NamedValues, nv_Subscribe); + FEnabled := BoldGetNamedValue(NamedValues,'Enabled'); + FRootTypeName := BoldGetNamedValue(NamedValues,'RootTypeName'); + FSubscribe := BoldGetNamedValue(NamedValues,'Subscribe'); end; end; @@ -96,11 +95,11 @@ procedure TBoldDerivedHandleCom.ValuesToServer; else RootHandleId := 0; NamedValues := BoldCreateNamedValues( - [nv_StaticSystemHandle, - nv_Enabled, - nv_RootHandle, - nv_RootTypeName, - nv_Subscribe], + ['StaticSystemHandle', + 'Enabled', + 'RootHandle', + 'RootTypeName', + 'Subscribe'], [StaticSystemHandleId, FEnabled, RootHandleId, @@ -111,7 +110,9 @@ procedure TBoldDerivedHandleCom.ValuesToServer; function TBoldDerivedHandleCom.ServerHandleClassName: string; begin - result := ServerHandleClassName_DerivedHandle; + result := 'TBoldDerivedHandle'; end; +initialization + end. diff --git a/Source/ClientHandlesCom/Core/BoldExpressionHandleCom.pas b/Source/ClientHandlesCom/Core/BoldExpressionHandleCom.pas index d9d8b428..dddf015c 100644 --- a/Source/ClientHandlesCom/Core/BoldExpressionHandleCom.pas +++ b/Source/ClientHandlesCom/Core/BoldExpressionHandleCom.pas @@ -1,10 +1,11 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldExpressionHandleCom; interface uses - BoldComObjectSpace, - BoldComObjectSpace_TLB, BoldRootedHandlesCom, BoldVariableDefinitionCom; @@ -42,11 +43,11 @@ implementation uses SysUtils, - ComHandlesConst, - BoldComHandlesConst, - BoldUtils, + BoldComObjectSpace, + BoldComObjectSpace_TLB, + BoldComUtils, BoldDefs, - BoldComUtils; + BoldRev; {-- TBoldExpressionHandleCom --------------------------------------------------} @@ -58,18 +59,16 @@ destructor TBoldExpressionHandleCom.Destroy; procedure TBoldExpressionHandleCom.ClearAllValues; begin - // from TBoldElementHandleCom FDynamicBoldType := nil; FStaticBoldType := nil; FStaticSystemTypeInfo := nil; FValue := nil; FHandleId := 0; - // from TBoldNonSystemHandleCom - // from TBoldRootedHandleCom + FStaticRootType := nil; - // from TBoldExpressionHandleCom end; + function TBoldExpressionHandleCom.GetExpression: string; begin if not OwnsHandleOnServer then @@ -103,14 +102,14 @@ procedure TBoldExpressionHandleCom.ValuesFromServer; DummyList, DummyListType, NamedValues); - FHandleId := BoldGetNamedValue(NamedValues, nv_HandleId); + FHandleId := BoldGetNamedValue(NamedValues,'HandleId'); if not OwnsHandleOnServer then begin - FEnabled := BoldGetNamedValue(NamedValues, nv_Enabled); - FRootTypeName := BoldGetNamedValue(NamedValues, nv_RootTypeName); - FSubscribe := BoldGetNamedValue(NamedValues, nv_Subscribe); - FExpression := BoldGetNamedValue(NamedValues, nv_Expression); - fEvaluateInPS := BoldGetNamedValue(NamedValues, nv_EvaluateInPS); + FEnabled := BoldGetNamedValue(NamedValues,'Enabled'); + FRootTypeName := BoldGetNamedValue(NamedValues,'RootTypeName'); + FSubscribe := BoldGetNamedValue(NamedValues,'Subscribe'); + FExpression := BoldGetNamedValue(NamedValues,'Expression'); + fEvaluateInPS := BoldGetNamedValue(NamedValues, 'EvaluateInPS'); end; end; @@ -131,29 +130,30 @@ procedure TBoldExpressionHandleCom.ValuesToServer; else RootHandleId := 0; NamedValues := BoldCreateNamedValues( - [nv_StaticSystemHandle, - nv_Enabled, - nv_RootHandle, - nv_RootTypeName, - nv_Subscribe, - nv_Expression, - nv_EvaluateInPS], + ['StaticSystemHandle', + 'Enabled', + 'RootHandle', + 'RootTypeName', + 'Subscribe', + 'Expression', + 'EvaluateInPS'], [StaticSystemHandleId, - FEnabled, - RootHandleId, - FRootTypeName, - FSubscribe, - FExpression, - fEvaluateInPS]); - ServerElementHandle.SetData(DataFlags, nil, NamedValues); + FEnabled, + RootHandleId, + FRootTypeName, + FSubscribe, + FExpression, + fEvaluateInPS]); + ServerElementHandle.SetData(DataFlags,nil,NamedValues); end; + procedure TBoldExpressionHandleCom.SetExpression(const Value: string); begin if Value <> FExpression then begin if not OwnsHandleOnServer then - raise EBold.CreateFmt(sPropertyIsReadOnly, ['Expression']); // do not localize + raise EBold.Create('Expression is read-only'); FExpression := Value; LocalValueChanged; end; @@ -164,15 +164,16 @@ procedure TBoldExpressionHandleCom.SetVariables(Value: TBoldVariableDefinitionCo if Value <> Variables then begin if not OwnsHandleOnServer then - raise EBold.CreateFmt(sPropertyIsReadOnly, ['Variables']); // do not localize + raise EBold.Create('Variables is read-only'); FVariables := Value; LocalValueChanged; end; end; + function TBoldExpressionHandleCom.ServerHandleClassName: string; begin - result := ServerHandleClassName_ExpressionHandle; + result := 'TBoldExpressionHandle'; end; function TBoldExpressionHandleCom.GetEvaluateInPS: boolean; @@ -187,7 +188,7 @@ procedure TBoldExpressionHandleCom.SetEvaluateInPS(const Value: boolean); if Value <> fEvaluateInPS then begin if not OwnsHandleOnServer then - raise EBold.CreateFmt(sPropertyIsReadOnly, ['EvaluateInPs']); // do not localize + raise EBold.Create('EvaluateInPs is read-only'); fEvaluateInPS := Value; LocalValueChanged; end; diff --git a/Source/ClientHandlesCom/Core/BoldHandlesCom.pas b/Source/ClientHandlesCom/Core/BoldHandlesCom.pas index 523f7a53..1d3bcfb5 100644 --- a/Source/ClientHandlesCom/Core/BoldHandlesCom.pas +++ b/Source/ClientHandlesCom/Core/BoldHandlesCom.pas @@ -1,10 +1,12 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldHandlesCom; interface uses Classes, - BoldDefs, BoldSubscription, BoldComObjectSpace, BoldComObjectSpace_TLB, @@ -35,7 +37,6 @@ TBoldElementHandleCom = class(TBoldComImportHandle) OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); procedure SetServerElementHandle(const ElementHandle: IBoldElementHandle); protected - // server values FDynamicBoldType: IBoldElementTypeInfo; FHandleId: Integer; FStaticBoldType: IBoldElementTypeInfo; @@ -74,7 +75,6 @@ TBoldAbstractSystemHandleCom = class(TBoldElementHandleCom) function GetSystemActive: Boolean; procedure SetIsDefault(Value: Boolean); protected - // server values FBoldSystem: IBoldSystem; FSystemActive: Boolean; function GetOwnsHandleOnServer: Boolean; override; @@ -109,8 +109,6 @@ implementation uses SysUtils, - ComHandlesConst, - BoldUtils, BoldComUtils; const @@ -120,6 +118,7 @@ implementation var G_DefaultBoldSystemHandle: TBoldAbstractSystemHandleCom = nil; + {-- TBoldElementHandleCom -----------------------------------------------------} procedure TBoldElementHandleCom.ConnectionClosing; @@ -200,7 +199,7 @@ function TBoldElementHandleCom.GetHandleId: Integer; DummyList, DummyType, NamedValues); - FHandleId := BoldGetNamedValue(NamedValues, nv_HandleId); + FHandleId := BoldGetNamedValue(NamedValues,'HandleId'); end; Result := FHandleId; end; diff --git a/Source/ClientHandlesCom/Core/BoldListHandleCom.pas b/Source/ClientHandlesCom/Core/BoldListHandleCom.pas index dad31a75..3b6f595e 100644 --- a/Source/ClientHandlesCom/Core/BoldListHandleCom.pas +++ b/Source/ClientHandlesCom/Core/BoldListHandleCom.pas @@ -1,10 +1,11 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldListHandleCom; interface uses - BoldComObjectSpace, - BoldComObjectSpace_TLB, BoldCursorHandleCom; type @@ -36,11 +37,11 @@ implementation uses SysUtils, - ComHandlesConst, - BoldComHandlesConst, - BoldUtils, + BoldComObjectSpace, + BoldComObjectSpace_TLB, + BoldComUtils, BoldDefs, - BoldComUtils; + BoldRev; {-- TBoldListHandleCom --------------------------------------------------------} @@ -52,16 +53,13 @@ destructor TBoldListHandleCom.Destroy; procedure TBoldListHandleCom.ClearAllValues; begin - // from TBoldElementHandleCom FDynamicBoldType := nil; FStaticBoldType := nil; FStaticSystemTypeInfo := nil; FValue := nil; FHandleId := 0; - // from TBoldNonSystemHandleCom - // from TBoldRootedHandleCom + FStaticRootType := nil; - // from TBoldAbstractListHandleCom FCount := 0; FCurrentBoldObject := nil; FCurrentIndex := -1; @@ -92,7 +90,7 @@ procedure TBoldListHandleCom.SetExpression(const Value: string); if Value <> FExpression then begin if not OwnsHandleOnServer then - raise EBold.CreateFmt(sPropertyIsReadOnly, ['Expression']); // do not localize + raise EBold.Create('Expression is read-only'); FExpression := Value; LocalValueChanged; end; @@ -125,17 +123,17 @@ procedure TBoldListHandleCom.ValuesFromServer; FList, FListElementType, NamedValues); - FHandleId := BoldGetNamedValue(NamedValues, nv_HandleId); - FCount := BoldGetNamedValue(NamedValues, nv_Count); + FHandleId := BoldGetNamedValue(NamedValues,'HandleId'); + FCount := BoldGetNamedValue(NamedValues,'Count'); if not OwnsHandleOnServer then begin - FEnabled := BoldGetNamedValue(NamedValues, nv_Enabled); - FRootTypeName := BoldGetNamedValue(NamedValues, nv_RootTypeName); - FSubscribe := BoldGetNamedValue(NamedValues, nv_Subscribe); - FCurrentIndex := BoldGetNamedValue(NamedValues, nv_CurrentIndex); - FAutoFirst := BoldGetNamedValue(NamedValues, nv_AutoFirst); - FExpression := BoldGetNamedValue(NamedValues, nv_Expression); - fEvaluateInPS := BoldGetNamedValue(NamedValues, nv_EvaluateInPS); + FEnabled := BoldGetNamedValue(NamedValues,'Enabled'); + FRootTypeName := BoldGetNamedValue(NamedValues,'RootTypeName'); + FSubscribe := BoldGetNamedValue(NamedValues,'Subscribe'); + FCurrentIndex := BoldGetNamedValue(NamedValues,'CurrentIndex'); + FAutoFirst := BoldGetNamedValue(NamedValues,'AutoFirst'); + FExpression := BoldGetNamedValue(NamedValues,'Expression'); + fEvaluateInPS := BoldGetNamedValue(NamedValues, 'EvaluateInPS'); end else AdjustCurrentIndex; @@ -159,30 +157,30 @@ procedure TBoldListHandleCom.ValuesToServer; else RootHandleId := 0; NamedValues := BoldCreateNamedValues( - [nv_StaticSystemHandle, - nv_Enabled, - nv_RootHandle, - nv_RootTypeName, - nv_Subscribe, - nv_CurrentIndex, - nv_AutoFirst, - nv_Expression, - nv_EvaluateInPS], + ['StaticSystemHandle', + 'Enabled', + 'RootHandle', + 'RootTypeName', + 'Subscribe', + 'CurrentIndex', + 'AutoFirst', + 'Expression', + 'EvaluateInPS'], [StaticSystemHandleId, - FEnabled, - RootHandleId, - FRootTypeName, - FSubscribe, - FCurrentIndex, - FAutoFirst, - FExpression, - fEvaluateInPS]); + FEnabled, + RootHandleId, + FRootTypeName, + FSubscribe, + FCurrentIndex, + FAutoFirst, + FExpression, + fEvaluateInPS]); ServerElementHandle.SetData(DataFlags,nil,NamedValues); end; function TBoldListHandleCom.ServerHandleClassName: string; begin - result := ServerHandleClassName_ListHandle; + result := 'TBoldListHandle'; end; function TBoldListHandleCom.GetEvaluateInPS: boolean; @@ -197,7 +195,7 @@ procedure TBoldListHandleCom.SetEvaluateInPS(const Value: boolean); if Value <> fEvaluateInPS then begin if not OwnsHandleOnServer then - raise EBold.CreateFmt(sPropertyIsReadOnly, ['EvaluateInPS']); // do not localize + raise EBold.Create('EvaluateInPS is read-only'); fEvaluateInPS := Value; LocalValueChanged; end; diff --git a/Source/ClientHandlesCom/Core/BoldPlaceableSubscriberCom.pas b/Source/ClientHandlesCom/Core/BoldPlaceableSubscriberCom.pas index fb2d631a..ea94fa56 100644 --- a/Source/ClientHandlesCom/Core/BoldPlaceableSubscriberCom.pas +++ b/Source/ClientHandlesCom/Core/BoldPlaceableSubscriberCom.pas @@ -1,51 +1,10 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPlaceableSubscriberCom; interface -(* - -uses - Classes, - - BoldSubscription, - BoldComObjectSpace, - BoldHandlesCom; -type -{ TODO: Not implemented at all yet } -{---forward declarations---} - TBoldPlaceableSubscriberCom = class; - {---method types---} -// TBoldSubscribeToElementEvent = procedure (element: IBoldElement; Subscriber: TBoldComClientSubscriber) of object; - TBoldPlaceableSubcriberReceive = procedure(sender: TBoldPlaceableSubscriberCom; Originator: TObject; OriginalEvent: TBoldEvent; - RequestedEvent: TBoldRequestedEvent) of object; - - {---TBoldPlaceableSubscriberCom---} - TBoldPlaceableSubscriberCom = class(TBoldSubscribableComponent) - private - FBoldHandle: TBoldElementHandleCom; - FOnReceive: TBoldPlaceableSubcriberReceive; - FOnSubscribeToElement: TBoldSubscribeToElementEvent; - FHandleSubscriber: TBoldPassthroughSubscriber; - FValueSubscriber: TBoldPassthroughSubscriber; - procedure SetBoldHandle(Value: TBoldElementHandleCom); - procedure HandleSubscriberReceive(Originator: TObject; OriginalEvent: TBoldEvent; - RequestedEvent: TBoldRequestedEvent); - procedure HandleValueChanged; - procedure ValueSubscriberReceive(Originator: TObject; OriginalEvent: TBoldEvent; - RequestedEvent: TBoldRequestedEvent); - protected - procedure Notification(AComponent: TComponent; Operation: TOperation); override; - procedure SubscribeToElement(element: IBoldElement; Subscriber: TBoldComClientSubscriber); virtual; - procedure Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); virtual; - public - constructor Create(Owner: TComponent); override; - destructor Destroy; override; - published - property BoldHandle: TBoldElementHandleCom read FBoldHandle write SetBoldHandle; - property OnReceive: TBoldPlaceableSubcriberReceive read FOnReceive write fOnReceive; - property OnSubscribeToElement: TBoldSubscribeToElementEvent read FOnSubscribeToElement write FOnSubscribeToElement; - end; -*) implementation (* uses @@ -118,5 +77,8 @@ procedure TBoldPlaceableSubscriberCom.Receive(Originator: TObject; OriginalEvent if Assigned(FOnReceive) then fOnReceive(Self, Originator, OriginalEvent, RequestedEvent); end; + + +initialization *) end. diff --git a/Source/ClientHandlesCom/Core/BoldReferenceHandleCom.pas b/Source/ClientHandlesCom/Core/BoldReferenceHandleCom.pas index 465b05a8..8a5c88d6 100644 --- a/Source/ClientHandlesCom/Core/BoldReferenceHandleCom.pas +++ b/Source/ClientHandlesCom/Core/BoldReferenceHandleCom.pas @@ -1,9 +1,11 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldReferenceHandleCom; interface uses - BoldComObjectSpace, BoldComObjectSpace_TLB, BoldHandlesCom; @@ -35,11 +37,10 @@ implementation uses SysUtils, - ComHandlesConst, - BoldComHandlesConst, - BoldUtils, + BoldComObjectSpace, + BoldComUtils, BoldDefs, - BoldComUtils; + BoldRev; {-- TBoldReferenceHandleCom ---------------------------------------------------} @@ -51,14 +52,12 @@ destructor TBoldReferenceHandleCom.Destroy; procedure TBoldReferenceHandleCom.ClearAllValues; begin - // from TBoldElementHandleCom FDynamicBoldType := nil; FStaticBoldType := nil; FStaticSystemTypeInfo := nil; FValue := nil; FHandleId := 0; - // from TBoldNonSystemHandleCom - // from TBoldReferenceHandleCom + end; @@ -81,7 +80,7 @@ procedure TBoldReferenceHandleCom.SetStaticValueTypeName(const Value: string); if Value <> StaticValueTypeName then begin if not OwnsHandleOnServer then - raise EBold.CreateFmt(sPropertyIsReadOnly, ['StaticValueTypeName']); // do not localize + raise EBold.Create('StaticValueTypeName is read-only'); FStaticValueTypeName := Value; LocalValueChanged; end; @@ -92,13 +91,13 @@ procedure TBoldReferenceHandleCom.SetValue(NewValue: IBoldElement); if NewValue <> FValue then begin if not assigned(EffectiveConnectionHandle) then - raise EBold.Createfmt(sSetValueNotAllowedWithoutConnectionHandle, [Classname]); + raise EBold.Createfmt('%s.Setvalue: Now allowed without a connectionHandle', [Classname]); if not EffectiveConnectionHandle.Connected then - raise EBold.Createfmt(sSetValueNotAllowedWithInactiveConnectionHandle, [ClassName]); + raise EBold.Createfmt('%s.Setvalue: Now allowed with an inactive ConnectionHandle', [ClassName]); if not OwnsHandleOnServer then - raise EBold.CreateFmt(sPropertyIsReadOnly, ['Value']); // do not localize + raise EBold.Create('Value is read-only'); FValue := NewValue; LocalValueChanged; end; @@ -124,9 +123,9 @@ procedure TBoldReferenceHandleCom.ValuesFromServer; DummyList, DummyListType, NamedValues); - FHandleId := BoldGetNamedValue(NamedValues, nv_HandleId); + FHandleId := BoldGetNamedValue(NamedValues,'HandleId'); if not OwnsHandleOnServer then - FStaticValueTypeName := BoldGetNamedValue(NamedValues, nv_StaticValueTypeName); + FStaticValueTypeName := BoldGetNamedValue(NamedValues,'StaticValueTypeName'); end; procedure TBoldReferenceHandleCom.ValuesToServer; @@ -141,16 +140,18 @@ procedure TBoldReferenceHandleCom.ValuesToServer; else StaticSystemHandleId := 0; NamedValues := BoldCreateNamedValues( - [nv_StaticSystemHandle, - nv_StaticValueTypeName], + ['StaticSystemHandle', + 'StaticValueTypeName'], [StaticSystemHandleId, - FStaticValueTypeName]); + FStaticValueTypeName]); ServerElementHandle.SetData(DataFlags,FValue,NamedValues); end; function TBoldReferenceHandleCom.ServerHandleClassName: string; begin - result := ServerHandleClassName_ReferenceHandle; + result := 'TBoldReferenceHandle'; end; +initialization + end. diff --git a/Source/ClientHandlesCom/Core/BoldRootedHandlesCom.pas b/Source/ClientHandlesCom/Core/BoldRootedHandlesCom.pas index 47d426dd..b122c38e 100644 --- a/Source/ClientHandlesCom/Core/BoldRootedHandlesCom.pas +++ b/Source/ClientHandlesCom/Core/BoldRootedHandlesCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldRootedHandlesCom; interface @@ -54,19 +57,12 @@ implementation uses SysUtils, - BoldComConst, - BoldUtils, BoldDefs, BoldComClient; -resourcestring - sPropertyIsReadOnly = '% is Read Only'; - sCircularReference = 'Circular reference in RootHandle'; - - const breFreeHandle = 42; - + {-- TBoldRootedHandleCom ------------------------------------------------------} constructor TBoldRootedHandleCom.Create(Owner: TComponent); @@ -156,15 +152,14 @@ procedure TBoldRootedHandleCom.RootHandleSubscriber_Receive(Originator: TObject; procedure TBoldRootedHandleCom.SetConnectionHandle(Value: TBoldComConnectionHandle); begin - // if ConnectionHandle is set to nil we must subscribe to RootHandle instead if (Value <> ConnectionHandle) then begin - inherited; // does the actual setting + inherited; if not Assigned(ConnectionHandle) then begin if Assigned(RootHandle) then begin - RootHandle.AddSmallSubscription(ConnectionSubscriber, [bceHandleInit,bceHandleTerm], 0); + RootHandle.AddSmallSubscription(ConnectionSubscriber,[bceHandleInit,bceHandleTerm],0); if Connected then DoConnect; end; @@ -177,11 +172,10 @@ procedure TBoldRootedHandleCom.SetRootHandle(Value: TBoldElementHandleCom); if (Value <> RootHandle) then begin if (Value = Self) or ((Value is TBoldRootedHandleCom) and TBoldRootedHandleCom(Value).IsRootLinkedTo(Self)) then - raise EBold.Create(sCircularReference); + raise EBold.Create('Circular reference in RootHandle'); RootHandleSubscriber.CancelAllSubscriptions; if not Assigned(ConnectionHandle) then begin - // if we were connected through this RootHandle ConnectionSubscriber.CancelAllSubscriptions; if Connected then DoDisconnect; @@ -206,7 +200,7 @@ procedure TBoldRootedHandleCom.SetEnabled(Value: Boolean); if Value <> FEnabled then begin if not OwnsHandleOnServer then - raise EBold.CreateFmt(sPropertyIsReadOnly, ['Enabled']); // do not localize + raise EBold.Create('Enabled is read-only'); FEnabled := Value; LocalValueChanged; end; @@ -217,7 +211,7 @@ procedure TBoldRootedHandleCom.SetSubscribe(Value: Boolean); if FSubscribe <> Value then begin if not OwnsHandleOnServer then - raise EBold.CreateFmt(sPropertyIsReadOnly, ['Subscribe']); // do not localize + raise EBold.Create('Subscribe is read-only'); FSubscribe := Value; LocalValueChanged; end; @@ -228,10 +222,12 @@ procedure TBoldRootedHandleCom.SetRootTypeName(const Value: string); if Value <> RootTypeName then begin if not OwnsHandleOnServer then - raise EBold.CreateFmt(sPropertyIsReadOnly, ['RootTypeName']); // do not localize + raise EBold.Create('RootTypeName is read-only'); FRootTypeName := Value; LocalValueChanged; end; end; +initialization + end. diff --git a/Source/ClientHandlesCom/Core/BoldSQLHandleCom.pas b/Source/ClientHandlesCom/Core/BoldSQLHandleCom.pas index 1ae1f8f3..578c8ea3 100644 --- a/Source/ClientHandlesCom/Core/BoldSQLHandleCom.pas +++ b/Source/ClientHandlesCom/Core/BoldSQLHandleCom.pas @@ -1,11 +1,12 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSQLHandleCom; interface uses Classes, - BoldComObjectSpace, - BoldComObjectSpace_TLB, BoldHandlesCom; type @@ -44,15 +45,16 @@ TBoldSQLHandleCom = class(TBoldNonSystemHandleCom) property SQLWhereClause: string read GetSQLWhereClause write SetSQLWhereClause; end; + implementation uses SysUtils, - BoldComHandlesConst, - ComHandlesConst, - BoldUtils, + BoldComObjectSpace, + BoldComObjectSpace_TLB, + BoldComUtils, BoldDefs, - BoldComUtils; + BoldRev; constructor TBoldSQLHandleCom.Create(Owner: TComponent); begin @@ -68,24 +70,22 @@ destructor TBoldSQLHandleCom.Destroy; procedure TBoldSQLHandleCom.ClearAllValues; begin - // from TBoldElementHandleCom FDynamicBoldType := nil; FStaticBoldType := nil; FStaticSystemTypeInfo := nil; FValue := nil; FHandleId := 0; - // from TBoldNonSystemHandleCom - // from TBoldSQLHandleCom + end; procedure TBoldSQLHandleCom.ClearList; begin - ServerElementHandle.SetData(-1, nil, BoldCreateNamedValues([nv_Action], [nv_ClearList])); + ServerElementHandle.SetData(-1, nil, BoldCreateNamedValues(['Action'], ['ClearList'])); end; procedure TBoldSQLHandleCom.ExecuteSQL; begin - ServerElementHandle.SetData(-1, nil, BoldCreateNamedValues([nv_Action], [nv_ExecuteSQL])); + ServerElementHandle.SetData(-1, nil, BoldCreateNamedValues(['Action'], ['ExecuteSQL'])); end; function TBoldSQLHandleCom.GetClassExpressionName: string; @@ -118,7 +118,7 @@ function TBoldSQLHandleCom.GetSQLWhereClause: string; function TBoldSQLHandleCom.ServerHandleClassName: string; begin - Result := ServerHandleClassName_SQLHandle; + Result := 'TBoldSQLHandle'; end; procedure TBoldSQLHandleCom.SetClassExpressionName(const Value: string); @@ -126,7 +126,7 @@ procedure TBoldSQLHandleCom.SetClassExpressionName(const Value: string); if Value <> FClassExpressionName then begin if not OwnsHandleOnServer then - raise EBold.CreateFmt(sPropertyIsReadOnly, ['ClassExpressionName']); // do not localize + raise EBold.Create('ClassExpressionName is read-only'); FClassExpressionName := Value; LocalValueChanged; end; @@ -137,7 +137,7 @@ procedure TBoldSQLHandleCom.SetClearBeforeExecute(Value: Boolean); if Value <> FClearBeforeExecute then begin if not OwnsHandleOnServer then - raise EBold.CreateFmt(sPropertyIsReadOnly, ['ClearBeforeExecute']); // do not localize + raise EBold.Create('ClearBeforeExecute is read-only'); FClearBeforeExecute := Value; LocalValueChanged; end; @@ -148,7 +148,7 @@ procedure TBoldSQLHandleCom.SetSQLOrderByClause(const Value: string); if Value <> FSQLOrderByClause then begin if not OwnsHandleOnServer then - raise EBold.CreateFmt(sPropertyIsReadOnly, ['SQLOrderByClause']); // do not localize + raise EBold.Create('SQLOrderByClause is read-only'); FSQLOrderByClause := Value; LocalValueChanged; end; @@ -159,7 +159,7 @@ procedure TBoldSQLHandleCom.SetSQLWhereClause(const Value: string); if Value <> FSQLWhereClause then begin if not OwnsHandleOnServer then - raise EBold.CreateFmt(sPropertyIsReadOnly, ['SQLWhereClause']); // do not localize + raise EBold.Create('SQLWhereClause is read-only'); FSQLWhereClause := Value; LocalValueChanged; end; @@ -185,13 +185,13 @@ procedure TBoldSQLHandleCom.ValuesFromServer; DummyList, DummyListType, NamedValues); - FHandleId := BoldGetNamedValue(NamedValues, nv_HandleId); + FHandleId := BoldGetNamedValue(NamedValues,'HandleId'); if not OwnsHandleOnServer then begin - FClassExpressionName := BoldGetNamedValue(NamedValues, nv_ClassExpressionName); - FClearBeforeExecute := BoldGetNamedValue(NamedValues, nv_ClearBeforeExecute); - FSQLOrderByClause := BoldGetNamedValue(NamedValues, nv_SQLOrderByClause); - FSQLWhereClause := BoldGetNamedValue(NamedValues, nv_SQLWhereClause); + FClassExpressionName := BoldGetNamedValue(NamedValues,'ClassExpressionName'); + FClearBeforeExecute := BoldGetNamedValue(NamedValues,'ClearBeforeExecute'); + FSQLOrderByClause := BoldGetNamedValue(NamedValues,'SQLOrderByClause'); + FSQLWhereClause := BoldGetNamedValue(NamedValues,'SQLWhereClause'); end; end; @@ -208,16 +208,16 @@ procedure TBoldSQLHandleCom.ValuesToServer; else StaticSystemHandleId := 0; NamedValues := BoldCreateNamedValues( - [nv_StaticSystemHandle, - nv_ClassExpressionName, - nv_ClearBeforeExecute, - nv_SQLOrderByClause, - nv_SQLWhereClause], + ['StaticSystemHandle', + 'ClassExpressionName', + 'ClearBeforeExecute', + 'SQLOrderByClause', + 'SQLWhereClause'], [StaticSystemHandleId, - FClassExpressionName, - FClearBeforeExecute, - FSQLOrderByClause, - FSQLWhereClause]); + FClassExpressionName, + FClearBeforeExecute, + FSQLOrderByClause, + FSQLWhereClause]); ServerElementHandle.SetData(DataFlags,nil,NamedValues); end; diff --git a/Source/ClientHandlesCom/Core/BoldSystemHandleCom.pas b/Source/ClientHandlesCom/Core/BoldSystemHandleCom.pas index 607ef819..a9e3762d 100644 --- a/Source/ClientHandlesCom/Core/BoldSystemHandleCom.pas +++ b/Source/ClientHandlesCom/Core/BoldSystemHandleCom.pas @@ -1,10 +1,11 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSystemHandleCom; interface uses - BoldComObjectSpace, - BoldComObjectSpace_TLB, BoldHandlesCom; type @@ -18,6 +19,7 @@ TBoldSystemHandleCom = class(TBoldAbstractSystemHandleCom) function GetPersistent: Boolean; protected function ServerHandleClassName: string; override; + procedure ClearAllValues; override; procedure ValuesFromServer; override; procedure ValuesToServer; override; @@ -31,11 +33,10 @@ implementation uses SysUtils, - ComHandlesConst, - BoldComHandlesConst, - BoldUtils, + BoldComObjectSpace_TLB, + BoldComUtils, BoldDefs, - BoldComUtils; + BoldRev; {-- TBoldSystemHandleCom ------------------------------------------------------} @@ -47,19 +48,17 @@ destructor TBoldSystemHandleCom.Destroy; procedure TBoldSystemHandleCom.ClearAllValues; begin - // from TBoldElementHandleCom FDynamicBoldType := nil; FStaticBoldType := nil; FStaticSystemTypeInfo := nil; FValue := nil; FHandleId := 0; - // from TBoldAbstractSystemHandleCom FBoldSystem := nil; FSystemActive := False; - // from TBoldSystemHandleCom FPersistent := False; end; + function TBoldSystemHandleCom.GetPersistent: Boolean; begin EnsureCurrent; @@ -72,7 +71,7 @@ procedure TBoldSystemHandleCom.UpdateDatabase; if Assigned(System) then System.UpdateDatabase else - raise EBold.Create(sNotConnected); + raise EBold.Create('UpdateDatabase: Not connected'); end; procedure TBoldSystemHandleCom.ValuesFromServer; @@ -94,19 +93,21 @@ procedure TBoldSystemHandleCom.ValuesFromServer; DummyList, DummyListType, NamedValues); - FHandleId := BoldGetNamedValue(NamedValues, nv_HandleId); - FSystemActive := BoldGetNamedValue(NamedValues, nv_Active); - FPersistent := BoldGetNamedValue(NamedValues, nv_Persistent); + FHandleId := BoldGetNamedValue(NamedValues,'HandleId'); + FSystemActive := BoldGetNamedValue(NamedValues,'Active'); + FPersistent := BoldGetNamedValue(NamedValues,'Persistent'); end; procedure TBoldSystemHandleCom.ValuesToServer; begin - // Nothing to set, the SystemHandle is always read-only. end; + function TBoldSystemHandleCom.ServerHandleClassName: string; begin - result := ServerHandleClassName_SystemHandle; + result := 'TBoldServerHandle'; end; +initialization + end. diff --git a/Source/ClientHandlesCom/Core/BoldVariableDefinitionCom.pas b/Source/ClientHandlesCom/Core/BoldVariableDefinitionCom.pas index 2f5f670f..579e0664 100644 --- a/Source/ClientHandlesCom/Core/BoldVariableDefinitionCom.pas +++ b/Source/ClientHandlesCom/Core/BoldVariableDefinitionCom.pas @@ -1,23 +1,21 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldVariableDefinitionCom; interface uses Classes, - BoldDefs, BoldSubscription, - BoldHandlesCom, - BoldComObjectSpace, - BoldComObjectSpace_TLB; + BoldHandlesCom; type -{ TODO: Create proxy, stuff values, etc. } TBoldVariableDefinitionCom = class; TBoldVariableTupleListCom = class; TBoldVariableTupleCom = class; - { TBoldVariableDefinitionCom } TBoldVariableDefinitionCom = class(TBoldSubscribableComponent) private fVariableTupleList: TBoldVariableTupleListCom; @@ -30,7 +28,6 @@ TBoldVariableDefinitionCom = class(TBoldSubscribableComponent) property Variables: TBoldVariableTupleListCom read fVariableTupleList write SetVariableTupleList; end; - { TBoldVariableTupleListCom } TBoldVariableTupleListCom = class(TCollection) private fOwner: TBoldVariableDefinitionCom; @@ -46,7 +43,6 @@ TBoldVariableTupleListCom = class(TCollection) property Items[Index: integer]: TBoldVariableTupleCom read GetItems; default; end; - { TBoldVariableTupleCom } TBoldVariableTupleCom = class(TCollectionItem) private FVariableName: String; @@ -62,19 +58,19 @@ TBoldVariableTupleCom = class(TCollectionItem) function GetDisplayName: string; override; public constructor Create(Collection: TCollection); override; - destructor Destroy; override; + destructor destroy; override; published property BoldHandle: TBoldElementHandleCom read FBoldHandle write SetBoldHandle; property VariableName: String read FVariableName write SetVariableName; property UseListElement: Boolean read FUseListElement write SetUseListElement; end; + implementation uses SysUtils, - BoldComHandlesConst, - BoldUtils; + BoldDefs; { TBoldVariableDefinitionCom } constructor TBoldVariableDefinitionCom.create(Owner: TComponent); @@ -121,7 +117,7 @@ function TBoldVariableTupleListCom.GetUniqueName: String; begin i := 1; repeat - result := 'Variable' + IntToStr(i); // do not translate + result := 'Variable'+IntToStr(i); Inc(i); until NameIsUnique(result); end; @@ -167,7 +163,7 @@ constructor TBoldVariableTupleCom.Create(Collection: TCollection); fBoldHandleSubscriber := TBoldPassthroughSubscriber.Create(_ReceiveHandleEvent); end; -destructor TBoldVariableTupleCom.Destroy; +destructor TBoldVariableTupleCom.destroy; begin FreeAndNil(fBoldHandleSubscriber); inherited; @@ -179,9 +175,9 @@ function TBoldVariableTupleCom.GetDisplayName: string; if assigned(BoldHandle) then Result := result + ': ' + BoldHandle.Name else - result := result + ': Not Connected'; // do not localize + result := result + ': Not Connected'; if UseListElement then - result := result + ' (list)'; // do not localize + result := result + ' (list)'; end; procedure TBoldVariableTupleCom.SetBoldHandle(const Value: TBoldElementHandleCom); @@ -189,17 +185,14 @@ procedure TBoldVariableTupleCom.SetBoldHandle(const Value: TBoldElementHandleCom FBoldHandle := Value; fBoldHandleSubscriber.CancelAllSubscriptions; if assigned(value) then - Value.AddSmallSubscription(fBoldHandleSubscriber, [beDestroying], beDestroying); - { TODO: Reeanable when AbstractListHandleCom fixed } -// if not (BoldHandle is TBoldAbstractListHandleCom) then -// UseListElement := false; + Value.AddSmallSubscription(fBoldHandleSubscriber, [beDestroying], beDestroying); + Changed; + end; procedure TBoldVariableTupleCom.SetUseListElement(const Value: Boolean); -begin - { TODO: Reeanable when AbstractListHandleCom fixed } -// FUseListElement := Value and (BoldHandle is TBoldAbstractListHandleCom); +begin Changed; end; @@ -207,14 +200,15 @@ procedure TBoldVariableTupleCom.SetVariableName(const Value: String); begin if FVariableName <> Value then begin if not (Collection as TBoldVariableTupleListCom).NameIsUnique(Value) then - raise EBold.CreateFmt(sNameNotUnique, [Value]); + raise EBold.CreateFmt('Can''t rename variable to "%s", name already exists', [Value]); if not (Collection as TBoldVariableTupleListCom).NameIsValid(Value) then - raise EBold.Create(sInvalidCharsInName); + raise EBold.Create('Invalid variable name, only alphanum characters and underscore valid'); FVariableName := Value; Changed; end; end; + procedure TBoldVariableTupleCom._ReceiveHandleEvent(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); begin @@ -223,8 +217,7 @@ procedure TBoldVariableTupleCom._ReceiveHandleEvent(Originator: TObject; end; procedure TBoldVariableDefinitionCom.VariablesChanged; -begin - { TODO: Stuff Values } +begin end; end. diff --git a/Source/ClientHandlesCom/Core/BoldVariableHandleCom.pas b/Source/ClientHandlesCom/Core/BoldVariableHandleCom.pas index 8a44b054..f4036cfd 100644 --- a/Source/ClientHandlesCom/Core/BoldVariableHandleCom.pas +++ b/Source/ClientHandlesCom/Core/BoldVariableHandleCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldVariableHandleCom; interface @@ -41,8 +44,6 @@ implementation uses SysUtils, - BoldComHandlesConst, - ComHandlesConst, BoldUtils, BoldDefs, BoldComUtils; @@ -65,14 +66,12 @@ destructor TBoldVariableHandleCom.Destroy; procedure TBoldVariableHandleCom.ClearAllValues; begin - // from TBoldElementHandleCom FDynamicBoldType := nil; FStaticBoldType := nil; FStaticSystemTypeInfo := nil; FValue := nil; FHandleId := 0; - // from TBoldNonSystemHandleCom - // from TBoldVariableHandleCom + end; function TBoldVariableHandleCom.GetValueTypeName: string; @@ -99,7 +98,7 @@ procedure TBoldVariableHandleCom.SetValueTypeName(const Value: string); if Value <> FValueTypeName then begin if not OwnsHandleOnServer then - raise EBold.CreateFmt(sPropertyIsReadOnly, [ValueTypeName]); + raise EBold.CreateFmt('%s.ValueTypeName is read-only', [ClassName]); FValueTypeName := Value; LocalValueChanged; end; @@ -110,7 +109,7 @@ procedure TBoldVariableHandleCom.SetInitialValues(Value: TStrings); if Value <> FInitialValues then begin if not OwnsHandleOnServer then - raise EBold.CreateFmt(sPropertyIsReadOnly, [InitialValues]); + raise EBold.CreateFmt('%s.InitialValues is read-only', [ClassName]); FInitialValues.Assign(Value); LocalValueChanged; end; @@ -137,13 +136,13 @@ procedure TBoldVariableHandleCom.ValuesFromServer; DummyList, DummyListType, NamedValues); - FHandleId := BoldGetNamedValue(NamedValues, nv_HandleId); + FHandleId := BoldGetNamedValue(NamedValues, 'HandleId'); if not OwnsHandleOnServer then begin - FValueTypeName := BoldGetNamedValue(NamedValues, nv_ValueTypeName); + FValueTypeName := BoldGetNamedValue(NamedValues, 'ValueTypeName'); Temp := TStringList.Create; try - BoldVariantToStrings(BoldGetNamedValue(NamedValues, nv_InitialValues),Temp); + BoldVariantToStrings(BoldGetNamedValue(NamedValues, 'InitialValues'),Temp); FInitialValues.Assign(Temp); finally Temp.Free; @@ -163,25 +162,24 @@ procedure TBoldVariableHandleCom.ValuesToServer; else StaticSystemHandleId := 0; NamedValues := BoldCreateNamedValues( - [nv_StaticSystemHandle, - nv_ValueTypeName, - nv_InitialValues], + ['StaticSystemHandle', + 'ValueTypeName', + 'InitialValues'], [StaticSystemHandleId, - FValueTypeName, - BoldStringsToVariant(FInitialValues)]); + FValueTypeName, + BoldStringsToVariant(FInitialValues)]); ServerElementHandle.SetData(DataFlags, nil, NamedValues); end; function TBoldVariableHandleCom.ServerHandleClassName: string; begin - result := ServerHandleClassName_VariableHandle; + result := 'TBoldVariableHandle'; end; procedure TBoldVariableHandleCom.DefineProperties(Filer: TFiler); begin inherited DefineProperties(Filer); - // ExpressionName changed name to ValueTypeName after 2.5 - Filer.DefineProperty('ExpressionName', ReadExpressionName, nil, True); // do not localize + Filer.DefineProperty('ExpressionName', ReadExpressionName, nil, True); end; procedure TBoldVariableHandleCom.ReadExpressionName(Reader: TReader); @@ -189,4 +187,6 @@ procedure TBoldVariableHandleCom.ReadExpressionName(Reader: TReader); ValueTypeName := Reader.ReadString; end; +initialization + end. diff --git a/Source/ClientHandlesCom/Core/ComHandlesConst.pas b/Source/ClientHandlesCom/Core/ComHandlesConst.pas index 4e4950d0..203c1199 100644 --- a/Source/ClientHandlesCom/Core/ComHandlesConst.pas +++ b/Source/ClientHandlesCom/Core/ComHandlesConst.pas @@ -38,4 +38,4 @@ interface implementation -end. \ No newline at end of file +end. diff --git a/Source/ClientHandlesCom/IDE/BoldHandleComReg.RES b/Source/ClientHandlesCom/IDE/BoldHandleComReg.RES new file mode 100644 index 00000000..c9a49673 Binary files /dev/null and b/Source/ClientHandlesCom/IDE/BoldHandleComReg.RES differ diff --git a/Source/ClientHandlesCom/IDE/BoldHandleComReg.pas b/Source/ClientHandlesCom/IDE/BoldHandleComReg.pas index db22903a..f788d77d 100644 --- a/Source/ClientHandlesCom/IDE/BoldHandleComReg.pas +++ b/Source/ClientHandlesCom/IDE/BoldHandleComReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldHandleComReg; interface @@ -11,7 +14,6 @@ implementation BoldUtils, Classes, DesignIntf, - BoldIDEConsts, BoldGuard, BoldSystemHandleCom, BoldDerivedHandleCom, @@ -26,31 +28,30 @@ implementation {$R BoldHandleComReg.res} -const - prop_ObjectName = 'Objectname'; - procedure Register; begin - RegisterComponents('Bold COM Handles', // do not localize - [ - TBoldSystemHandleCom, - TBoldDerivedHandleCom, - TBoldExpressionHandleCom, - TBoldCursorHandleCom, - TBoldListHandleCom, - TBoldReferenceHandleCom, - TBoldSQLHandleCom, - //TBoldVariableDefinitionCom, - TBoldVariableHandleCom - ]); - RegisterPropertyEditor(TypeInfo(String), TBoldSystemHandleCom, prop_ObjectName, TBoldObjectNameProperty); - RegisterPropertyEditor(TypeInfo(String), TBoldDerivedHandleCom, prop_ObjectName, TBoldObjectNameProperty); - RegisterPropertyEditor(TypeInfo(String), TBoldExpressionHandleCom, prop_ObjectName, TBoldObjectNameProperty); - RegisterPropertyEditor(TypeInfo(String), TBoldCursorHandleCom, prop_ObjectName, TBoldObjectNameProperty); - RegisterPropertyEditor(TypeInfo(String), TBoldListHandleCom, prop_ObjectName, TBoldObjectNameProperty); - RegisterPropertyEditor(TypeInfo(String), TBoldReferenceHandleCom, prop_ObjectName, TBoldObjectNameProperty); - RegisterPropertyEditor(TypeInfo(String), TBoldSQLHandleCom, prop_ObjectName, TBoldObjectNameProperty); - RegisterPropertyEditor(TypeInfo(String), TBoldVariableHandleCom, prop_ObjectName, TBoldObjectNameProperty); + + begin + RegisterComponents('Bold COM Handles', + [ + TBoldSystemHandleCom, + TBoldDerivedHandleCom, + TBoldExpressionHandleCom, + TBoldCursorHandleCom, + TBoldListHandleCom, + TBoldReferenceHandleCom, + TBoldSQLHandleCom, + TBoldVariableHandleCom + ]); + RegisterPropertyEditor(TypeInfo(String), TBoldSystemHandleCom, 'Objectname', TBoldObjectNameProperty); + RegisterPropertyEditor(TypeInfo(String), TBoldDerivedHandleCom, 'Objectname', TBoldObjectNameProperty); + RegisterPropertyEditor(TypeInfo(String), TBoldExpressionHandleCom, 'Objectname', TBoldObjectNameProperty); + RegisterPropertyEditor(TypeInfo(String), TBoldCursorHandleCom, 'Objectname', TBoldObjectNameProperty); + RegisterPropertyEditor(TypeInfo(String), TBoldListHandleCom, 'Objectname', TBoldObjectNameProperty); + RegisterPropertyEditor(TypeInfo(String), TBoldReferenceHandleCom, 'Objectname', TBoldObjectNameProperty); + RegisterPropertyEditor(TypeInfo(String), TBoldSQLHandleCom, 'Objectname', TBoldObjectNameProperty); + RegisterPropertyEditor(TypeInfo(String), TBoldVariableHandleCom, 'Objectname', TBoldObjectNameProperty); + end; end; end. diff --git a/Source/ClientHandlesCom/IDE/BoldHandleComReg.rc b/Source/ClientHandlesCom/IDE/BoldHandleComReg.rc index 7c31f801..79959782 100644 --- a/Source/ClientHandlesCom/IDE/BoldHandleComReg.rc +++ b/Source/ClientHandlesCom/IDE/BoldHandleComReg.rc @@ -1,12 +1,12 @@ -TBOLDSYSTEMHANDLECOM BITMAP LOADONCALL TBoldSystemHandleCom.bmp -TBOLDEXPRESSIONHANDLECOM BITMAP LOADONCALL TBoldExpressionHandleCom.bmp -TBOLDLISTHANDLECOM BITMAP LOADONCALL TBoldListHandleCom.bmp -TBOLDSQLHANDLECOM BITMAP LOADONCALL TBoldSQLHandleCom.bmp -TBOLDPLACEABLESUBSCRIBERCOM BITMAP LOADONCALL TBoldPlaceableSubscriberCom.bmp -TBOLDFILTERCOM BITMAP LOADONCALL TBoldFilterCom.bmp -TBOLDCOMPARERCOM BITMAP LOADONCALL TBoldComparerCom.bmp -TBOLDVARIABLEHANDLECOM BITMAP LOADONCALL TBoldVariableHandleCom.bmp -TBOLDREFERENCEHANDLECOM BITMAP LOADONCALL TBoldReferenceHandleCom.bmp -TBOLDCURSORHANDLECOM BITMAP LOADONCALL TBoldCursorHandleCom.bmp -TBOLDDERIVEDHANDLECOM BITMAP LOADONCALL TBoldDerivedHandleCom.bmp -TBOLDVARIABLEDEFINITIONCOM BITMAP LOADONCALL TBoldVariableDefinitionCom.bmp +TBOLDSYSTEMHANDLECOM BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldSystemHandleCom.bmp +TBOLDEXPRESSIONHANDLECOM BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldExpressionHandleCom.bmp +TBOLDLISTHANDLECOM BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldListHandleCom.bmp +TBOLDSQLHANDLECOM BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldSQLHandleCom.bmp +TBOLDPLACEABLESUBSCRIBERCOM BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldPlaceableSubscriberCom.bmp +TBOLDFILTERCOM BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldFilterCom.bmp +TBOLDCOMPARERCOM BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldComparerCom.bmp +TBOLDVARIABLEHANDLECOM BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldVariableHandleCom.bmp +TBOLDREFERENCEHANDLECOM BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldReferenceHandleCom.bmp +TBOLDCURSORHANDLECOM BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldCursorHandleCom.bmp +TBOLDDERIVEDHANDLECOM BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldDerivedHandleCom.bmp +TBOLDVARIABLEDEFINITIONCOM BITMAP LOADONCALL ..\..\..\Images\ComponentsCom\TBoldVariableDefinitionCom.bmp diff --git a/Source/Common/COM/BoldApartmentThread.pas b/Source/Common/COM/BoldApartmentThread.pas index e0ccb2e1..89171c93 100644 --- a/Source/Common/COM/BoldApartmentThread.pas +++ b/Source/Common/COM/BoldApartmentThread.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldApartmentThread; interface @@ -12,10 +15,8 @@ interface BM_CREATEOBJECTINTHREAD = WM_USER + $1234; type - { forward declarations } TBoldApartmentThread = class; - { prototypes } TCreateInstanceProc = function(const UnkOuter: IUnknown; const IID: TGUID; out Obj): HResult of object; stdcall; TBoldApartmentType = (batMTA, batSTA); @@ -25,7 +26,6 @@ TCreateInstanceInfo = record ApartmentThread: TBoldApartmentThread; end; - { TBoldApartmentThread } TBoldApartmentThread = class(TBoldNotifiableThread) private FCreateInstanceProc: TCreateInstanceProc; @@ -59,8 +59,8 @@ implementation uses SysUtils, ActiveX, - BoldThreadSafeLog, - BoldComConst; + BoldThreadSafeLog + ; { apartment handler window } function ApartmentThreadWndProc (hWndTarget: HWND; iMessage, wParam, lParam: longint): longint; stdcall; @@ -79,10 +79,10 @@ function ApartmentThreadWndProc (hWndTarget: HWND; iMessage, wParam, lParam: lon if Succeeded (at.CreateResult) then at.CreateResult := at.MarshalInterface (pUnk); ReleaseSemaphore(at.ObjectCreatedEvent, 1, nil); - pUnk := nil; // get rid of own reference, MarshalInterface already added one + pUnk := nil; Result := 0; except - BoldLogError(spciInfoNotInitialized); + BoldLogError('ApartmentThreadWndProc: pciInfo not initialized'); end; end else @@ -94,7 +94,6 @@ function ApartmentThreadWndProc (hWndTarget: HWND; iMessage, wParam, lParam: lon end; var - // this variable is initialized (zeroed) in the initializationsection) cApartmentThreadWindowClass: TWndClass; { TBoldApartmentThread } @@ -140,7 +139,7 @@ procedure TBoldApartmentThread.Execute; res: integer; begin InitServerWindow (TRUE); - BoldLogThread('ID=AptThread'); // do not localize + BoldLogThread('ID=AptThread'); case ApartmentType of batSTA: CoInitializeEx(nil, COINIT_APARTMENTTHREADED); @@ -187,7 +186,7 @@ function TBoldApartmentThread.UnmarshalInterface (out pObject): HResult; Result := CoGetInterfaceAndReleaseStream (IStream (FStream), iid, pObject); FStream := NIL; except on E: Exception do - BoldLogError('%s.UnmarshalInterface: %s', [ClassName, E.Message]); // do not localize + BoldLogError('%s.UnmarshalInterface: %s', [ClassName, E.Message]); end; end; @@ -207,5 +206,5 @@ initialization cApartmentThreadWindowClass.hCursor := 0; cApartmentThreadWindowClass.hbrBackground := 0; cApartmentThreadWindowClass.lpszMenuName := NIL; - cApartmentThreadWindowClass.lpszClassName := 'TBoldApartmentThreadWindow'; // do not localize + cApartmentThreadWindowClass.lpszClassName := 'TBoldApartmentThreadWindow' end. diff --git a/Source/Common/COM/BoldComAdapter.pas b/Source/Common/COM/BoldComAdapter.pas index c388b46d..d0bc6591 100644 --- a/Source/Common/COM/BoldComAdapter.pas +++ b/Source/Common/COM/BoldComAdapter.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComAdapter; interface @@ -18,7 +21,7 @@ TBoldComAdapterFactory = class; TBoldAdaptableObject = TObject; TBoldAdaptableClass = class of TObject; - + TBoldComAdapterClass = class of TBoldComAdapter; {--- IBoldComAdapter ---} @@ -37,10 +40,10 @@ TBoldComAdapterContext = class(TBoldNonRefCountedObject) {--- TBoldComAdapter ---} TBoldComAdapter = class(TBoldAutoInterfacedObject, IBoldComAdapter) private - FAdaptee: TBoldAdaptableObject; - FIsOwner: Boolean; - FSubscriber: TBoldPassthroughSubscriber; + fIsOwner: Boolean; + fSubscriber: TBoldPassthroughSubscriber; protected + fAdaptee: TBoldAdaptableObject; function GetEnsuredAdaptee: TBoldAdaptableObject; { IBoldComAdapter } function GetAdaptee: TBoldAdaptableObject; @@ -73,24 +76,24 @@ TBoldComAdapterFactory = class(TBoldNonRefCountedObject) AdaptableClass: TBoldAdaptableClass); end; -procedure BoldComRegisterAdapter(AdapterClass: TBoldComAdapterClass; - AdaptableClass: TBoldAdaptableClass); -procedure BoldComCreateAdapter(Adaptee: TBoldAdaptableObject; - Owner: Boolean; const IID: TGUID; out Obj); +procedure BoldComRegisterAdapter(AdapterClass: TBoldComAdapterClass; AdaptableClass: TBoldAdaptableClass); +{ril}procedure BoldComCreateAdapter(Adaptee: TBoldAdaptableObject; Owner: Boolean; const IID: TGUID; out Obj); function BoldComInterfaceToObject(const Unk: IUnknown): TBoldAdaptableObject; +//PATCH +function GetDebugInfo: string; + implementation uses SysUtils, + Classes, //PATCH BoldDefs, BoldIndexableList, BoldHashIndexes, - BoldComUtils, - BoldComConst; + BoldComUtils; type - { TBoldAdapterCache } TBoldAdapterCache = class(TBoldUnorderedIndexableList) private function GetAdapterByAdaptee(Adaptee: TBoldAdaptableObject): TBoldComAdapter; @@ -102,9 +105,10 @@ TBoldAdapterCache = class(TBoldUnorderedIndexableList) {---TBoldObjectHashIndex---} TBoldAdapterCacheIndex = class(TBoldObjectHashIndex) protected - function ItemAsKeyObject(Item: TObject): TObject; override; + function ItemASKeyObject(Item: TObject): TObject; override; end; + var G_BoldComAdapterFactory: TBoldComAdapterFactory = nil; G_AdapterCache: TBoldAdapterCache = nil; @@ -120,6 +124,57 @@ function AdapterCache: TBoldAdapterCache; result := G_AdapterCache; end; +//PATCH +function GetDebugInfo: string; +var + vAdapterCache: TBoldAdapterCache; + vTraverser: TBoldIndexableListTraverser; + vAdapter: TBoldComAdapter; + vNoAdapteeCnt: Integer; + vAdapterRefCount: array [0..255] of Integer; + I: Integer; + vClasses: TStringList; +begin + vAdapterCache := AdapterCache; + vClasses := TStringList.Create; + vClasses.Sorted := True; + + Result := 'AdapterCache.Count:'+IntToStr(vAdapterCache.Count); + vTraverser := vAdapterCache.CreateTraverser; + try + vNoAdapteeCnt := 0; + FillChar(vAdapterRefCount,SizeOf(vAdapterRefCount),0); + while vTraverser.MoveNext do + begin + vAdapter := vTraverser.Item as TBoldComAdapter; + if Assigned(vAdapter.fAdaptee) then + begin + I := vClasses.Add(vAdapter.fAdaptee.ClassName); + vClasses.Objects[I] := TObject(Integer(vClasses.Objects[I])+1); + end + else + Inc(vNoAdapteeCnt); + + Inc(vAdapterRefCount[vAdapter.RefCount]); + + //Annat intressant som kan mätas och användas för klassning: + // + //vAdapter.RefCount + end; + Result := Result+' HasNoAdaptee:'+IntToStr(vNoAdapteeCnt)+#13#10; + for I:=0 to vClasses.Count-1 do + Result := Result+vClasses[I]+'='+IntToStr(Integer(vClasses.Objects[I]))+#13#10; + Result := Result+' RefCount=AdapterCount:'; + for I:=Low(vAdapterRefCount) to High(vAdapterRefCount) do + if vAdapterRefCount[I]<>0 then + Result := Result+IntToStr(I)+'='+IntToStr(vAdapterRefCount[I])+', '; + + finally + FreeAndNil(vTraverser); + FreeAndNil(vClasses); + end; +end; + procedure BoldComRegisterAdapter(AdapterClass: TBoldComAdapterClass; AdaptableClass: TBoldAdaptableClass); @@ -127,11 +182,13 @@ procedure BoldComRegisterAdapter(AdapterClass: TBoldComAdapterClass; TBoldComAdapterFactory.Instance.RegisterAdapterClass(AdapterClass,AdaptableClass); end; -procedure BoldComCreateAdapter(Adaptee: TBoldAdaptableObject; - Owner: Boolean; const IID: TGUID; out Obj); +procedure BoldComCreateAdapter(Adaptee: TBoldAdaptableObject; Owner: Boolean; const IID: TGUID; out Obj); +{ril} var Adapter: TBoldComAdapter; +{ UnknownAdapter: IUnknown; +} begin Pointer(Obj) := nil; if Assigned(Adaptee) then @@ -141,13 +198,19 @@ procedure BoldComCreateAdapter(Adaptee: TBoldAdaptableObject; Adapter := TBoldComAdapterFactory.Instance.CreateAdapterForObject(Adaptee,Owner); if not Assigned(Adapter) then - raise EBoldCom.CreateFmt(sNoAdapterRegistered,[Adaptee.ClassName]); - UnknownAdapter := Adapter; // AddRef + raise EBoldCom.CreateFmt('No adapter registered for %s',[Adaptee.ClassName]); +{ + UnknownAdapter := Adapter; if UnknownAdapter.QueryInterface(IID,Obj) <> 0 then - begin - UnknownAdapter := nil; // Release - raise EBoldCom.CreateFmt(sUnsupportedInterface,[Adapter.ClassName]); +} + if Adapter.QueryInterface(IID,Obj) <> 0 then +{ begin + UnknownAdapter := nil; +} + raise EBoldCom.CreateFmt('%s: Unsupported interface',[Adapter.ClassName]); +{ end; +} end; end; @@ -155,10 +218,8 @@ function BoldComInterfaceToObject(const Unk: IUnknown): TBoldAdaptableObject; begin Result := nil; if Assigned(Unk) then - begin - with Unk as IBoldComAdapter do - Result := GetAdaptee; - end; +// Result := (Unk as IBoldComAdapter).GetAdaptee; + Result := (Unk as IBoldComAdapter).GetAdaptee; end; {-- TBoldComAdapter -----------------------------------------------------------} @@ -166,7 +227,7 @@ function BoldComInterfaceToObject(const Unk: IUnknown): TBoldAdaptableObject; constructor TBoldComAdapter.Create(AdaptableObject: TBoldAdaptableObject; Owner: Boolean; const TypeLib: ITypeLib; const DispIntf: TGUID); begin - FSubscriber := TBoldPassthroughSubscriber.Create(ReceiveEvent); + fSubscriber := TBoldPassthroughSubscriber.Create(ReceiveEvent); SetAdaptee(AdaptableObject,Owner); inherited Create(TypeLib, DispIntf); end; @@ -175,9 +236,9 @@ destructor TBoldComAdapter.Destroy; begin if assigned(Adaptee) then AdapterCache.remove(self); - FreeAndNil(FSubscriber); - if FIsOwner and Assigned(FAdaptee) then - FreeAndNil(FAdaptee) + FreeAndNil(fSubscriber); + if fIsOwner and Assigned(fAdaptee) then + FreeAndNil(fAdaptee) else fAdaptee := nil; inherited Destroy; @@ -185,57 +246,57 @@ destructor TBoldComAdapter.Destroy; function TBoldComAdapter.GetAdaptee: TBoldAdaptableObject; begin - Result := FAdaptee; + Result := fAdaptee; end; function TBoldComAdapter.GetIsOwner: Boolean; begin - Result := FIsOwner; + Result := fIsOwner; end; function TBoldComAdapter.GetEnsuredAdaptee: TBoldAdaptableObject; begin - Result := FAdaptee; - if not Assigned(Result) then - raise EBoldCom.CreateFmt(sNoAdaptee, [ClassName]); + Result := fAdaptee; + if Result=nil then + raise EBoldCom.CreateFmt('%s: No adaptee',[ClassName]); end; procedure TBoldComAdapter.ReceiveEvent(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); begin - if (Originator = FAdaptee) and (OriginalEvent = beDestroying) then + if (Originator = fAdaptee) and (OriginalEvent = beDestroying) then begin AdapterCache.Remove(self); - FAdaptee := nil; + fAdaptee := nil; end; end; procedure TBoldComAdapter.SetAdaptee(Value: TBoldAdaptableObject; Owner: Boolean); begin - if FAdaptee <> Value then + if fAdaptee <> Value then begin if assigned(fAdaptee) then AdapterCache.remove(self); - FSubscriber.CancelAllSubscriptions; - if FIsOwner and Assigned(FAdaptee) then - FreeAndNil(FAdaptee); - - FAdaptee := Value; - - if FAdaptee is TBoldSubscribableObject then - TBoldSubscribableObject(FAdaptee).AddSubscription(FSubscriber, beDestroying, beDestroying) - else if FAdaptee is TBoldSubscribableComponent then - TBoldSubscribableComponent(FAdaptee).AddSubscription(FSubscriber, beDestroying, beDestroying) - else if FAdaptee is TBoldSubscribablePersistent then - TBoldSubscribablePersistent(FAdaptee).AddSubscription(FSubscriber, beDestroying, beDestroying) + fSubscriber.CancelAllSubscriptions; + if fIsOwner and Assigned(fAdaptee) then + FreeAndNil(fAdaptee); + + fAdaptee := Value; + + if fAdaptee is TBoldSubscribableObject then + TBoldSubscribableObject(fAdaptee).AddSubscription(fSubscriber, beDestroying, beDestroying) + else if fAdaptee is TBoldSubscribableComponent then + TBoldSubscribableComponent(fAdaptee).AddSubscription(fSubscriber, beDestroying, beDestroying) + else if fAdaptee is TBoldSubscribablePersistent then + TBoldSubscribablePersistent(fAdaptee).AddSubscription(fSubscriber, beDestroying, beDestroying) else if assigned(fAdaptee) then - raise EBold.CreateFmt(sCannotAdaptNonSubscribables, [className, value.ClassName]); + raise EBold.CreateFmt('%s.SetAdaptee: Can not adapt objects that are not subscribable (such as %s)', [className, value.ClassName]); if assigned(fAdaptee) then AdapterCache.Add(self); end; - if FIsOwner <> Owner then - FIsOwner := Owner; + if fIsOwner <> Owner then + fIsOwner := Owner; end; {-- TBoldComAdapterFactory ----------------------------------------------------} @@ -333,12 +394,10 @@ function TBoldAdapterCacheIndex.ItemASKeyObject(Item: TObject): TObject; result := (item as TBoldComAdapter).Adaptee; end; -initialization // empty +initialization finalization FreeAndNil(G_BoldComAdapterFactory); FreeAndNil(G_AdapterCache); end. - - diff --git a/Source/Common/COM/BoldComEventQueue.pas b/Source/Common/COM/BoldComEventQueue.pas index 6c5b2b55..4171c200 100644 --- a/Source/Common/COM/BoldComEventQueue.pas +++ b/Source/Common/COM/BoldComEventQueue.pas @@ -1,9 +1,13 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComEventQueue; + interface uses - SyncObjs, + SyncObjs, //NEW BoldBase; type @@ -35,7 +39,7 @@ TBoldComEventQueue = class(TBoldMemoryManagedObject) FOnEvent: TBoldComEventQueueEvent; FPopMode: TBoldComEventQueuePopMode; FTail: PBoldComEventQueueItem; - FCriticalSection: TCriticalSection; +//TODO FCriticalSection: TCriticalSection; //TODO Remove comment when interface change is allowed class procedure CreateQueueWindow; class procedure FreeQueueWindow; protected @@ -52,14 +56,29 @@ TBoldComEventQueue = class(TBoldMemoryManagedObject) property PopMode: TBoldComEventQueuePopMode read FPopMode; end; + TBoldComEventQueue2 = class(TBoldComEventQueue) + FCriticalSection: TCriticalSection; + end; + + implementation uses BoldEnvironment, - BoldMemoryManager, - SysUtils, + SysUtils, //NEW Windows; +var + G_FCriticalSection: TCriticalSection = nil; //TODO Remove when interface change is allowed + +function FCriticalSection: TCriticalSection; //TODO Remove when interface change is allowed +begin + if not Assigned(G_FCriticalSection) then + G_FCriticalSection := TCriticalSection.Create; + Result := G_FCriticalSection; +end; + + const BM_POPEVENTQUEUE = $8FFF; BM_DESTROYWINDOW = $8FFE; @@ -99,16 +118,15 @@ function BoldComEventQueueWndProc(Window: HWND; hCursor: 0; hbrBackground: 0; lpszMenuName: nil; - lpszClassName: 'TBoldComEventQueueWindow'); // do not localize + lpszClassName: 'TBoldComEventQueueWindow'); constructor TBoldComEventQueue.Create(PopMode: TBoldComEventQueuePopMode); begin inherited Create; - FCriticalSection := TCriticalSection.Create; +//TODO FCriticalSection := TCriticalSection.Create; //TODO Remove comment when interface change is allowed FPopMode := PopMode; Inc(BoldComEventQueueWindowCount); if BoldComEventQueueWindowCount = 1 then - // first queue instance creates the window CreateQueueWindow; end; @@ -119,9 +137,8 @@ destructor TBoldComEventQueue.Destroy; BoldEffectiveEnvironment.ProcessMessages; Dec(BoldComEventQueueWindowCount); if BoldComEventQueueWindowCount = 0 then - // last queue instance destroys window SendMessage(BoldComEventQueueWindow, BM_DESTROYWINDOW, 0, 0); - FreeAndNil(FCriticalSection); +//TODO FreeAndNil(FCriticalSection); //TODO Remove comment when interface change is allowed inherited Destroy; end; @@ -159,8 +176,8 @@ procedure TBoldComEventQueue.Clear; Item := PopItem; while Assigned(Item) do begin - BoldMemoryManager_.DeAllocateMemory(Item, SizeOf(TBoldComEventQueueItem)); - Item := PopItem; + FreeMem(Item, sizeof(TBoldComEventQueueItem)); + Item := PopItem; end; FCount := 0; end; @@ -182,7 +199,8 @@ procedure TBoldComEventQueue.Pop; try HandleEvent(Item^.EventData); finally - BoldMemoryManager_.DeAllocateMemory(Item, SizeOf(TBoldComEventQueueItem)); + FreeMem(Item, sizeof(TBoldComEventQueueItem)); +//OLD Dispose(Item); end; Item := PopItem; end; @@ -192,53 +210,54 @@ procedure TBoldComEventQueue.Pop; try HandleEvent(Item^.EventData); finally - BoldMemoryManager_.DeAllocateMemory(Item, SizeOf(TBoldComEventQueueItem)); + FreeMem(Item, sizeof(TBoldComEventQueueItem)); +//OLD Dispose(Item); end; end; end; function TBoldComEventQueue.PopItem: PBoldComEventQueueItem; begin - // get first item in list Result := nil; if Assigned(FHead) then begin - FCriticalSection.Enter; + FCriticalSection.Enter; //NEW Result := FHead; - // remove from list FHead := Result^.Next; if not Assigned(FHead) then FTail := nil; Dec(FCount); - FCriticalSection.Leave; + FCriticalSection.Leave; //NEW end; end; procedure TBoldComEventQueue.Push(const EventData: TBoldComEventData); var Item: PBoldComEventQueueItem; - PostMessagePopEventQueueMessage: Boolean; + PostMessagePopEventQueueMessage: Boolean; //NEW begin - // allocate new list item - Item := BoldMemoryManager_.AllocateMemory(SizeOf(TBoldComEventQueueItem)); - // copy event data between structures + GetMem(Item, sizeof(TBoldComEventQueueItem)); +//OLD New(Item); Move(EventData,Item^.EventData,SizeOf(EventData)); - // no next item, since this will be the last item Item^.Next := nil; - // add to end of list - FCriticalSection.Enter; + FCriticalSection.Enter; //NEW if not Assigned(FHead) then FHead := Item; if Assigned(FTail) then FTail^.Next := Item; FTail := Item; Inc(FCount); - PostMessagePopEventQueueMessage := (popMode=pmSingleEvent) or (FCount=1); - FCriticalSection.Leave; - if PostMessagePopEventQueueMessage then - PostMessage(BoldComEventQueueWindow,BM_POPEVENTQUEUE,0,Integer(Self)); + PostMessagePopEventQueueMessage := (popMode=pmSingleEvent) or (FCount=1); //NEW + FCriticalSection.Leave; //NEW + if PostMessagePopEventQueueMessage then //NEW + PostMessage(BoldComEventQueueWindow,BM_POPEVENTQUEUE,0,Integer(Self)); //NEW +//OLD case popMode of +//OLD pmSingleEvent: PostMessage(BoldComEventQueueWindow,BM_POPEVENTQUEUE,0,Integer(Self)); +//OLD pmAllEvents: if Count = 1 then PostMessage(BoldComEventQueueWindow,BM_POPEVENTQUEUE,0,Integer(Self)); +//OLD end; end; +initialization +finalization + FreeAndNil(G_FCriticalSection); //TODO Remove when interface change is allowed end. - - diff --git a/Source/Common/COM/BoldComObj.pas b/Source/Common/COM/BoldComObj.pas index b895ccda..db9a3777 100644 --- a/Source/Common/COM/BoldComObj.pas +++ b/Source/Common/COM/BoldComObj.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComObj; interface @@ -47,6 +50,7 @@ TBoldVariantEnumerator = class(TBoldRefCountedObject, IEnumVariant) function Clone(out Enum: IEnumVariant): HResult; stdcall; public constructor Create(Collection: IBoldVariantCollection); + destructor Destroy; override; end; {-- TBoldAutoInterfacedObject --} @@ -111,6 +115,11 @@ constructor TBoldVariantEnumerator.Create(Collection: IBoldVariantCollection); FCollection := Collection; end; +destructor TBoldVariantEnumerator.Destroy; +begin + inherited; +end; + function TBoldVariantEnumerator.Next(celt: LongWord; var rgvar: OleVariant; pceltFetched: PLongWord): HResult; type @@ -277,4 +286,7 @@ function TBoldAggregatedAutoInterfacedObject.QueryInterface(const IID: TGUID; ou Result := IUnknown(FController).QueryInterface(IID,Obj); end; + +initialization + end. diff --git a/Source/Common/COM/BoldComThreads.pas b/Source/Common/COM/BoldComThreads.pas index 27cdad30..861761c0 100644 --- a/Source/Common/COM/BoldComThreads.pas +++ b/Source/Common/COM/BoldComThreads.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComThreads; interface @@ -22,6 +25,7 @@ TBoldComConnectionThread = class(TBoldMemoryManagedObject) FConnectRes: HResult; public constructor Create(const HostName: string; const CLSID, IID: TGUID); + destructor Destroy; override; function Connect(out Obj): Boolean; property Busy: Boolean read FBusy; property ConnectRes: HResult read fConnectRes; @@ -65,6 +69,7 @@ TBoldComCreateObjectThread = class(TThread) procedure Execute; override; public constructor Create(Owner: TBoldComConnectionThread; CreateSuspended: Boolean); + destructor Destroy; override; property InterfaceStream: Pointer read FInterfaceStream; property CreateRes: HResult read fCreateRes; end; @@ -77,6 +82,11 @@ constructor TBoldComCreateObjectThread.Create(Owner: TBoldComConnectionThread; FCreateRes := NOERROR; end; +destructor TBoldComCreateObjectThread.Destroy; +begin + inherited; +end; + procedure TBoldComCreateObjectThread.Execute; var Unk: IUnknown; @@ -110,6 +120,11 @@ constructor TBoldComConnectionThread.Create(const HostName: string; fConnectRes := NOERROR; end; +destructor TBoldComConnectionThread.Destroy; +begin + inherited; +end; + function TBoldComConnectionThread.Connect(out Obj): Boolean; var ThreadObject: TBoldComCreateObjectThread; @@ -147,7 +162,6 @@ function TBoldComConnectionThread.Connect(out Obj): Boolean; end; end; else - // Error Break; end; end; @@ -231,4 +245,6 @@ procedure TBoldComWorkerThread.Release; SetEvent(FWaitEvent); end; +initialization + end. diff --git a/Source/Common/COM/BoldComUtils.pas b/Source/Common/COM/BoldComUtils.pas index 2fbbbbad..b6551b8c 100644 --- a/Source/Common/COM/BoldComUtils.pas +++ b/Source/Common/COM/BoldComUtils.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComUtils; interface @@ -215,25 +218,21 @@ function BoldVariantIsNamedValues(V: OleVariant): Boolean; var Va: OleVariant; begin - // Variant must be array Result := VarIsArray(V); if Result then begin - // Array must contain two elements, index 0 and 1 Result := VarArrayDimCount(V) = 1; Result := Result and (VarArrayLowBound(V,1) = 0); Result := Result and (VarArrayHighBound(V,1) = 1); end; if Result then begin - // First element must be string array Va := V[0]; Result := VarIsArray(Va) and ((VarType(Va) and varTypeMask) = varOleStr) and (VarArrayDimCount(Va) = 1); end; if Result then begin - // Second element must be variant array Va := V[1]; Result := VarIsArray(Va) and ((VarType(Va) and varTypeMask) = varVariant) and (VarArrayDimCount(Va) = 1); @@ -343,12 +342,11 @@ procedure BoldInitializeComSecurity(AuthenticationLevel, ImpersonationLevel: lon procedure BoldSetSecurityForInterface(AuthenticationLevel, ImpersonationLevel: longint; Unk: IUnknown); begin - //TODO: this doens't seem to work CoSetProxyBlanket(Unk, RPC_C_AUTHN_LEVEL_NONE, RPC_C_AUTHNZ_NONE, nil, AuthenticationLevel, ImpersonationLevel, nil, EOAC_NONE); end; -initialization // empty +initialization finalization if NeedToUninitialize then CoUninitialize; diff --git a/Source/Common/COM/BoldThreadedComObjectFactory.pas b/Source/Common/COM/BoldThreadedComObjectFactory.pas index 9b19f506..8bad89cf 100644 --- a/Source/Common/COM/BoldThreadedComObjectFactory.pas +++ b/Source/Common/COM/BoldThreadedComObjectFactory.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldThreadedComObjectFactory; interface @@ -10,11 +13,10 @@ interface BoldDefs; type - { forward declarations } + TBoldThreadedComObjectFactory = class; TBoldComObject = class; - { TBoldThreadedComObjectFactory } TBoldThreadedComObjectFactory = class(TComObjectFactory, IClassFactory) private FApartmentType: TBoldApartmentType; @@ -32,7 +34,6 @@ TBoldThreadedComObjectFactory = class(TComObjectFactory, IClassFactory) property ApartmentType: TBoldApartmentType read FApartmentType write FApartmentType; end; - { TBoldComObject } TBoldComObject = class(TComObject) public procedure Disconnect; virtual; @@ -46,8 +47,7 @@ implementation BoldUtils, Windows, BoldPropagatorConstants, - Messages, - BoldComConst; + Messages; { TBoldThreadedComObjectFactory } @@ -74,7 +74,7 @@ function TBoldThreadedComObjectFactory.CreateInstance(const UnkOuter: IUnknown; FApartmentThread := TBoldApartmentThread.Create(ApartmentType, DoCreateInstance, UnkOuter, IID); FApartmentThread.Resume; if not FApartmentThread.WaitUntilReady(TIMEOUT*10) then - raise EBold.Create(sApartmentThreadTimedOut); + raise EBold.Create('Appartment thread timed out'); end else FApartmentThread.Init(UnkOuter, IID); @@ -117,4 +117,6 @@ procedure TBoldComObject.Disconnect; CoDisconnectObject(self, 0); end; +initialization + end. diff --git a/Source/Common/Connection/BoldClient.pas b/Source/Common/Connection/BoldClient.pas index 5c0701a9..d35a8916 100644 --- a/Source/Common/Connection/BoldClient.pas +++ b/Source/Common/Connection/BoldClient.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldClient; interface @@ -38,7 +41,8 @@ TBoldClientApplication = class(TBoldNonRefCountedObject) implementation uses - SysUtils; + SysUtils, + BoldRev; var G_BoldClientApplication: TBoldClientApplication = nil; diff --git a/Source/Common/Connection/BoldServer.pas b/Source/Common/Connection/BoldServer.pas index 88fac1c9..44915a0d 100644 --- a/Source/Common/Connection/BoldServer.pas +++ b/Source/Common/Connection/BoldServer.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldServer; interface @@ -38,7 +41,8 @@ TBoldServerApplication = class(TBoldNonRefCountedObject) implementation uses - SysUtils; + SysUtils, + BoldRev; var G_BoldServerApplication: TBoldServerApplication = nil; diff --git a/Source/Common/ConnectionCOM/BoldComClient.pas b/Source/Common/ConnectionCOM/BoldComClient.pas index 769953f6..632a34da 100644 --- a/Source/Common/ConnectionCOM/BoldComClient.pas +++ b/Source/Common/ConnectionCOM/BoldComClient.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComClient; interface @@ -134,7 +137,7 @@ implementation uses Windows, - SysUtils, // InterlockedIncrement/Decrement for non-WIN32 + SysUtils, ActiveX, Variants, ComObj, @@ -142,8 +145,7 @@ implementation BoldHashIndexes, BoldGUIDUtils, BoldComUtils, - BoldComThreads, - BoldComConst; + BoldComThreads; type TBoldProtectedAccessSubscriber = class(TBoldSubscriber) @@ -161,7 +163,7 @@ TBoldComClientSubscriberHashIndex = class(TBoldCardinalHashIndex) function FindSubscriberBySubscriberId(SubscriberId: integer): TBoldComClientSubscriber; end; - + {-- TBoldComClientSubscriber --------------------------------------------------} constructor TBoldComClientSubscriber.create; @@ -272,7 +274,7 @@ function TBoldComClientConnection.Connect(const HostName: string; Result := True; if (ConnectionState = bceConnected) then Exit; if (ConnectionState <> bceDisconnected) then - raise EBoldCom.Create(sConnectionStateError); + raise EBoldCom.Create('Connection state error.'); FConnectClientInterface := ConnectClientInterface; Connecting; try @@ -355,7 +357,7 @@ function TBoldComClientConnection.Disconnect: Boolean; Result := True; if (ConnectionState = bceDisconnected) then Exit; if (ConnectionState <> bceConnected) then - raise EBoldCom.Create(sConnectionStateError); + raise EBoldCom.Create('Connection state error.'); try Disconnecting; finally @@ -433,15 +435,13 @@ procedure TBoldComClient.AddConnection(Connection: TBoldComClientConnection); end; procedure TBoldComClient.CancelSubscriptions(SubscriberId: Integer; Connection: TBoldComClientConnection = nil); -const - Meth_CancelSubscriptions = 'CancelSubscriptions'; var I: Integer; Conn: TBoldComClientConnection; begin if Assigned(Connection) and Assigned(Connection.BoldServer) and (Connection.ConnectionState = bceConnected) then - Connection.BoldServer.Execute(Meth_CancelSubscriptions,SubscriberId) + Connection.BoldServer.Execute('CancelSubscriptions',SubscriberId) else begin for I := 0 to ConnectionCount - 1 do @@ -449,7 +449,7 @@ procedure TBoldComClient.CancelSubscriptions(SubscriberId: Integer; Connection: Conn := Connections[I]; if Assigned(Conn) and Assigned(Conn.BoldServer) and (Conn.ConnectionState = bceConnected) then - Conn.BoldServer.Execute(Meth_CancelSubscriptions,SubscriberId) + Conn.BoldServer.Execute('CancelSubscriptions',SubscriberId) end; end; end; @@ -467,12 +467,12 @@ procedure TBoldComClient.RemoveSubscriber(Subscriber: TBoldComClientSubscriber); Connection := Connections[I]; if Assigned(Connection) and Assigned(Connection.BoldServer) and (Connection.ConnectionState = bceConnected) then - Connection.BoldServer.Execute('RemoveSubscriber', Subscriber.SubscriberId) // do not localize + Connection.BoldServer.Execute('RemoveSubscriber', Subscriber.SubscriberId) end; end else FUnusedSubscriberIds.Add(Subscriber.SubscriberId); - + fSubscribers.remove(Subscriber); end; @@ -569,5 +569,3 @@ finalization G_BoldComClient.Free; end. - - diff --git a/Source/Common/ConnectionCOM/BoldComConnection.pas b/Source/Common/ConnectionCOM/BoldComConnection.pas index 851f1fa2..932f64b7 100644 --- a/Source/Common/ConnectionCOM/BoldComConnection.pas +++ b/Source/Common/ConnectionCOM/BoldComConnection.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComConnection; interface @@ -14,19 +17,15 @@ interface function BoldComConnectionTypeLibrary: ITypeLib; -// ----------------------------------------------------------------------------- -// Type Library -// ----------------------------------------------------------------------------- - -// *********************************************************************// -// GUIDS declared in the TypeLibrary. Following prefixes are used: -// Type Libraries : LIBID_xxxx -// CoClasses : CLASS_xxxx -// DISPInterfaces : DIID_xxxx -// Non-DISP interfaces: IID_xxxx -// *********************************************************************// + + + + + + + + const - // TypeLibrary Major and minor versions BoldComConnectionMajorVersion = 1; BoldComConnectionMinorVersion = 0; @@ -37,9 +36,7 @@ function BoldComConnectionTypeLibrary: ITypeLib; IID_IBoldProvider: TGUID = '{E07B7DF5-77D2-11D2-B7E0-00600871B01B}'; type -// *********************************************************************// -// Forward declaration of types defined in TypeLibrary -// *********************************************************************// + IBoldClient = interface; IBoldClientDisp = dispinterface; IBoldServer = interface; @@ -47,31 +44,25 @@ function BoldComConnectionTypeLibrary: ITypeLib; IBoldProvider = interface; IBoldProviderDisp = dispinterface; -// *********************************************************************// -// Interface: IBoldClient -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {E07B7DF3-77D2-11D2-B7E0-00600871B01B} -// *********************************************************************// + + + IBoldClient = interface(IDispatch) ['{E07B7DF3-77D2-11D2-B7E0-00600871B01B}'] function OnServerEvent(Event: Integer; Data: OleVariant): OleVariant; safecall; end; -// *********************************************************************// -// DispIntf: IBoldClientDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {E07B7DF3-77D2-11D2-B7E0-00600871B01B} -// *********************************************************************// + + + IBoldClientDisp = dispinterface ['{E07B7DF3-77D2-11D2-B7E0-00600871B01B}'] function OnServerEvent(Event: Integer; Data: OleVariant): OleVariant; dispid 1; end; -// *********************************************************************// -// Interface: IBoldServer -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {E07B7DF4-77D2-11D2-B7E0-00600871B01B} -// *********************************************************************// + + + IBoldServer = interface(IDispatch) ['{E07B7DF4-77D2-11D2-B7E0-00600871B01B}'] function Connect(const ClientId: WideString; Flags: Integer; const Client: IBoldClient): WordBool; safecall; @@ -79,11 +70,9 @@ function BoldComConnectionTypeLibrary: ITypeLib; function Execute(const Name: WideString; Params: OleVariant): OleVariant; safecall; end; -// *********************************************************************// -// DispIntf: IBoldServerDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {E07B7DF4-77D2-11D2-B7E0-00600871B01B} -// *********************************************************************// + + + IBoldServerDisp = dispinterface ['{E07B7DF4-77D2-11D2-B7E0-00600871B01B}'] function Connect(const ClientId: WideString; Flags: Integer; const Client: IBoldClient): WordBool; dispid 1; @@ -91,11 +80,9 @@ function BoldComConnectionTypeLibrary: ITypeLib; function Execute(const Name: WideString; Params: OleVariant): OleVariant; dispid 3; end; -// *********************************************************************// -// Interface: IBoldProvider -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {E07B7DF5-77D2-11D2-B7E0-00600871B01B} -// *********************************************************************// + + + IBoldProvider = interface(IDispatch) ['{E07B7DF5-77D2-11D2-B7E0-00600871B01B}'] function CreateObject(const ClassName: WideString): IUnknown; safecall; @@ -104,11 +91,9 @@ function BoldComConnectionTypeLibrary: ITypeLib; property ObjectInfo: OleVariant read Get_ObjectInfo; end; -// *********************************************************************// -// DispIntf: IBoldProviderDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {E07B7DF5-77D2-11D2-B7E0-00600871B01B} -// *********************************************************************// + + + IBoldProviderDisp = dispinterface ['{E07B7DF5-77D2-11D2-B7E0-00600871B01B}'] function CreateObject(const ClassName: WideString): IUnknown; dispid 1; @@ -116,15 +101,12 @@ function BoldComConnectionTypeLibrary: ITypeLib; property ObjectInfo: OleVariant readonly dispid 3; end; -// ----------------------------------------------------------------------------- -// Type Library End -// ----------------------------------------------------------------------------- + implementation uses SysUtils, - BoldComConst, BoldComUtils; var @@ -135,9 +117,11 @@ function BoldComConnectionTypeLibrary: ITypeLib; if not Assigned(G_TypeLibrary) then begin if LoadRegTypeLib(LIBID_BoldComConnection,1,0,0,G_TypeLibrary) <> 0 then - raise EBoldCom.Create(sUnableToLoadTypeLib); + raise EBoldCom.Create('Unable to load type library (BoldComConnection)'); end; Result := G_TypeLibrary; end; +initialization + end. diff --git a/Source/Common/ConnectionCOM/BoldComServ.pas b/Source/Common/ConnectionCOM/BoldComServ.pas index 80087b62..1ea711aa 100644 --- a/Source/Common/ConnectionCOM/BoldComServ.pas +++ b/Source/Common/ConnectionCOM/BoldComServ.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComServ; interface @@ -10,6 +13,8 @@ function Bold_TheComServer: TComServerObject; implementation uses + SysUtils, + BoldUtils, ComServ; function Bold_TheComServer: TComServerObject; @@ -17,4 +22,7 @@ function Bold_TheComServer: TComServerObject; result := ComServer; end; + +initialization + end. diff --git a/Source/Common/ConnectionCOM/BoldComServer.pas b/Source/Common/ConnectionCOM/BoldComServer.pas index 44bd88b6..6bfec256 100644 --- a/Source/Common/ConnectionCOM/BoldComServer.pas +++ b/Source/Common/ConnectionCOM/BoldComServer.pas @@ -1,3 +1,7 @@ + +{ Global compiler directives } +{$include bold.inc} + unit BoldComServer; interface @@ -14,7 +18,8 @@ interface BoldIndexableList, BoldComObj, BoldComConnection, - BoldThreadedComObjectFactory; + BoldThreadedComObjectFactory + ; const // Server events @@ -34,6 +39,7 @@ TBoldComServerThreadedConnectionFactory = class; TBoldComServer = class; TBoldComServerConnectionClass = class of TBoldComServerConnection; + TBoldComServerConnectionEvent = procedure(Sender: TBoldComServerConnection; var Disconnect: Boolean); {-- TBoldComServerSubscriber --} @@ -101,11 +107,13 @@ TBoldComServerSubscriberList = class(TBoldUnorderedIndexableList) TBoldComServerEventSenderThread = class(TThread) private FOwner: TBoldComServerConnection; + FClientInterfaceCookie: Cardinal; protected procedure Execute; override; procedure SendEventFailure; public - constructor Create(aOwner: TBoldComServerConnection); + constructor Create(aOwner: TBoldComServerConnection; aClientInterfaceCookie: Cardinal); + property ClientInterfaceCookie: Cardinal read FClientInterfaceCookie; end; {-- TBoldComServerConnection --} @@ -113,9 +121,9 @@ TBoldComServerConnection = class(TComObject) private FActive: Boolean; FClientId: string; - FClientInterface: IBoldClient; - FSenderThread: TBoldComServerEventSenderThread; - FClientInterfaceCookie: DWORD; + FClientInterface: IBoldClient; //TODO WARNING! Contains InterfaceCookie +//TODO FSenderThread: TBoldComServerEventSenderThread; //NEW +//TODO FHasClientInterface: Boolean; //NEW//TODO FClientInterfaceCookie: DWORD; //NEW FConnected: Boolean; FDestroying: Boolean; FEventQueue: TBoldComServerEventQueue; @@ -130,13 +138,12 @@ TBoldComServerConnection = class(TComObject) function GetSubscriber(SubscriberId: Integer): TBoldComServerSubscriber; procedure RemoveSubscriber(SubscriberId: Integer); procedure PushEvent(SubscriberId: integer; Originator: TObject; OriginalEvent, RequestedEvent: TBoldevent); - function GetSenderThread: TBoldComServerEventSenderThread; - function GetClientInterfaceFromGIT(out aClient: IBoldClient): Boolean; +//TODO function GetClientInterface: IBoldClient; +//TODO function GetClientInterface(out aClient: IBoldClient): Boolean; +//TODO function DoSendQueuedEvents: Boolean; //NEW +//TODO procedure DoSendEventFailure; //NEW property Subscribers: TBoldComServerSubscriberList read FSubscribers; - property SenderThread: TBoldComServerEventSenderThread read GetSenderThread; - protected - procedure DoSendEventFailure; - function DoSendQueuedEvents(aClient: IBoldClient): Boolean; + public destructor Destroy; override; procedure Disconnect; @@ -145,7 +152,7 @@ TBoldComServerConnection = class(TComObject) procedure SendQueuedEvents; property Active: Boolean read FActive; property ClientId: string read FClientId; - property ClientInterface: IBoldClient read FClientInterface; + property ClientInterface: IBoldClient read FClientInterface; //TODO WARNING! Contains InterfaceCookie property Connected: Boolean read FConnected; property EventQueue: TBoldComServerEventQueue read FEventQueue; property OnSendEventFailure: TBoldComServerConnectionEvent read fOnSendEventFailure write fOnSendEventFailure; @@ -192,6 +199,7 @@ TBoldComServer = class(TBoldServer) procedure GetObjectInfo(const ClassId: TGUID; ObjectNames, ClassNames: TStrings); procedure RemoveConnection(Connection: TBoldComServerConnection); procedure SendQueuedEvents; + protected public constructor Create; destructor Destroy; override; @@ -207,7 +215,7 @@ TBoldComServer = class(TBoldServer) //Set to true to enable client callbacks in separate worker threads. BoldAsynchronousClientCallbackOnServerEvent: Boolean = False; -{.$DEFINE BOLDCOMCALLBACKDEBUG} +{$DEFINE BOLDCOMCALLBACKDEBUG} {$IFDEF BOLDCOMCALLBACKDEBUG} //Functions used for performance testing of callbacks function CallStats: string; @@ -222,9 +230,7 @@ implementation BoldHashIndexes, BoldComUtils, Variants, - BoldMemoryManager, - BoldApartmentThread, - BoldComConst; + BoldApartmentThread; const CLSID_StdGlobalInterfaceTable: TGUID = '{00000323-0000-0000-C000-000000000046}'; //NEW (Missing in ActiveX) @@ -239,8 +245,19 @@ implementation out ppv): HResult; stdcall; end; + TBoldEventSenderThreadList = class(TBoldCardinalHashIndex) + protected + function ItemAsKeyCardinal(Item: TObject): Cardinal; override; + public + function FindEventSenderThreadByCookie(ClientInterfaceCookie: Cardinal): TBoldComServerEventSenderThread; + function FindClientInterfaceByCookie(ClientInterfaceCookie: Cardinal): IBoldClient; + procedure ConnectClient(const ServerConnection: TBoldComServerConnection; const Client: IBoldClient; var ClientInterfaceCookie: Cardinal); + procedure DisconnectClient(var ClientInterfaceCookie: Cardinal); + end; + var G_GlobalInterfaceTable: IGlobalInterfaceTable; + G_BoldEventSenderThreadList: TBoldEventSenderThreadList; function GlobalInterfaceTable: IGlobalInterfaceTable; begin @@ -249,6 +266,14 @@ function GlobalInterfaceTable: IGlobalInterfaceTable; Result := G_GlobalInterfaceTable; end; +function BoldEventSenderThreadList: TBoldEventSenderThreadList; + +begin + if not Assigned(G_BoldEventSenderThreadList) then + G_BoldEventSenderThreadList := TBoldEventSenderThreadList.Create;; + Result := G_BoldEventSenderThreadList; +end; + {$IFDEF BOLDCOMCALLBACKDEBUG} var CallCount: Integer = 0; @@ -259,7 +284,7 @@ function GlobalInterfaceTable: IGlobalInterfaceTable; function CallStats: string; begin if CallCount>0 then - Result := Format(sCallStats, + Result := Format('Total:%.1fs Min:%.0fms Max:%.0fms Avg:%.0fms Count:%d', [CallTime, CallMin*1000, CallMax*1000, CallTime/CallCount*1000, CallCount]); end; @@ -352,7 +377,7 @@ function TBoldComServerEventQueue.GetAllEvents: OleVariant; Result[J+2] := Item^.EventData.OriginalEvent; Result[J+3] := Item^.EventData.RequestedEvent; Inc(J,4); - BoldMemoryManager_.DeAllocateMemory(Item, SizeOf(TBoldComEventQueueItem)); + FreeMem(Item, sizeof(TBoldComEventQueueItem)); end; end else @@ -437,17 +462,18 @@ destructor TBoldComServerConnection.Destroy; FConnected := False; FActive := False; TBoldComServer.Instance.RemoveConnection(Self); - if Assigned(FSenderThread) then - begin - FSenderThread.Terminate; - FSenderThread.FOwner := nil; - FSenderThread.Resume; - end; - if Assigned(FClientInterface) and BoldAsynchronousClientCallbackOnServerEvent then - begin - GlobalInterfaceTable.RevokeInterfaceFromGlobal(FClientInterfaceCookie); - FClientInterfaceCookie := 0; - end; + BoldEventSenderThreadList.DisconnectClient(Cardinal(FClientInterface)); // does not compile in x64 !!! +// if Assigned(FSenderThread) then +// begin +// FSenderThread.Terminate; +// FSenderThread.FOwner := nil; +// FSenderThread.Resume; +// end; +// if Assigned(FClientInterface) then +// begin +// GlobalInterfaceTable.RevokeInterfaceFromGlobal(FClientInterfaceCookie); +// FClientInterfaceCookie := 0; +// end; FClientInterface := nil; FClientId := ''; RemoveSubscriber(-1); @@ -490,20 +516,24 @@ function TBoldComServerConnection.ObjQueryInterface(const IID: TGUID; out Obj): end; end; -procedure TBoldComServerConnection.DoSendEventFailure; +procedure {TBoldComServerConnection.}DoSendEventFailure(Self: TBoldComServerConnection); var AskDisconnect: Boolean; begin - AskDisconnect := True; - if Assigned(FOnSendEventFailure) then - OnSendEventFailure(Self, AskDisconnect); - if AskDisconnect then - ClientDisconnect; + with Self do + begin + AskDisconnect := True; + if Assigned(FOnSendEventFailure) then + OnSendEventFailure(Self, AskDisconnect); + if AskDisconnect then + ClientDisconnect; + end; end; -function TBoldComServerConnection.DoSendQueuedEvents(aClient: IBoldClient): Boolean; +function {TBoldComServerConnection.}DoSendQueuedEvents(Self: TBoldComServerConnection): Boolean; var Data: OleVariant; + vClient: IBoldClient; {$IFDEF BOLDCOMCALLBACKDEBUG} CounterStart, CounterStop, CounterFreq: Int64; //TEST ElapsedTime: Double; //TEST @@ -511,51 +541,60 @@ function TBoldComServerConnection.DoSendQueuedEvents(aClient: IBoldClient): Bool begin //NOTE This method can be called from a worker thread and must be threadsafe! Result := False; - if Connected and Assigned(aClient) then + if Self.Connected and (Cardinal(Self.FClientInterface)<>0) then begin - Data := FEventQueue.GetAllEvents; + Data := Self.FEventQueue.GetAllEvents; if not VarIsEmpty(Data) then begin + vClient := BoldEventSenderThreadList.FindClientInterfaceByCookie(Cardinal(Self.FClientInterface)); + if Assigned(vClient) then + begin {$IFDEF BOLDCOMCALLBACKDEBUG} - QueryPerformanceCounter(CounterStart); + QueryPerformanceCounter(CounterStart); {$ENDIF} - aClient.OnServerEvent(EVENT_SUBSCRIPTION,Data); + vClient.OnServerEvent(EVENT_SUBSCRIPTION,Data); {$IFDEF BOLDCOMCALLBACKDEBUG} - QueryPerformanceCounter(CounterStop); - QueryPerformanceFrequency(CounterFreq); - ElapsedTime := ((CounterStop-CounterStart)/CounterFreq); - CallTime := CallTime+ElapsedTime; - if ElapsedTimeCallMax then - CallMax := ElapsedTime; - InterlockedIncrement(CallCount); + QueryPerformanceCounter(CounterStop); + QueryPerformanceFrequency(CounterFreq); + ElapsedTime := ((CounterStop-CounterStart)/CounterFreq); + CallTime := CallTime+ElapsedTime; + if ElapsedTimeCallMax then + CallMax := ElapsedTime; + InterlockedIncrement(CallCount); {$ENDIF} + end; Result := True; end; end else - FEventQueue.Clear; + Self.FEventQueue.Clear; end; + procedure TBoldComServerConnection.SendQueuedEvents; +var + vSenderThread: TBoldComServerEventSenderThread; begin if FEventQueue.Count>0 then begin if BoldAsynchronousClientCallbackOnServerEvent then begin - SenderThread.Resume; + vSenderThread := BoldEventSenderThreadList.FindEventSenderThreadByCookie(Cardinal(FClientInterface)); + if Assigned(vSenderThread) then + vSenderThread.Resume; end else begin try - DoSendQueuedEvents(FClientInterface); + DoSendQueuedEvents(Self); except - DoSendEventFailure; + DoSendEventFailure(Self); end; end; end; @@ -571,11 +610,10 @@ procedure TBoldComServerConnection.CancelSubscriptions(SubscriberId: Integer); // cancel all subscriptions... Traverser := Subscribers.CreateTraverser; try - while not Traverser.EndOfList do + while Traverser.MoveNext do begin Subscriber := TBoldComServerSubscriber(Traverser.item); Subscriber.CancelAllSubscriptions; - Traverser.Next; end; finally Traverser.Free; @@ -625,12 +663,6 @@ procedure TBoldComServerConnection.PushEvent(SubscriberId: integer; Originator: EventQueue.Push(EventData); end; -function TBoldComServerConnection.GetClientInterfaceFromGIT(out aClient: IBoldClient): Boolean; -begin - Result := False; - if Assigned(FClientInterface) and BoldAsynchronousClientCallbackOnServerEvent then - Result := Succeeded(GlobalInterfaceTable.GetInterfaceFromGlobal(FClientInterfaceCookie, IID_IBoldClient, aClient)); -end; function TBoldComServerConnection.ClientConnect(const ClientId: string; Flags: Integer; const Client: IBoldClient): Boolean; @@ -641,10 +673,7 @@ function TBoldComServerConnection.ClientConnect(const ClientId: string; if Active and (not Assigned(C) or (C = Self)) then begin FClientId := ClientId; - FClientInterfaceCookie := 0; - if BoldAsynchronousClientCallbackOnServerEvent then - GlobalInterfaceTable.RegisterInterfaceInGlobal(Client, IID_IBoldClient, FClientInterfaceCookie); - FClientInterface := Client; + BoldEventSenderThreadList.ConnectClient(Self, Client, Cardinal(FClientInterface)); //NEW FConnected := True; Result := True; end @@ -659,9 +688,12 @@ function TBoldComServerConnection.ClientDisconnect: Boolean; FConnected := False; RemoveSubscriber(-1); FEventQueue.Clear; - if Assigned(FClientInterface) and BoldAsynchronousClientCallbackOnServerEvent then - GlobalInterfaceTable.RevokeInterfaceFromGlobal(FClientInterfaceCookie); - FClientInterfaceCookie := 0; + BoldEventSenderThreadList.DisconnectClient(Cardinal(FClientInterface)); +// if Assigned(FClientInterface) then +// begin +// GlobalInterfaceTable.RevokeInterfaceFromGlobal(FClientInterfaceCookie); +// FClientInterfaceCookie := 0; +// end; FClientInterface := nil; FClientId := ''; Result := True; @@ -678,9 +710,9 @@ procedure TBoldComServerConnection.Disconnect; function TBoldComServerConnection.Execute(const Name: string; Params: OleVariant): OleVariant; begin - if CompareText(Name,'CancelSubscriptions') = 0 then // do not localize + if CompareText(Name,'CancelSubscriptions') = 0 then CancelSubscriptions(Params) - else if CompareText(Name,'RemoveSubscriber') = 0 then // do not localize + else if CompareText(Name,'RemoveSubscriber') = 0 then RemoveSubscriber(Params); end; @@ -689,13 +721,6 @@ function TBoldComServerConnection.GetSubscriber(SubscriberId: Integer): TBoldCom Result := Subscribers.SubscriberById[SubscriberId]; end; -function TBoldComServerConnection.GetSenderThread: TBoldComServerEventSenderThread; -begin - if not Assigned(FSenderThread) then - FSenderThread := TBoldComServerEventSenderThread.Create(Self); - Result := FSenderThread; -end; - {-- TBoldServerConnectionFactory ----------------------------------------------} constructor TBoldComServerConnectionFactory.Create(ComServer: TComServerObject; @@ -728,7 +753,7 @@ procedure TBoldComServerConnectionFactory.UpdateRegistry(Register: Boolean); // create the category CatInfo.catid := CATID_BoldServer; CatInfo.lcid := 409; - StringToWideChar('BoldServer Classes', CatInfo.szDescription,127); // do not localize + StringToWideChar('BoldServer Classes',CatInfo.szDescription,127); Reg.RegisterCategories(1,@CatInfo); end; if Assigned(CatDesc) then @@ -895,7 +920,7 @@ procedure TBoldComServerThreadedConnectionFactory.UpdateRegistry( // create the category CatInfo.catid := CATID_BoldServer; CatInfo.lcid := 409; - StringToWideChar('BoldServer Classes',CatInfo.szDescription,127); // do not localize + StringToWideChar('BoldServer Classes',CatInfo.szDescription,127); Reg.RegisterCategories(1,@CatInfo); end; if Assigned(CatDesc) then @@ -938,11 +963,13 @@ function TBoldComServerSubscriberHashIndex.ItemAsKeyCardinal(Item: TObject): car Result := TBoldComServerSubscriber(Item).SubscriberId; end; +//NEW Class { TBoldComServerEventSenderThread } -constructor TBoldComServerEventSenderThread.Create(aOwner: TBoldComServerConnection); +constructor TBoldComServerEventSenderThread.Create(aOwner: TBoldComServerConnection; aClientInterfaceCookie: Cardinal); begin FOwner := aOwner; + FClientInterfaceCookie := aClientInterfaceCookie; FreeOnTerminate := True; inherited Create(True); end; @@ -950,22 +977,18 @@ constructor TBoldComServerEventSenderThread.Create(aOwner: TBoldComServerConnect procedure TBoldComServerEventSenderThread.SendEventFailure; begin if not Terminated then - FOwner.DoSendEventFailure; + DoSendEventFailure(FOwner); end; procedure TBoldComServerEventSenderThread.Execute; -var - vClient: IBoldClient; begin CoInitialize(nil); repeat try - if (not Terminated) and FOwner.GetClientInterfaceFromGIT(vClient) then - while (not Terminated) and FOwner.DoSendQueuedEvents(vClient) do {loop}; - vClient := nil; + while (not Terminated) and {FOwner.}DoSendQueuedEvents(FOwner) do {loop}; except if not Terminated then - Synchronize(SendEventFailure); + Synchronize(SendEventFailure); end; if not Terminated then Suspend; @@ -973,10 +996,64 @@ procedure TBoldComServerEventSenderThread.Execute; CoUninitialize; end; +{ TBoldEventSenderThreadList } +procedure TBoldEventSenderThreadList.ConnectClient(const ServerConnection: TBoldComServerConnection; const Client: IBoldClient; var ClientInterfaceCookie: Cardinal); +var + vSenderThread: TBoldComServerEventSenderThread; +begin + if ClientInterfaceCookie<>0 then + DisconnectClient(ClientInterfaceCookie); + if Assigned(Client) then + begin + OleCheck(GlobalInterfaceTable.RegisterInterfaceInGlobal(Client, IID_IBoldClient, ClientInterfaceCookie)); + vSenderThread := TBoldComServerEventSenderThread.Create(ServerConnection, ClientInterfaceCookie); + Add(vSenderThread); + end; +end; + +procedure TBoldEventSenderThreadList.DisconnectClient(var ClientInterfaceCookie: Cardinal); +var + vSenderThread: TBoldComServerEventSenderThread; +begin + if ClientInterfaceCookie<>0 then + begin + vSenderThread := FindEventSenderThreadByCookie(ClientInterfaceCookie); + if Assigned(vSenderThread) then + begin + Remove(vSenderThread); + vSenderThread.Terminate; + vSenderThread.FOwner := nil; + vSenderThread.FClientInterfaceCookie := 0; + vSenderThread.Resume; + end; + OleCheck(GlobalInterfaceTable.RevokeInterfaceFromGlobal(ClientInterfaceCookie)); + ClientInterfaceCookie := 0; + end; +end; + +function TBoldEventSenderThreadList.FindClientInterfaceByCookie(ClientInterfaceCookie: Cardinal): IBoldClient; +begin + Result := nil; + if ClientInterfaceCookie<>0 then + OleCheck(GlobalInterfaceTable.GetInterfaceFromGlobal(ClientInterfaceCookie, IID_IBoldClient, Result)); +end; + +function TBoldEventSenderThreadList.FindEventSenderThreadByCookie(ClientInterfaceCookie: Cardinal): TBoldComServerEventSenderThread; +begin + Result := TBoldComServerEventSenderThread(Find(ClientInterfaceCookie)); + Assert(not Assigned(Result) or (Result is TBoldComServerEventSenderThread)); +end; + +function TBoldEventSenderThreadList.ItemAsKeyCardinal(Item: TObject): Cardinal; +begin + Assert(Item is TBoldComServerEventSenderThread); + Result := TBoldComServerEventSenderThread(Item).ClientInterfaceCookie; +end; + initialization finalization - FreeAndNil(G_BoldComServer); + FreeAndNil(G_BoldComServer); //CHANGED + FreeAndNil(G_BoldEventSenderThreadList); //NEW end. - diff --git a/Source/Common/ConnectionHandles/BoldClientHandles.pas b/Source/Common/ConnectionHandles/BoldClientHandles.pas index 4904ce93..5ad11d66 100644 --- a/Source/Common/ConnectionHandles/BoldClientHandles.pas +++ b/Source/Common/ConnectionHandles/BoldClientHandles.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldClientHandles; interface @@ -35,6 +38,7 @@ TBoldImportHandle = class(TBoldClientHandle) implementation + {-- TBoldClientHandle ---------------------------------------------------------} constructor TBoldClientHandle.Create(AOwner: TComponent); @@ -69,4 +73,6 @@ procedure TBoldImportHandle.SetObjectName(const Value: string); end; end; +initialization + end. diff --git a/Source/Common/ConnectionHandles/BoldServerHandles.pas b/Source/Common/ConnectionHandles/BoldServerHandles.pas index 758216e4..ed439151 100644 --- a/Source/Common/ConnectionHandles/BoldServerHandles.pas +++ b/Source/Common/ConnectionHandles/BoldServerHandles.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldServerHandles; interface @@ -79,4 +82,6 @@ procedure TBoldExportHandle.SetObjectName(const Value: string); end; end; +initialization + end. diff --git a/Source/Common/ConnectionHandlesCOM/BoldComClientHandles.pas b/Source/Common/ConnectionHandlesCOM/BoldComClientHandles.pas index 9e5686a7..929dfac7 100644 --- a/Source/Common/ConnectionHandlesCOM/BoldComClientHandles.pas +++ b/Source/Common/ConnectionHandlesCOM/BoldComClientHandles.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComClientHandles; interface @@ -16,6 +19,7 @@ TBoldComImportHandle = class; TBoldComClientObjectHandle = class; {-- TBoldComConnectionHandle --} + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldComConnectionHandle = class(TBoldClientHandle) private FAfterConnect: TNotifyEvent; @@ -31,12 +35,13 @@ TBoldComConnectionHandle = class(TBoldClientHandle) FServerEvents: Boolean; FServerHost: string; FServerName: string; - FSubscriber: TBoldPassthroughSubscriber; + FSubscriber: TBoldExtendedPassthroughSubscriber; FThreaded: Boolean; - FECode: HResult; function GetBoldProvider: IBoldProvider; + FECode: HResult; + function GetBoldProvider: IBoldProvider; function GetConnected: Boolean; function GetServerCLSID: string; - function GetSubscriber: TBoldPassthroughSubscriber; + function GetSubscriber: TBoldExtendedPassthroughSubscriber; procedure ReceiveExtended(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const); procedure SetConnected(Value: Boolean); @@ -45,7 +50,7 @@ TBoldComConnectionHandle = class(TBoldClientHandle) procedure SetServerHost(const Value: string); procedure SetServerName(const Value: string); procedure SetThreaded(Value: Boolean); - property Subscriber: TBoldPassthroughSubscriber read GetSubscriber; + property Subscriber: TBoldExtendedPassthroughSubscriber read GetSubscriber; protected function GetHandledObject: TObject; override; procedure Loaded; override; @@ -54,7 +59,7 @@ TBoldComConnectionHandle = class(TBoldClientHandle) destructor Destroy; override; property BoldProvider: IBoldProvider read GetBoldProvider; property Connected: Boolean read GetConnected write SetConnected; - property ECode: HResult read FECode; + property ECode: HResult read FECode; published property AfterConnect: TNotifyEvent read FAfterConnect write FAfterConnect; property AfterDisconnect: TNotifyEvent read FAfterDisconnect write FAfterDisconnect; @@ -101,6 +106,7 @@ TBoldComImportHandle = class(TBoldImportHandle) property ObjectName; end; + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldComClientObjectHandle = class(TBoldComImportHandle) private FComObject: IUnknown; @@ -116,7 +122,6 @@ implementation uses SysUtils, ComObj, - BoldComConst, BoldComUtils; {-- TBoldComConnectionHandle -----------------------------------------------------} @@ -132,7 +137,6 @@ constructor TBoldComConnectionHandle.Create(AOwner: TComponent); destructor TBoldComConnectionHandle.Destroy; begin - // if constructor fails because typelib not loaded, then we have no fConnection) if assigned(fConnection) then Connected := False; FreeAndNil(FConnection); @@ -168,10 +172,10 @@ function TBoldComConnectionHandle.GetServerCLSID: string; Result := ''; end; -function TBoldComConnectionHandle.GetSubscriber: TBoldPassthroughSubscriber; +function TBoldComConnectionHandle.GetSubscriber: TBoldExtendedPassthroughSubscriber; begin if not Assigned(FSubscriber) then - FSubscriber := TBoldPassthroughSubscriber.CreateWithExtendedReceive(ReceiveExtended); + FSubscriber := TBoldExtendedPassthroughSubscriber.CreateWithExtendedReceive(ReceiveExtended); Result := FSubscriber; end; @@ -190,7 +194,7 @@ procedure TBoldComConnectionHandle.ReceiveExtended(Originator: TObject; Original case VR.VType of vtInteger: result := VR.VInteger; else - raise Exception.Create(sUnknownHResultType); + raise Exception.Create('unknown type in GetHResult'); end; end; @@ -211,7 +215,6 @@ procedure TBoldComConnectionHandle.ReceiveExtended(Originator: TObject; Original bceConnecting: begin SendEvent(Self,OriginalEvent); -// if Assigned(BeforeConnect) then BeforeConnect(Self); end; bceConnectFailed: begin @@ -240,17 +243,16 @@ procedure TBoldComConnectionHandle.SetConnected(Value: Boolean); begin if Value then begin - // Connect if FConnection.ConnectionState <> bceDisconnected then Exit; if ServerCLSID = '' then begin if ServerName = '' then - raise EBoldCom.Create(sUnspecifiedServer); + raise EBoldCom.Create('Cannot connect, no server specified.'); try ClassID := ProgIDToClassId(ServerName); except on Exception do - raise EBoldCom.Create(sInvalidServerName); + raise EBoldCom.Create('Cannot connect, invalid server name.'); end; end else @@ -260,7 +262,6 @@ procedure TBoldComConnectionHandle.SetConnected(Value: Boolean); end else begin - // Disconnect if FConnection.ConnectionState <> bceConnected then Exit; FConnection.Disconnect; @@ -272,7 +273,7 @@ procedure TBoldComConnectionHandle.SetServerCLSID(const Value: string); if Value <> ServerCLSID then begin if FConnection.ConnectionState <> bceDisconnected then - raise EBoldCom.CreateFmt(sCannotChangePropertyWhenActive, ['ServerCLSID']); // do not localize + raise EBoldCom.Create('Cannot change ServerCLSID on active connection.'); if Value = '' then FillChar(FServerCLSID, SizeOf(FServerCLSID), 0) else begin @@ -304,7 +305,7 @@ procedure TBoldComConnectionHandle.SetServerHost(const Value: string); if Value <> FServerHost then begin if FConnection.ConnectionState <> bceDisconnected then - raise EBoldCom.CreateFmt(sCannotChangePropertyWhenActive, ['ServerHost']); // do not localize + raise EBoldCom.Create('Cannot change ServerHost on active connection.'); FServerHost := Value; end; end; @@ -314,7 +315,7 @@ procedure TBoldComConnectionHandle.SetServerName(const Value: string); if Value <> ServerName then begin if FConnection.ConnectionState <> bceDisconnected then - raise EBoldCom.CreateFmt(sCannotChangePropertyWhenActive, ['ServerName']); // do not localize + raise EBoldCom.Create('Cannot change ServerName on active connection.'); FServerName := Value; if (FServerName <> '') and not (csReading in ComponentState) then begin @@ -332,7 +333,7 @@ procedure TBoldComConnectionHandle.SetThreaded(Value: Boolean); if Value <> FThreaded then begin if FConnection.ConnectionState <> bceDisconnected then - raise EBoldCom.CreateFmt(sCannotChangePropertyWhenActive, ['Threaded']); // do not localize + raise EBoldCom.Create('Cannot change Threaded on active connection.'); FThreaded := Value; end; end; @@ -428,7 +429,7 @@ procedure TBoldComImportHandle.SetActive(Value: Boolean); begin if Value then begin - inherited; // does the actual setting + inherited; if Connected then DoConnect; end @@ -436,7 +437,7 @@ procedure TBoldComImportHandle.SetActive(Value: Boolean); begin if Connected then DoDisconnect; - inherited; // does the actual setting + inherited; end; end; end; @@ -465,11 +466,11 @@ procedure TBoldComImportHandle.SetObjectName(const Value: string); if Connected then begin DoDisconnect; - inherited; // does the actual setting + inherited; DoConnect; end else - inherited; // does the actual setting + inherited; end; end; @@ -490,4 +491,6 @@ function TBoldComClientObjectHandle.GetComObject: IUnknown; Result := FComObject; end; +initialization + end. diff --git a/Source/Common/ConnectionHandlesCOM/BoldComServerHandles.pas b/Source/Common/ConnectionHandlesCOM/BoldComServerHandles.pas index 83c0d38e..42e0439e 100644 --- a/Source/Common/ConnectionHandlesCOM/BoldComServerHandles.pas +++ b/Source/Common/ConnectionHandlesCOM/BoldComServerHandles.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComServerHandles; interface @@ -83,6 +86,7 @@ TBoldComObjectProvider = class(TBoldNonRefCountedObject,IBoldComServerObjectPr end; {-- TBoldComServerHandle --} + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldComServerHandle = class(TBoldServerHandle) private FClasses: TBoldComClasses; @@ -131,8 +135,9 @@ TBoldComExportHandle = class(TBoldExportHandle) end; TBoldComGetComObjectEvent = procedure(Sender: TObject; out Obj: IUnknown) of object; - + {-- TBoldComServerObjectHandle --} + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldComServerObjectHandle = class(TBoldComExportHandle) private FOnGetComObject: TBoldComGetComObjectEvent; @@ -147,7 +152,6 @@ implementation uses SysUtils, - BoldComConst, ActiveX, ComObj, BoldHandle, @@ -212,14 +216,14 @@ procedure TBoldComClass.SetCLSID(const Value: string); begin if not IsLoading and not IsDesignTime then if Active then - raise EBoldCom.CreateFmt(sCannotChangeCLSIDAtRT,[ClassName]); + raise EBoldCom.CreateFmt('%s: Cannot change CLSID at run-time',[ClassName]); try GUID := StringToGUID(Value); FCLSID := Value; Changed(False); except on Exception do - raise EBoldCom.CreateFmt(sInvalidCLSID,[ClassName]); + raise EBoldCom.CreateFmt('%s: Invalid CLSID',[ClassName]); end; end; end; @@ -229,7 +233,7 @@ procedure TBoldComClass.SetDescription(const Value: string); if FDescription <> Value then begin if not IsLoading and not IsDesignTime then - raise EBoldCom.CreateFmt(sCannotChangeDescAtRT,[ClassName]); + raise EBoldCom.CreateFmt('%s: Cannot change Description at run-time',[ClassName]); FDescription := Value; Changed(False); end; @@ -246,14 +250,14 @@ procedure TBoldComClass.SetName(const Value: string); if FName <> Value then begin if not IsLoading and not IsDesignTime then - raise EBoldCom.CreateFmt(sCannotChangeNameAtRT,[ClassName]); + raise EBoldCom.CreateFmt('%s: Cannot change Name at run-time',[ClassName]); if IsValidIdent(Value) then begin FName := Value; Changed(False); end else - raise EBoldCom.CreateFmt(sInvalidName,[ClassName]); + raise EBoldCom.CreateFmt('%s: Invalid Name',[ClassName]); end; end; @@ -323,7 +327,7 @@ function TBoldComClasses.GetUniqueName: string; I := 0; repeat Inc(I); - Result := Format('Class%d',[I]); // do not localize + Result := Format('Class%d',[I]); until not ClassExists(Result); end; @@ -335,9 +339,7 @@ procedure TBoldComClasses.SetItem(Index: Integer; Value: TBoldComClass); procedure TBoldComClasses.Update(Item: TCollectionItem); begin if Item <> nil then - // updating item else - // update all end; {-- TBoldComObjectProvider ----------------------------------------------------} @@ -582,4 +584,6 @@ function TBoldComServerObjectHandle.GetHandledObject: TObject; Result := nil; end; +initialization + end. diff --git a/Source/Common/ConnectionHandlesCOM/BoldXMLDispatcher.pas b/Source/Common/ConnectionHandlesCOM/BoldXMLDispatcher.pas index 5fb1a748..f96e782a 100644 --- a/Source/Common/ConnectionHandlesCOM/BoldXMLDispatcher.pas +++ b/Source/Common/ConnectionHandlesCOM/BoldXMLDispatcher.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldXMLDispatcher; interface @@ -7,7 +10,7 @@ interface BoldUtils, BoldSOAP_TLB, BoldStringList, - MSXML_TLB, + Bold_MSXML_TLB, BoldComServerHandles, BoldDefs, BoldXMLRequests, @@ -36,8 +39,9 @@ TBoldXMLSOAPService = class(TAutoIntfObject, IBoldSOAPService) end; TBoldXMLDispatchErrorEvent = procedure (const E: Exception; out response: string) of object; - + TBoldGetXMLRequestEvent = procedure (const XML: string; out Request: TBoldXMLRequest) of object; + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldXMLDispatcher = class(TBoldComExportHandle) private FActions: TBoldXMLActions; @@ -75,7 +79,6 @@ TBoldXMLActionItem = class(TBoldUniquelyNamedCollectionItemWithNameStorage) constructor Create(Collection: TCollection); override; destructor Destroy; override; procedure DispatchAction(const request: TBoldXMLRequest; out response: string); -// function GetActionNode(const DomDocument: IXMLDomDocument; out DomNode: IXMLDomNode): Boolean; published property Default: Boolean read FDefault write SetDefault default False; property ActionName: string read getActionName write setActionName; @@ -98,12 +101,10 @@ TBoldXMLActions = class(TBoldCollectionWithUniquelyNamedItems) implementation -{$R *.res} - uses ActiveX, - windows, - BoldComConst; + windows + ; const breProducerDestroying = 100; @@ -113,14 +114,16 @@ implementation constructor TBoldXMLSOAPService.Create(Owner: TObject); var typelib: ITypeLib; + Res: HResult; begin - if (LoadRegTypeLib(LIBID_BoldSOAP, 1, 0, 0, typelib) = S_OK) then + Res := LoadRegTypeLib(LIBID_BoldSOAP, 1, 0, 0, typelib); + if (Res = S_OK) then begin inherited Create(typelib, IBoldSOAPService); FOwner := Owner; - end + end else - raise EBold.CreateFmt(sUnableToLoadTypeLibBoldSoap, [ClassName]); + raise EBold.CreateFmt('%s.Create: Unable to load type library LIBID_BoldSOAP. (LoadRegTypeLib Result: %d)', [ClassName, Res]); end; procedure TBoldXMLSOAPService.Get(const request: WideString; @@ -134,7 +137,7 @@ procedure TBoldXMLSOAPService.Get(const request: WideString; else XMLRequest := TBoldXMLRequest.CreateFromXML(request); if not Assigned(XMLRequest) then - raise EBold.CreateFmt(sXMLRequestNotAssigned, [ClassName]); + raise EBold.CreateFmt('%s.Get: XMLRequest not assigned', [ClassName]); (Owner as TBoldXMLDispatcher).DispatchAction(XMLRequest, ResponseXML); reply := ResponseXML; end; @@ -162,7 +165,7 @@ procedure TBoldXMLDispatcher.DispatchAction(const request: TBoldXMLRequest; begin try if not Assigned(request) then - raise EBold.CreateFmt(sXMLRequestIsNil, [ClassName]); + raise EBold.CreateFmt('%s.DispatchAction: request is nil', [ClassName]); I := 0; Default := nil; ActionName := request.ActionName; @@ -210,8 +213,8 @@ procedure TBoldXMLDispatcher.HandleDispatchError(const E: Exception; begin xmlresponse := TBoldXMLRequest.CreateInitialized; try - xmlresponse.SetAction('SOAP:Fault'); // do not localize - xmlresponse.AddParam('SOAP:faultstring', E.Message); // do not localize + xmlresponse.SetAction('SOAP:Fault'); + xmlresponse.AddParam('SOAP:faultstring', E.Message); response := xmlresponse.DomDocument.XML; finally FreeAndNil(xmlresponse); @@ -235,7 +238,7 @@ constructor TBoldXMLActionItem.Create(Collection: TCollection); s := Copy(ClassName, 2, MaxInt); repeat Inc(I); - aName := Format('%s%d',[s, I]); // do not localize + aName := Format('%s%d',[s, I]); until not Assigned(self.Collection.ItemByName[aName]); ActionName := aName; FSubscriber := TBoldPassThroughSubscriber.Create(_Receive); diff --git a/Source/Common/ConnectionHandlesCOM/BoldXMLDispatcherVB.pas b/Source/Common/ConnectionHandlesCOM/BoldXMLDispatcherVB.pas index c7269e64..d4879c93 100644 --- a/Source/Common/ConnectionHandlesCOM/BoldXMLDispatcherVB.pas +++ b/Source/Common/ConnectionHandlesCOM/BoldXMLDispatcherVB.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldXMLDispatcherVB; interface @@ -8,8 +11,9 @@ interface BoldXMLRequests, comobj, BoldXMLDispatcher; - type + + TBoldXMLSOAPService2 = class(TAutoIntfObject, IBoldSOAPService2) private FOwner: TObject; @@ -20,20 +24,18 @@ TBoldXMLSOAPService2 = class(TAutoIntfObject, IBoldSOAPService2) constructor Create(Owner: TObject); property Owner: TObject read FOwner; end; - + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldXMLDispatcherVB = class(TBoldXMLDispatcher) protected function GetComObject: IUnknown; override; end; -implementation -{$R *.res} +implementation uses ActiveX, - windows, - BoldComConst; + windows; { TBoldXMLSOAPService2 } @@ -47,7 +49,7 @@ constructor TBoldXMLSOAPService2.Create(Owner: TObject); FOwner := Owner; end else - raise EBold.CreateFmt(sUnableToLoadTypeLibBoldSoap, [ClassName]); + raise EBold.CreateFmt('%s.Create: Unable to load type library LIBID_BoldSOAP', [ClassName]); end; procedure TBoldXMLSOAPService2.Get(const request: WideString; @@ -61,11 +63,12 @@ procedure TBoldXMLSOAPService2.Get(const request: WideString; else XMLRequest := TBoldXMLRequest.CreateFromXML(request); if not Assigned(XMLRequest) then - raise EBold.CreateFmt(sXMLRequestNotAssigned, [ClassName]); + raise EBold.CreateFmt('%s.Get: XMLRequest not assigned', [ClassName]); (Owner as TBoldXMLDispatcher).DispatchAction(XMLRequest, ResponseXML); reply := ResponseXML; end; + function TBoldXMLSOAPService2.Get2(const request: WideString): WideString; begin Get(request, Result); @@ -78,5 +81,8 @@ function TBoldXMLDispatcherVB.GetComObject: IUnknown; Result := TBoldXMLSOAPService2.Create(self) as IUnknown; end; -end. + + + +end. diff --git a/Source/Common/Core/BoldBase.pas b/Source/Common/Core/BoldBase.pas index 7b46ce93..621863c9 100644 --- a/Source/Common/Core/BoldBase.pas +++ b/Source/Common/Core/BoldBase.pas @@ -1,8 +1,16 @@ + +{ Global compiler directives } +{$include bold.inc} + unit BoldBase; interface uses +{$IFDEF DebugInstanceCounter} + Classes, + SysUtils, +{$ENDIF} BoldDefs; type @@ -12,12 +20,18 @@ TBoldRefCountedObject = class; TBoldNonRefCountedObject = class; {-- TBoldMemoryManagedObject --} +// TBoldMemoryManagedObject = TObject; // Just an alias, to avoid 1 level deeper inheritance for no reason TBoldMemoryManagedObject = class(TObject) + protected + function GetDebugInfo: string; virtual; + function ContextObject: TObject; virtual; public class function NewInstance: TObject; override; procedure FreeInstance; override; + property DebugInfo: string read GetDebugInfo; end; + {-- TBoldInterfacedObject --} TBoldInterfacedObject = class(TBoldMemoryManagedObject, IInterface) protected @@ -35,7 +49,7 @@ TBoldRefCountedObject = class(TBoldInterfacedObject) function _AddRef: Integer; override; function _Release: Integer; override; public - {$IFNDEF BOLD_BCB} { TODO : Check if needed in BCB6 } + {$IFNDEF BOLD_BCB} procedure AfterConstruction; override; class function NewInstance: TObject; override; {$ENDIF} @@ -79,27 +93,89 @@ TBoldNonRefCountedObject = class(TBoldInterfacedObject) BoldElementFlag22 = 1 shl 22; BoldElementFlag23 = 1 shl 23; - type +type + {---TBoldFlaggedObject---} TBoldFlaggedObject = class(TBoldMemoryManagedObject) private fStateAndFlagBank: cardinal; protected - procedure SetInternalState(Mask, shift, value: cardinal); - function GetInternalState(Mask, shift: cardinal): cardinal; - procedure SetElementFlag(Flag: TBoldElementFlag; Value: Boolean); - function GetElementFlag(Flag: TBoldElementFlag): Boolean; + procedure SetInternalState(Mask, shift, value: cardinal); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetInternalState(Mask, shift: cardinal): cardinal; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetElementFlag(Flag: TBoldElementFlag; Value: Boolean); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetElementFlag(Flag: TBoldElementFlag): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + property StateAndFlagBank: cardinal read fStateAndFlagBank; // allow reading in subclasses end; +{$IFDEF DebugInstanceCounter} +const + cDefaultInstanceLimit = 1000; +var + DebugInstanceCounter: boolean = false; + +procedure GetInstaceList(AStringList: TStringList; ASort: boolean = true; AInstanceLimit: integer = cDefaultInstanceLimit); +procedure ClearInstanceLog; +{$ENDIF} + implementation uses BoldCommonConst, + + {$IFDEF DebugInstanceCounter} + BoldIndexableList, + BoldHashIndexes, + {$ENDIF} {$IFNDEF BOLD_DISABLEMEMORYMANAGER} BoldMemoryManager, {$ENDIF} Windows; +var + Finalized: boolean; + +{$IFDEF DebugInstanceCounter} +type + TBoldClassStats = class(TObject) + strict private + fClass: TClass; + fCreatedInstances: int64; + fDestroyedInstances: int64; + private + fChanged: boolean; + public + function LiveInstances: int64; + function MemoryUsage: int64; + procedure InstanceCreated; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure InstanceDestroyed; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + property BoldClass: TClass read fClass; + property CreatedInstances: int64 read fCreatedInstances; + property DestroyedInstances: int64 read fDestroyedInstances; + constructor Create(AClass: TClass); + end; + + TBoldClassStatsList = class(TBoldIndexableList) + private + function GetClassStats(const index: integer): TBoldClassStats; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + class var IX_Class: integer; + public + constructor Create; + function StatsForClass(AClassType: TClass): TBoldClassStats; + property ClassStats[const index: integer]: TBoldClassStats read GetClassStats; default; + property Count; + end; + + TClassIndex = class(TBoldClassHashIndex) + protected + function ItemAsKeyClass(Item: TObject): TClass; override; + end; + +var + gClassStatsList: TBoldClassStatsList; + gInternalUpdate: integer = 0; + +{$ENDIF} + {-- TBoldInterfacedObject -----------------------------------------------------} function TBoldInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult; @@ -185,32 +261,218 @@ procedure TBoldFlaggedObject.SetInternalState(Mask, shift, value: cardinal); cardinal(Value shl Shift); end; +// warning, this code is duplicated in TBoldMember since inlining does not work as it should function TBoldFlaggedObject.GetInternalState(Mask, shift: cardinal): cardinal; begin result := (fStateAndFlagBank and mask) shr shift; end; -{-- TBoldMemoryManagedObject -----------------------------------------------------} +{$IFDEF DebugInstanceCounter} -procedure TBoldMemoryManagedObject.FreeInstance; +{ TBoldClassStatsList } + +constructor TBoldClassStatsList.Create; begin - {$IFNDEF BOLD_DISABLEMEMORYMANAGER} - CleanUpInstance; - BoldMemoryManager_.DeAllocateMemory(Pointer(self), InstanceSize); - {$ELSE} inherited; - {$ENDIF} + SetIndexCapacity(1); + IX_Class := -1; + SetIndexVariable(IX_Class, AddIndex(TClassIndex.Create)); +end; + +function TBoldClassStatsList.GetClassStats( + const index: integer): TBoldClassStats; +begin + Result := TBoldClassStats(inherited Items[index]); +end; + +function TBoldClassStatsList.StatsForClass(AClassType: TClass): TBoldClassStats; +begin + Result := TBoldClassStats(TClassIndex(Indexes[IX_Class]).FindByClass(AClassType)); + if not Assigned(Result) then + begin + Result := TBoldClassStats.Create(AClassType); + self.Add(result); + end; +end; + +{ TClassIndex } + +function TClassIndex.ItemAsKeyClass(Item: TObject): TClass; +begin + Result := TBoldClassStats(Item).BoldClass; +end; + +{ TBoldClassStats } + +constructor TBoldClassStats.Create(AClass: TClass); +begin + fClass := AClass; +end; + +procedure TBoldClassStats.InstanceCreated; +begin + inc(fCreatedInstances); + fChanged := true; +end; + +procedure TBoldClassStats.InstanceDestroyed; +begin + inc(fDestroyedInstances); + fChanged := true; +end; + +function TBoldClassStats.LiveInstances: int64; +begin + result := fCreatedInstances - fDestroyedInstances; +end; + +function TBoldClassStats.MemoryUsage: int64; +begin + result := LiveInstances * BoldClass.InstanceSize; +end; + +procedure GetInstaceList(AStringList: TStringList; ASort: boolean = true; AInstanceLimit: integer = cDefaultInstanceLimit); +var + vSl: TStringList; + i: integer; + vBoldClassStats: TBoldClassStats; + vTotalCreated, vTotalDestroyed, vTotalMemoryUsage: int64; +begin + vTotalCreated := 0; + vTotalDestroyed := 0; + vTotalMemoryUsage := 0; + vSl := TStringList.Create; + vSl.sorted := ASort; + try + for I := 0 to gClassStatsList.Count - 1 do + begin + vBoldClassStats := gClassStatsList[i]; + vBoldClassStats.fChanged := false; + Inc(vTotalCreated, vBoldClassStats.CreatedInstances); + inc(vTotalDestroyed, vBoldClassStats.DestroyedInstances); + Inc(vTotalMemoryUsage, vBoldClassStats.MemoryUsage); + if vBoldClassStats.LiveInstances > AInstanceLimit then + vSl.Add( Format('%10d - %10d = %10d: %s (%d bytes)', [vBoldClassStats.CreatedInstances, vBoldClassStats.DestroyedInstances, vBoldClassStats.LiveInstances, vBoldClassStats.BoldClass.ClassName, vBoldClassStats.MemoryUsage])); + end; + AStringList.Add(StringOfChar('-', 37)); + AStringList.Add(' Created - Destroyed = Live : ClassName (Minimal Memory usage in bytes)'); + AStringList.Add(StringOfChar('-', 37)); + AStringList.AddStrings(vSl); + AStringList.Add(StringOfChar('-', 37)); + AStringList.Add( Format('%10d - %10d = %10d: (%d bytes)', [vTotalCreated, vTotalDestroyed, vTotalCreated - vTotalDestroyed, vTotalMemoryUsage])); + AStringList.Add(StringOfChar('-', 37)); + finally + vSl.free; + end; +end; + +procedure ClearInstanceLog; +begin + gClassStatsList.Clear; +end; + +procedure CheckForLiveInstances; +var + i: integer; + vBoldClassStats: TBoldClassStats; + sl: TStringList; +begin + sl := TStringList.Create; + try + for I := 0 to gClassStatsList.Count - 1 do + begin + vBoldClassStats := gClassStatsList[i]; + if vBoldClassStats.LiveInstances > 0 then + sl.Add(Format('%d instances of %s', [vBoldClassStats.LiveInstances, vBoldClassStats.BoldClass.ClassName])); + end; + if sl.count > 0 then + raise Exception.Create(sl.text); + finally + sl.free; + end; +end; +{$ENDIF} + + +{ TBoldMemoryManagedObject } + +function TBoldMemoryManagedObject.GetDebugInfo: string; +begin + if ContextObject <> nil then + result := ContextObject.ClassName + else + result := ClassName; +end; + +function TBoldMemoryManagedObject.ContextObject: TObject; +begin + result := self; end; class function TBoldMemoryManagedObject.NewInstance: TObject; begin - {$IFNDEF BOLD_DISABLEMEMORYMANAGER} +{$IFNDEF BOLD_DISABLEMEMORYMANAGER} result := TObject(BoldMemoryManager_.AllocateMemory(InstanceSize)); InitInstance(result); - {$ELSE} +{$ELSE} result := inherited NewInstance; +{$ENDIF} +{$IFDEF DebugInstanceCounter} + if DebugInstanceCounter and (gInternalUpdate = 0) then + gClassStatsList.StatsForClass(self).InstanceCreated; +{$ENDIF} +end; + +procedure TBoldMemoryManagedObject.FreeInstance; + + procedure InternalRaise; + begin + raise EBold.Create('TBoldMemoryManagedObject.FreeInstance: Attempt to destroy object after BoldBase Finalization. Inspect/revert recent Uses clause changes.'); + end; + +begin + if Finalized then + InternalRaise; + {$IFDEF DebugInstanceCounter} + if DebugInstanceCounter and (gInternalUpdate = 0) then + gClassStatsList.StatsForClass(ClassType).InstanceDestroyed; {$ENDIF} +{$IFNDEF BOLD_DISABLEMEMORYMANAGER} + CleanUpInstance; + BoldMemoryManager_.DeAllocateMemory(Pointer(self), InstanceSize); +{$ELSE} + inherited; +{$ENDIF} end; +procedure InitDebugMethods; +begin + exit; +{$IFDEF BOLD_DISABLEMEMORYMANAGER} + with TBoldMemoryManagedObject(nil) do + begin + DebugInfo; + GetDebugInfo; + end; +{$ENDIF} +end; + +initialization +{$IFDEF DebugInstanceCounter} + inc(gInternalUpdate); + gClassStatsList := TBoldClassStatsList.Create; + dec(gInternalUpdate); +{$ENDIF} +InitDebugMethods; + +finalization +{$IFDEF DebugInstanceCounter} + CheckForLiveInstances; + inc(gInternalUpdate); + gClassStatsList.free; + dec(gInternalUpdate); +{$ENDIF} + Finalized := true; + end. diff --git a/Source/Common/Core/BoldCommonConst.pas b/Source/Common/Core/BoldCommonConst.pas index e90c7aee..67976d40 100644 --- a/Source/Common/Core/BoldCommonConst.pas +++ b/Source/Common/Core/BoldCommonConst.pas @@ -94,10 +94,6 @@ interface sNotRunningInIDE = '%s: Not running in IDE'; sUnknownDisplayMode = '%s.ApplicationEventsOnIdle: Unknown displaymode'; -//BoldGettingStartedExpert - sGettingStarted = 'Getting Started'; - sCouldNotFindGettingStarted = 'Could not find Bold for Delphi''s GettingStarted document: %s'; - //BoldIDEMenus sCompanyHomePage = '&BoldSoft Home Page'; sProductHomePage = 'Bold for &Delphi Home Page'; diff --git a/Source/Common/Core/BoldContainers.pas b/Source/Common/Core/BoldContainers.pas index 67b0ee73..68fd40ce 100644 --- a/Source/Common/Core/BoldContainers.pas +++ b/Source/Common/Core/BoldContainers.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldContainers; interface @@ -48,13 +51,13 @@ TBoldArray = class(TBoldContainer) procedure AddItems(const Items; NumItems: Integer); procedure EnsureCapacity; function GetCapacity: Integer; - procedure MoveItems(FromIndex, ToIndex, NumItems: Integer); + procedure MoveItems(FromIndex, ToIndex, NumItems: Integer); {$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure SetCapacity(Value: Integer); protected - function Add(const Item): Integer; + function Add(const Item): Integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} function AddArray(BoldArray: TBoldArray): Integer; procedure Dispose(Index: Integer); virtual; - procedure Get(Index: Integer; var Item); + procedure Get(Index: Integer; var Item); {$IFDEF BOLD_INLINE}inline;{$ENDIF} function GetCount: Integer; override; function GetGrowDelta: Integer; virtual; function GetItemSize: Integer; virtual; abstract; @@ -73,8 +76,11 @@ TBoldArray = class(TBoldContainer) procedure DeleteRange(FromIndex, ToIndex: integer); procedure Exchange(Index1, Index2: Integer); procedure Move(FromIndex, ToIndex: Integer); - procedure Pack; - procedure Sort(Compare: TBoldArraySortCompare); + procedure Pack; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure Sort(Compare: TBoldArraySortCompare; SortMode: TBoldSortMode = + BoldDefaultSortMode); overload; + procedure Sort(CompareFunc: TBoldArraySortCompare; FirstIndex, LastIndex: + Integer; SortMode: TBoldSortMode = BoldDefaultSortMode); overload; property Capacity: Integer read GetCapacity write SetCapacity; property ItemSize: Integer read GetItemSize; end; @@ -82,33 +88,47 @@ TBoldArray = class(TBoldContainer) { TBoldPointerArray } TBoldPointerArray = class(TBoldArray) private - function Get(Index: Integer): Pointer; - procedure Put(Index: Integer; Item: Pointer); + function Get(Index: Integer): Pointer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure Put(Index: Integer; Item: Pointer); {$IFDEF BOLD_INLINE}inline;{$ENDIF} protected function GetItemSize: Integer; override; public - function Add(Item: Pointer): Integer; - function IndexOf(Item: Pointer): Integer; - procedure Insert(Index: Integer; Item: Pointer); - function Remove(Item: Pointer): Integer; - function RemoveWithNil(Item: Pointer): Integer; + function Add(Item: Pointer): Integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function IndexOf(Item: Pointer): Integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure Insert(Index: Integer; Item: Pointer); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function Remove(Item: Pointer): Integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function RemoveWithNil(Item: Pointer): Integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} property Items[Index: Integer]: Pointer read Get write Put; default; end; + TBoldArrayTraverser = class(TBoldMemoryManagedObject) + private + FIndex: Integer; + FArray: TBoldObjectArray; + protected + property Index: Integer read fIndex; + property ObjectArray: TBoldObjectArray read fArray; + public + constructor Create(AArray: TBoldObjectArray); + function GetCurrent: TObject; + function MoveNext: Boolean; + end; + { TBoldObjectArray } TBoldObjectArray = class(TBoldArray) private - function Get(Index: Integer): TObject; - procedure Put(Index: Integer; Item: TObject); + function Get(Index: Integer): TObject; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure Put(Index: Integer; Item: TObject); {$IFDEF BOLD_INLINE}inline;{$ENDIF} protected procedure Dispose(Index: Integer); override; function GetItemSize: Integer; override; public - function Add(Item: TObject): Integer; - function IndexOf(Item: TObject): Integer; - procedure Insert(Index: Integer; Item: TObject); - function Remove(Item: TObject): Integer; - function RemoveWithNil(Item: TObject): Integer; + function GetEnumerator: TBoldArrayTraverser; + function Add(Item: TObject): Integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function IndexOf(Item: TObject): Integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure Insert(Index: Integer; Item: TObject); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function Remove(Item: TObject): Integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function RemoveWithNil(Item: TObject): Integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} property Items[Index: Integer]: TObject read Get write Put; default; end; @@ -122,25 +142,25 @@ TBoldInterfaceArray = class(TBoldArray) function GetItemSize: Integer; override; public function Add(const Item: IUnknown): Integer; - function IndexOf(const Item: IUnknown): Integer; + function IndexOf(const Item: IUnknown): Integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure Insert(Index: Integer; const Item: IUnknown); - function Remove(const Item: IUnknown): Integer; - function RemoveWithNil(const Item: IUnknown): Integer; + function Remove(const Item: IUnknown): Integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function RemoveWithNil(const Item: IUnknown): Integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} property Items[Index: Integer]: IUnknown read Get write Put; default; end; { TBoldIntegerArray } TBoldIntegerArray = class(TBoldArray) private - function Get(Index: Integer): integer; - procedure Put(Index: Integer; const Item: integer); + function Get(Index: Integer): integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure Put(Index: Integer; const Item: integer); {$IFDEF BOLD_INLINE}inline;{$ENDIF} protected procedure Dispose(Index: Integer); override; function GetItemSize: Integer; override; public - function Add(const Item: integer): Integer; + function Add(const Item: integer): Integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} function IndexOf(const Item: integer): Integer; - procedure Insert(Index: Integer; const Item: integer); + procedure Insert(Index: Integer; const Item: integer); {$IFDEF BOLD_INLINE}inline;{$ENDIF} function Remove(const Item: integer): Integer; property Items[Index: Integer]: integer read Get write Put; default; end; @@ -153,47 +173,8 @@ TBoldIntegerArray = class(TBoldArray) implementation uses - SysUtils; - -procedure QuickSort(SortList: TBoldArray; L, R: Integer; - SCompare: TBoldArraySortCompare); -var - I, J: Integer; - P, T: Pointer; -begin - repeat - I := L; - J := R; - SortList.Get((L + R) shr 1, P); - repeat - SortList.Get(I, T); - while SCompare(T, P) < 0 do - begin - Inc(I); - SortList.Get(I, T); - end; - - SortList.Get(J, T); - while SCompare(T, P) > 0 do - begin - Dec(J); - SortList.Get(J, T); - end; - - if I <= J then - begin - SortList.Exchange(i, j); -{ SortList^[I] := SortList^[J]; - SortList^[J] := T;} - Inc(I); - Dec(J); - end; - until I > J; - if L < J then - QuickSort(SortList, L, J, SCompare); - L := I; - until I >= R; -end; + SysUtils, + BoldRev; {-- TBoldContainer ------------------------------------------------------------} @@ -217,12 +198,309 @@ destructor TBoldArray.Destroy; inherited; end; -procedure TBoldArray.Sort(Compare: TBoldArraySortCompare); +procedure TBoldArray.Sort(CompareFunc: TBoldArraySortCompare; FirstIndex, + LastIndex: Integer; SortMode: TBoldSortMode = BoldDefaultSortMode); + + ////////////////////////////////////////////////////////////////////////////// + // Insertion Sort: // + // stable, inplace, but only fast on small lists // + ////////////////////////////////////////////////////////////////////////////// + procedure InsertSort(L, R: Integer; SCompare: TBoldArraySortCompare); + var + I, J: Integer; + T: Pointer; + begin + GetMem(T, ItemSize); + for I := L + 1 to R do begin + if SCompare(@FArray^[I * ItemSize], + @FArray^[(I - 1) * ItemSize]) < 0 then + begin + J := I; + Get(J, T^); + while (J > L) and + (SCompare(T, @FArray^[(J - 1) * ItemSize]) < 0) do + begin + System.Move(FArray^[(J - 1) * ItemSize], + FArray^[J * ItemSize], + ItemSize); + Dec(J); + end; + Put(J, T^); + end; + end; + FreeMem(T, ItemSize); + end; + + ////////////////////////////////////////////////////////////////////////////// + // Quick Sort: // + // fast, inplace (without help array), // + // but NOT stable (sorting changes within same elements) // + ////////////////////////////////////////////////////////////////////////////// + procedure QuickSort(Left, Right: Integer; SCompare: TBoldArraySortCompare); + var + TempSize: Integer; + I, J: Integer; + P: Pointer; + begin + TempSize := ItemSize; + GetMem(P, TempSize); + try + repeat + I := Left; + J := Right; + System.Move(FArray^[((Left + Right) shr 1) * TempSize], P^, TempSize); + repeat + while SCompare(@FArray^[I * ItemSize], P) < 0 do + Inc(I); + while SCompare(@FArray^[J * ItemSize], P) > 0 do + Dec(J); + if I <= J then + begin + if I <> J then + begin + Exchange(I, J); + end; + Inc(I); + Dec(J); + end; + until I > J; + if Left < J then + QuickSort(Left, J, SCompare); + Left := I; + until I >= Right; + finally + FreeMem(P); + end; + end; +{ + ////////////////////////////////////////////////////////////////////////////// + // Merge Sort - Inplace Variant: // + // http://thomas.baudel.name/Visualisation/VisuTri/inplacestablesort.html // + // stable, inplace, but slower than Quicksort and normal Mergesort // + ////////////////////////////////////////////////////////////////////////////// + function Lower(Left, Right, Val: Integer; SCompare: TBoldElementCompare): + Integer; + var + iLen: Integer; + iHalf: Integer; + iMid: Integer; + begin + iLen := Right - Left; + while iLen > 0 do begin + iHalf := iLen div 2; + iMid := Left + iHalf; + if SCompare(Elements[iMid], Elements[Val]) < 0 then begin + Left := iMid + 1; + iLen := iLen - iHalf - 1; + end else begin + iLen := iHalf; + end; + end; + Result := Left; + end; + + function Upper(Left, Right, Val: Integer; SCompare: TBoldElementCompare): + Integer; + var + iLen: Integer; + iHalf: Integer; + iMid: Integer; + begin + iLen := Right - Left; + while iLen > 0 do begin + iHalf := iLen div 2; + iMid := Left + iHalf; + if SCompare(Elements[Val], Elements[iMid]) < 0 then begin + iLen := iHalf; + end else begin + Left := iMid + 1; + iLen := iLen - iHalf - 1; + end; + end; + Result := Left; + end; + + function GCD(M, N: Integer): Integer; + var + T: Integer; + begin + while (N <> 0) do begin + T := M mod N; + M := N; N := T; + end; + Result := M; + end; + + procedure Rotate(Left, Middle, Right: Integer; SCompare: TBoldElementCompare); + var + N: Integer; + SavedElement: TBoldElement; + Shift: Integer; + P1, P2: Integer; + begin + if (Left <> Middle) and (Right <> Middle) then begin + N := GCD(Right - Left, Middle - Left); + while N <> 0 do begin + Dec(N); + SavedElement := Elements[Left + N]; + Shift := Middle - Left; + P1 := Left + N; + P2 := Left + N + Shift; + while (P2 <> Left + N) do begin + Elements[P1] := Elements[P2]; + P1 := P2; + if Right - P2 > Shift then begin + Inc(P2, Shift); + end else begin + P2 := Left + (Shift - (Right - P2)); + end; + end; + Elements[P1] := SavedElement; + end; + end; + end; + + procedure MergeInplace(Left, Pivot, Right, Len1, Len2: Integer; SCompare: + TBoldElementCompare); + var + iFirstCut, iSecondCut: Integer; + iLen11, iLen22: Integer; + iNewMid: Integer; + begin + if (Len1 <> 0) and (Len2 <> 0) then begin + if Len1 + Len2 = 2 then begin + if SCompare(Elements[Pivot], Elements[Left]) < 0 then begin + if Pivot < Left then begin + Move(Pivot, Left); + Move(Left - 1, Pivot); + end else begin + Move(Left, Pivot); + Move(Pivot - 1, Left); + end; + end; + end else begin + if Len1 > Len2 then begin + iLen11 := Len1 div 2; + iFirstCut := Left + iLen11; + iSecondCut := Lower(Pivot, Right, iFirstCut, SCompare); + iLen22 := iSecondCut - Pivot; + end else begin + iLen22 := Len2 div 2; + iSecondCut := Pivot + iLen22; + iFirstCut := Upper(Left, Pivot, iSecondCut, SCompare); + iLen11 := iFirstCut - Left; + end; + Rotate(iFirstCut, Pivot, iSecondCut, SCompare); + iNewMid := iFirstCut + iLen22; + MergeInplace(Left, iFirstCut, iNewMid, iLen11, iLen22, SCompare); + MergeInplace(iNewMid, iSecondCut, Right, Len1 - iLen11, Len2 - iLen22, SCompare); + end; + end; + end; + + procedure MergeSortInplace(Left, Right: Integer; SCompare: TBoldElementCompare); + var + Middle: Integer; + begin + if Right - Left < 8 then begin + InsertSort(Left, Right, SCompare); + end else begin + Middle := (Left + Right) div 2; + MergeSortInplace(Left, Middle, SCompare); + MergeSortInplace(Middle, Right, SCompare); + MergeInplace(Left, Middle, Right, Middle - Left, Right - Middle, SCompare); + end; + end; +} + ////////////////////////////////////////////////////////////////////////////// + // Merge Sort: // + // http://www.iti.fh-flensburg.de/lang/algorithmen/sortieren/merge/merge.htm// + // fastest, stable, // + // but not fully inplace (help array with only n/2 is needed) // + ////////////////////////////////////////////////////////////////////////////// + procedure MergeSort(Left, Right: Integer; SCompare: TBoldArraySortCompare); + var + HelpArray: PByteArray; + + procedure DoMergeSort(Left, Right: Integer; SCompare: TBoldArraySortCompare); + var + m: Integer; + i, j, k: Integer; + begin + if Left < Right then begin + if Right - Left < 8 then begin + InsertSort(Left, Right, SCompare); + end else begin + m := (Left + Right) div 2; + DoMergeSort(Left, m, SCompare); + DoMergeSort(m + 1, Right, SCompare); + + j := m + 1; + // Copy first half of elements in help array + System.Move(FArray^[Left * ItemSize], + HelpArray^[0], + (j - Left) * ItemSize); + + i := 0; + k := Left; + // Copy back the next largest element + while (k < j) and (j <= Right) do begin + if SCompare(@HelpArray^[i * ItemSize], + @FArray^[J * ItemSize]) <= 0 then + begin + System.Move(HelpArray^[i * ItemSize], + FArray^[k * ItemSize], + ItemSize); + Inc(i); + end else begin + System.Move(FArray^[j * ItemSize], + FArray^[k * ItemSize], + ItemSize); + Inc(j); + end; + Inc(k); + end; + + // Copy back the rest of help array if existing + if k < j then begin + System.Move(HelpArray^[i * ItemSize], + FArray^[k * ItemSize], + (j - k) * ItemSize); + end; + end; + end; + end; + + var + TempSize: Integer; + begin + TempSize := ((Count + 1) div 2) * ItemSize; + GetMem(HelpArray, TempSize); + try + DoMergeSort(FirstIndex, LastIndex, CompareFunc); + finally + FreeMem(HelpArray); + end; + end; + begin - if Count > 0 then - QuickSort(self, 0, Count - 1, Compare); + if Assigned(Self) and (Count > 1) then begin + case SortMode of + smQuickSort: QuickSort(FirstIndex, LastIndex, CompareFunc); + smMergeSort: MergeSort(FirstIndex, LastIndex, CompareFunc); + smMergeSortInplace: begin +// MergeSortInplace(FirstIndex, LastIndex, CompareFunc); + raise EBoldInternal.Create('TBoldArray.Sort: smMergeSortInplace is not supported here'); + end; + end; + end; end; +procedure TBoldArray.Sort(Compare: TBoldArraySortCompare; SortMode: + TBoldSortMode = BoldDefaultSortMode); +begin + Sort(Compare, 0, Count - 1, SortMode); +end; function TBoldArray.Add(const Item): Integer; begin @@ -259,6 +537,20 @@ procedure TBoldArray.Clear; SetCapacity(0); end; +procedure TBoldArray.MoveItems(FromIndex, ToIndex, NumItems: Integer); +begin + if (FromIndex < 0) or (ToIndex < 0) or + (FromIndex + NumItems > FCapacity) or + (ToIndex + NumItems > FCapacity) then + begin + raise Exception.Create('Bad parameters to TBoldArray.MoveItems'); + end; + + System.Move(FArray^[FromIndex * ItemSize], + FArray^[ToIndex * ItemSize], + NumItems * ItemSize); +end; + procedure TBoldArray.Delete(Index: Integer); begin if (Index < 0) or (Index >= FCount) then @@ -293,11 +585,8 @@ procedure TBoldArray.Exchange(Index1, Index2: Integer); TempSize := ItemSize; GetMem(Item, TempSize); try - // copy item at Index 1 System.Move(FArray^[Index1 * TempSize], Item^, TempSize); - // copy Index2 to Index 1 System.Move(FArray^[Index2 * TempSize], FArray^[Index1 * TempSize], TempSize); - // copy copied item (Index1) to Index2 System.Move(Item^, FArray^[Index2 * TempSize], TempSize); finally FreeMem(Item); @@ -371,13 +660,6 @@ procedure TBoldArray.Move(FromIndex, ToIndex: Integer); end; end; -procedure TBoldArray.MoveItems(FromIndex, ToIndex, NumItems: Integer); -begin - System.Move(FArray^[FromIndex * ItemSize], - FArray^[ToIndex * ItemSize], - NumItems * ItemSize); -end; - procedure TBoldArray.Pack; begin SetCapacity(FCount); @@ -495,12 +777,8 @@ function TBoldObjectArray.Add(Item: TObject): Integer; end; procedure TBoldObjectArray.Dispose(Index: Integer); -var - Obj: TObject; begin - Obj := Get(Index); - if Assigned(Obj) then - Obj.Free; + Get(Index).Free; end; function TBoldObjectArray.Get(Index: Integer): TObject; @@ -508,6 +786,11 @@ function TBoldObjectArray.Get(Index: Integer): TObject; inherited Get(Index,Result); end; +function TBoldObjectArray.GetEnumerator: TBoldArrayTraverser; +begin + result := TBoldArrayTraverser.Create(self); +end; + function TBoldObjectArray.GetItemSize: Integer; begin Result := SizeOf(TObject); @@ -608,7 +891,6 @@ function TBoldIntegerArray.Add(const Item: integer): Integer; procedure TBoldIntegerArray.Dispose(Index: Integer); begin - // do nothing end; function TBoldIntegerArray.Get(Index: Integer): integer; @@ -663,4 +945,28 @@ procedure TBoldArray.DeleteRange(FromIndex, ToIndex: integer); MoveItems(ToIndex + 1, FromIndex, FCount - ToIndex); end; +{ TBoldArrayTraverser } + +constructor TBoldArrayTraverser.Create(AArray: TBoldObjectArray); +begin + inherited Create; + FIndex := -1; + FArray := AArray; +end; + +function TBoldArrayTraverser.GetCurrent: TObject; +begin + result := fArray[Index]; +end; + +function TBoldArrayTraverser.MoveNext: Boolean; +begin + Result := Index < fArray.Count - 1; + if Result then + Inc(FIndex); +end; + + +initialization + end. diff --git a/Source/Common/Core/BoldDefs.pas b/Source/Common/Core/BoldDefs.pas index b31c0a7f..8c70b25e 100644 --- a/Source/Common/Core/BoldDefs.pas +++ b/Source/Common/Core/BoldDefs.pas @@ -1,15 +1,19 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDefs; interface uses + Classes, SysUtils; const NO_CLASS = -1; - INTERNALNULLKEY = -1; // used for 'databases' without NULL such as paradox and DBase - UNASSIGNEDID = -1; // indicating newly created DefaultID without DBValue + INTERNALNULLKEY = -1; + UNASSIGNEDID = -1; NOTVALIDCLIENTID = -1; @@ -19,14 +23,12 @@ interface BOLDCR = #13; BOLDLF = #10; - BOLDDIRSEPARATOR = '\'; // Prepare for other directory separator + BOLDDIRSEPARATOR = '\'; ALLFILESFILTER: string = 'All files (*.*)|*.*'; IDCOLUMN_NAME: string = 'BOLD_ID'; -// IDCOLUMN_SQLTYPE: string = 'INTEGER'; TYPECOLUMN_NAME: string = 'BOLD_TYPE'; -// TYPECOLUMN_SQLTYPE: string = 'SMALLINT'; TABLEPREFIXTAG = ''; DEFAULTTABLEPREFIX: string = 'Bold'; OBJECTTABLE_NAME: string = TABLEPREFIXTAG+'_OBJECT'; @@ -43,6 +45,7 @@ interface MMT_TABLENAME_COLUMN: String = 'TABLENAME'; MMT_COLUMNS_COLUMN: String = 'COLUMNS'; MMT_MAPPERNAME_COLUMN: String = 'MAPPERNAME'; + MMT_INDEX_COLUMN: string = 'COLUMNINDEX'; AllInstancesMappingTable_NAME: string = TABLEPREFIXTAG+'_R_CLSMAP'; AID_CLASSNAME_COLUMN: String = 'CLASSNAME'; @@ -59,17 +62,24 @@ interface TIMESTAMPCOLUMN_NAME: string = 'BOLD_TIME_STAMP'; GLOBALIDCOLUMN_NAME: string = 'EXTERNAL_ID'; TIMESTAMPSTARTCOLUMNNAME: String = 'TimeStampStart'; + TIMESTAMPSTARTCOLUMNNAMEUPPER: String = 'TIMESTAMPSTART'; TIMESTAMPSTOPCOLUMNNAME: String = 'TimeStampStop'; LASTTIMESTAMPCOLUMN_NAME: string = 'LastTimestamp'; THISTIMESTAMPCOLUMN_NAME: string = 'ThisTimestamp'; LASTCLOCKCOLUMN_NAME: string = 'LastClockTime'; THISCLOCKCOLUMN_NAME: string = 'ThisClockTime'; MODELVERSIONCOLUMN_NAME: string = 'MODEL_VERSION'; + ORDERCOLUMN_SUFFIX: string = '_O'; + ORDERCOLUMN_INDEX: integer = 1; {values for TBoldRepresentation} brDefault = 1; brShort = 2; brLong = 3; + brJson = 4; + brXml = 5; + brHtml = 6; + fmNormal = 0; fmDistributable = 1; @@ -86,12 +96,20 @@ interface PROPAGATOR_PARAMETER_DELIMITER_CHAR = '|'; + BOLD_DATABASE_ERROR_UNKNOWN = 'Unknown Error: %s'; + BOLD_DATABASE_ERROR_CONNECTION = 'Can not connect to Server %s '; + BOLD_DATABASE_ERROR_LOGIN = 'User %s failed to logon to database %s on server %s'; + BOLD_DATABASE_ERROR_LOGIN_WINDOWS_AUTH = '(Windows Authentication error)'; + BOLD_DATABASE_ERROR_SQL = 'Syntax of SQL "%s" is not correct. (%s)'; + BOLD_DATABASE_ERROR_UPDATE = 'Failed to update database'; + BOLD_DATABASE_ERROR_DEADLOCK = 'Deadlock occured. (%s)'; type TBoldRoleType= (rtRole, rtLinkRole, rtInnerLinkRole); + TBoldRoleSet = set of TBoldRoleType; TBoldDataBaseGenerationMode = (dbgTable, dbgQuery); TBoldStorage = (bsInternal, bsPartiallyExternal, bsExternal, bsExternalKey); - + TBoldTimeStampType = integer; TBoldClientID = Integer; @@ -106,25 +124,25 @@ interface TBoldDbType = integer; TBoldRepresentation = integer; TBoldExpression = string; - TBoldCompareType = (ctDefault, ctAsString, ctAsText, ctAsAnsiString, ctAsAnsiText, ctAsDate, ctAsTime); + TBoldCompareType = (ctDefault, ctAsString, ctCaseSensitive, ctCaseInsensitive, ctAsDate, ctAsTime); TBoldOrientation = (orHorizontal, orVertical, orGrid); TBoldSQLStyle = (ssColumns, ssParameters, ssValues); TBoldAbstractionLevel = (alAbstract, alConcrete); + TBoldAnsiString = {$IFDEF BOLD_UNICODE}AnsiString{$ELSE}string{$ENDIF}; + TBoldUnicodeString = {$IFDEF BOLD_UNICODE}string{$ELSE}WideString{$ENDIF}; - // Exception types - EBold = class(Exception); // General Bold Exception class - - EBoldDesignTime = class(EBold); // Raised for designtime errors - EBoldImport = class(EBold); // Raised for errors during import + EBold = class(Exception); + EBoldDesignTime = class(EBold); + EBoldImport = class(EBold); EBoldBadRepresentation = class(EBold); - EBoldInternal = class(EBold); // Raised for internal errors - EBoldFeatureNotImplementedYet = class(EBoldInternal); // Not yet... - EBoldBadColumnIndex = class(EBoldInternal); // Raised for column index "out of bound". + EBoldInternal = class(EBold); + EBoldFeatureNotImplementedYet = class(EBoldInternal); + EBoldBadColumnIndex = class(EBoldInternal); - EBoldAssertionFailed = class(EBold); // raised when a user defined constraint (ie May-operation) is violated. + EBoldAssertionFailed = class(EBold); EBoldXMLLoadError = class(EBold); EBoldXMLIncorrectXPath = class(EBold); @@ -134,18 +152,50 @@ EBoldEnsureDatabaseLockError = class(EBold); EBoldLockManagerError = class(EBold); EBoldLicenseError = class(EBold); + EBoldObjectIDError = class(EBold); + + EBoldMissingID = class(EBold); + + EBoldObjectNotInPs = class(EBold); + EBoldDuplicateSingleLinkValueInDb = class(EBold); + TBoldValuePersistenceState = (bvpsCurrent, bvpsModified, bvpsInvalid, bvpsTransient); TBoldValuePersistenceStateSet = set of TBoldValuePersistenceState; + TBoldDatabaseErrorType = (bdetError, bdetConnection, bdetUpdate, bdetSQL, + bdetDeadlock, bdetLogin); + EBoldDatabaseError = class(EBold) + private + FOriginalExceptionClass: string; + FOriginalExceptionMessage: string; + procedure SetOriginalExceptionClass(const Value: string); + procedure SetOriginalExceptionMessage(const Value: string); + public + property OriginalExceptionClass: string read FOriginalExceptionClass write SetOriginalExceptionClass; + property OriginalExceptionMessage: string read FOriginalExceptionMessage write SetOriginalExceptionMessage; + end; + + EBoldDatabaseConnectionError = class(EBoldDatabaseError); + EBoldDatabaseUpdateError = class(EBoldDatabaseError); + EBoldDatabaseSQLError = class(EBoldDatabaseError); + EBoldDatabaseDeadlockError = class(EBoldDatabaseError); + EBoldDatabaseLoginError = class(EBoldDatabaseError); // Log stuff TBoldLogType = (ltInfo, ltDetail, ltWarning, ltError, ltSeparator); TBoldModuleType = (mtUnit, mtText, mtIncFile); + TBoldSortMode = (smQuickSort, smMergeSort, smMergeSortInplace); const BOLDMAXTIMESTAMP = high(TBoldTimeStampType); BOLDINVALIDTIMESTAMP = -1; + {$IFDEF BOLD_DELPHI16_OR_LATER} + BOLDMAXLISTSIZE = MaxInt div 16; + {$ELSE} + BOLDMAXLISTSIZE = Classes.MaxListSize; + {$ENDIF} + {$IFDEF BOLD_DELPHI} BOLD_HOST_IDE = 'Delphi'; {$ENDIF} @@ -153,6 +203,79 @@ EBoldLicenseError = class(EBold); BOLD_HOST_IDE = 'C++Builder'; {$ENDIF} + {$IFDEF BOLD_DELPHI6} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Borland\' + BOLD_HOST_IDE + '\6.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI7} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Borland\' + BOLD_HOST_IDE + '\7.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI8} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Borland\BDS\1.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI9} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Borland\BDS\2.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI10} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Borland\BDS\3.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI11} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Borland\BDS\4.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI12} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Borland\BDS\5.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI13} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\CodeGear\BDS\6.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI14} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\CodeGear\BDS\7.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI15} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Embarcadero\BDS\8.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI16} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Embarcadero\BDS\9.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI17} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Embarcadero\BDS\10.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI18} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Embarcadero\BDS\11.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI19} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Embarcadero\BDS\12.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI20} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Embarcadero\BDS\13.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI21} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Embarcadero\BDS\14.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI22} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Embarcadero\BDS\15.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI23} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Embarcadero\BDS\16.0\'; // check + {$ENDIF} + {$IFDEF BOLD_DELPHI24} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Embarcadero\BDS\18.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI25} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Embarcadero\BDS\19.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI26} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Embarcadero\BDS\20.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI27} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Embarcadero\BDS\21.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI28} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Embarcadero\BDS\22.0\'; + {$ENDIF} + {$IFDEF BOLD_DELPHI29} + BOLD_HOST_IDE_REGISTRYPATH = '\Software\Embarcadero\BDS\23.0\'; + {$ENDIF} + const ONE_SECOND = 1000; SIXTY_SECONDS = 60 * ONE_SECOND; @@ -164,8 +287,21 @@ EBoldLicenseError = class(EBold); beDisconnecting = 62; beModified = 63; +const + BoldDefaultSortMode = smMergeSort; // smQuickSort; implementation -end. +{ EBoldDatabaseError } + +procedure EBoldDatabaseError.SetOriginalExceptionClass(const Value: string); +begin + FOriginalExceptionClass := Value; +end; +procedure EBoldDatabaseError.SetOriginalExceptionMessage(const Value: string); +begin + FOriginalExceptionMessage := Value; +end; + +end. diff --git a/Source/Common/Core/BoldStreams.pas b/Source/Common/Core/BoldStreams.pas index 70286135..06f39666 100644 --- a/Source/Common/Core/BoldStreams.pas +++ b/Source/Common/Core/BoldStreams.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldStreams; interface @@ -15,4 +18,7 @@ interface implementation + +initialization + end. diff --git a/Source/Common/Core/BoldThreadSafeQueue.pas b/Source/Common/Core/BoldThreadSafeQueue.pas index 24669f3f..d327adc9 100644 --- a/Source/Common/Core/BoldThreadSafeQueue.pas +++ b/Source/Common/Core/BoldThreadSafeQueue.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldThreadSafeQueue; interface @@ -14,7 +17,6 @@ TBoldThreadSafeQueue = class; TBoldThreadSafeQueueEntry = class; TBoldThreadSafeStringQueue = class; - { prototypes } TBoldQueueEvent = procedure(Queue: TBoldThreadSafeQueue) of Object; {ring queue with marker} @@ -47,7 +49,7 @@ TBoldThreadSafeQueue = class(TBoldMemoryManagedObject) procedure NotifyQueueNotEmpty; function UnsafeIsEmpty: Boolean; {not threadsafe, for internal use only} public - constructor Create(Name: String); + constructor Create(const Name: String); destructor Destroy; override; procedure Clear; property Count: integer read GetCount; @@ -62,30 +64,32 @@ TBoldThreadSafeObjectQueue = class(TBoldThreadSafeQueue) fCount: integer; fMaxCount: integer; function GetMaxCount: integer; + procedure SetOwnsObjects(const Value: boolean); protected function GetCount: integer; override; procedure UnsafeEnqueue(anObject: TObject); function UnsafeDequeue: TObject; public - constructor Create(Name: String; OwnsObjects: Boolean = true); + constructor Create(const Name: String; OwnsObjects: Boolean = true); procedure Enqueue(anObject: TObject); procedure DequeueList(ResultList: TObjectList; Max: integer); function Dequeue: TObject; // returns nil if queue empty - property OwnsObjects: boolean read fOwnsObjects; + property OwnsObjects: boolean read fOwnsObjects write SetOwnsObjects; property MaxCount: integer read GetMaxCount; end; { TBoldThreadSafeInterfaceQueue } TBoldThreadSafeInterfaceQueue = class(TBoldThreadSafeQueue) public - procedure Enqueue(anInterface: IInterface); + procedure Enqueue(const anInterface: IInterface); function Dequeue: IInterface; // returns nil if queue empty end; { TBoldThreadSafeStringQueue } TBoldThreadSafeStringQueue = class(TBoldThreadSafeQueue) public - procedure Enqueue(aString: string); + procedure Enqueue(const aString: string); + procedure EnqueueList(aList: TStrings); function Dequeue: string; // returns '' string if queue empty procedure AppendToStringList(aList: TStrings); end; @@ -93,7 +97,8 @@ TBoldThreadSafeStringQueue = class(TBoldThreadSafeQueue) implementation uses - SysUtils; + SysUtils, + BoldRev; type { TBoldThreadSafeQueueObjectEntry } @@ -113,7 +118,7 @@ TBoldThreadSafeQueueStringEntry = class(TBoldThreadSafeQueueEntry) private faString: string; public - constructor CreateAfter(aString: string; Entry: TBoldThreadSafeQueueEntry); + constructor CreateAfter(const aString: string; Entry: TBoldThreadSafeQueueEntry); property aString: string read fAString; end; @@ -128,7 +133,7 @@ TBoldThreadSafeQueueInterfaceEntry = class(TBoldThreadSafeQueueEntry) { TBoldThreadSafeQueue } -constructor TBoldThreadSafeQueue.Create(Name: String); +constructor TBoldThreadSafeQueue.Create(const Name: String); begin inherited create; fLocker := TBoldLoggableCriticalSection.Create(Name); @@ -253,7 +258,7 @@ function TBoldThreadSafeQueueObjectEntry.GetObject: TObject; { TBoldThreadSafeObjectQueue } -constructor TBoldThreadSafeObjectQueue.Create(Name: String; OwnsObjects: Boolean); +constructor TBoldThreadSafeObjectQueue.Create(const Name: String; OwnsObjects: Boolean); begin inherited Create(Name); fOwnsObjects := OwnsObjects; @@ -311,6 +316,16 @@ function TBoldThreadSafeObjectQueue.GetMaxCount: integer; end; end; +procedure TBoldThreadSafeObjectQueue.SetOwnsObjects(const Value: boolean); +begin + Lock; + try + fOwnsObjects := Value; + finally + Unlock; + end; +end; + function TBoldThreadSafeObjectQueue.UnsafeDequeue: TObject; var Head: TBoldThreadSafeQueueEntry; @@ -343,7 +358,7 @@ procedure TBoldThreadSafeObjectQueue.UnsafeEnqueue(anObject: TObject); { TBoldThreadSafeQueueStringEntry } -constructor TBoldThreadSafeQueueStringEntry.CreateAfter(aString: string; +constructor TBoldThreadSafeQueueStringEntry.CreateAfter(const aString: string; Entry: TBoldThreadSafeQueueEntry); begin inherited CreateAfter(Entry); @@ -391,7 +406,7 @@ function TBoldThreadSafeStringQueue.Dequeue: string; end; end; -procedure TBoldThreadSafeStringQueue.Enqueue(aString: string); +procedure TBoldThreadSafeStringQueue.Enqueue(const aString: string); var WasEmpty: Boolean; begin @@ -407,6 +422,29 @@ procedure TBoldThreadSafeStringQueue.Enqueue(aString: string); end; end; +procedure TBoldThreadSafeStringQueue.EnqueueList(aList: TStrings); +var + WasEmpty: Boolean; + i: integer; + s: string; +begin + if (aList.Count = 0) then exit; + Lock; + try + WasEmpty := UnsafeIsEmpty; + for I := 0 to aList.Count - 1 do + begin + s := aList[i]; + assert(s <> ''); + TBoldThreadSafeQueueStringEntry.CreateAfter(s, fMarker); + end; + if (WasEmpty) then + NotifyQueueNotEmpty; + finally + Unlock; + end; +end; + { TBoldThreadSafeInterfaceQueue } function TBoldThreadSafeInterfaceQueue.Dequeue: IInterface; @@ -429,7 +467,7 @@ function TBoldThreadSafeInterfaceQueue.Dequeue: IInterface; end; end; -procedure TBoldThreadSafeInterfaceQueue.Enqueue(anInterface: IInterface); +procedure TBoldThreadSafeInterfaceQueue.Enqueue(const anInterface: IInterface); var WasEmpty: Boolean; begin @@ -443,7 +481,7 @@ procedure TBoldThreadSafeInterfaceQueue.Enqueue(anInterface: IInterface); finally Unlock; end; -end; +end; { TBoldThreadSafeQueueInterfaceEntry } @@ -454,4 +492,6 @@ constructor TBoldThreadSafeQueueInterfaceEntry.CreateAfter( fanInterface := anInterface; end; +initialization + end. diff --git a/Source/Common/Environment/BoldEnvironment.pas b/Source/Common/Environment/BoldEnvironment.pas index ffd7abc9..cef86a6a 100644 --- a/Source/Common/Environment/BoldEnvironment.pas +++ b/Source/Common/Environment/BoldEnvironment.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldEnvironment; interface @@ -31,10 +34,9 @@ TBoldEnvironmentConfiguration = class fApplicationSubscriber: TBoldApplicationSubscriber; fQueueFinalized: Boolean; procedure FinalizeQueue; -// this procedure should be called _ApplicationDestroyed - procedure DeactivateQueue; + procedure _ApplicationDestroyed; - function GetRunningInIDE: Boolean; + class function GetRunningInIDE: Boolean; protected function GetQueue: TBoldQueue; function GetQueueClass: TBoldQueueClass; virtual; @@ -42,6 +44,7 @@ TBoldEnvironmentConfiguration = class function GetName: string; virtual; abstract; function GetRootComponent: TComponent; virtual; public + procedure AfterConstruction; override; destructor Destroy; override; procedure HandleDesigntimeException(Sender: TObject); virtual; procedure UpdateDesigner(Sender: TObject); virtual; @@ -62,7 +65,7 @@ TBoldEnvironmentConfiguration = class TBoldFreestandingEnvironmentConfiguration = class(TBoldEnvironmentConfiguration) protected function GetName: string; override; - public + public procedure BringToFront; override; procedure FocusMainForm; override; end; @@ -79,20 +82,23 @@ TBoldFreestandingEnvironmentConfiguration = class(TBoldEnvironmentConfiguratio function BoldEffectiveEnvironment: TBoldEnvironmentConfiguration; function BoldEnvironmentsFinalized: Boolean; + function BoldInstalledQueue: TBoldQueue; {$IFDEF BOLD_INLINE} inline; {$ENDIF} implementation uses SysUtils, - BoldEnvironmentVCL; //Temporary fix + BoldEnvironmentVCL, // Don't remove this! + BoldRev; const UnsupportedFunction = '%s: function unsupported in environment configuration %s'; var G_EnvironmentsFinalized: Boolean = false; + G_BoldEffectiveEnvironment: TBoldEnvironmentConfiguration; -function BoldEffectiveEnvironment: TBoldEnvironmentConfiguration; +function GetBoldEffectiveEnvironment: TBoldEnvironmentConfiguration; begin if Assigned(BoldInternalCustomConfiguration) then Result := BoldInternalCustomConfiguration @@ -109,6 +115,21 @@ function BoldEffectiveEnvironment: TBoldEnvironmentConfiguration; raise EBoldInternal.Create('BoldEffectiveEnvironment, no environment available. Unit BoldEnvironment either not initialized, or already finalized'); end; +function BoldEffectiveEnvironment: TBoldEnvironmentConfiguration; +begin + if not Assigned(G_BoldEffectiveEnvironment) then + G_BoldEffectiveEnvironment := GetBoldEffectiveEnvironment; + result := G_BoldEffectiveEnvironment; +end; + +function BoldInstalledQueue: TBoldQueue; +begin + if BoldEnvironmentsFinalized then + result := nil + else + result := BoldEffectiveEnvironment.Queue; +end; + function BoldEnvironmentsFinalized: Boolean; begin result := G_EnvironmentsFinalized; @@ -116,6 +137,12 @@ function BoldEnvironmentsFinalized: Boolean; { TBoldEnvironmentConfiguration } +procedure TBoldEnvironmentConfiguration.AfterConstruction; +begin + inherited; + G_BoldEffectiveEnvironment := nil; +end; + function TBoldEnvironmentConfiguration.AskUser(const Text: string): Boolean; begin raise EBoldInternal.CreateFmt(UnsupportedFunction, ['AskUser', Name]); @@ -147,7 +174,7 @@ procedure TBoldEnvironmentConfiguration.ProcessMessages; raise EBoldInternal.CreateFmt(UnsupportedFunction, ['ProcessMessages', Name]) end; -function TBoldEnvironmentConfiguration.GetRunningInIDE: Boolean; +class function TBoldEnvironmentConfiguration.GetRunningInIDE: Boolean; begin Result := BoldInternalRunningInIDE; end; @@ -168,14 +195,13 @@ function TBoldEnvironmentConfiguration.GetQueue: TBoldQueue; begin fQueue := GetQueueClass.Create; fApplicationSubscriber := TBoldApplicationSubscriber.Create(RootComponent); - fApplicationSubscriber.OnApplicationDestroyed := DeactivateQueue; + fApplicationSubscriber.OnApplicationDestroyed := _ApplicationDestroyed; end; Result := fQueue; end; procedure TBoldEnvironmentConfiguration.FinalizeQueue; begin - //NOTE: Cannot use FreeAndNil, as it does things in the wrong order. if Assigned(fQueue) then begin fQueue.Free; @@ -198,6 +224,7 @@ destructor TBoldEnvironmentConfiguration.Destroy; begin if not QueueFinalized then FinalizeQueue; + G_BoldEffectiveEnvironment := nil; inherited; end; @@ -216,8 +243,7 @@ procedure TBoldEnvironmentConfiguration.TriggerQueueMechanism; raise EBoldInternal.CreateFmt(UnsupportedFunction, ['TriggerQueueMechanism', Name]); end; -// this procedure should be called _ApplicationDestroyed -procedure TBoldEnvironmentConfiguration.DeactivateQueue; +procedure TBoldEnvironmentConfiguration._ApplicationDestroyed; begin fApplicationSubscriber := nil; if assigned(fQueue) and not QueueFinalized then @@ -228,19 +254,17 @@ procedure TBoldEnvironmentConfiguration.DeactivateQueue; procedure TBoldFreestandingEnvironmentConfiguration.BringToFront; begin - // Don't call inherited - // Ignore silently + end; procedure TBoldFreestandingEnvironmentConfiguration.FocusMainForm; begin - // Don't call inherited - // Ignore silently + end; function TBoldFreestandingEnvironmentConfiguration.GetName: string; begin - Result := 'Freestanding'; // do not localize + Result := 'Freestanding'; end; { TBoldApplicationSubscriber } @@ -263,6 +287,7 @@ finalization FreeAndNil(BoldInternalCLXConfiguration); FreeAndNil(BoldInternalCustomConfiguration); FreeAndNil(BoldInternalFreestandingConfiguration); + G_BoldEffectiveEnvironment := nil; G_EnvironmentsFinalized := true; end. diff --git a/Source/Common/Environment/BoldEnvironmentAllowBothUseCLX.pas b/Source/Common/Environment/BoldEnvironmentAllowBothUseCLX.pas index 272c2e4e..28443d2b 100644 --- a/Source/Common/Environment/BoldEnvironmentAllowBothUseCLX.pas +++ b/Source/Common/Environment/BoldEnvironmentAllowBothUseCLX.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldEnvironmentAllowBothUseCLX; interface @@ -12,4 +15,3 @@ implementation initialization BoldInternalAllowBothUseCLX := true; end. - diff --git a/Source/Common/Environment/BoldEnvironmentAllowBothUseVCL.pas b/Source/Common/Environment/BoldEnvironmentAllowBothUseVCL.pas index 998a2f06..1ddfd3f3 100644 --- a/Source/Common/Environment/BoldEnvironmentAllowBothUseVCL.pas +++ b/Source/Common/Environment/BoldEnvironmentAllowBothUseVCL.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldEnvironmentAllowBothUseVCL; interface @@ -12,4 +15,3 @@ implementation initialization BoldInternalAllowBothUseVCL := true; end. - diff --git a/Source/Common/Environment/BoldEnvironmentCLX.pas b/Source/Common/Environment/BoldEnvironmentCLX.pas index 77b16dbb..12548050 100644 --- a/Source/Common/Environment/BoldEnvironmentCLX.pas +++ b/Source/Common/Environment/BoldEnvironmentCLX.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldEnvironmentCLX; interface @@ -14,14 +17,14 @@ implementation QExtCtrls, BoldEnvironment, BoldQueue, - BoldCommonConst; + BoldRev; type TBoldCLXEnvironmentConfiguration = class(TBoldEnvironmentConfiguration) protected function GetName: string; override; function GetRootComponent: TComponent; override; - function GetQueueClass: TBoldQueueClass; override; + function GetQueueClass: TBoldQueueClass; override; public procedure HandleDesigntimeException(Sender: TObject); override; procedure UpdateDesigner(Sender: TObject);override; @@ -32,8 +35,6 @@ TBoldCLXEnvironmentConfiguration = class(TBoldEnvironmentConfiguration) procedure FocusMainForm; override; end; - // Use the fact the a timer with 0 time will be placed last in queue - // This was communicated by Chuck J, does not seem to be documented, but is used in QForms.Application TBoldTimerQueue = class(TBoldQueue) private @@ -53,26 +54,23 @@ TBoldTimerQueue = class(TBoldQueue) function TBoldCLXEnvironmentConfiguration.AskUser(const Text: string): Boolean; begin - // Don't call inherited Result := MessageDlg(Text, mtWarning, [mbYes, mbNo], 0) = mrYes; end; procedure TBoldCLXEnvironmentConfiguration.BringToFront; begin - // Don't call inherited Application.BringToFront end; procedure TBoldCLXEnvironmentConfiguration.FocusMainForm; begin - // Don't call inherited if Assigned(Application) and Assigned(Application.MainForm) then Application.MainForm.SetFocus; end; function TBoldCLXEnvironmentConfiguration.GetName: string; begin - Result := 'CLX'; // do not localize + Result := 'CLX'; end; function TBoldCLXEnvironmentConfiguration.GetQueueClass: TBoldQueueClass; @@ -82,27 +80,23 @@ function TBoldCLXEnvironmentConfiguration.GetQueueClass: TBoldQueueClass; function TBoldCLXEnvironmentConfiguration.GetRootComponent: TComponent; begin - // Don't call inherited Result := Application; end; procedure TBoldCLXEnvironmentConfiguration.HandleDesigntimeException( Sender: TObject); begin - // Don't call inherited Application.HandleException(Sender); end; function TBoldCLXEnvironmentConfiguration.IsFormOrDataModule( Sender: TObject): Boolean; begin - // Don't call inherited Result := (Sender is TForm) or (Sender is TDataModule); end; procedure TBoldCLXEnvironmentConfiguration.ProcessMessages; begin - // Don't call inherited; Application.ProcessMessages; end; @@ -112,8 +106,7 @@ procedure TBoldCLXEnvironmentConfiguration.UpdateDesigner(Sender: TObject); Owner: TComponent; begin if not RunningInIDE then - raise EBold.CreateFmt(sNotRunningInIDE, ['UpdateDesigner']); // do not localize - // Don't call inherited + raise EBold.CreateFmt('%s: Not running in IDE', ['UpdateDesigner']); ParentForm := nil; Owner := nil; if (Sender is TControl) then @@ -125,13 +118,10 @@ procedure TBoldCLXEnvironmentConfiguration.UpdateDesigner(Sender: TObject); if Assigned(Owner) then begin if (Owner is TCustomFrame) then - // this happens if the model resides in a frame ParentForm := GetParentForm(TCustomFrame(Owner)) else if (Owner is TCustomForm) then - // this happens if the model resides on a form ParentForm := TCustomForm(Owner) else if (Owner is TDataModule) and Assigned(Owner.Owner) and (Owner.Owner is TCustomForm) then - // this happens if the component resides on a Datamodule, the owner.owner is a TDatamoduleDesigner... ParentForm := TCustomForm(Owner.Owner); end; end; @@ -158,7 +148,7 @@ function TBoldTimerQueue.GetIdleTimer: TTimer; if not Assigned(fIdleTimer) then begin fIdleTimer := TTimer.Create(nil); - fIdleTimer.Interval := MaxInt; + fIdleTimer.Interval := MaxInt; fIdleTimer.OnTimer := IdleTimerEvent; end; Result := fIdleTimer; @@ -176,7 +166,7 @@ procedure TBoldTimerQueue.IdleTimerEvent(Sender: TObject); dmDisplayOne: Done := not DisplayOne; dmDisplayAll: Done := not DisplayAll; else - raise EBoldInternal.CreateFmt(sUnknownDisplayMode, [classname]); + raise EBoldInternal.CreateFmt('%s.ApplicationEventsOnIdle: Unknown displaymode', [classname]); end; end; except @@ -190,18 +180,16 @@ procedure TBoldTimerQueue.IdleTimerEvent(Sender: TObject); procedure TBoldTimerQueue.ActivateDisplayQueue; begin - // Don't call inherited, abstract in parent fBoldQueueActive := true; IdleTimer.Interval := 0; end; procedure TBoldTimerQueue.DeActivateDisplayQueue; begin - // Don't call inherited, abstract in parent fBoldQueueActive := false; IdleTimer.Interval := MaxInt; end; initialization - BoldInternalCLXConfiguration := TBoldCLXEnvironmentConfiguration.Create; // Freed in finalization of BoldEnvironment + BoldInternalCLXConfiguration := TBoldCLXEnvironmentConfiguration.Create; end. diff --git a/Source/Common/Environment/BoldEnvironmentIDE.pas b/Source/Common/Environment/BoldEnvironmentIDE.pas index 35445be0..c99ccc5e 100644 --- a/Source/Common/Environment/BoldEnvironmentIDE.pas +++ b/Source/Common/Environment/BoldEnvironmentIDE.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldEnvironmentIDE; interface @@ -5,10 +8,14 @@ interface implementation uses + {$IFDEF BOLD_IDEVCL} BoldEnvironmentVCL, + {$ENDIF} + {$IFDEF BOLD_IDECLX} + BoldEnvironmentCLX, + {$ENDIF} BoldEnvironment; initialization BoldInternalRunningInIDE := true; end. - diff --git a/Source/Common/Environment/BoldEnvironmentVCL.pas b/Source/Common/Environment/BoldEnvironmentVCL.pas index 84eda90e..5463920f 100644 --- a/Source/Common/Environment/BoldEnvironmentVCL.pas +++ b/Source/Common/Environment/BoldEnvironmentVCL.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldEnvironmentVCL; interface @@ -16,7 +19,7 @@ implementation Forms, BoldQueue, BoldEnvironment, - BoldCommonConst; + BoldRev; type { forward declarations } @@ -57,26 +60,23 @@ TBoldVCLEnvironmentConfiguration = class(TBoldEnvironmentConfiguration) function TBoldVCLEnvironmentConfiguration.AskUser(const Text: string): Boolean; begin - // Don't call inherited Result := MessageDlg(Text, mtWarning, [mbYes, mbNo], 0) = mrYes; end; procedure TBoldVCLEnvironmentConfiguration.BringToFront; begin - // Don't call inherited Application.BringToFront end; procedure TBoldVCLEnvironmentConfiguration.FocusMainForm; begin - // Don't call inherited if Assigned(Application) and Assigned(Application.MainForm) then Application.MainForm.SetFocus; end; function TBoldVCLEnvironmentConfiguration.GetName: string; begin - Result := 'VCL'; // do not localize + Result := 'VCL'; end; function TBoldVCLEnvironmentConfiguration.GetQueueClass: TBoldQueueClass; @@ -86,33 +86,28 @@ function TBoldVCLEnvironmentConfiguration.GetQueueClass: TBoldQueueClass; function TBoldVCLEnvironmentConfiguration.GetRootComponent: TComponent; begin - // Don't call inherited Result := Application; end; procedure TBoldVCLEnvironmentConfiguration.HandleDesigntimeException(Sender: TObject); begin - // Don't call inherited Application.HandleException(Sender); end; function TBoldVCLEnvironmentConfiguration.IsFormOrDataModule(Sender: TObject): Boolean; begin - // Don't call inherited Result := (Sender is TForm) or (Sender is TDataModule); end; procedure TBoldVCLEnvironmentConfiguration.ProcessMessages; begin - // Don't call inherited; Application.ProcessMessages; end; procedure TBoldVCLEnvironmentConfiguration.TriggerQueueMechanism; begin - // is there a better message to send to get the applicaiton to exit the idlestate? - // perhaps a timer? - // remember that it might be called from another thread... + + PostMessage(Application.Handle, WM_PAINT, 0, 0); end; @@ -121,9 +116,8 @@ procedure TBoldVCLEnvironmentConfiguration.UpdateDesigner(Sender: TObject); ParentForm: TCustomForm; Owner: TComponent; begin - // Don't call inherited if not RunningInIDE then - raise EBold.CreateFmt(sNotRunningInIDE, ['UpdateDesigner']); // do not localize + raise EBold.CreateFmt('%s: Not running in IDE', ['UpdateDesigner']); ParentForm := nil; Owner := nil; if (Sender is TControl) then @@ -135,13 +129,10 @@ procedure TBoldVCLEnvironmentConfiguration.UpdateDesigner(Sender: TObject); if Assigned(Owner) then begin if (Owner is TCustomFrame) then - // this happens if the model resides in a frame ParentForm := GetParentForm(TCustomFrame(Owner)) else if (Owner is TCustomForm) then - // this happens if the model resides on a form ParentForm := TCustomForm(Owner) else if (Owner is TDataModule) and Assigned(Owner.Owner) and (Owner.Owner is TCustomForm) then - // this happens if the component resides on a Datamodule, the owner.owner is a TDatamoduleDesigner... ParentForm := TCustomForm(Owner.Owner); end; end; @@ -153,7 +144,6 @@ procedure TBoldVCLEnvironmentConfiguration.UpdateDesigner(Sender: TObject); procedure TBoldAppEventQueue.ActivateDisplayQueue; begin - // Don't call inherited, abstract in parent fBoldQueueActive := true; AppEvents.OnIdle := ApplicationEventsOnIdle; end; @@ -168,17 +158,19 @@ procedure TBoldAppEventQueue.ApplicationEventsOnIdle(Sender: TObject; var Done: dmDisplayOne: Done := not DisplayOne; dmDisplayAll: Done := not DisplayAll; else - raise EBoldInternal.CreateFmt(sUnknownDisplayMode, [classname]); + raise EBoldInternal.CreateFmt('%s.ApplicationEventsOnIdle: Unknown displaymode', [classname]); end; + if Done then + PerformPostDisplayQueue; end; except Application.HandleException(nil); end; + end; procedure TBoldAppEventQueue.DeActivateDisplayQueue; begin - // Don't call inherited, abstract in parent fBoldQueueActive := false; AppEvents.OnIdle := nil; end; diff --git a/Source/Common/HTTP/BoldDataBlock.pas b/Source/Common/HTTP/BoldDataBlock.pas index 747b9a76..2cff1d32 100644 --- a/Source/Common/HTTP/BoldDataBlock.pas +++ b/Source/Common/HTTP/BoldDataBlock.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDataBlock; interface @@ -38,7 +41,8 @@ TBoldDataBlock = class(TBoldMemoryManagedObject) implementation uses - SysUtils; + SysUtils, + BoldRev; { TBoldDataBlock} @@ -96,4 +100,6 @@ function TBoldDataBlock.GetMemory: Pointer; Result := FStream.Memory; end; +initialization + end. diff --git a/Source/Common/HTTP/BoldWebConnection.pas b/Source/Common/HTTP/BoldWebConnection.pas index a80ac4aa..7b06ad3b 100644 --- a/Source/Common/HTTP/BoldWebConnection.pas +++ b/Source/Common/HTTP/BoldWebConnection.pas @@ -1,7 +1,9 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWebConnection; interface - uses BoldWinInet, Classes, @@ -12,9 +14,11 @@ interface SDefaultURL = 'http://server.company.com/scripts/httpsrvr.dll'; type + {forward declarations} TBoldWebConnection = class; + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldWebConnection = class(TComponent) private FUserName: string; @@ -69,7 +73,7 @@ procedure TBoldWebConnection.Check(Error: Boolean); if Error and (ErrCode <> 0) then begin SetLength(S, 256); - FormatMessage(FORMAT_MESSAGE_FROM_HMODULE, Pointer(GetModuleHandle('wininet.dll')), // do not localize + FormatMessage(FORMAT_MESSAGE_FROM_HMODULE, Pointer(GetModuleHandle('wininet.dll')), ErrCode, 0, PChar(S), Length(S), nil); SetLength(S, StrLen(PChar(S))); while (Length(S) > 0) and (S[Length(S)] in [#10, #13]) do @@ -83,7 +87,7 @@ constructor TBoldWebConnection.Create(AOwner: TComponent); inherited Create(AOwner); FInetRoot := nil; FInetConnect := nil; - FAgent := 'Bold Application'; // do not localize + FAgent := 'Bold Application'; URL := SDefaultURL; end; @@ -107,7 +111,7 @@ function TBoldWebConnection.Receive(WaitForInput: Boolean; Context: Integer): TB if BoldHttpQueryInfo(Pointer(Context), BOLD_HTTP_QUERY_STATUS_TEXT, @S[1], Size, Index) then begin SetLength(S, Size); - raise Exception.CreateFmt('%s (%d)', [S, Status]); // do not localize + raise Exception.CreateFmt('%s (%d)', [S, Status]); end; end; Result := TBoldDataBlock.Create; @@ -121,10 +125,8 @@ function TBoldWebConnection.Receive(WaitForInput: Boolean; Context: Integer): TB end; until Size = 0; - // If we want to compare the size of the result with the expected size, we must call httpQueryInfo with the - // flag HTTP_QUERY_CONTENT_LENGTH -// if Assigned(Result) and (Len <> DWord(Result.Size)) then -// raise EBold.Create(SInvalidDataPacket); + + end; function TBoldWebConnection.Send(const Data: TBoldDataBlock): Integer; @@ -135,13 +137,13 @@ function TBoldWebConnection.Send(const Data: TBoldDataBlock): Integer; AcceptTypes: PChararr; begin SetLength(AcceptTypes, 2); - AcceptTypes[0] := PChar('application/octet-stream'); // do not localize + AcceptTypes[0] := PChar('application/octet-stream'); AcceptTypes[1] := nil; Flags := BOLD_INTERNET_FLAG_KEEP_CONNECTION or BOLD_INTERNET_FLAG_NO_CACHE_WRITE; if FURLScheme = BOLD_INTERNET_SCHEME_HTTPS then Flags := Flags or BOLD_INTERNET_FLAG_SECURE; SetConnected(True); - Request := BoldHttpOpenRequest(FInetConnect, 'POST', FURLSite, '', '', AcceptTypes, Flags, Integer(Self)); // do not localize + Request := BoldHttpOpenRequest(FInetConnect, 'POST', FURLSite, '', '', AcceptTypes, Flags, Integer(Self)); Check(not Assigned(Request)); while True do begin @@ -227,4 +229,6 @@ procedure TBoldWebConnection.SetURL(const Value: string); end; end; +initialization + end. diff --git a/Source/Common/Handles/BoldHandle.pas b/Source/Common/Handles/BoldHandle.pas index 5bea5d3a..8e7e6d76 100644 --- a/Source/Common/Handles/BoldHandle.pas +++ b/Source/Common/Handles/BoldHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldHandle; interface diff --git a/Source/Common/IDE/BoldAbout.dfm b/Source/Common/IDE/BoldAbout.dfm index 6e9bf1a2..33ccef25 100644 --- a/Source/Common/IDE/BoldAbout.dfm +++ b/Source/Common/IDE/BoldAbout.dfm @@ -28,10 +28,6 @@ object frmAboutBold: TfrmAboutBold TabOrder = 0 object TabAbout: TTabSheet Caption = 'About' - ExplicitLeft = 0 - ExplicitTop = 0 - ExplicitWidth = 0 - ExplicitHeight = 0 object BtnUnlock: TSpeedButton Left = 4 Top = 4 @@ -837,10 +833,6 @@ object frmAboutBold: TfrmAboutBold end object tsTeam: TTabSheet Caption = 'Team' - ExplicitLeft = 0 - ExplicitTop = 0 - ExplicitWidth = 0 - ExplicitHeight = 0 object Label9: TLabel Left = 148 Top = 8 @@ -1157,7 +1149,7 @@ object frmAboutBold: TfrmAboutBold Left = 68 Top = 392 Bitmap = { - 494C010101000400080010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 + 494C010101000400040010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 0000000000003600000028000000400000001000000001002000000000000010 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 @@ -1300,7 +1292,7 @@ object frmAboutBold: TfrmAboutBold Left = 320 Top = 146 Bitmap = { - 494C010106000900080010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 + 494C010106000900040010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 0000000000003600000028000000400000002000000001002000000000000020 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 diff --git a/Source/Common/IDE/BoldAbstractPropertyEditors.pas b/Source/Common/IDE/BoldAbstractPropertyEditors.pas index 7a0dfc09..39cef2e3 100644 --- a/Source/Common/IDE/BoldAbstractPropertyEditors.pas +++ b/Source/Common/IDE/BoldAbstractPropertyEditors.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAbstractPropertyEditors; interface @@ -5,8 +8,7 @@ interface uses Windows, Graphics, - DesignEditors, - EditIntf; + DesignEditors; type { forward declarations } @@ -89,10 +91,14 @@ TBoldComponentPropertyIndicateMissing = class(TBoldComponentProperty) { Source code altering property editors } { TModifyingMethodProperty } TModifyingMethodProperty = class(TBoldMethodProperty) + protected + procedure InsertText(const s: string); virtual; public procedure Edit; override; - procedure InsertText(const s: string); virtual; - function TextToInsert: string; virtual; + procedure InsertVariables; virtual; + procedure InsertImplementation; virtual; + function ImplementationTextToInsert: string; virtual; + function VariableDefinitionTextToInsert: string; virtual; procedure ReposCursor(DeltaLines, ColPos: integer); function GetDeltaLines: integer; virtual; function GetColPos: integer; virtual; @@ -137,7 +143,8 @@ procedure TModifyingMethodProperty.Edit; inherited; if NewMethod and ConfirmAdd then begin - InsertText(TextToInsert); + InsertVariables; + InsertImplementation; ReposCursor(DeltaLines, ColPos); end; end; @@ -147,7 +154,12 @@ function TModifyingMethodProperty.ConfirmAdd: boolean; Result := True; end; -function TModifyingMethodProperty.TextToInsert: string; +function TModifyingMethodProperty.VariableDefinitionTextToInsert: string; +begin + result := ''; +end; + +function TModifyingMethodProperty.ImplementationTextToInsert: string; begin Result := ''; end; @@ -156,6 +168,24 @@ procedure TModifyingMethodProperty.InsertText(const s: string); begin end; +procedure TModifyingMethodProperty.InsertVariables; +var + s: string; +begin + s := VariableDefinitionTextToInsert; + if s = '' then + exit; + ReposCursor(-1, 0); + InsertText(s); + ReposCursor(2, 0); +end; + +procedure TModifyingMethodProperty.InsertImplementation; +begin +// ReposCursor(-1, 0); + InsertText(ImplementationTextToInsert); +end; + procedure TModifyingMethodProperty.ReposCursor(DeltaLines, ColPos: integer); var ColDelta: integer; @@ -194,14 +224,14 @@ procedure TBoldOTAModifyingMethodProperty.InsertText(const s: string); EditPos: TOTAEditpos; CharPos: TOTACharpos; begin - if Supports(BorlandIDEServices, IOTAEditorServices, EditorServices) then + if (s <> '') and Supports(BorlandIDEServices, IOTAEditorServices, EditorServices) then begin EditPos := EditorServices.TopBuffer.TopView.CursorPos; EditorServices.TopBuffer.TopView.ConvertPos(True, EditPos, CharPos); CurPos := EditorServices.TopBuffer.TopView.CharPosToPos(CharPos); Writer := EditorServices.TopBuffer.CreateUndoableWriter; Writer.CopyTo(CurPos); - Writer.Insert(PAnsiChar(s)); // marco to be fixed + Writer.Insert(PAnsiChar({$IFDEF BOLD_UNICODE}AnsiString{$ENDIF}(s))); end; end; @@ -238,7 +268,7 @@ function TBoldOneLinerWithEvalMethodProperty.GetDeltaLines: integer; function TBoldOneLinerWithEvalMethodProperty.GetColPos: integer; begin - Result := Pos(BOLDSYM_QUOTECHAR, TextToInsert)+1; + Result := Pos(BOLDSYM_QUOTECHAR, ImplementationTextToInsert)+1; end; { TBoldStringProperty } diff --git a/Source/Common/IDE/BoldDefsDT.pas b/Source/Common/IDE/BoldDefsDT.pas index fb067601..fd613636 100644 --- a/Source/Common/IDE/BoldDefsDT.pas +++ b/Source/Common/IDE/BoldDefsDT.pas @@ -1,21 +1,27 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDefsDT; interface - uses - BoldDefs; // BOLDCRLF for BCB + BoldDefs; const - HelpFile = 'bold90.hlp'; +{$IFDEF BOLD_DELPHI6} + HelpFile = 'boldd6.hlp'; +{$ENDIF} +{$IFDEF BOLD_DELPHI7} + HelpFile = 'boldd7.hlp'; +{$ENDIF} ATTRIBUTEWIZARDHELPFILE = 'boldattributewizard.hlp'; MODELEDITORHELPFILE = 'boldmodeleditor.hlp'; - URLBoldSoft = 'http://www.borland.com'; - URLBoldForDelphi = 'http://www.borland.com'; - URLSupport = 'http://www.borland.com'; + URLBoldForDelphi = 'http://www.boldfordelphi.com'; + URLSupport = 'http://www.forum.boldfordelphi.com'; - GETTINGSTARTEDPATH = '\doc\frames\'; //NOTE: Must end with backslash! + GETTINGSTARTEDPATH = '\doc\frames\'; GETTINGSTARTEDDOCNAME = 'getting_started_f.html'; regPath = 'Path'; @@ -56,4 +62,7 @@ interface implementation + +initialization + end. diff --git a/Source/Common/IDE/BoldExpert.pas b/Source/Common/IDE/BoldExpert.pas index b11bf6f1..bb99d68d 100644 --- a/Source/Common/IDE/BoldExpert.pas +++ b/Source/Common/IDE/BoldExpert.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldExpert; interface @@ -15,7 +18,7 @@ TBoldExpertClass = class of TBoldExpert; TBoldExpert = class(TInterfacedObject, IOTANotifier, IOTAWizard) public constructor Create; virtual; - procedure ExecuteEvent(Sender: TObject); //TNotifyEvent compatible. Calls Execute. + procedure ExecuteEvent(Sender: TObject); {IOTANotifier} procedure AfterSave; virtual; procedure BeforeSave; virtual; @@ -37,33 +40,31 @@ TBoldExpert = class(TInterfacedObject, IOTANotifier, IOTAWizard) implementation -{.$R *.res} +uses + BoldRev; + +{$R *.res} { TBoldExpert } procedure TBoldExpert.AfterSave; begin - // Required for interface end; procedure TBoldExpert.BeforeSave; begin - // Required for interface end; constructor TBoldExpert.Create; begin - // To avoid abstract constructor. end; procedure TBoldExpert.Destroyed; begin - // Required for interface end; procedure TBoldExpert.Execute; begin - // Required for interface end; procedure TBoldExpert.ExecuteEvent(Sender: TObject); @@ -73,7 +74,7 @@ procedure TBoldExpert.ExecuteEvent(Sender: TObject); function TBoldExpert.GetAuthor: string; begin - Result := 'BoldSoft'; // do not localize + Result := 'BoldSoft'; end; function TBoldExpert.GetComment: string; @@ -83,12 +84,12 @@ function TBoldExpert.GetComment: string; function TBoldExpert.GetGlyph: HICON; begin - Result := LoadIcon(FindClassHInstance(ClassType), 'BOLDEXPERT'); // do not localize + Result := LoadIcon(FindClassHInstance(ClassType), 'BOLDEXPERT'); end; function TBoldExpert.GetIDString: string; begin - Result := 'BoldSoft.' + GetName; // do not localize + Result := 'BoldSoft.' + GetName; end; function TBoldExpert.GetMenuText: string; @@ -103,7 +104,7 @@ function TBoldExpert.GetName: string; function TBoldExpert.GetPage: string; begin - Result := 'Bold'; // do not localize + Result := 'Bold'; end; function TBoldExpert.GetState: TWizardState; @@ -113,7 +114,8 @@ function TBoldExpert.GetState: TWizardState; procedure TBoldExpert.Modified; begin - // Required for interface end; +initialization + end. diff --git a/Source/Common/IDE/BoldExpertMenus.pas b/Source/Common/IDE/BoldExpertMenus.pas index 96c8e4c8..86e97442 100644 --- a/Source/Common/IDE/BoldExpertMenus.pas +++ b/Source/Common/IDE/BoldExpertMenus.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldExpertMenus; interface @@ -18,6 +21,9 @@ TdmExpertMenus = class(TDataModule) implementation + {$R *.DFM} +initialization + end. diff --git a/Source/Common/IDE/BoldGettingStartedExpert.pas b/Source/Common/IDE/BoldGettingStartedExpert.pas index b8902606..fedfb6d9 100644 --- a/Source/Common/IDE/BoldGettingStartedExpert.pas +++ b/Source/Common/IDE/BoldGettingStartedExpert.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldGettingStartedExpert; interface @@ -24,7 +27,7 @@ TBoldGettingStartedExpert = class(TSimpleMenuWizard) function getURLGettingStarted: string; function DoShowGettingStarted: Boolean; procedure OnTimer(Sender: TObject); - property URLGettingStarted: string read getURLGettingStarted; + property URLGettingStarted: string read getURLGettingStarted; protected procedure Initialize; override; public @@ -54,26 +57,22 @@ implementation Toolsapi, ShellAPI, windows, - dialogs, - BoldCommonConst; + dialogs; procedure Register; begin -{$MESSAGE HINT 'Wizard turned off'} -(* RegisterPackageWizard(GettingStartedExpert); -*) end; procedure InitExpert; begin try dmMenus := TDMExpertMenus.Create(nil); - BoldMenuExpert; //ensure "Bold" menu has been created - GettingStartedExpert := TBoldGettingStartedExpert.Create('BoldGettingStartedExpert', sGettingStarted, [], 5, 'Bold'); // do not localize + BoldMenuExpert; + GettingStartedExpert := TBoldGettingStartedExpert.Create('BoldGettingStartedExpert', 'Getting Started', [], 5, 'Bold'); GettingStartedExpert.AddMenuItem(dmMenus.GettingStartedMenu); except on E: Exception do - showmessage(Format('InitExpert: ', [E.Message])); // do not localize + showmessage(Format('InitExpert: ', [E.Message])); end; end; @@ -116,7 +115,7 @@ procedure TBoldGettingStartedExpert.SetRegistryValue(const Show: Boolean); try BoldRegistry.RegistryMode := rmDesignTime; BoldRegistry.OpenKey(BoldGettingStartedRegKey); - BoldRegistry.WriteBool('Show', Show); // do not localize + BoldRegistry.WriteBool('Show', Show); BoldRegistry.CloseKey; finally FreeAndNil(BoldRegistry); @@ -131,7 +130,7 @@ function TBoldGettingStartedExpert.DoShowGettingStarted: Boolean; try BoldRegistry.RegistryMode := rmDesigntime; BoldRegistry.OpenKey(BoldGettingStartedRegKey); - Result := BoldRegistry.ReadBool('Show', True); // do not localize + Result := BoldRegistry.ReadBool('Show', True); BoldRegistry.CloseKey; finally FreeAndNil(BoldRegistry); @@ -142,10 +141,10 @@ procedure TBoldGettingStartedExpert.DisplayGettingStarted(Sender: TObject); begin if not FileExists(UrlGettingStarted) then begin - showmessage(Format(sCouldNotFindGettingStarted, [UrlGettingStarted])); + showmessage(Format('Could not find Bold for Delphi''s GettingStarted document: %s', [UrlGettingStarted])); end else - ShellExecute(0, 'open', PChar(URLGettingStarted), '', '', SW_SHOWNORMAL); // do not localize + ShellExecute(0, 'open', PChar(URLGettingStarted), '', '', SW_SHOWNORMAL); end; procedure TBoldGettingStartedExpert.OnTimer(Sender: TObject); @@ -174,14 +173,9 @@ destructor TBoldGettingStartedExpert.Destroy; inherited; end; -{$MESSAGE HINT 'Getting started expert disabled'} -(***** -// Skip the getting started expert initialization InitExpert; finalization DoneExpert; -***) - end. diff --git a/Source/Common/IDE/BoldGettingStartedForm.pas b/Source/Common/IDE/BoldGettingStartedForm.pas index 8ef665ce..cbcf0472 100644 --- a/Source/Common/IDE/BoldGettingStartedForm.pas +++ b/Source/Common/IDE/BoldGettingStartedForm.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldGettingStartedForm; interface @@ -36,6 +39,7 @@ TFGettingStarted = class(TForm) implementation + {$R *.DFM} procedure TFGettingStarted.btnShowClick(Sender: TObject); @@ -57,4 +61,6 @@ procedure TFGettingStarted.btnCloseClick(Sender: TObject); Close; end; +initialization + end. diff --git a/Source/Common/IDE/BoldIDEConsts.pas b/Source/Common/IDE/BoldIDEConsts.pas index e62f60e4..9ae92f8b 100644 --- a/Source/Common/IDE/BoldIDEConsts.pas +++ b/Source/Common/IDE/BoldIDEConsts.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldIDEConsts; interface @@ -10,12 +13,12 @@ interface BOLDPAGENAME_CONTROLS = 'Bold Controls'; BOLDPAGENAME_OLLE = 'Bold OLLE'; BOLDPAGENAME_COM = 'Bold COM'; - BOLDPAGENAME_COMHANDLES = 'Bold COM Handles'; - BOLDPAGENAME_COMCONTROLS = 'Bold COM Controls'; BOLDPAGENAME_OSS_CMS = 'Bold OSS/CMS'; BOLDACTIONGROUPNAME = 'Bold Actions'; - LIBSUFFIX = '90'; implementation + +initialization + end. diff --git a/Source/Common/IDE/BoldIDEMenus.pas b/Source/Common/IDE/BoldIDEMenus.pas index 4130c92d..a9d22424 100644 --- a/Source/Common/IDE/BoldIDEMenus.pas +++ b/Source/Common/IDE/BoldIDEMenus.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldIDEMenus; interface @@ -27,7 +30,6 @@ TBoldMenuExpert = class(TBoldExpert) {Menu Actions} procedure ActionAbout(Sender: TObject); procedure ActionHelp(Sender: TObject); - procedure ActionURLHome(Sender: TObject); procedure ActionURLBfD(Sender: TObject); {Properties} property BoldMenu: TMenuItem read fBoldMenu; @@ -41,9 +43,7 @@ implementation uses SysUtils, Forms, - BoldDefsDT, - BoldAbout, - BoldCommonConst; + BoldDefsDT; var G_BoldMenuExpert: TBoldMenuExpert = nil; @@ -67,12 +67,6 @@ function BoldMenuExpertAssigned: boolean; procedure TBoldMenuExpert.ActionAbout(Sender: TObject); begin - with BoldAbout.TfrmAboutBold.Create(nil) do - try - ShowModal; - finally - Free; - end; end; procedure TBoldMenuExpert.ActionHelp(Sender: TObject); @@ -80,22 +74,17 @@ procedure TBoldMenuExpert.ActionHelp(Sender: TObject); HelpHandle: HWND; begin //FIXME PORT ###What happened to the helpfile property? -//{ -- temproary removed during porting +{ -- temproary removed during porting HelpHandle := Application.Handle; if Application.MainForm <> nil then HelpHandle := Application.MainForm.Handle; WinHelp(HelpHandle, HelpFile, HELP_FINDER, 0); -//} +} end; procedure TBoldMenuExpert.ActionURLBfD(Sender: TObject); begin - ShellExecute(0, 'open', URLBoldForDelphi, '', '', SW_SHOWMAXIMIZED); // do not localize -end; - -procedure TBoldMenuExpert.ActionURLHome(Sender: TObject); -begin - ShellExecute(0, 'open', URLBoldSoft, '', '', SW_SHOWMAXIMIZED); // do not localize + ShellExecute(0, 'open', URLBoldForDelphi, '', '', SW_SHOWMAXIMIZED); end; function TBoldMenuExpert.AddMenuItem(aName, aCaption: string; aClickEvent: TNotifyEvent; first: Boolean = false): TMenuItem; @@ -131,20 +120,18 @@ procedure TBoldMenuExpert.CreateBaseMenuItems; {Main Bold Menu} fBoldMenu := TMenuItem.Create(fOwner); fBoldMenu.Enabled := true; - fBoldMenu.Caption := '&Bold'; // do not localize - fBoldMenu.Name := 'BoldMenu'; // do not localize + fBoldMenu.Caption := '&Bold'; + fBoldMenu.Name := 'BoldMenu'; I := 0; - while (I'ToolsMenu') do // do not localize + while (I'ToolsMenu') do Inc(I); - AddMenuItem('BoldURLDelimiterMenu', '-', nil); // do not localize - AddMenuItem('BoldHomePageMenu', sCompanyHomePage, ActionURLHome); // do not localize - AddMenuItem('BoldBfDHomePageMenu', sProductHomePage, ActionURLBfD); // do not localize - AddMenuItem('BoldHelpDelimiterMenu', '-', nil); // do not localize - AddMenuItem('BoldHelpMenu', sHelp, ActionHelp); // do not localize - AddMenuItem('BoldAboutDelimiterMenu', '-', nil); // do not localize - AddMenuItem('BoldAboutMenu', sAbout, ActionAbout); // do not localize - // in D7, the menu must have items before it is added to the main menu + AddMenuItem('BoldURLDelimiterMenu', '-', nil); + AddMenuItem('BoldBfDHomePageMenu', 'Bold for &Delphi Home Page', ActionURLBfD); + AddMenuItem('BoldHelpDelimiterMenu', '-', nil); + AddMenuItem('BoldHelpMenu', '&Help', ActionHelp); + AddMenuItem('BoldAboutDelimiterMenu', '-', nil); +// AddMenuItem('BoldAboutMenu', '&About', ActionAbout); MainMenu.Items.Insert(I, fBoldMenu); end; @@ -173,7 +160,7 @@ procedure TBoldMenuExpert.RegisterBoldExpert(aBoldExpertClass: TBoldExpertClass) MenuItem := TMenuItem.Create(fOwner); with MenuItem do begin - Name := Expert.ClassName + 'Menu'; // do not localize + Name := Expert.ClassName + 'Menu'; Caption := Expert.GetMenuText; OnClick := Expert.ExecuteEvent; end; @@ -187,4 +174,6 @@ procedure TBoldMenuExpert.RemoveAndDestroyMenuItem(var anItem: TMenuItem); anItem := nil; end; +initialization + end. diff --git a/Source/Common/IDE/BoldIDESupport.pas b/Source/Common/IDE/BoldIDESupport.pas index 043a2e0e..14ba2b63 100644 --- a/Source/Common/IDE/BoldIDESupport.pas +++ b/Source/Common/IDE/BoldIDESupport.pas @@ -1,25 +1,18 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldIDESupport; interface procedure RemovePackageFromDisabledPackagesRegistry(PackageName: String); -function IDEBaseRegistryKey: string; implementation uses + BoldDefs, Classes, - Registry, - ToolsAPI; - -function IDEBaseRegistryKey: string; -var - Service: IOTAServices; -begin - service := (BorlandIDEServices as IOTAServices); - Assert(Assigned(Service), 'Service not assigned'); - Result := Service.GetBaseRegistryKey + '\'; -end; + Registry; procedure RemovePackageFromDisabledPackagesRegistry(PackageName: String); var @@ -28,23 +21,18 @@ procedure RemovePackageFromDisabledPackagesRegistry(PackageName: String); Values: TStringList; begin RegKey := TRegistry.Create; - try - if Regkey.OpenKey(IDEBaseRegistryKey + 'Disabled Packages', false) then // do not localize - begin - Values := TStringList.Create; - try - RegKey.GetValueNames(Values); - - for i := 0 to Values.Count - 1 do - if pos(PackageName, Values[i]) <> 0 then - RegKey.DeleteValue(Values[i]); - finally - Values.Free; - end; - end; - finally - RegKey.Free; - end; + if Regkey.OpenKey(BOLD_HOST_IDE_REGISTRYPATH + 'Disabled Packages', false) then + begin + Values := TStringList.Create; + RegKey.GetValueNames(Values); + + for i := 0 to Values.Count - 1 do + if pos(PackageName, Values[i]) <> 0 then + RegKey.DeleteValue(Values[i]); + Values.Free; + end; end; +initialization + end. diff --git a/Source/Common/IDE/BoldLicenseTextForm.pas b/Source/Common/IDE/BoldLicenseTextForm.pas index b1c1f95f..b462a5a8 100644 --- a/Source/Common/IDE/BoldLicenseTextForm.pas +++ b/Source/Common/IDE/BoldLicenseTextForm.pas @@ -1,9 +1,12 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLicenseTextForm; interface uses - Windows, Classes, Controls, Forms, + Windows, Classes, Controls, Forms, BoldRegistry, Dialogs, StdCtrls, ExtCtrls; @@ -36,6 +39,7 @@ implementation SysUtils, BoldUtils; + procedure TfrmLicenseText.FormCloseQuery(Sender: TObject; var CanClose: Boolean); var Reg: TBoldRegistry; @@ -67,5 +71,4 @@ procedure TfrmLicenseText.FormClose(Sender: TObject; end; -initialization end. diff --git a/Source/Common/IDE/BoldModelAwareComponentEditor.pas b/Source/Common/IDE/BoldModelAwareComponentEditor.pas index fecf2a02..02dc19e4 100644 --- a/Source/Common/IDE/BoldModelAwareComponentEditor.pas +++ b/Source/Common/IDE/BoldModelAwareComponentEditor.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldModelAwareComponentEditor; interface @@ -29,8 +32,7 @@ implementation SysUtils, TypInfo, BoldDefs, - BoldDefsDT, - BoldCommonConst; + BoldDefsDT; const PropNames: array[0..5] of string = @@ -47,11 +49,10 @@ procedure TBoldModelAwareComponentEditor.EditModel; begin Model := FollowUplinkToModel(Component); if Assigned(Model) then - // create and show the model editor GetComponentEditor(Model, Designer).Edit else - raise EBold.CreateFmt(sNoModel, [Component.Name]); -end; + raise EBold.CreateFmt('%s does not seem to be connected to a model', [Component.Name]); +end; function TBoldModelAwareComponentEditor.GetEditModelMenuCaption: string; begin @@ -108,4 +109,6 @@ function TBoldModelAwareComponentEditor.FollowUplinkToModel( Result := nil; end; +initialization + end. diff --git a/Source/Common/IDE/BoldOTAFileHandler.pas b/Source/Common/IDE/BoldOTAFileHandler.pas index 5b2d359a..8e2ce20a 100644 --- a/Source/Common/IDE/BoldOTAFileHandler.pas +++ b/Source/Common/IDE/BoldOTAFileHandler.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOTAFileHandler; interface @@ -35,7 +38,6 @@ TBoldOTAFileHandler = class(TBoldFileHandler) function GetOTAEditWriter: IOTAEditWriter; function GetOTAModule: IOTAModule; function GetOTASourceEditor: IOTASourceEditor; - procedure SetEditorLine(Line: Integer); protected procedure LoadStringList; override; procedure DoFlushFile; override; @@ -46,6 +48,7 @@ TBoldOTAFileHandler = class(TBoldFileHandler) function FileInProject(const name: string): Boolean; function FilePathInProject(const name: string): string; function PositionToTextInEditor(const S: string): Boolean; + procedure SetEditorLine(Line: Integer); property ModuleCreator: TBoldModuleCreator read GetModuleCreator; property OTAEditReader: IOTAEditReader read GetOTAEditReader; property OTAEditWriter: IOTAEditWriter read GetOTAEditWriter; @@ -79,12 +82,12 @@ implementation SysUtils, BoldUtils, BoldLogHandler, - BoldCommonConst; + BoldRev; constructor TBoldOTAFileHandler.create(const FileName: string; ModuleType: TBoldModuleType; ShowFileInGuiIfPossible: Boolean; OnInitializeFileContents: TBoldInitializeFileContents); begin - // in OTA, strip away the path... we will find a new one later. - OTADEBUGLogFmt(sLogCreatingOTAFileHandler, [FileName]); + if OTADEBUG then + BoldLog.LogFmt('Creating an OTA filehandler for file: %s', [FileName]); inherited Create(ExtractFileName(FileName), ModuleType, ShowFileInGuiIfPossible, OnInitializeFileContents); fModuleCreator := nil; end; @@ -112,15 +115,17 @@ function TBoldOTAFileHandler.GetOTAModule: IOTAModule; result := nil; if not assigned(fOTAModule) then begin + if OTADEBUG then + BoldLog.LogFmt('Getting a module for %s', [FileName]); + fOtaModule := EnsuredModule(FileName, ModuleCreator, ModuleType = mttext, fWasOpen); if OTADEBUG then begin if fWasOpen then - BoldLog.LogFmt(sLogModuleWasOpen, [FileName]) + BoldLog.Log(FileName + ' was already open') else - BoldLog.LogFmt(sLogHadToOpenModule, [FileName]); + BoldLog.Log('had to open ' + FileName ); end; -// OTADEBUGLogFmt('Done Creating OTAModule'); end; result := fOTAModule; @@ -142,7 +147,7 @@ function TBoldOTAFileHandler.GetOTASourceEditor: IOTASourceEditor; end; if not Assigned(fOTASourceEditor) then - raise EBoldDesignTime.CreateFmt(sUnableToOpenSourceEditor, [filename]); + raise EBoldDesignTime.CreateFmt('Unable to open Source Editor for %s', [filename]); end; Result := fOTASourceEditor; @@ -157,13 +162,13 @@ procedure TBoldOTAFileHandler.SetEditorLine(Line: Integer); begin EditPos.Col := 0; EditPos.Line := Line; - SetCursorPos(EditPos); // set cursorpos + SetCursorPos(EditPos); EditPos.Col := 1; - SetTopPos(EditPos); // set viewpos + SetTopPos(EditPos); end; except on E: Exception do - Raise EBoldDesignTime.CreateFmt(sUnableToPositionCursor, [FileName, Line]); + Raise EBoldDesignTime.CreateFmt('Unable to position cursor in %s (line %d)', [FileName, Line]); end; end; @@ -171,7 +176,7 @@ procedure TBoldOTAFileHandler.LoadStringList; const ChunkSize = 30000; var - Buf: PChar; + Buf: PAnsiChar; position: integer; s: String; Size, @@ -185,7 +190,7 @@ procedure TBoldOTAFileHandler.LoadStringList; position := 0; while position < Size do begin - //marco ReadChars := OTAEditReader.GetText(position, buf + position, ChunkSize); // bug, must be less that 2**31-1 + ReadChars := OTAEditReader.GetText(position, buf + position, ChunkSize); position := position + ReadChars; end; Buf[Size] := BoldNULL; @@ -196,14 +201,8 @@ procedure TBoldOTAFileHandler.LoadStringList; finally FreeMem(Buf, Size + 1); end; - end - else - begin + end else Stringlist.Clear; - end; -// OTADEBUGLogFmt('Adding to project'); -// Doesn't work well! (BorlandIDEServices as IOTAModuleServices).GetActiveProject.AddFile(FileName, true); -// OTADEBUGLogFmt('DONE - Adding to project'); end; function TBoldOTAFileHandler.PositionToTextInEditor(const S: string): Boolean; @@ -224,13 +223,13 @@ procedure TBoldOTAFileHandler.DoFlushFile; if CheckWriteable(OTAModule.FileName) then begin OTAEditWriter.DeleteTo(GetEditorSize - 2); -//marco OTAEditWriter.Insert(PChar(StringList.Text)); + OTAEditWriter.Insert(PAnsiChar({$IFDEF BOLD_UNICODE}AnsiString{$ENDIF}(StringList.Text))); OTAModule.Save(False, True); end else begin - BoldLog.LogFmt(sModuleReadOnly, [OTAModule.FileName], ltError); - ShowMessage(SysUtils.Format(sModuleReadOnly, [OTAModule.FileName])); + BoldLog.LogFmt('%s is readonly!', [OTAModule.FileName], ltError); + ShowMessage(OTAModule.FileName + ' is readonly!'); end; end; @@ -239,23 +238,24 @@ function TBoldOTAFileHandler.GetModuleCreator: TBoldModuleCreator; if not assigned(fModuleCreator) then begin fModuleCreator := TBoldModuleCreator.Create(FileName, ModuleType, fShowInEditor); - if not FileInProject(Filename) then - OTADEBUGLogFmt('File %s not in Project... ', [Filename]); +{ if not FileInProject(Filename) then + ShowMessage('File not in Project... ' + Filename);} end; result := fModuleCreator; end; + function TBoldOTAFileHandler.GetEditorSize: Integer; const ChunkSize = 30000; var - buf: array[0..ChunkSize] of Char; + buf: array[0..ChunkSize] of AnsiChar; ReadChars: integer; begin result := 0; repeat -//marco ReadChars := OTAEditReader.GetText(Result, buf, ChunkSize); + ReadChars := OTAEditReader.GetText(Result, buf, ChunkSize); Result := Result + ReadChars; until ReadChars < ChunkSize; end; @@ -271,7 +271,7 @@ function TBoldOTAFileHandler.GetOTAEditReader: IOTAEditReader; except on e: exception do begin - BoldLog.LogFmt(sUnableToCreateReader, [e.message], ltError); + BoldLog.LogFmt('Unable to create reader: %s', [e.message], ltError); raise end; end; @@ -289,9 +289,9 @@ function TBoldOTAFileHandler.GetOTAEditWriter: IOTAEditWriter; result := fOTAEditWriter; end; -destructor TBoldOTAFileHandler.Destroy; +destructor TBoldOTAFileHandler.destroy; begin - inherited; // Need to call inherited before freeing interfaces + inherited; fOTAEditReader := nil; fOTAEditWriter := nil; fModuleCreator := nil; @@ -301,12 +301,10 @@ destructor TBoldOTAFileHandler.Destroy; procedure TBoldIOTANotifier.AfterSave; begin - // Nothing implemented here end; procedure TBoldIOTANotifier.BeforeSave; begin - // Nothing implemented here end; constructor TBoldIOTANotifier.create(fileHandler: TBoldOTAFileHandler); @@ -317,7 +315,6 @@ constructor TBoldIOTANotifier.create(fileHandler: TBoldOTAFileHandler); procedure TBoldIOTANotifier.Destroyed; begin - // Nothing implemented here end; procedure TBoldIOTANotifier.Modified; @@ -334,13 +331,11 @@ procedure TBoldIOTANotifier.Modified; procedure TBoldIOTAEditorNotifier.ViewActivated(const View: IOTAEditView); begin - // Nothing implemented here end; procedure TBoldIOTAEditorNotifier.ViewNotification( const View: IOTAEditView; Operation: TOperation); begin - // Nothing implemented here end; procedure TBoldOTAFileHandler.CloseFile; @@ -351,18 +346,21 @@ procedure TBoldOTAFileHandler.CloseFile; fOTAEditWriter := nil; fModuleCreator := nil; - OTADEBUGLogFmt('%s has %d editors', [FileNAme, FOTASourceEditor.GetEditViewCount]); // do not localize + if OTADEBUG then + BoldLog.Log(SysUtils.format('%s has %d editors', [FileNAme, FOTASourceEditor.GetEditViewCount])); fOTASourceEditor := nil; - OTADEBUGLogFmt('Closing %s', [FileName]); // do not localize + if OTADEBUG then + BoldLog.Log('Closing '+FileName); try if OTAModule.Close and OTADEBUG then - BoldLog.Log('Closed '+FileName); // do not localize + BoldLog.Log('Closed '+FileName); except on e: exception do - BoldLog.LogFmt(sFailedToCloseModule, [FileName, e.Message]); // do not localize + BoldLog.Log('Failed to Close '+FileName+': '+e.message); end; - OTADEBUGLogFmt('Done Closing %s', [FileName]); // do not localize + if OTADEBUG then + BoldLog.Log('Done Closing '+FileName); fOTAModule := nil; end; end; @@ -371,3 +369,4 @@ initialization BoldPrefferedFileHandlerClass := TBoldOTAFileHandler; end. + diff --git a/Source/Common/IDE/BoldOTASupport.pas b/Source/Common/IDE/BoldOTASupport.pas index be112267..ff94265d 100644 --- a/Source/Common/IDE/BoldOTASupport.pas +++ b/Source/Common/IDE/BoldOTASupport.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOTASupport; interface @@ -57,54 +60,36 @@ function FindFileModuleInProject(const fileName: String; Project: IOTAProject): function GetProjectPath(Project: IOTAProject): String; function GetProjectOtherPaths(Project: IOTAProject): string; function EnsuredModule(FileName: string; ModuleCreator: TBoldModuleCreator; AllowLoadFromDisk: Boolean; var WasOpen: Boolean): IOTAModule; -procedure OTADEBUGLogFmt(const s: string; args: array of const); var OTAModuleServices: IOTAModuleServices; OTAActionServices: IOTAActionServices; - {$IFDEF DEBUG} - OTADEBUG: boolean = True; - {$ELSE} OTADEBUG: boolean = False; - {$ENDIF} implementation uses - {$IFDEF DEBUG} - Dialogs, - {$ENDIF} SysUtils, IniFiles, Registry, BoldLogHandler, BoldUtils, - BoldCommonConst, - BoldIDESupport; - -procedure OTADEBUGLogFmt(const s: string; args: array of const); -begin - if OTADEBUG then - BoldLog.LogFmt(s, Args); - {$IFDEF DEBUG} - ShowMessage(Format(s, Args)); - {$ENDIF} -end; + BoldRev; function GetProjectSearchPath(Project: IOTAProject): String; var DofFileName: string; begin result := ''; - if assigned(Project) then + if assigned(project) then begin Result := ExtractFilepath(Project.FileName) + ';'; - DofFileName := ChangeFileExt(Project.FileName, '.DOF'); // do not localize + DofFileName := ChangeFileExt(project.FileName, '.DOF'); with TINIFile.Create(DofFileName) do try - Result := Result + ReadString('DIRECTORIES', 'SearchPath', ''); // do not localize + Result := Result + ReadString('DIRECTORIES', 'SearchPath', ''); finally free; end; @@ -117,8 +102,8 @@ function GetDelphiSearchPath: String; with TRegistry.Create do begin try - if OpenKey(IDEBaseRegistryKey + 'Library', False) then // do not localize - Result := ReadString('Search Path'); // do not localize + if OpenKey(BOLD_HOST_IDE_REGISTRYPATH + 'Library', False) then + Result := ReadString('Search Path'); CloseKey; finally Free; @@ -145,7 +130,8 @@ function OpenExistingFileInDelphi(FileName: String; SearchPath: String): IOTAMod begin result := nil; Ensuretrailing(SearchPath, ';'); - OTADEBUGLogFmt('Looking with searchpath: %s', [SearchPath]); // do not localize + if OTADEBUG then + BoldLog.LogFmt('Looking with searchpath: %s', [SearchPath]); while SearchPath <> '' do begin @@ -159,7 +145,8 @@ function OpenExistingFileInDelphi(FileName: String; SearchPath: String): IOTAMod result := FindDelphiModuleForFile(FileName); if assigned(result) then begin - OTADEBUGLogFmt('Loaded and Opened the file %s', [path + filename]); // do not localize + if OTADEBUG then + BoldLog.LogFmt('Loaded and Opened the file %s', [path + filename]); exit; end; end; @@ -171,29 +158,32 @@ function EnsuredModule(FileName: string; ModuleCreator: TBoldModuleCreator; Allo Project: IOTAProject; begin result := nil; - - OTADEBUGLogFmt('Looking in ModuleServices for %s', [FileName]); // do not localize + if OTADEBUG then + BoldLog.LogFmt('Looking in ModuleServices for %s', [FileName]); result := FindDelphiModuleForFile(FileName); WasOpen := assigned(Result); - + if not Assigned(Result) then begin Project := GetOTAProject; if assigned(Project) then begin - OTADEBUGLogFmt('Looking in Project for %s', [FileName]); // do not localize + if OTADEBUG then + BoldLog.LogFmt('Looking in Project for %s', [FileName]); result := FindFileModuleInProject(FileName, Project); if not assigned(result) then begin - OTADEBUGLogFmt('Looking in Project SearchPath for %s', [FileName]); // do not localize + if OTADEBUG then + BoldLog.LogFmt('Looking in Project SearchPath for %s', [FileName]); result := OpenExistingFileInDelphi(FileName, GetProjectSearchPath(Project)); end; if not Assigned(Result) then begin - OTADEBUGLogFmt('Looking in folders of other files in project for %s', [FileName]); // do not localize + if OTADEBUG then + BoldLog.LogFmt('Looking in folders of other files in project for %s', [FileName]); result := OpenExistingFileInDelphi(FileName, GetProjectOtherPaths(Project)); end; end; @@ -201,19 +191,20 @@ function EnsuredModule(FileName: string; ModuleCreator: TBoldModuleCreator; Allo if not assigned(result) then begin - OTADEBUGLogFmt('Looking in Delphi SearchPath for %s', [FileName]); // do not localize + if OTADEBUG then + BoldLog.LogFmt('Looking in Delphi SearchPath for %s', [FileName]); result := OpenExistingFileInDelphi(FileName, GetDelphiSearchPath); end; if not assigned(result) then begin - OTADEBUGLogFmt('Creating New module for %s', [FileName]); // do not localize + if OTADEBUG then + BoldLog.LogFmt('Creating New module for %s', [FileName]); result := OTAModuleServices.CreateModule(ModuleCreator); end; - OTADEBUGLogFmt('New module created: %s', [FileName]); // do not localize if not assigned(result) then - raise EBoldDesignTime.CreateFmt(sUnableToGetModule, [filename]); + raise EBoldDesignTime.CreateFmt('Unable to get module for %s', [filename]); end; function BoldFilePathForComponent(component: TComponent): string; @@ -241,12 +232,10 @@ function BoldFilePathForComponent(component: TComponent): string; begin RootComponent := FormEditor.GetRootComponent; - // if there is a component on the form with the same name - // as the one we are looking for, and the form has the same - // name as the owner of our component + if assigned(FormEditor.FindComponent(Component.Name)) and - RootComponent.GetPropValueByName('Name', RootName) and // do not localize + RootComponent.GetPropValueByName('Name', RootName) and (RootName = Owner.Name) then begin Result := IncludeTrailingPathDelimiter(Trim(ExtractFilePath(Module.FileName))); @@ -262,18 +251,17 @@ function BoldFilePathForComponent(component: TComponent): string; function GetOTAProject: IOTAProject; var i: integer; + CurrentModule: IOTAModule; begin - Result := OTAModuleServices.GetActiveProject; - if not Assigned(Result) then - begin - // find the first project available - for i := 0 to OTAModuleServices.ModuleCount - 1 do - if OTAModuleServices.Modules[i].QueryInterface(IOTAProject, result) = S_OK then - if uppercase(ExtractFileExt(result.GetFileName)) = '.DPR' then // do not localize - exit; - result := nil; - end; -end; + result := (BorlandIDEServices as IOTAModuleServices).GetActiveProject; + if OTADEBUG then + begin + if Assigned(result) then + BoldLog.LogFmt('CurrentModule:', [result.FileName]) + else + BoldLog.Log('CurrentModule not found'); + end; + end; function FindFileModuleInProject(const fileName: String; Project: IOTAProject): IOTAModule; var @@ -282,15 +270,13 @@ function FindFileModuleInProject(const fileName: String; Project: IOTAProject): result := nil; if assigned(Project) then for i := 0 to Project.GetModuleCount - 1 do - begin - OTADEBUGLogFmt('FindFileModuleInProject: %s - %s', [ExtractFileName(Project.GetModule(i).GetFileName), ExtractFileName(FileName)]); if SameFileName(ExtractFileName(Project.GetModule(i).GetFileName), ExtractFileName(FileName)) then begin - OTADEBUGLogFmt('Opening existing file from project: %s', [Project.GetModule(i).FileName]); // do not localize + if OTADEBUG then + BoldLog.Log('Opening existing file from project: '+ Project.GetModule(i).FileName); Result := Project.GetModule(i).OpenModule; Exit; end; - end; end; function GetProjectPath(Project: IOTAProject): String; @@ -328,7 +314,6 @@ function TBoldModuleCreator.GetCreatorType: string; else result := ''; end; - result := ''; end; function TBoldModuleCreator.GetExisting: Boolean; @@ -337,8 +322,8 @@ function TBoldModuleCreator.GetExisting: Boolean; if FileExists(fFilename) then result := true; - if not result then - OTADEBUGLogFmt('TBoldModuleCreator.GetExisting: %s does not exist', [fFileName]); // do not localize + if not result and OTADEBUG then + BoldLog.LogFmt('%s does not exist', [fFileName]); end; function TBoldModuleCreator.GetFileSystem: string; @@ -347,14 +332,18 @@ function TBoldModuleCreator.GetFileSystem: string; end; function TBoldModuleCreator.GetOwner: IOTAModule; +var + Module: IOTAModule; begin - Result := nil; - Exit; case fModuleType of - // IncFiles and units should be owned by the project is possible mtIncFile, - mtUnit: Result := (BorlandIDEServices as IOTAModuleServices).GetActiveProject; - // Other files will not get added to a project (IDL files) + mtUnit: begin + Module := (BorlandIDEServices as IOTAModuleServices).CurrentModule; + if Assigned(Module) and (Module.OwnerCount > 0) then + Result := Module.Owners[0] + else + Result := nil; + end; mtText: result := nil; end; end; @@ -416,7 +405,7 @@ function TBoldModuleCreator.NewIntfSource(const ModuleIdent, FormIdent, Ancestor procedure TBoldModuleCreator.FormCreated(const FormEditor: IOTAFormEditor); begin -end; +end; constructor TBoldUnitFile.Create(const UnitIdent: string); begin @@ -436,7 +425,7 @@ function TBoldUnitFile.GetAge: TDateTime; initialization OTAModuleServices := BorlandIDEServices as IOTAModuleServices; OTAActionServices := BorlandIDEServices as IOTAActionServices; - if assigned(BorlandIDEServices) then + if assigned(OTAModuleServices) and Assigned(OTAActionServices) then BoldRunningAsDesignTimePackage := true; end. diff --git a/Source/Common/IDE/BoldPropertyEditors.pas b/Source/Common/IDE/BoldPropertyEditors.pas index 23f94845..0e3f3614 100644 --- a/Source/Common/IDE/BoldPropertyEditors.pas +++ b/Source/Common/IDE/BoldPropertyEditors.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPropertyEditors; interface @@ -138,6 +141,7 @@ TBoldStringListEditor = class(TDefaultEditor) function DerivedFrom(TypeInfo: PTypeInfo; const aClass: TClass): boolean; public procedure EditProperty(const PropertyEditor: IProperty; var Continue: Boolean); override; + destructor Destroy; override; end; {---TBoldFileNameProperty---} @@ -152,13 +156,13 @@ TBoldFileNameProperty = class(TBoldStringProperty) {---TBoldElementSubscribeMethodProperty---} TBoldElementSubscribeMethodProperty = class(TBoldOneLinerWithEvalMethodProperty) public - function TextToInsert: string; override; + function ImplementationTextToInsert: string; override; end; {---TBoldElementFilterMethodProperty---} TBoldElementFilterMethodProperty = class(TBoldOTAModifyingMethodProperty) public - function TextToInsert: string; override; + function ImplementationTextToInsert: string; override; function GetDeltaLines: integer; override; function GetColPos: integer; override; end; @@ -166,7 +170,7 @@ TBoldElementFilterMethodProperty = class(TBoldOTAModifyingMethodProperty) {---TBoldElementCompareMethodProperty---} TBoldElementCompareMethodProperty = class(TBoldOTAModifyingMethodProperty) public - function TextToInsert: string; override; + function ImplementationTextToInsert: string; override; function GetDeltaLines: integer; override; function GetColPos: integer; override; end; @@ -181,6 +185,8 @@ implementation Controls, Dialogs, BoldHandles, + BoldIndex, + BoldIndexableList, BoldMetaElementList, BoldDefs, BoldDefsDT, @@ -229,6 +235,12 @@ function TBoldStringListEditor.DerivedFrom(TypeInfo: PTypeInfo; aClass.InheritsFrom(TypeData^.ClassType); end; +destructor TBoldStringListEditor.Destroy; +begin + FreeAndNil(fTimer); + inherited; +end; + procedure TBoldStringListEditor.EditProperty(const PropertyEditor: IProperty; var Continue: Boolean); begin inherited; @@ -291,13 +303,13 @@ function TBoldFileNameProperty.GetAttributes: TPropertyAttributes; end; {---TBoldElementSubscribeMethodProperty---} -function TBoldElementSubscribeMethodProperty.TextToInsert: string; +function TBoldElementSubscribeMethodProperty.ImplementationTextToInsert: string; begin Result := Format(' Element%sSubscribeToExpression(%s%s, Subscriber, False);', [BOLDSYM_POINTERDEREFERENCE, BOLDSYM_QUOTECHAR, BOLDSYM_QUOTECHAR]); // do not localize end; {---TBoldElementFilterMethodProperty---} -function TBoldElementFilterMethodProperty.TextToInsert: string; +function TBoldElementFilterMethodProperty.ImplementationTextToInsert: string; begin Result := ''; {$IFDEF BOLD_DELPHI} @@ -319,7 +331,7 @@ function TBoldElementFilterMethodProperty.GetColPos: integer; end; {---TBoldElementCompareMethodProperty---} -function TBoldElementCompareMethodProperty.TextToInsert: string; +function TBoldElementCompareMethodProperty.ImplementationTextToInsert: string; begin Result := Format(' %sResult %s 0;', [BOLDSYM_TYPEINTEGER, BOLDSYM_ASSIGNMENT]) + BOLDCRLF; // do not localize Result := Result + Format(' if %s(item1) %s %s(item2) %s', [BOLDSYM_ASSIGNED, BOLDSYM_AND, BOLDSYM_ASSIGNED, BOLDSYM_THEN]) + BOLDCRLF; // do not localize diff --git a/Source/Common/IDE/BoldReg.RES b/Source/Common/IDE/BoldReg.RES new file mode 100644 index 00000000..8e7ed242 Binary files /dev/null and b/Source/Common/IDE/BoldReg.RES differ diff --git a/Source/Common/IDE/BoldReg.pas b/Source/Common/IDE/BoldReg.pas index 064895fc..a51ec34a 100644 --- a/Source/Common/IDE/BoldReg.pas +++ b/Source/Common/IDE/BoldReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldReg; interface @@ -13,7 +16,7 @@ implementation BoldTemplateExpander, BoldIDEConsts; -{.$R *.res} +{$R *.res} procedure Register; begin @@ -22,3 +25,4 @@ procedure Register; end; end. + diff --git a/Source/Common/IDE/BoldReg.rc b/Source/Common/IDE/BoldReg.rc index f6be2b20..0e1d8af1 100644 --- a/Source/Common/IDE/BoldReg.rc +++ b/Source/Common/IDE/BoldReg.rc @@ -1,4 +1,4 @@ -TBOLDTEMPLATEHOLDER BITMAP LOADONCALL TBoldTemplateHolder.bmp +TBOLDTEMPLATEHOLDER BITMAP LOADONCALL ..\..\..\Images\Components\TBoldTemplateHolder.bmp diff --git a/Source/Common/IDE/BoldTextStream.pas b/Source/Common/IDE/BoldTextStream.pas index 0fcbf051..522f9724 100644 --- a/Source/Common/IDE/BoldTextStream.pas +++ b/Source/Common/IDE/BoldTextStream.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldTextStream; interface @@ -16,7 +19,6 @@ interface { forward declarations } TBoldTextStream = class; TITextStream = class; - // For backward comaptibility TTextStream = TBoldTextStream; { TBoldTextStream } @@ -85,14 +87,14 @@ procedure TBoldTextStream.AddString(const s: string); procedure TBoldTextStream.StartBlock; begin - Writeln('begin'); // do not localize + Writeln('begin'); Indent; end; procedure TBoldTextStream.EndBlock(const AddNewLine: boolean); begin Dedent; - Writeln('end;'); // do not localize + Writeln('end;'); if AddNewLine then NewLine; end; @@ -171,4 +173,6 @@ procedure TBoldTextStream.Clear; Size := 0; end; +initialization + end. diff --git a/Source/Common/IDE/BoldWebConnectionReg.RES b/Source/Common/IDE/BoldWebConnectionReg.RES new file mode 100644 index 00000000..a91fd506 Binary files /dev/null and b/Source/Common/IDE/BoldWebConnectionReg.RES differ diff --git a/Source/Common/IDE/BoldWebConnectionReg.pas b/Source/Common/IDE/BoldWebConnectionReg.pas index 86db60e0..5e3113b5 100644 --- a/Source/Common/IDE/BoldWebConnectionReg.pas +++ b/Source/Common/IDE/BoldWebConnectionReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWebConnectionReg; interface @@ -6,7 +9,8 @@ procedure Register; implementation -{.$R *.res} +{$R BoldWebConnectionReg.res} + uses BoldWebConnection, BoldIDEConsts, @@ -23,3 +27,4 @@ procedure Register; end; end. + diff --git a/Source/Common/IDE/BoldWebConnectionReg.rc b/Source/Common/IDE/BoldWebConnectionReg.rc index eb1a6c80..2a068993 100644 --- a/Source/Common/IDE/BoldWebConnectionReg.rc +++ b/Source/Common/IDE/BoldWebConnectionReg.rc @@ -1 +1 @@ -TBOLDWEBCONNECTION BITMAP LOADONCALL TBoldWebConnection.bmp \ No newline at end of file +TBOLDWEBCONNECTION BITMAP LOADONCALL ..\..\..\Images\Components\TBoldWebConnection.bmp \ No newline at end of file diff --git a/Source/Common/IDECOM/BoldComEditors.pas b/Source/Common/IDECOM/BoldComEditors.pas index 2c16130e..1086bf1a 100644 --- a/Source/Common/IDECOM/BoldComEditors.pas +++ b/Source/Common/IDECOM/BoldComEditors.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComEditors; interface @@ -76,8 +79,7 @@ implementation SysUtils, DesignIntf, Windows, - Dialogs, - BoldComConst; + Dialogs; constructor TBoldComServerUnitFile.Create(const UnitIdent: string; Creator: TBoldComServerUnitCreator); @@ -94,31 +96,31 @@ function TBoldComServerUnitFile.GetSource: string; with TStringList.Create do begin try - Add(Format('unit %s;', [FUnitIdent])); // do not localize - Add(''); // do not localize - Add('interface'); // do not localize - Add(''); // do not localize - Add('implementation'); // do not localize - Add(''); // do not localize - Add('uses'); // do not localize - Add(' ComServ, BoldComServer;'); // do not localize - Add(''); // do not localize - Add('const'); // do not localize + Add(Format('unit %s;', [FUnitIdent])); + Add(''); + Add('interface'); + Add(''); + Add('implementation'); + Add(''); + Add('uses'); + Add(' ComServ, BoldComServer;'); + Add(''); + Add('const'); for I := 0 to Creator.ServerHandle.Classes.Count - 1 do begin Item := Creator.ServerHandle.Classes[I]; - Add(Format(' %s_CLSID: TGUID = ''%s'';', [Item.Name, Item.CLSID])); // do not localize + Add(Format(' %s_CLSID: TGUID = ''%s'';', [Item.Name, Item.CLSID])); end; Add(''); - Add('initialization'); // do not localize + Add('initialization'); for I := 0 to Creator.ServerHandle.Classes.Count - 1 do begin Item := Creator.ServerHandle.Classes[I]; - Add(' TBoldComServerConnectionFactory.Create(ComServer, '); // do not localize - Add(Format(' %s_CLSID, ''%s'', ''%s'');', [Item.Name, Item.Name, Item.Description])); // do not localize + Add(' TBoldComServerConnectionFactory.Create(ComServer, '); + Add(Format(' %s_CLSID, ''%s'', ''%s'');', [Item.Name, Item.Name, Item.Description])); end; Add(''); - Add('end.'); // do not localize + Add('end.'); Result := Text; finally Free; @@ -238,7 +240,7 @@ procedure TBoldComServerHandleComponentEditor.ExecuteVerb(Index: Integer); ServerHandle := Component as TBoldComServerHandle; if ServerHandle.Classes.Count > 0 then begin - if MessageDlg(sGenerateServerCode, + if MessageDlg('This will generate server code, continue?', mtConfirmation, [mbYes, mbNo], 0) = idYes then begin BorlandIDEServices.QueryInterface(IOTAModuleServices, Ms); @@ -250,7 +252,7 @@ procedure TBoldComServerHandleComponentEditor.ExecuteVerb(Index: Integer); end; end else - MessageDlg(sCannotGenerateServerCode, mtWarning, [mbOK], 0); + MessageDlg('Can''t generate code, no class(es) defined.', mtWarning, [mbOK], 0); end; end; @@ -258,7 +260,7 @@ function TBoldComServerHandleComponentEditor.GetVerb(Index: Integer): string; begin if Index = 0 then begin - Result := sCaptionGenerateServerCode; + Result := 'Generate server code...'; end; end; @@ -295,4 +297,6 @@ procedure TBoldComServerClassPropertyEditor.GetValueList(List: TStrings); ServerHandle.Classes.GetClassNames(List); end; +initialization + end. diff --git a/Source/Common/IDECOM/BoldComReg.pas b/Source/Common/IDECOM/BoldComReg.pas index d7d600c8..8b6e2a60 100644 --- a/Source/Common/IDECOM/BoldComReg.pas +++ b/Source/Common/IDECOM/BoldComReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComReg; interface @@ -5,7 +8,9 @@ interface procedure Register; implementation + {$R BoldComReg.Res} + uses Classes, DesignIntf, @@ -13,7 +18,8 @@ implementation BoldComClientHandles, BoldComEditors, BoldIDEConsts, - BoldObjectNamePropertyEditor; + BoldObjectNamePropertyEditor + ; procedure Register; begin @@ -26,8 +32,8 @@ procedure Register; RegisterComponentEditor(TBoldComServerHandle, TBoldComServerHandleComponentEditor); RegisterPropertyEditor(TypeInfo(string), TBoldComExportHandle, - 'ServerClass', TBoldComServerClassPropertyEditor); // do not localize - RegisterPropertyEditor(TypeInfo(String), TBoldComClientObjectHandle, 'Objectname', TBoldObjectNameProperty); // do not localize + 'ServerClass', TBoldComServerClassPropertyEditor); + RegisterPropertyEditor(TypeInfo(String), TBoldComClientObjectHandle, 'Objectname', TBoldObjectNameProperty); end; end. diff --git a/Source/Common/IDECOM/BoldComReg.res b/Source/Common/IDECOM/BoldComReg.res new file mode 100644 index 00000000..b4f9eba1 Binary files /dev/null and b/Source/Common/IDECOM/BoldComReg.res differ diff --git a/Source/Common/IDECOM/BoldObjectNamePropertyEditor.pas b/Source/Common/IDECOM/BoldObjectNamePropertyEditor.pas index aa9b90db..cab63c9a 100644 --- a/Source/Common/IDECOM/BoldObjectNamePropertyEditor.pas +++ b/Source/Common/IDECOM/BoldObjectNamePropertyEditor.pas @@ -1,5 +1,10 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldObjectNamePropertyEditor; +{$Include Bold.inc} + interface uses @@ -73,6 +78,7 @@ TBoldObjectNameProperty = class(TBoldStringProperty) function GetAttributes: TPropertyAttributes; override; end; + var ObjectNamePropEditFrm: TObjectNamePropEditFrm; @@ -81,8 +87,7 @@ implementation uses BoldComUtils, Variants, - dialogs, - BoldComConst; + dialogs; {$R *.DFM} @@ -122,9 +127,9 @@ function TObjectNamePropEditFrm.Display(pConnectionHandle: TObject): Boolean; fConnectionHandle := pConnectionHandle as TBoldComConnectionHandle; if Assigned(ConnectionHandle) then begin - Caption := Format(sObjectsInX, [ConnectionHandle.ServerName]); + Caption := Format('Objects in %s', [ConnectionHandle.ServerName]); if (ObjectServers.IndexOf(ConnectionHandle.ServerCLSID) = -1) and - (MessageDlg(Format(sQueryStartServer, [ConnectionHandle.ServerName]), mtConfirmation, [mbYes, mbNo], 0) = mrYes) then + (MessageDlg(Format('Would you like to start the server %s to get the list of exported objects?', [ConnectionHandle.ServerName]), mtConfirmation, [mbYes, mbNo], 0) = mrYes) then GetObjectsFromServer; CurrentInfo := nil; if (ObjectServers.IndexOf(ConnectionHandle.ServerCLSID) <> -1) then @@ -171,7 +176,7 @@ procedure TObjectNamePropEditFrm.GetObjectsFromServer; FreeAndNil(ObjectNames); FreeAndNil(ClassNames); end; - end; // if connected + end; ConnectionHandle.Connected := false; end; @@ -257,8 +262,7 @@ procedure TObjectNamePropEditFrm.RefreshActionExecute(Sender: TObject); var CurrentInfo: TBoldProviderObjectInfo; begin - //refresh list - if (MessageDlg(Format(sQueryConnectToServer, [ConnectionHandle.ServerName]), mtConfirmation, [mbYes, mbNo], 0) = mrYes) then + if (MessageDlg(Format('Connect to server %s and retrieve exported objects?', [ConnectionHandle.ServerName]), mtConfirmation, [mbYes, mbNo], 0) = mrYes) then begin GetObjectsFromServer; CurrentInfo := nil; @@ -280,7 +284,7 @@ procedure TBoldObjectNameProperty.Edit; SelectedPersistent := nil; for i := 0 to PropCount - 1 do SelectedPersistent := GetComponent(i); - obj := GetObjectProp(SelectedPersistent, 'ConnectionHandle'); // do not localize + obj := GetObjectProp(SelectedPersistent, 'ConnectionHandle'); if Assigned(obj) then begin with TObjectNamePropEditFrm.Create(Application) do @@ -291,7 +295,7 @@ procedure TBoldObjectNameProperty.Edit; end; end else - MessageDlg(sCannotFindConnectionHandle,mtInformation, [mbOk], 0); + MessageDlg('Cannot find a ConnectionHandle.',mtInformation, [mbOk], 0); end; function TBoldObjectNameProperty.FileFilter: string; @@ -304,7 +308,9 @@ function TBoldObjectNameProperty.GetAttributes: TPropertyAttributes; Result := [paDialog, paRevertable]; end; -initialization //empty + + +initialization finalization FreeObjectServers; diff --git a/Source/Common/IDECOM/BoldXMLDispatcherEditor.pas b/Source/Common/IDECOM/BoldXMLDispatcherEditor.pas index d9eebd1a..c2b51bb8 100644 --- a/Source/Common/IDECOM/BoldXMLDispatcherEditor.pas +++ b/Source/Common/IDECOM/BoldXMLDispatcherEditor.pas @@ -1,10 +1,15 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldXMLDispatcherEditor; interface uses DesignEditors, - DesignIntf; + DesignIntf, + BoldRev; + type { forward declarations } @@ -22,15 +27,12 @@ TBoldXMLDispatcherEditor = class(TDefaultEditor) implementation -uses - BoldComConst; - { TBoldXMLDispatcherEditor } procedure TBoldXMLDispatcherEditor.EditProperty( const PropertyEditor: IProperty; var Continue: Boolean); begin - if PropertyEditor.GetName = 'Actions' then // do not localize + if PropertyEditor.GetName = 'Actions' then begin PropertyEditor.Edit; Continue := False; @@ -48,7 +50,7 @@ procedure TBoldXMLDispatcherEditor.ExecuteVerb(Index: Integer); function TBoldXMLDispatcherEditor.GetVerb(Index: Integer): string; begin case Index of - 0: Result := sEditActions; + 0: Result := 'Edit actions...'; end; end; @@ -57,4 +59,6 @@ function TBoldXMLDispatcherEditor.GetVerbCount: Integer; Result := 1; end; +initialization + end. diff --git a/Source/Common/IDECOM/BoldXMLDispatcherReg.pas b/Source/Common/IDECOM/BoldXMLDispatcherReg.pas index 893aa5eb..cd73a3fb 100644 --- a/Source/Common/IDECOM/BoldXMLDispatcherReg.pas +++ b/Source/Common/IDECOM/BoldXMLDispatcherReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldXMLDispatcherReg; interface @@ -10,11 +13,12 @@ implementation BoldXMLDispatcher, BoldXMLDispatcherEditor, DesignIntf, + BoldGuard, Classes; procedure Register; begin - RegisterComponents('Bold XML', [TBoldXMLDispatcher]); // do not localize + RegisterComponents('Bold XML', [TBoldXMLDispatcher]); RegisterComponentEditor(TBoldXMLDispatcher, TBoldXMLDispatcherEditor); end; diff --git a/Source/Common/IDECOM/BoldXMLDispatcherVBReg.pas b/Source/Common/IDECOM/BoldXMLDispatcherVBReg.pas index e1061d1a..cd5e0c12 100644 --- a/Source/Common/IDECOM/BoldXMLDispatcherVBReg.pas +++ b/Source/Common/IDECOM/BoldXMLDispatcherVBReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldXMLDispatcherVBReg; interface @@ -8,11 +11,12 @@ implementation uses BoldXMLDispatcherVB, - Classes; + Classes, + BoldGuard; procedure Register; begin - RegisterComponents('Bold XML', [TBoldXMLDispatcherVB]); // do not localize + RegisterComponents('Bold XML', [TBoldXMLDispatcherVB]); end; end. diff --git a/Source/Common/Include/Bold.inc b/Source/Common/Include/Bold.inc index e69de29b..f9defb25 100644 --- a/Source/Common/Include/Bold.inc +++ b/Source/Common/Include/Bold.inc @@ -0,0 +1,511 @@ + +{.$WARN SYMBOL_PLATFORM OFF} +{.$WARN UNIT_PLATFORM OFF} + +{$IFDEF BCB} + {$DEFINE BOLD_BCB} +{$ENDIF} + +{$IFDEF DELPHI} + {$DEFINE BOLD_DELPHI} +{$ENDIF} + + +{$IFDEF BOLD_DELPHI} {$IFDEF BOLD_BCB} +Illegal symbol combination BOLD_DELPHI and BOLD_BCB +{$ENDIF} {$ENDIF} + +{$IFNDEF BOLD_DELPHI} {$IFNDEF BOLD_BCB} + {$DEFINE BOLD_DELPHI} +{$ENDIF} {$ENDIF} + +// Determine delphi version from compiler version + +{$IFDEF VER140} // Delphi 6 + {$DEFINE BOLD_DELPHI6} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER150} // Delphi 7 + {$DEFINE BOLD_DELPHI7} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER160} // Delphi 8 + {$DEFINE BOLD_DELPHI8} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER170} // Delphi 9 (2005) + {$DEFINE BOLD_DELPHI9} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER180} // Delphi 10 (2006) + {$DEFINE BOLD_DELPHI10} + {$DEFINE BOLD_DELPHI10_OR_LATER} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER185} // Delphi 11 (2007) + {$UNDEF BOLD_DELPHI10} // Delphi 2007 is both VER180 and VER185 + {$DEFINE BOLD_DELPHI11} + {$DEFINE BOLD_DELPHI11_OR_LATER} + {$DEFINE BOLD_DELPHI10_OR_LATER} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER190} // Delphi 12 (2007 .NET) + {$DEFINE BOLD_DELPHI12} + {$DEFINE BOLD_DELPHI10_OR_LATER} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER200} // Delphi 13 (2009) + {$DEFINE BOLD_DELPHI13} + {$DEFINE BOLD_DELPHI13_OR_LATER} + {$DEFINE BOLD_DELPHI11_OR_LATER} + {$DEFINE BOLD_DELPHI10_OR_LATER} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER210} // Delphi 14 (2010) + {$DEFINE BOLD_DELPHI14} + {$DEFINE BOLD_DELPHI13_OR_LATER} + {$DEFINE BOLD_DELPHI11_OR_LATER} + {$DEFINE BOLD_DELPHI10_OR_LATER} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER220} // Delphi 15 (XE) + {$DEFINE BOLD_DELPHI15} + {$DEFINE BOLD_DELPHI15_OR_LATER} + {$DEFINE BOLD_DELPHI14_OR_LATER} + {$DEFINE BOLD_DELPHI13_OR_LATER} + {$DEFINE BOLD_DELPHI11_OR_LATER} + {$DEFINE BOLD_DELPHI10_OR_LATER} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER230} // Delphi 16 (XE2) + {$DEFINE BOLD_DELPHI16} + {$DEFINE BOLD_DELPHI16_OR_LATER} + {$DEFINE BOLD_DELPHI13_OR_LATER} + {$DEFINE BOLD_DELPHI11_OR_LATER} + {$DEFINE BOLD_DELPHI10_OR_LATER} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER240} // Delphi 17 (XE3) + {$DEFINE BOLD_DELPHI17} + {$DEFINE BOLD_DELPHI17_OR_LATER} + {$DEFINE BOLD_DELPHI16_OR_LATER} + {$DEFINE BOLD_DELPHI13_OR_LATER} + {$DEFINE BOLD_DELPHI11_OR_LATER} + {$DEFINE BOLD_DELPHI10_OR_LATER} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER250} // Delphi 18 (XE4) + {$DEFINE BOLD_DELPHI18} + {$DEFINE BOLD_DELPHI18_OR_LATER} + {$DEFINE BOLD_DELPHI17_OR_LATER} + {$DEFINE BOLD_DELPHI16_OR_LATER} + {$DEFINE BOLD_DELPHI13_OR_LATER} + {$DEFINE BOLD_DELPHI11_OR_LATER} + {$DEFINE BOLD_DELPHI10_OR_LATER} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER260} // Delphi 19 (XE5) + {$DEFINE BOLD_DELPHI19} + {$DEFINE BOLD_DELPHI19_OR_LATER} + {$DEFINE BOLD_DELPHI18_OR_LATER} + {$DEFINE BOLD_DELPHI17_OR_LATER} + {$DEFINE BOLD_DELPHI16_OR_LATER} + {$DEFINE BOLD_DELPHI13_OR_LATER} + {$DEFINE BOLD_DELPHI11_OR_LATER} + {$DEFINE BOLD_DELPHI10_OR_LATER} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER270} // Delphi 20 (XE6) + {$DEFINE BOLD_DELPHI20} + {$DEFINE BOLD_DELPHI20_OR_LATER} + {$DEFINE BOLD_DELPHI19_OR_LATER} + {$DEFINE BOLD_DELPHI18_OR_LATER} + {$DEFINE BOLD_DELPHI17_OR_LATER} + {$DEFINE BOLD_DELPHI16_OR_LATER} + {$DEFINE BOLD_DELPHI13_OR_LATER} + {$DEFINE BOLD_DELPHI11_OR_LATER} + {$DEFINE BOLD_DELPHI10_OR_LATER} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER280} // Delphi 21 (XE7) + {$DEFINE BOLD_DELPHI21} + {$DEFINE BOLD_DELPHI21_OR_LATER} + {$DEFINE BOLD_DELPHI20_OR_LATER} + {$DEFINE BOLD_DELPHI19_OR_LATER} + {$DEFINE BOLD_DELPHI18_OR_LATER} + {$DEFINE BOLD_DELPHI17_OR_LATER} + {$DEFINE BOLD_DELPHI16_OR_LATER} + {$DEFINE BOLD_DELPHI13_OR_LATER} + {$DEFINE BOLD_DELPHI11_OR_LATER} + {$DEFINE BOLD_DELPHI10_OR_LATER} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER290} // Delphi 22 (XE8) + {$DEFINE BOLD_DELPHI22} + {$DEFINE BOLD_DELPHI22_OR_LATER} + {$DEFINE BOLD_DELPHI21_OR_LATER} + {$DEFINE BOLD_DELPHI20_OR_LATER} + {$DEFINE BOLD_DELPHI19_OR_LATER} + {$DEFINE BOLD_DELPHI18_OR_LATER} + {$DEFINE BOLD_DELPHI17_OR_LATER} + {$DEFINE BOLD_DELPHI16_OR_LATER} + {$DEFINE BOLD_DELPHI13_OR_LATER} + {$DEFINE BOLD_DELPHI11_OR_LATER} + {$DEFINE BOLD_DELPHI10_OR_LATER} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER300} // Delphi 23 (XE10) Seattle + {$DEFINE BOLD_DELPHI23} + {$DEFINE BOLD_DELPHI23_OR_LATER} + {$DEFINE BOLD_DELPHI22_OR_LATER} + {$DEFINE BOLD_DELPHI21_OR_LATER} + {$DEFINE BOLD_DELPHI20_OR_LATER} + {$DEFINE BOLD_DELPHI19_OR_LATER} + {$DEFINE BOLD_DELPHI18_OR_LATER} + {$DEFINE BOLD_DELPHI17_OR_LATER} + {$DEFINE BOLD_DELPHI16_OR_LATER} + {$DEFINE BOLD_DELPHI13_OR_LATER} + {$DEFINE BOLD_DELPHI11_OR_LATER} + {$DEFINE BOLD_DELPHI10_OR_LATER} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER310} // Delphi 24 (XE10.1) Berlin + {$DEFINE BOLD_DELPHI24} + {$DEFINE BOLD_DELPHI24_OR_LATER} + {$DEFINE BOLD_DELPHI23_OR_LATER} + {$DEFINE BOLD_DELPHI22_OR_LATER} + {$DEFINE BOLD_DELPHI21_OR_LATER} + {$DEFINE BOLD_DELPHI20_OR_LATER} + {$DEFINE BOLD_DELPHI19_OR_LATER} + {$DEFINE BOLD_DELPHI18_OR_LATER} + {$DEFINE BOLD_DELPHI17_OR_LATER} + {$DEFINE BOLD_DELPHI16_OR_LATER} + {$DEFINE BOLD_DELPHI13_OR_LATER} + {$DEFINE BOLD_DELPHI11_OR_LATER} + {$DEFINE BOLD_DELPHI10_OR_LATER} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER320} // Delphi 25 (XE10.2) Tokyo + {$DEFINE BOLD_DELPHI25} + {$DEFINE BOLD_DELPHI25_OR_LATER} + {$DEFINE BOLD_DELPHI24_OR_LATER} + {$DEFINE BOLD_DELPHI23_OR_LATER} + {$DEFINE BOLD_DELPHI22_OR_LATER} + {$DEFINE BOLD_DELPHI21_OR_LATER} + {$DEFINE BOLD_DELPHI20_OR_LATER} + {$DEFINE BOLD_DELPHI19_OR_LATER} + {$DEFINE BOLD_DELPHI18_OR_LATER} + {$DEFINE BOLD_DELPHI17_OR_LATER} + {$DEFINE BOLD_DELPHI16_OR_LATER} + {$DEFINE BOLD_DELPHI13_OR_LATER} + {$DEFINE BOLD_DELPHI11_OR_LATER} + {$DEFINE BOLD_DELPHI10_OR_LATER} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER330} // Delphi 25 (XE10.3) Rio + {$DEFINE BOLD_DELPHI26} + {$DEFINE BOLD_DELPHI26_OR_LATER} + {$DEFINE BOLD_DELPHI25_OR_LATER} + {$DEFINE BOLD_DELPHI24_OR_LATER} + {$DEFINE BOLD_DELPHI23_OR_LATER} + {$DEFINE BOLD_DELPHI22_OR_LATER} + {$DEFINE BOLD_DELPHI21_OR_LATER} + {$DEFINE BOLD_DELPHI20_OR_LATER} + {$DEFINE BOLD_DELPHI19_OR_LATER} + {$DEFINE BOLD_DELPHI18_OR_LATER} + {$DEFINE BOLD_DELPHI17_OR_LATER} + {$DEFINE BOLD_DELPHI16_OR_LATER} + {$DEFINE BOLD_DELPHI13_OR_LATER} + {$DEFINE BOLD_DELPHI11_OR_LATER} + {$DEFINE BOLD_DELPHI10_OR_LATER} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER340} // Delphi 26 (XE10.4) Sydney + {$DEFINE BOLD_DELPHI27} + {$DEFINE BOLD_DELPHI27_OR_LATER} + {$DEFINE BOLD_DELPHI26_OR_LATER} + {$DEFINE BOLD_DELPHI25_OR_LATER} + {$DEFINE BOLD_DELPHI24_OR_LATER} + {$DEFINE BOLD_DELPHI23_OR_LATER} + {$DEFINE BOLD_DELPHI22_OR_LATER} + {$DEFINE BOLD_DELPHI21_OR_LATER} + {$DEFINE BOLD_DELPHI20_OR_LATER} + {$DEFINE BOLD_DELPHI19_OR_LATER} + {$DEFINE BOLD_DELPHI18_OR_LATER} + {$DEFINE BOLD_DELPHI17_OR_LATER} + {$DEFINE BOLD_DELPHI16_OR_LATER} + {$DEFINE BOLD_DELPHI13_OR_LATER} + {$DEFINE BOLD_DELPHI11_OR_LATER} + {$DEFINE BOLD_DELPHI10_OR_LATER} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER350} // Delphi 27 (11.3) Alexandria + {$DEFINE BOLD_DELPHI28} + {$DEFINE BOLD_DELPHI28_OR_LATER} + {$DEFINE BOLD_DELPHI27_OR_LATER} + {$DEFINE BOLD_DELPHI26_OR_LATER} + {$DEFINE BOLD_DELPHI25_OR_LATER} + {$DEFINE BOLD_DELPHI24_OR_LATER} + {$DEFINE BOLD_DELPHI23_OR_LATER} + {$DEFINE BOLD_DELPHI22_OR_LATER} + {$DEFINE BOLD_DELPHI21_OR_LATER} + {$DEFINE BOLD_DELPHI20_OR_LATER} + {$DEFINE BOLD_DELPHI19_OR_LATER} + {$DEFINE BOLD_DELPHI18_OR_LATER} + {$DEFINE BOLD_DELPHI17_OR_LATER} + {$DEFINE BOLD_DELPHI16_OR_LATER} + {$DEFINE BOLD_DELPHI13_OR_LATER} + {$DEFINE BOLD_DELPHI11_OR_LATER} + {$DEFINE BOLD_DELPHI10_OR_LATER} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF VER360} // Delphi 28 (12.1) Athens + {$DEFINE BOLD_DELPHI28} + {$DEFINE BOLD_DELPHI28_OR_LATER} + {$DEFINE BOLD_DELPHI27_OR_LATER} + {$DEFINE BOLD_DELPHI26_OR_LATER} + {$DEFINE BOLD_DELPHI25_OR_LATER} + {$DEFINE BOLD_DELPHI24_OR_LATER} + {$DEFINE BOLD_DELPHI23_OR_LATER} + {$DEFINE BOLD_DELPHI22_OR_LATER} + {$DEFINE BOLD_DELPHI21_OR_LATER} + {$DEFINE BOLD_DELPHI20_OR_LATER} + {$DEFINE BOLD_DELPHI19_OR_LATER} + {$DEFINE BOLD_DELPHI18_OR_LATER} + {$DEFINE BOLD_DELPHI17_OR_LATER} + {$DEFINE BOLD_DELPHI16_OR_LATER} + {$DEFINE BOLD_DELPHI13_OR_LATER} + {$DEFINE BOLD_DELPHI11_OR_LATER} + {$DEFINE BOLD_DELPHI10_OR_LATER} + {$DEFINE BOLD_DELPHI7_OR_LATER} + {$DEFINE BOLD_DELPHI6_OR_LATER} +{$ENDIF} + +{$IFDEF LINUX} + // Our implementation depends on MSXML and is not supported on Linux + {$UNDEF BOLD_XML_SUPPORT} + {DEFINE BOLD_IDECLX} + {$DEFINE BOLD_CLX} +{$ENDIF} + + +{$IFDEF MSWINDOWS} + {DEFINE BOLD_IDEVCL} +{$ENDIF} + +// Edition switches +{$IFNDEF BOLD_PROFESSIONAL} + {$IFNDEF BOLD_LITE} + {$DEFINE BOLD_ENTERPRISE} + {$ENDIF} +{$ENDIF} + + +// Compiler control +{$IFDEF BOLD_DEV} + {$ASSERTIONS ON} + {$DEBUGINFO ON} + {$IOCHECKS ON} + {$LOCALSYMBOLS ON} + {$OPTIMIZATION OFF} + {$OVERFLOWCHECKS ON} + {$RANGECHECKS ON} + {$REFERENCEINFO ON} + {$STACKFRAMES ON} +{$ENDIF} + +{$IFDEF BOLD_RELEASE} + {$ASSERTIONS OFF} + {$DEBUGINFO OFF} + {$IOCHECKS ON} + {$LOCALSYMBOLS OFF} + {$OPTIMIZATION ON} + {$OVERFLOWCHECKS OFF} + {$RANGECHECKS OFF} + {$REFERENCEINFO OFF} + {$STACKFRAMES OFF} +{$ENDIF} + +{$IFDEF BOLD_DEBUG} {$IFDEF BOLD_RELEASE} +Illegal symbol combination +{$ENDIF} {$ENDIF} + + +// If building SLIB, swicth on some flags switched off by BOLD_RELEASE +{$IFDEF BOLD_SLIB} + {$STACKFRAMES ON} + {$OPTIMIZATION OFF} + {$DEBUGINFO ON} + {$LOCALSYMBOLS ON} + {$IOCHECKS ON} + {$OVERFLOWCHECKS ON} + {$RANGECHECKS ON} + {$REFERENCEINFO ON} + {$ASSERTIONS ON} + {$DEFINE BOLD_MEMORYDEBUG} +{$ENDIF} + +{$IFDEF BOLD_MEMORYDEBUG} + {$DEFINE BOLD_DISABLEMEMORYMANAGER} + {$DEFINE BOLD_DISABLESHAREDSTRINGS} +{$ENDIF} + +{$DEFINE BOLD_DISABLEMEMORYMANAGER} +{.$DEFINE BOLDCOMCLIENT} + +{$IFNDEF DEBUG} + {$DEFINE BOLD_INLINE} +{$ENDIF} + +{$UNDEF BOLD_UNICODE} +{$IFDEF BOLD_DELPHI13_OR_LATER} + {$DEFINE BOLD_UNICODE} +{$ENDIF} + +{$IFDEF BOLD_UNICODE} + {$STRINGCHECKS OFF} // http://www.micro-isv.asia/2008/10/needless-string-checks-with-ensureunicodestring/ +{$ENDIF BOLD_UNICODE} + + // Use OXML instead of MSXML for XML operations (faster and can handle larger XML) +{.$DEFINE OXML} + + // Faster Display Queue - Simplified handling of (Most)Prioritized and less iteration of Display List +{$DEFINE BoldQueue_Optimization} + + // When fetching an object which class list is loaded then search there instead of going to db. +{$DEFINE FetchFromClassList} + + // Mechanism to automatically place subscriptions for all derivation code in .inc files +{.$DEFINE NoAutoSubscription} + + // Mechanism for efficient fetching +{.$DEFINE SpanFetch} + + // Turns off query mechanism +{.$DEFINE BOLD_NO_QUERIES} + + // Do not allow creation of transient instances of a persistent class. + // This is rarely used and if explicitly prohibited allows TBoldClassListController to not have to execute AddTransientFromSystem +{.$DEFINE NoTransientInstancesOfPersistentClass} + + // Do not allow adding of objects from different systems to same list +{.$DEFINE AllowCrossSystemLists} + + // Affects EndModify, if the new value is same as Old value mark the object Current instead of modified +{$DEFINE CompareToOldValues} + + // Debug addon to count instances per subclass of TBoldMemoryManagedObject +{$DEFINE DebugInstanceCounter} + + // It saves memory to use LightMemberDeriver, but FormSaver is not compatible with LightMemberDeriver +{$DEFINE LightMemberDeriver} + + // Define to use string comparison for all attributes. This may be faster, it uses IBoldStringRepresentable + // but assumes each value has distinct string representation. +{.$DEFINE StringAttributeComparison} + + // Turns of ObjectSpace transaction mechanism +{.$DEFINE NoObjectSpaceTransactions} + + // Turns off MayUpdate +{.$DEFINE NoMayUpdate} + + // USEGLOBALCHARBUFFER is an optimization in BoldHashIndexes.pas +{$DEFINE USEGLOBALCHARBUFFER} + +// Shared Strings brings minimal memory savings, but at cost of performance +{$DEFINE BOLD_DISABLESHAREDSTRINGS} + +// Extrenal IDServer used instead of BoldID/Timestamp tables, improves write performance and avoids deadlocks +{.$DEFINE IDServer} + +// Uses StringBuilder for constructing SQL statements +{$DEFINE RIL} + +// All attributes will return emptyValue instead of exception reading nil. +{.$DEFINE NoNilAttributeExceptions} + +// Does not allow setting or storing of negative dates (before 1899) or after (2899-12-30) +{.$DEFINE NoNegativeDates} + +// Converts zero date (1899) to nil when reading from db +{$DEFINE ConvertZeroDateToDateNil} + +// DateTime and Date conform to each other +{.$DEFINE DateTimeConformsToDate} + +// Allows usage of OCL expressions in constraint messages, the context of expression is the constrained element. Expression has to return a string. +{.$DEFINE OCLConstraintMessages} + +// IndexColumn creates an extra Index column in MemberMappingTable +{.$DEFINE IndexColumn} + +//Includes BoldJson and BoldObjectRepresentationJson +{.$DEFINE BoldJson} + +// BoldSystem broadcasts member events - allows getting events from all objects and their members by only placing one subscription on system +{$DEFINE BoldSystemBroadcastMemberEvents} + +// Generates Enum classes for For..In support, available since D2007 +{$IFDEF BOLD_DELPHI11_OR_LATER} // D2007+ + {$DEFINE UseBoldListEnumerator} +{$ENDIF} + +// do not copy old values to Rollback valuespace during fetch +{$DEFINE DisableRollbackDuringFetch} + +// if link object is deleted (but not yet saved) and then same two objects on both ends are linked again, then reuse the deleted link object instead of creating new one. +// This effectively avoids a db delete and insert of logically same object but with new id. +// As a side effect this also avoids DetectLinkClassDuplicates in batch mode detecting false duplicate +{$DEFINE ReuseDeletedLinkObjectOnRelink} + +{$IFDEF ReuseDeletedLinkObjectOnRelink} + {$IFNDEF CompareToOldValues} + ReuseDeletedLinkObjectOnRelink requires CompareToOldValues + {$ENDIF} +{$ENDIF} diff --git a/Source/Common/Logging/BoldLogForm.dfm b/Source/Common/Logging/BoldLogForm.dfm index 6bb3c46f..ce1da62d 100644 --- a/Source/Common/Logging/BoldLogForm.dfm +++ b/Source/Common/Logging/BoldLogForm.dfm @@ -1,9 +1,9 @@ object BoldLogForm: TBoldLogForm Left = 477 Top = 234 - Width = 469 - Height = 347 Caption = 'Bold' + ClientHeight = 289 + ClientWidth = 553 Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText @@ -38,15 +38,13 @@ object BoldLogForm: TBoldLogForm Menu = MainMenu1 OldCreateOrder = True Position = poScreenCenter - OnCreate = FormCreate - OnDestroy = FormDestroy PixelsPerInch = 96 TextHeight = 13 object Log: TRichEdit Left = 0 Top = 0 - Width = 461 - Height = 281 + Width = 553 + Height = 269 Align = alClient ReadOnly = True ScrollBars = ssBoth @@ -54,8 +52,8 @@ object BoldLogForm: TBoldLogForm end object Panel1: TPanel Left = 0 - Top = 281 - Width = 461 + Top = 269 + Width = 553 Height = 20 Align = alBottom BevelOuter = bvNone @@ -63,7 +61,7 @@ object BoldLogForm: TBoldLogForm object ProgressBar1: TProgressBar Left = 0 Top = 0 - Width = 461 + Width = 553 Height = 20 Align = alClient Step = 1 @@ -108,6 +106,7 @@ object BoldLogForm: TBoldLogForm end object mnuShowAll: TMenuItem Caption = 'Show all log' + Visible = False OnClick = mnuShowAllClick end end @@ -116,7 +115,7 @@ object BoldLogForm: TBoldLogForm Left = 44 Top = 8 Bitmap = { - 494C010103000400040010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 + 494C0101030004000C0010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 0000000000003600000028000000400000001000000001002000000000000010 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 diff --git a/Source/Common/Logging/BoldLogForm.pas b/Source/Common/Logging/BoldLogForm.pas index 60806a30..cc8cb267 100644 --- a/Source/Common/Logging/BoldLogForm.pas +++ b/Source/Common/Logging/BoldLogForm.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLogForm; interface @@ -38,39 +41,40 @@ TBoldLogForm = class(TForm) procedure cmdCloseClick(Sender: TObject); procedure mnuCopyClick(Sender: TObject); procedure mnuShowAllClick(Sender: TObject); - procedure FormCreate(Sender: TObject); - procedure FormDestroy(Sender: TObject); procedure mnuAddSeparatorClick(Sender: TObject); procedure mnuClearLogClick(Sender: TObject); private { Private declarations } - fLogLines: TStringList; function ShowAllLines: boolean; + function GetLogLines: TStrings; public { Public declarations } procedure AddLog(const s: string); procedure Clear; procedure UpdateView; procedure SaveLog; - property LogLines: TStringList read fLogLines; + property LogLines: TStrings read GetLogLines; end; implementation uses SysUtils, - BoldUtils, - BoldCommonConst; + BoldUtils; {$R *.dfm} procedure TBoldLogForm.AddLog(const s: string); +const + cMaxLines = 20000; begin - fLogLines.Add(s); + while LogLines.Count > cMaxLines do + LogLines.Delete(0); + LogLines.Add(s); try UpdateView; except on E:Exception do - if MessageDlg(Format(sClearAndContinue, [E.Message]), + if MessageDlg(Format('Error: "%s". Clear log and continue?', [E.Message]), mtWarning, [mbYes, mbNo], 0) = mrYes then Log.Lines.Clear else @@ -102,20 +106,11 @@ procedure TBoldLogForm.UpdateView; var i: integer; begin - if visible then - begin - Log.Lines.BeginUpdate; - try - Log.Lines.Clear; - if ShowAllLines then - Log.Lines.Assign(fLogLines) - else - for i := MaxIntValue([0, fLogLines.Count - 50]) to fLogLines.Count - 1 do - Log.Lines.Add(fLogLines[i]); - finally - Log.Lines.EndUpdate; - end; - end; + if not Visible then + exit; + Log.SetFocus; + Log.SelStart := Log.GetTextLen; + Log.Perform(EM_SCROLLCARET, 0, 0); end; procedure TBoldLogForm.mnuShowAllClick(Sender: TObject); @@ -129,24 +124,19 @@ function TBoldLogForm.ShowAllLines: boolean; Result := mnuShowAll.Checked; end; -procedure TBoldLogForm.FormCreate(Sender: TObject); +function TBoldLogForm.GetLogLines: TStrings; begin - fLogLines := TStringList.Create; -end; - -procedure TBoldLogForm.FormDestroy(Sender: TObject); -begin - FreeAndNil(fLogLines); + result := Log.Lines; end; procedure TBoldLogForm.SaveLog; begin with TSaveDialog.Create(nil) do try - DefaultExt := 'log'; // do not localize - Filter := Format('%s (*.log)|*.log|%s (*.txt)|*.txt|%s (*.*)|*.*', [sLogFiles, sTextFiles, sAllFiles]); // do not localize + DefaultExt := 'log'; + Filter := 'Log files (*.log)|*.log|Text files (*.txt)|*.txt|All files (*.*)|*.*'; Options := [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist, ofNoReadOnlyReturn]; - Title := sSaveLogAs; + Title := 'Save Log As'; if Execute then LogLines.SaveToFile(FileName); finally @@ -157,11 +147,13 @@ procedure TBoldLogForm.SaveLog; procedure TBoldLogForm.mnuAddSeparatorClick(Sender: TObject); begin BoldLog.Separator; + UpdateView; end; procedure TBoldLogForm.mnuClearLogClick(Sender: TObject); begin - fLogLines.Clear; + LogLines.Clear; + UpdateView; end; end. diff --git a/Source/Common/Logging/BoldLogHandler.pas b/Source/Common/Logging/BoldLogHandler.pas index 9edd3d7a..5b375a08 100644 --- a/Source/Common/Logging/BoldLogHandler.pas +++ b/Source/Common/Logging/BoldLogHandler.pas @@ -1,11 +1,12 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLogHandler; interface uses - Classes, BoldDefs, - BoldMath, BoldSubscription, BoldLogReceiverInterface; @@ -20,6 +21,7 @@ TBoldLogHandler = class(TBoldSubscribableObject) fIndent: integer; fInterrupted: Boolean; fInterruptHandled: Boolean; + fLastCommandIsSeparator: Boolean; procedure SetProgress(const Value: integer); procedure SetLogHeader(const Value: string); procedure SetProgressMax(const Value: integer); @@ -44,8 +46,8 @@ TBoldLogHandler = class(TBoldSubscribableObject) procedure Separator; procedure ProgressStep; virtual; procedure Sync; virtual; - procedure RegisterLogReceiver(LogReceiver: IBoldLogReceiver); - procedure UnregisterLogReceiver(LogReceiver: IBoldLogReceiver); + procedure RegisterLogReceiver(const LogReceiver: IBoldLogReceiver); + procedure UnregisterLogReceiver(const LogReceiver: IBoldLogReceiver); procedure InterruptProcess; function ProcessInterruption: Boolean; property ProgressMax: integer write SetProgressMax; @@ -62,7 +64,7 @@ TBoldLogReceiverSubscriber = class(TBoldSubscriber) procedure ReceiveExtended(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const); override; function GetHandlesExtendedEvents: Boolean; override; public - constructor Create(Receiver: IBoldLogreceiver); + constructor Create(const Receiver: IBoldLogreceiver); end; function BoldLog: TBoldLogHandler; @@ -71,26 +73,28 @@ implementation uses SysUtils, - BoldUtils, - BoldCommonConst; + BoldMath, + BoldRev; const bleFirst = 1; - bleSetProgress = 1; // Value: integer - bleSetLogHeader = 2; // Value: string - bleSetProgressMax = 3; // Value: integer + bleSetProgress = 1; + bleSetLogHeader = 2; + bleSetProgressMax = 3; bleClear = 4; bleHide = 5; - bleLog = 6; // s: string; LogType: TBoldLogType + bleLog = 6; bleProgressStep = 7; bleShow = 8; - bleStartLog = 9; //SessionName: String + bleStartLog = 9; bleEndLog = 10; bleProcessInterruption = 11; - bleRemoveReceiver = 12; // LogReceiver; + bleRemoveReceiver = 12; bleSync = 13; bleLast = 13; + + var G_BoldLog: TBoldLogHandler = nil; G_BoldLogHandlerClass: TBoldLogHandlerClass = TBoldLogHandler; @@ -104,6 +108,7 @@ function BoldLog: TBoldLogHandler; constructor TBoldLogHandler.Create; begin + fLastCommandIsSeparator := true; inherited; end; @@ -119,9 +124,12 @@ function TBoldLogHandler.IndentSpaces: string; procedure TBoldLogHandler.Separator; begin + if fLastCommandIsSeparator then + exit; Log('', ltSeparator); Log('-={++++}=-', ltSeparator); Log('', ltSeparator); + fLastCommandIsSeparator := true; end; procedure TBoldLogHandler.Clear; @@ -157,6 +165,7 @@ procedure TBoldLogHandler.EndLog; procedure TBoldLogHandler.Log(const s: string; LogType: TBoldLogType = ltInfo); begin SendExtendedEvent(bleLog, [IndentSpaces + s, Integer(LogType)]); + fLastCommandIsSeparator := false; end; procedure TBoldLogHandler.LogFmt(const s: string; const Args: array of const; LogType: TBoldLogType = ltInfo); @@ -220,12 +229,12 @@ procedure TBoldLoghandler.ProgressStep; SendEvent(bleProgressStep); end; -procedure TBoldLogHandler.RegisterLogReceiver(LogReceiver: IBoldLogReceiver); +procedure TBoldLogHandler.RegisterLogReceiver(const LogReceiver: IBoldLogReceiver); begin TBoldLogReceiverSubscriber.Create(LogReceiver); end; -procedure TBoldLogHandler.UnregisterLogReceiver(LogReceiver: IBoldLogReceiver); +procedure TBoldLogHandler.UnregisterLogReceiver(const LogReceiver: IBoldLogReceiver); begin SendExtendedEvent(bleRemoveReceiver, [LogReceiver]); end; @@ -233,7 +242,7 @@ procedure TBoldLogHandler.UnregisterLogReceiver(LogReceiver: IBoldLogReceiver); procedure TBoldLogHandler.InterruptProcess; begin - Log(sTryingToAbort); + Log('Trying to abort process'); fInterrupted := true; fInterruptHandled := false; end; @@ -245,14 +254,14 @@ function TBoldLogHandler.ProcessInterruption: Boolean; if result then begin if not fInterruptHandled then - Log(sProcessStopped); + Log('Process stopped'); fInterruptHandled := true; end; end; { TBoldLogReceiverSubscriber } -constructor TBoldLogReceiverSubscriber.Create(Receiver: IBoldLogreceiver); +constructor TBoldLogReceiverSubscriber.Create(const Receiver: IBoldLogreceiver); begin inherited Create; fReceiver := Receiver; @@ -268,31 +277,33 @@ function TBoldLogReceiverSubscriber.GetHandlesExtendedEvents: Boolean; procedure TBoldLogReceiverSubscriber.Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); begin - // Do nothing... Handled by Extended end; procedure TBoldLogReceiverSubscriber.ReceiveExtended(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const); - + function GetString(const VR: TVarRec): String; begin case VR.VType of - vtString: result := VR.VString^; - vtAnsiString: result := PChar(VR.VAnsiString); + vtString: Result := string(VR.vString); + vtAnsiString: Result := string(VR.vAnsiString); + {$IFDEF BOLD_UNICODE} + vtUnicodeString: Result := string(VR.vUnicodeString); + {$ENDIF} else - raise Exception.Create(sUnknownTypeInGetString); + raise Exception.Create('unknown type in GetString'); end; end; begin case OriginalEvent of - bleSetProgress: fReceiver.SetProgress(args[0].VInteger); // Value: integer - bleSetLogHeader: fReceiver.SetLogHeader(GetString(Args[0])); // Value: string - bleSetProgressMax: fReceiver.SetProgressMax(args[0].VInteger); // Value: integer - bleLog: fReceiver.Log(GetString(Args[0]), TBoldLogType(args[1].vInteger)) ;// s: string; LogType: TBoldLogType - bleStartLog: fReceiver.StartLog(GetString(Args[0]));//SessionName: String - // commit suicide + bleSetProgress: fReceiver.SetProgress(args[0].VInteger); + bleSetLogHeader: fReceiver.SetLogHeader(GetString(Args[0])); + bleSetProgressMax: fReceiver.SetProgressMax(args[0].VInteger); + bleLog: fReceiver.Log(GetString(Args[0]), TBoldLogType(args[1].vInteger)) ; + bleStartLog: fReceiver.StartLog(GetString(Args[0])); + bleRemoveReceiver: if IUnknown(Args[0].VInterface) = freceiver then free; beDestroying: Free; bleClear: fReceiver.Clear; @@ -307,6 +318,7 @@ procedure TBoldLogReceiverSubscriber.ReceiveExtended(Originator: TObject; end; end; + procedure TBoldLogHandler.Sync; begin SendEvent(bleSync); diff --git a/Source/Common/Logging/BoldLogHandlerForm.pas b/Source/Common/Logging/BoldLogHandlerForm.pas index 0bb8499d..73f5ba18 100644 --- a/Source/Common/Logging/BoldLogHandlerForm.pas +++ b/Source/Common/Logging/BoldLogHandlerForm.pas @@ -1,11 +1,12 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLogHandlerForm; interface uses Forms, - Classes, - BoldUtils, BoldDefs, BoldLogHandler, BoldLogReceiverInterface, @@ -19,21 +20,17 @@ TBoldLogHandlerReceiver = class; TBoldLogHandlerReceiver = class(TInterfacedObject, IBoldLogReceiver) private fLogForm: TBoldLogForm; - fLogFormNotifier: TBoldPassthroughNotifier; fSessionName: String; function GetLogForm: TBoldLogForm; procedure HideProgressBar; - function GetLogFormNotifier: TBoldPassthroughNotifier; protected property LogForm: TBoldLogForm read GetLogForm; - property LogFormNotifier: TBoldPassthroughNotifier read GetLogFormNotifier; procedure SetProgress(const Value: integer); procedure SetLogHeader(const Value: string); procedure SetProgressMax(const Value: integer); procedure ProcessInterruption; - procedure Notification(AComponent: TComponent; Operation: TOperation); public - destructor Destroy; override; + destructor destroy; override; procedure Clear; procedure Hide; procedure Log(const s: string; LogType: TBoldLogType = ltInfo); @@ -49,7 +46,8 @@ implementation uses SysUtils, - BoldCommonConst; + BoldUtils, + BoldIsoDateTime; var LogHandlerForm: TBoldLogHandlerReceiver; @@ -61,26 +59,22 @@ procedure TBoldLogHandlerReceiver.Clear; LogForm.Clear; end; -destructor TBoldLogHandlerReceiver.Destroy; +destructor TBoldLogHandlerReceiver.destroy; begin FreeAndNil(fLogForm); - FreeAndNil(fLogFormNotifier); inherited; end; procedure TBoldLogHandlerReceiver.EndLog; begin - Log(format(sLogDone, [formatDateTime('c', now), fSessionName])); + Log(format('%s: Done %s', [AsIsoDateTimeMs(now), fSessionName])); Hideprogressbar; end; function TBoldLogHandlerReceiver.GetLogForm: TBoldLogForm; begin if not Assigned(fLogForm) then - begin fLogForm := TBoldLogForm.Create(nil); - fLogForm.FreeNotification(LogFormNotifier); - end; Result := fLogForm; end; @@ -112,9 +106,7 @@ procedure TBoldLogHandlerReceiver.SetProgress(const Value: integer); procedure TBoldLogHandlerReceiver.SetLogHeader(const Value: string); begin - LogForm.AddLog('=================================='); - LogForm.AddLog('==='+Value); - LogForm.AddLog('=================================='); + LogForm.AddLog(Value); end; procedure TBoldLogHandlerReceiver.SetProgressMax(const Value: integer); @@ -131,9 +123,9 @@ procedure TBoldLogHandlerReceiver.Show; procedure TBoldLogHandlerReceiver.StartLog(const SessionName: String); begin - LogForm.Caption := Format(sLogFormCaption, [SessionName]); + LogForm.Caption := 'Logging Activity: ' + SessionName; fSessionName := SessionName; - Log(format(sLogStarting, [formatDateTime('c', now), SessionName])); // do not localize + Log(format('%s: Starting %s', [AsIsoDateTimeMs(now), SessionName])); end; procedure TBoldLogHandlerReceiver.ProcessInterruption; @@ -151,21 +143,8 @@ procedure TBoldLogHandlerReceiver.Sync; Application.ProcessMessages; end; -procedure TBoldLogHandlerReceiver.Notification(AComponent: TComponent; - Operation: TOperation); -begin - if (AComponent = fLogForm) and (Operation = opRemove) then - fLogForm := nil; -end; - -function TBoldLogHandlerReceiver.GetLogFormNotifier: TBoldPassthroughNotifier; -begin - if not assigned(fLogFormNotifier) then - fLogFormNotifier := TBoldPassthroughNotifier.CreateWithEvent(Notification); - result := fLogFormNotifier; -end; - initialization + LogHandlerForm := TBoldLogHandlerReceiver.Create; BoldLog.RegisterLogReceiver(LogHandlerForm as IBoldLogReceiver); diff --git a/Source/Common/Logging/BoldLogHandlerSimple.pas b/Source/Common/Logging/BoldLogHandlerSimple.pas index 9f03fb39..e752d60c 100644 --- a/Source/Common/Logging/BoldLogHandlerSimple.pas +++ b/Source/Common/Logging/BoldLogHandlerSimple.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLogHandlerSimple; interface @@ -16,18 +19,18 @@ TBoldSimpleLogReceiver = class(TInterfacedObject, IBoldLogReceiver) function GetLogLines: TStringList; protected procedure SetProgress(const Value: integer); - procedure SetLogHeader(const Value: string); + procedure SetLogHeader(const Value: string); virtual; procedure SetProgressMax(const Value: integer); procedure ProcessInterruption; public - destructor Destroy; override; + destructor destroy; override; procedure Clear; procedure Hide; - procedure Log(const s: string; LogType: TBoldLogType); + procedure Log(const s: string; LogType: TBoldLogType); virtual; procedure ProgressStep; procedure Show; procedure Sync; - procedure StartLog(const SessionName: string); + procedure StartLog(const SessionName: string); virtual; procedure EndLog; property LogLines: TStringList read GetLogLines; end; @@ -37,7 +40,7 @@ implementation uses SysUtils, BoldUtils, - BoldCommonConst; + BoldRev; { TBoldSimpleLogReceiver } @@ -46,7 +49,7 @@ procedure TBoldSimpleLogReceiver.Clear; LogLines.Clear; end; -destructor TBoldSimpleLogReceiver.Destroy; +destructor TBoldSimpleLogReceiver.destroy; begin FreeAndNil(fLogLines); inherited; @@ -54,7 +57,6 @@ destructor TBoldSimpleLogReceiver.Destroy; procedure TBoldSimpleLogReceiver.EndLog; begin - // intentionally left blank end; function TBoldSimpleLogReceiver.GetLogLines: TStringList; @@ -64,9 +66,9 @@ function TBoldSimpleLogReceiver.GetLogLines: TStringList; Result := fLogLines; end; + procedure TBoldSimpleLogReceiver.Hide; begin - // intentionally left blank end; procedure TBoldSimpleLogReceiver.Log(const s: string; LogType: TBoldLogType); @@ -76,12 +78,10 @@ procedure TBoldSimpleLogReceiver.Log(const s: string; LogType: TBoldLogType); procedure TBoldSimpleLogReceiver.ProgressStep; begin - // intentionally left blank end; procedure TBoldSimpleLogReceiver.SetProgress(const Value: integer); begin - // intentionally left blank end; procedure TBoldSimpleLogReceiver.SetLogHeader(const Value: string); @@ -91,28 +91,25 @@ procedure TBoldSimpleLogReceiver.SetLogHeader(const Value: string); procedure TBoldSimpleLogReceiver.SetProgressMax(const Value: integer); begin - // intentionally left blank end; procedure TBoldSimpleLogReceiver.Show; begin - // intentionally left blank end; procedure TBoldSimpleLogReceiver.StartLog(const SessionName: String); begin - LogLines.Add(Format(sSessionStart, [SessionName])); + LogLines.Add('Session: ' + SessionName); end; procedure TBoldSimpleLogReceiver.ProcessInterruption; begin - // Intentionally left blank end; procedure TBoldSimpleLogReceiver.Sync; begin - // Intentionally left blank end; -end. +initialization +end. diff --git a/Source/Common/Logging/BoldLogReceiverInterface.pas b/Source/Common/Logging/BoldLogReceiverInterface.pas index 488df3cd..9de852ba 100644 --- a/Source/Common/Logging/BoldLogReceiverInterface.pas +++ b/Source/Common/Logging/BoldLogReceiverInterface.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLogReceiverInterface; interface @@ -31,4 +34,9 @@ interface implementation + + +initialization + + end. diff --git a/Source/Common/Logging/BoldSmallLogFrame.pas b/Source/Common/Logging/BoldSmallLogFrame.pas index 3784bbc6..5d8430ea 100644 --- a/Source/Common/Logging/BoldSmallLogFrame.pas +++ b/Source/Common/Logging/BoldSmallLogFrame.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSmallLogFrame; interface @@ -43,15 +46,15 @@ TBoldLogFrame = class(TFrame, IBoldLogReceiver) procedure Log(const s: string; LogType: TBoldLogType = ltInfo); procedure ProgressStep; procedure Show; - procedure Sync; + procedure Sync; procedure StartLog(const SessionName: String); procedure EndLog; procedure WarningIndicatorClick(Sender: TObject); procedure CalculateTimeLeft; procedure ProcessInterruption; public - constructor Create(Owner: TComponent); override; - destructor Destroy; override; + constructor create(Owner: TComponent); override; + destructor destroy; override; class function CreateSmallLogForm(Caption: string): TForm; { Public declarations } end; @@ -60,8 +63,7 @@ implementation uses SysUtils, - BoldUtils, - BoldCommonConst; + BoldUtils; type TExposedShape = class(TShape) @@ -81,8 +83,8 @@ procedure TBoldLogFrame.CalculateTimeLeft; DonePart := pgLog.Position / pgLog.Max; PartLeft := 1 - DonePart; TimeLeft := (PartLeft * usedTime) / DonePart; - lblTimeLeft.Caption := Format(sLogTimeLeft, [FormatDateTime('hh:mm:ss', timeLeft)]); // do not localize - lblTotTime.Caption := Format(sLogTotalTime, [FormatDateTime('hh:mm:ss', TimeLeft + UsedTime)]); // do not localize + lblTimeLeft.Caption := 'Time left: ' + FormatDateTime('hh:mm:ss', timeLeft); + lblTotTime.Caption := 'Tot time: ' + FormatDateTime('hh:mm:ss', TimeLeft + UsedTime); Refresh; end; end; @@ -103,12 +105,12 @@ constructor TBoldLogFrame.create(Owner: TComponent); lblLogText.Caption := ''; lblLogMainHeader.Caption := ''; lblLogHeader.Caption := ''; - lblTimeLeft.Caption := ''; + lblTimeLeft.Caption := ''; BoldLog.RegisterLogReceiver(self); TExposedShape(WarningIndicator).OnClick := WarningIndicatorClick; end; -destructor TBoldLogFrame.Destroy; +destructor TBoldLogFrame.destroy; begin BoldLog.UnRegisterLogReceiver(self); inherited; @@ -116,17 +118,16 @@ destructor TBoldLogFrame.Destroy; procedure TBoldLogFrame.EndLog; begin -// SetLogHeader(fSessionName); - lblLogText.Caption := sLogSmallDone; + lblLogText.Caption := 'Done...'; pgLog.Position := pgLog.Max + 1; if not WarningPanel.Visible then Timer1.Enabled := true; btnStop.Enabled := false; if fHighestSeverity = ltWarning then - lblLogText.Caption := Format(sLogSmallWarnings, [sLogSmallDone]) + lblLogText.Caption := lblLogText.Caption + ' there were warnings, click the yellow icon for details...' else if fHighestSeverity = ltError then - lblLogText.Caption := Format(sLogSmallErrors, [sLogSmallDone]); + lblLogText.Caption := lblLogText.Caption + ' there were errors, click the red icon for details...'; end; @@ -192,7 +193,7 @@ procedure TBoldLogFrame.StartLog(const SessionName: String); Refresh; Show; fStartTime := now; - Timer1.Enabled := false; + Timer1.Enabled := false; btnStop.Enabled := true; fHighestSeverity := ltInfo; end; diff --git a/Source/Common/Logging/BoldThreadSafeLog.pas b/Source/Common/Logging/BoldThreadSafeLog.pas index 621dc29a..c42a2547 100644 --- a/Source/Common/Logging/BoldThreadSafeLog.pas +++ b/Source/Common/Logging/BoldThreadSafeLog.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldThreadSafeLog; interface @@ -69,7 +72,8 @@ implementation SysUtils, BoldUtils, Windows, - BoldDefs; + BoldDefs, + BoldIsoDateTime; var LogThreadActivities: Boolean; @@ -196,7 +200,7 @@ destructor TFileLogging.Destroy; CloseStream; finally fLocker.Release; - end; + end; FreeAndNil(fLocker); inherited; end; @@ -215,7 +219,6 @@ function TFileLogging.OpenStream: Boolean; OpenMode := fmOpenWrite or fmShareDenyWrite; fFileStream := TFileStream.Create(fFileName, OpenMode); FFileStream.Seek(0, soFromEnd); -// fFileStream.Seek(fFileStream.Size, soFromBeginning); // go to end of file Result := true except Result := false; @@ -225,6 +228,7 @@ function TFileLogging.OpenStream: Boolean; procedure TFileLogging.Trace(const Entry: string); var line: string; + Bytes: TBytes; begin fLocker.Acquire; try @@ -233,22 +237,23 @@ procedure TFileLogging.Trace(const Entry: string); if (fMaxSize > 0) and (fFileStream.Size > fMaxSize) then FlushStream; if IncludeDate then - Line := DateTimeToStr(now) + Line := AsISODateTimeMS(now) else - Line := TimeToStr(now); + Line := AsISOTimeMS(now); Line := Line + ' ' + Entry; if IncludeThreadId then begin if ShortThreadId then - line := line + Format(':TID=%d', [GetCurrentThreadID]) // do not localize + line := line + Format(':TID=%d', [GetCurrentThreadID]) else - line := line + Format(' (ThreadID=%d)', [GetCurrentThreadID]); // do not localize + line := line + Format(' (ThreadID=%d)', [GetCurrentThreadID]); end; Line := Line + BOLDCRLF; - fFileStream.Write(Pointer(line)^, Length(line)); + Bytes := TEncoding.UTF8.GetBytes(line); + fFileStream.write(Bytes, Length(Bytes)); end; finally fLocker.Release; @@ -262,7 +267,7 @@ procedure TFileLogging.CloseStream; procedure TFileLogging.FlushStream; begin - fFileStream.Size := 0; // go to end of file + fFileStream.Size := 0; end; procedure TFileLogging.SetOpen(const Value: Boolean); diff --git a/Source/Common/MsXml/MSXML_TLB.pas b/Source/Common/MsXml/Bold_MSXML_TLB.pas similarity index 82% rename from Source/Common/MsXml/MSXML_TLB.pas rename to Source/Common/MsXml/Bold_MSXML_TLB.pas index 3d5b3764..dd4f223b 100644 --- a/Source/Common/MsXml/MSXML_TLB.pas +++ b/Source/Common/MsXml/Bold_MSXML_TLB.pas @@ -1,57 +1,53 @@ -unit MSXML_TLB; - -// ************************************************************************ // -// WARNING -// ------- -// The types declared in this file were generated from data read from a -// Type Library. If this type library is explicitly or indirectly (via -// another type library referring to this type library) re-imported, or the -// 'Refresh' command of the Type Library Editor activated while editing the -// Type Library, the contents of this file will be regenerated and all -// manual modifications will be lost. -// ************************************************************************ // - -// PASTLWTR: 1.1 -// File generated on 2000-04-28 11:35:52 from Type Library described below. - -// *************************************************************************// -// NOTE: -// Items guarded by $IFDEF_LIVE_SERVER_AT_DESIGN_TIME are used by properties -// which return objects that may need to be explicitly created via a function -// call prior to any access via the property. These items have been disabled -// in order to prevent accidental use from within the object inspector. You -// may enable them by defining LIVE_SERVER_AT_DESIGN_TIME or by selectively -// removing them from the $IFDEF blocks. However, such items must still be -// programmatically created via a method of the appropriate CoClass before -// they can be used. -// ************************************************************************ // -// Type Lib: C:\WINNT\system32\msxml.dll (1) -// IID\LCID: {D63E0CE2-A0A2-11D0-9C02-00C04FC99C8E}\0 -// Helpfile: -// DepndLst: -// (1) v2.0 stdole, (C:\WINNT\System32\stdole2.tlb) -// (2) v4.0 StdVCL, (C:\WINNT\System32\STDVCL40.DLL) -// Errors: -// Hint: Parameter 'type' of IXMLDOMNode.nodeType changed to 'type_' -// Hint: Member 'implementation' of 'IXMLDOMDocument' changed to 'implementation_' -// Hint: Parameter 'type' of IXMLDOMDocument.createNode changed to 'type_' -// Hint: Member 'type' of 'IXMLElement' changed to 'type_' -// Hint: Member 'type' of 'IXMLElement2' changed to 'type_' -// ************************************************************************ // -{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. + +{ Global compiler directives } +{$include bold.inc} +unit Bold_MSXML_TLB; + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +{$TYPEDADDRESS OFF} interface uses Windows, ActiveX, Classes, Graphics, OleServer, OleCtrls, StdVCL; -// *********************************************************************// -// GUIDS declared in the TypeLibrary. Following prefixes are used: -// Type Libraries : LIBID_xxxx -// CoClasses : CLASS_xxxx -// DISPInterfaces : DIID_xxxx -// Non-DISP interfaces: IID_xxxx -// *********************************************************************// + + + + + const - // TypeLibrary Major and minor versions MSXMLMajorVersion = 2; MSXMLMinorVersion = 0; @@ -92,10 +88,8 @@ interface IID_IXMLError: TGUID = '{948C5AD3-C58D-11D0-9C0B-00C04FC99C8E}'; CLASS_XMLDocument: TGUID = '{CFC399AF-D876-11D0-9C10-00C04FC99C8E}'; -// *********************************************************************// -// Declaration of Enumerations defined in Type Library -// *********************************************************************// -// Constants for enum tagDOMNodeType + + type tagDOMNodeType = TOleEnum; const @@ -112,8 +106,6 @@ interface NODE_DOCUMENT_TYPE = $0000000A; NODE_DOCUMENT_FRAGMENT = $0000000B; NODE_NOTATION = $0000000C; - -// Constants for enum tagXMLEMEM_TYPE type tagXMLEMEM_TYPE = TOleEnum; const @@ -127,9 +119,7 @@ interface type -// *********************************************************************// -// Forward declaration of types defined in TypeLibrary -// *********************************************************************// + IXMLDOMImplementation = interface; IXMLDOMImplementationDisp = dispinterface; IXMLDOMNode = interface; @@ -186,10 +176,8 @@ interface IXMLAttributeDisp = dispinterface; IXMLError = interface; -// *********************************************************************// -// Declaration of CoClasses defined in Type Library -// (NOTE: Here we map each CoClass to its Default Interface) -// *********************************************************************// + + DOMDocument = IXMLDOMDocument; DOMFreeThreadedDocument = IXMLDOMDocument; XMLHTTPRequest = IXMLHttpRequest; @@ -197,9 +185,6 @@ interface XMLDocument = IXMLDocument2; -// *********************************************************************// -// Declaration of structures, unions and aliases. -// *********************************************************************// PUserType1 = ^_xml_error; {*} DOMNodeType = tagDOMNodeType; @@ -215,33 +200,27 @@ interface _reserved2: LongWord; end; - XMLELEM_TYPE = tagXMLEMEM_TYPE; + XMLELEM_TYPE = tagXMLEMEM_TYPE; + + + -// *********************************************************************// -// Interface: IXMLDOMImplementation -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF8F-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// IXMLDOMImplementation = interface(IDispatch) ['{2933BF8F-7B36-11D2-B20E-00C04F983E60}'] function hasFeature(const feature: WideString; const version: WideString): WordBool; safecall; end; -// *********************************************************************// -// DispIntf: IXMLDOMImplementationDisp -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF8F-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMImplementationDisp = dispinterface ['{2933BF8F-7B36-11D2-B20E-00C04F983E60}'] function hasFeature(const feature: WideString; const version: WideString): WordBool; dispid 145; end; -// *********************************************************************// -// Interface: IXMLDOMNode -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF80-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMNode = interface(IDispatch) ['{2933BF80-7B36-11D2-B20E-00C04F983E60}'] function Get_nodeName: WideString; safecall; @@ -303,11 +282,9 @@ interface property baseName: WideString read Get_baseName; end; -// *********************************************************************// -// DispIntf: IXMLDOMNodeDisp -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF80-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMNodeDisp = dispinterface ['{2933BF80-7B36-11D2-B20E-00C04F983E60}'] property nodeName: WideString readonly dispid 2; @@ -344,11 +321,9 @@ interface procedure transformNodeToObject(const stylesheet: IXMLDOMNode; outputObject: OleVariant); dispid 35; end; -// *********************************************************************// -// Interface: IXMLDOMNodeList -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF82-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMNodeList = interface(IDispatch) ['{2933BF82-7B36-11D2-B20E-00C04F983E60}'] function Get_item(index: Integer): IXMLDOMNode; safecall; @@ -361,11 +336,9 @@ interface property _newEnum: IUnknown read Get__newEnum; end; -// *********************************************************************// -// DispIntf: IXMLDOMNodeListDisp -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF82-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMNodeListDisp = dispinterface ['{2933BF82-7B36-11D2-B20E-00C04F983E60}'] property item[index: Integer]: IXMLDOMNode readonly dispid 0; default; @@ -375,11 +348,9 @@ interface property _newEnum: IUnknown readonly dispid -4; end; -// *********************************************************************// -// Interface: IXMLDOMNamedNodeMap -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF83-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMNamedNodeMap = interface(IDispatch) ['{2933BF83-7B36-11D2-B20E-00C04F983E60}'] function getNamedItem(const name: WideString): IXMLDOMNode; safecall; @@ -397,11 +368,9 @@ interface property _newEnum: IUnknown read Get__newEnum; end; -// *********************************************************************// -// DispIntf: IXMLDOMNamedNodeMapDisp -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF83-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMNamedNodeMapDisp = dispinterface ['{2933BF83-7B36-11D2-B20E-00C04F983E60}'] function getNamedItem(const name: WideString): IXMLDOMNode; dispid 83; @@ -416,11 +385,9 @@ interface property _newEnum: IUnknown readonly dispid -4; end; -// *********************************************************************// -// Interface: IXMLDOMDocument -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF81-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMDocument = interface(IXMLDOMNode) ['{2933BF81-7B36-11D2-B20E-00C04F983E60}'] function Get_doctype: IXMLDOMDocumentType; safecall; @@ -471,11 +438,9 @@ interface property ontransformnode: OleVariant write Set_ontransformnode; end; -// *********************************************************************// -// DispIntf: IXMLDOMDocumentDisp -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF81-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMDocumentDisp = dispinterface ['{2933BF81-7B36-11D2-B20E-00C04F983E60}'] property doctype: IXMLDOMDocumentType readonly dispid 38; @@ -540,11 +505,9 @@ interface procedure transformNodeToObject(const stylesheet: IXMLDOMNode; outputObject: OleVariant); dispid 35; end; -// *********************************************************************// -// Interface: IXMLDOMDocumentType -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF8B-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMDocumentType = interface(IXMLDOMNode) ['{2933BF8B-7B36-11D2-B20E-00C04F983E60}'] function Get_name: WideString; safecall; @@ -555,11 +518,9 @@ interface property notations: IXMLDOMNamedNodeMap read Get_notations; end; -// *********************************************************************// -// DispIntf: IXMLDOMDocumentTypeDisp -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF8B-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMDocumentTypeDisp = dispinterface ['{2933BF8B-7B36-11D2-B20E-00C04F983E60}'] property name: WideString readonly dispid 131; @@ -599,11 +560,9 @@ interface procedure transformNodeToObject(const stylesheet: IXMLDOMNode; outputObject: OleVariant); dispid 35; end; -// *********************************************************************// -// Interface: IXMLDOMElement -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF86-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMElement = interface(IXMLDOMNode) ['{2933BF86-7B36-11D2-B20E-00C04F983E60}'] function Get_tagName: WideString; safecall; @@ -618,11 +577,9 @@ interface property tagName: WideString read Get_tagName; end; -// *********************************************************************// -// DispIntf: IXMLDOMElementDisp -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF86-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMElementDisp = dispinterface ['{2933BF86-7B36-11D2-B20E-00C04F983E60}'] property tagName: WideString readonly dispid 97; @@ -668,11 +625,9 @@ interface procedure transformNodeToObject(const stylesheet: IXMLDOMNode; outputObject: OleVariant); dispid 35; end; -// *********************************************************************// -// Interface: IXMLDOMAttribute -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF85-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMAttribute = interface(IXMLDOMNode) ['{2933BF85-7B36-11D2-B20E-00C04F983E60}'] function Get_name: WideString; safecall; @@ -682,11 +637,9 @@ interface property value: OleVariant read Get_value write Set_value; end; -// *********************************************************************// -// DispIntf: IXMLDOMAttributeDisp -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF85-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMAttributeDisp = dispinterface ['{2933BF85-7B36-11D2-B20E-00C04F983E60}'] property name: WideString readonly dispid 118; @@ -725,20 +678,16 @@ interface procedure transformNodeToObject(const stylesheet: IXMLDOMNode; outputObject: OleVariant); dispid 35; end; -// *********************************************************************// -// Interface: IXMLDOMDocumentFragment -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {3EFAA413-272F-11D2-836F-0000F87A7782} -// *********************************************************************// + + + IXMLDOMDocumentFragment = interface(IXMLDOMNode) ['{3EFAA413-272F-11D2-836F-0000F87A7782}'] end; -// *********************************************************************// -// DispIntf: IXMLDOMDocumentFragmentDisp -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {3EFAA413-272F-11D2-836F-0000F87A7782} -// *********************************************************************// + + + IXMLDOMDocumentFragmentDisp = dispinterface ['{3EFAA413-272F-11D2-836F-0000F87A7782}'] property nodeName: WideString readonly dispid 2; @@ -775,11 +724,9 @@ interface procedure transformNodeToObject(const stylesheet: IXMLDOMNode; outputObject: OleVariant); dispid 35; end; -// *********************************************************************// -// Interface: IXMLDOMCharacterData -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF84-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMCharacterData = interface(IXMLDOMNode) ['{2933BF84-7B36-11D2-B20E-00C04F983E60}'] function Get_data: WideString; safecall; @@ -794,11 +741,9 @@ interface property length: Integer read Get_length; end; -// *********************************************************************// -// DispIntf: IXMLDOMCharacterDataDisp -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF84-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMCharacterDataDisp = dispinterface ['{2933BF84-7B36-11D2-B20E-00C04F983E60}'] property data: WideString dispid 109; @@ -842,21 +787,17 @@ interface procedure transformNodeToObject(const stylesheet: IXMLDOMNode; outputObject: OleVariant); dispid 35; end; -// *********************************************************************// -// Interface: IXMLDOMText -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF87-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMText = interface(IXMLDOMCharacterData) ['{2933BF87-7B36-11D2-B20E-00C04F983E60}'] function splitText(offset: Integer): IXMLDOMText; safecall; end; -// *********************************************************************// -// DispIntf: IXMLDOMTextDisp -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF87-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMTextDisp = dispinterface ['{2933BF87-7B36-11D2-B20E-00C04F983E60}'] function splitText(offset: Integer): IXMLDOMText; dispid 123; @@ -901,20 +842,16 @@ interface procedure transformNodeToObject(const stylesheet: IXMLDOMNode; outputObject: OleVariant); dispid 35; end; -// *********************************************************************// -// Interface: IXMLDOMComment -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF88-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMComment = interface(IXMLDOMCharacterData) ['{2933BF88-7B36-11D2-B20E-00C04F983E60}'] end; -// *********************************************************************// -// DispIntf: IXMLDOMCommentDisp -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF88-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMCommentDisp = dispinterface ['{2933BF88-7B36-11D2-B20E-00C04F983E60}'] property data: WideString dispid 109; @@ -958,20 +895,16 @@ interface procedure transformNodeToObject(const stylesheet: IXMLDOMNode; outputObject: OleVariant); dispid 35; end; -// *********************************************************************// -// Interface: IXMLDOMCDATASection -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF8A-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMCDATASection = interface(IXMLDOMText) ['{2933BF8A-7B36-11D2-B20E-00C04F983E60}'] end; -// *********************************************************************// -// DispIntf: IXMLDOMCDATASectionDisp -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF8A-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMCDATASectionDisp = dispinterface ['{2933BF8A-7B36-11D2-B20E-00C04F983E60}'] function splitText(offset: Integer): IXMLDOMText; dispid 123; @@ -1016,11 +949,9 @@ interface procedure transformNodeToObject(const stylesheet: IXMLDOMNode; outputObject: OleVariant); dispid 35; end; -// *********************************************************************// -// Interface: IXMLDOMProcessingInstruction -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF89-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMProcessingInstruction = interface(IXMLDOMNode) ['{2933BF89-7B36-11D2-B20E-00C04F983E60}'] function Get_target: WideString; safecall; @@ -1030,11 +961,9 @@ interface property data: WideString read Get_data write Set_data; end; -// *********************************************************************// -// DispIntf: IXMLDOMProcessingInstructionDisp -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF89-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMProcessingInstructionDisp = dispinterface ['{2933BF89-7B36-11D2-B20E-00C04F983E60}'] property target: WideString readonly dispid 127; @@ -1073,20 +1002,16 @@ interface procedure transformNodeToObject(const stylesheet: IXMLDOMNode; outputObject: OleVariant); dispid 35; end; -// *********************************************************************// -// Interface: IXMLDOMEntityReference -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF8E-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMEntityReference = interface(IXMLDOMNode) ['{2933BF8E-7B36-11D2-B20E-00C04F983E60}'] end; -// *********************************************************************// -// DispIntf: IXMLDOMEntityReferenceDisp -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF8E-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMEntityReferenceDisp = dispinterface ['{2933BF8E-7B36-11D2-B20E-00C04F983E60}'] property nodeName: WideString readonly dispid 2; @@ -1123,11 +1048,9 @@ interface procedure transformNodeToObject(const stylesheet: IXMLDOMNode; outputObject: OleVariant); dispid 35; end; -// *********************************************************************// -// Interface: IXMLDOMParseError -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {3EFAA426-272F-11D2-836F-0000F87A7782} -// *********************************************************************// + + + IXMLDOMParseError = interface(IDispatch) ['{3EFAA426-272F-11D2-836F-0000F87A7782}'] function Get_errorCode: Integer; safecall; @@ -1146,11 +1069,9 @@ interface property filepos: Integer read Get_filepos; end; -// *********************************************************************// -// DispIntf: IXMLDOMParseErrorDisp -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {3EFAA426-272F-11D2-836F-0000F87A7782} -// *********************************************************************// + + + IXMLDOMParseErrorDisp = dispinterface ['{3EFAA426-272F-11D2-836F-0000F87A7782}'] property errorCode: Integer readonly dispid 0; @@ -1162,11 +1083,9 @@ interface property filepos: Integer readonly dispid 184; end; -// *********************************************************************// -// Interface: IXMLDOMNotation -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF8C-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMNotation = interface(IXMLDOMNode) ['{2933BF8C-7B36-11D2-B20E-00C04F983E60}'] function Get_publicId: OleVariant; safecall; @@ -1175,11 +1094,9 @@ interface property systemId: OleVariant read Get_systemId; end; -// *********************************************************************// -// DispIntf: IXMLDOMNotationDisp -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF8C-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMNotationDisp = dispinterface ['{2933BF8C-7B36-11D2-B20E-00C04F983E60}'] property publicId: OleVariant readonly dispid 136; @@ -1218,11 +1135,9 @@ interface procedure transformNodeToObject(const stylesheet: IXMLDOMNode; outputObject: OleVariant); dispid 35; end; -// *********************************************************************// -// Interface: IXMLDOMEntity -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF8D-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMEntity = interface(IXMLDOMNode) ['{2933BF8D-7B36-11D2-B20E-00C04F983E60}'] function Get_publicId: OleVariant; safecall; @@ -1233,11 +1148,9 @@ interface property notationName: WideString read Get_notationName; end; -// *********************************************************************// -// DispIntf: IXMLDOMEntityDisp -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {2933BF8D-7B36-11D2-B20E-00C04F983E60} -// *********************************************************************// + + + IXMLDOMEntityDisp = dispinterface ['{2933BF8D-7B36-11D2-B20E-00C04F983E60}'] property publicId: OleVariant readonly dispid 140; @@ -1277,11 +1190,9 @@ interface procedure transformNodeToObject(const stylesheet: IXMLDOMNode; outputObject: OleVariant); dispid 35; end; -// *********************************************************************// -// Interface: IXTLRuntime -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {3EFAA425-272F-11D2-836F-0000F87A7782} -// *********************************************************************// + + + IXTLRuntime = interface(IXMLDOMNode) ['{3EFAA425-272F-11D2-836F-0000F87A7782}'] function uniqueID(const pNode: IXMLDOMNode): Integer; safecall; @@ -1297,11 +1208,9 @@ interface varDestLocale: OleVariant): WideString; safecall; end; -// *********************************************************************// -// DispIntf: IXTLRuntimeDisp -// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable -// GUID: {3EFAA425-272F-11D2-836F-0000F87A7782} -// *********************************************************************// + + + IXTLRuntimeDisp = dispinterface ['{3EFAA425-272F-11D2-836F-0000F87A7782}'] function uniqueID(const pNode: IXMLDOMNode): Integer; dispid 187; @@ -1349,22 +1258,18 @@ interface procedure transformNodeToObject(const stylesheet: IXMLDOMNode; outputObject: OleVariant); dispid 35; end; -// *********************************************************************// -// DispIntf: XMLDOMDocumentEvents -// Flags: (4112) Hidden Dispatchable -// GUID: {3EFAA427-272F-11D2-836F-0000F87A7782} -// *********************************************************************// + + + XMLDOMDocumentEvents = dispinterface ['{3EFAA427-272F-11D2-836F-0000F87A7782}'] procedure ondataavailable; dispid 198; procedure onreadystatechange; dispid -609; end; -// *********************************************************************// -// Interface: IXMLHttpRequest -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {ED8C108D-4349-11D2-91A4-00C04F7969E8} -// *********************************************************************// + + + IXMLHttpRequest = interface(IDispatch) ['{ED8C108D-4349-11D2-91A4-00C04F7969E8}'] procedure open(const bstrMethod: WideString; const bstrUrl: WideString; varAsync: OleVariant; @@ -1392,11 +1297,9 @@ interface property onreadystatechange: IDispatch write Set_onreadystatechange; end; -// *********************************************************************// -// DispIntf: IXMLHttpRequestDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {ED8C108D-4349-11D2-91A4-00C04F7969E8} -// *********************************************************************// + + + IXMLHttpRequestDisp = dispinterface ['{ED8C108D-4349-11D2-91A4-00C04F7969E8}'] procedure open(const bstrMethod: WideString; const bstrUrl: WideString; varAsync: OleVariant; @@ -1416,11 +1319,9 @@ interface property onreadystatechange: IDispatch writeonly dispid 14; end; -// *********************************************************************// -// Interface: IXMLDSOControl -// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable -// GUID: {310AFA62-0575-11D2-9CA9-0060B0EC3D39} -// *********************************************************************// + + + IXMLDSOControl = interface(IDispatch) ['{310AFA62-0575-11D2-9CA9-0060B0EC3D39}'] function Get_XMLDocument: IXMLDOMDocument; safecall; @@ -1433,11 +1334,9 @@ interface property readyState: Integer read Get_readyState; end; -// *********************************************************************// -// DispIntf: IXMLDSOControlDisp -// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable -// GUID: {310AFA62-0575-11D2-9CA9-0060B0EC3D39} -// *********************************************************************// + + + IXMLDSOControlDisp = dispinterface ['{310AFA62-0575-11D2-9CA9-0060B0EC3D39}'] property XMLDocument: IXMLDOMDocument dispid 65537; @@ -1445,11 +1344,9 @@ interface property readyState: Integer readonly dispid -525; end; -// *********************************************************************// -// Interface: IXMLElementCollection -// Flags: (4432) Hidden Dual OleAutomation Dispatchable -// GUID: {65725580-9B5D-11D0-9BFE-00C04FC99C8E} -// *********************************************************************// + + + IXMLElementCollection = interface(IDispatch) ['{65725580-9B5D-11D0-9BFE-00C04FC99C8E}'] procedure Set_length(p: Integer); safecall; @@ -1460,11 +1357,9 @@ interface property _newEnum: IUnknown read Get__newEnum; end; -// *********************************************************************// -// DispIntf: IXMLElementCollectionDisp -// Flags: (4432) Hidden Dual OleAutomation Dispatchable -// GUID: {65725580-9B5D-11D0-9BFE-00C04FC99C8E} -// *********************************************************************// + + + IXMLElementCollectionDisp = dispinterface ['{65725580-9B5D-11D0-9BFE-00C04FC99C8E}'] property length: Integer dispid 65537; @@ -1472,11 +1367,9 @@ interface function item(var1: OleVariant; var2: OleVariant): IDispatch; dispid 65539; end; -// *********************************************************************// -// Interface: IXMLDocument -// Flags: (4432) Hidden Dual OleAutomation Dispatchable -// GUID: {F52E2B61-18A1-11D1-B105-00805F49916B} -// *********************************************************************// + + + IXMLDocument = interface(IDispatch) ['{F52E2B61-18A1-11D1-B105-00805F49916B}'] function Get_root: IXMLElement; safecall; @@ -1506,11 +1399,9 @@ interface property dtdURL: WideString read Get_dtdURL; end; -// *********************************************************************// -// DispIntf: IXMLDocumentDisp -// Flags: (4432) Hidden Dual OleAutomation Dispatchable -// GUID: {F52E2B61-18A1-11D1-B105-00805F49916B} -// *********************************************************************// + + + IXMLDocumentDisp = dispinterface ['{F52E2B61-18A1-11D1-B105-00805F49916B}'] property root: IXMLElement readonly dispid 65637; @@ -1527,11 +1418,9 @@ interface function createElement(vType: OleVariant; var1: OleVariant): IXMLElement; dispid 65644; end; -// *********************************************************************// -// Interface: IXMLElement -// Flags: (4432) Hidden Dual OleAutomation Dispatchable -// GUID: {3F7F31AC-E15F-11D0-9C25-00C04FC99C8E} -// *********************************************************************// + + + IXMLElement = interface(IDispatch) ['{3F7F31AC-E15F-11D0-9C25-00C04FC99C8E}'] function Get_tagName: WideString; safecall; @@ -1553,11 +1442,9 @@ interface property text: WideString read Get_text write Set_text; end; -// *********************************************************************// -// DispIntf: IXMLElementDisp -// Flags: (4432) Hidden Dual OleAutomation Dispatchable -// GUID: {3F7F31AC-E15F-11D0-9C25-00C04FC99C8E} -// *********************************************************************// + + + IXMLElementDisp = dispinterface ['{3F7F31AC-E15F-11D0-9C25-00C04FC99C8E}'] property tagName: WideString dispid 65737; @@ -1572,11 +1459,9 @@ interface procedure removeChild(const pChildElem: IXMLElement); dispid 65746; end; -// *********************************************************************// -// Interface: IXMLDocument2 -// Flags: (4112) Hidden Dispatchable -// GUID: {2B8DE2FE-8D2D-11D1-B2FC-00C04FD915A9} -// *********************************************************************// + + + IXMLDocument2 = interface(IDispatch) ['{2B8DE2FE-8D2D-11D1-B2FC-00C04FD915A9}'] function Get_root(out p: IXMLElement2): HResult; stdcall; @@ -1597,11 +1482,9 @@ interface function Set_async(pf: WordBool): HResult; stdcall; end; -// *********************************************************************// -// Interface: IXMLElement2 -// Flags: (4432) Hidden Dual OleAutomation Dispatchable -// GUID: {2B8DE2FF-8D2D-11D1-B2FC-00C04FD915A9} -// *********************************************************************// + + + IXMLElement2 = interface(IDispatch) ['{2B8DE2FF-8D2D-11D1-B2FC-00C04FD915A9}'] function Get_tagName: WideString; safecall; @@ -1625,11 +1508,9 @@ interface property attributes: IXMLElementCollection read Get_attributes; end; -// *********************************************************************// -// DispIntf: IXMLElement2Disp -// Flags: (4432) Hidden Dual OleAutomation Dispatchable -// GUID: {2B8DE2FF-8D2D-11D1-B2FC-00C04FD915A9} -// *********************************************************************// + + + IXMLElement2Disp = dispinterface ['{2B8DE2FF-8D2D-11D1-B2FC-00C04FD915A9}'] property tagName: WideString dispid 65737; @@ -1645,11 +1526,9 @@ interface property attributes: IXMLElementCollection readonly dispid 65747; end; -// *********************************************************************// -// Interface: IXMLAttribute -// Flags: (4432) Hidden Dual OleAutomation Dispatchable -// GUID: {D4D4A0FC-3B73-11D1-B2B4-00C04FB92596} -// *********************************************************************// + + + IXMLAttribute = interface(IDispatch) ['{D4D4A0FC-3B73-11D1-B2B4-00C04FB92596}'] function Get_name: WideString; safecall; @@ -1658,49 +1537,40 @@ interface property value: WideString read Get_value; end; -// *********************************************************************// -// DispIntf: IXMLAttributeDisp -// Flags: (4432) Hidden Dual OleAutomation Dispatchable -// GUID: {D4D4A0FC-3B73-11D1-B2B4-00C04FB92596} -// *********************************************************************// + + + IXMLAttributeDisp = dispinterface ['{D4D4A0FC-3B73-11D1-B2B4-00C04FB92596}'] property name: WideString readonly dispid 65937; property value: WideString readonly dispid 65938; end; -// *********************************************************************// -// Interface: IXMLError -// Flags: (16) Hidden -// GUID: {948C5AD3-C58D-11D0-9C0B-00C04FC99C8E} -// *********************************************************************// + + + IXMLError = interface(IUnknown) ['{948C5AD3-C58D-11D0-9C0B-00C04FC99C8E}'] function GetErrorInfo(var pErrorReturn: _xml_error): HResult; stdcall; end; -// *********************************************************************// -// The Class CoDOMDocument provides a Create and CreateRemote method to -// create instances of the default interface IXMLDOMDocument exposed by -// the CoClass DOMDocument. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoDOMDocument = class class function Create: IXMLDOMDocument; class function CreateRemote(const MachineName: string): IXMLDOMDocument; end; -// *********************************************************************// -// OLE Server Proxy class declaration -// Server Object : TDOMDocument -// Help String : W3C-DOM XML Document -// Default Interface: IXMLDOMDocument -// Def. Intf. DISP?: No -// Event Interface: XMLDOMDocumentEvents -// TypeFlags : (2) CanCreate -// *********************************************************************// + + + + + + {$IFDEF LIVE_SERVER_AT_DESIGN_TIME} TDOMDocumentProperties= class; {$ENDIF} @@ -1779,12 +1649,11 @@ TDOMDocument = class(TOleServer) end; {$IFDEF LIVE_SERVER_AT_DESIGN_TIME} -// *********************************************************************// -// OLE Server Properties Proxy Class -// Server Object : TDOMDocument -// (This object is used by the IDE's Property Inspector to allow editing -// of the properties of this server) -// *********************************************************************// + + + + + TDOMDocumentProperties = class(TPersistent) private FServer: TDOMDocument; @@ -1820,28 +1689,22 @@ TDOMDocumentProperties = class(TPersistent) {$ENDIF} -// *********************************************************************// -// The Class CoDOMFreeThreadedDocument provides a Create and CreateRemote method to -// create instances of the default interface IXMLDOMDocument exposed by -// the CoClass DOMFreeThreadedDocument. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + CoDOMFreeThreadedDocument = class class function Create: IXMLDOMDocument; class function CreateRemote(const MachineName: string): IXMLDOMDocument; end; -// *********************************************************************// -// OLE Server Proxy class declaration -// Server Object : TDOMFreeThreadedDocument -// Help String : W3C-DOM XML Document (Apartment) -// Default Interface: IXMLDOMDocument -// Def. Intf. DISP?: No -// Event Interface: XMLDOMDocumentEvents -// TypeFlags : (2) CanCreate -// *********************************************************************// + + + + + + {$IFDEF LIVE_SERVER_AT_DESIGN_TIME} TDOMFreeThreadedDocumentProperties= class; {$ENDIF} @@ -1920,12 +1783,11 @@ TDOMFreeThreadedDocument = class(TOleServer) end; {$IFDEF LIVE_SERVER_AT_DESIGN_TIME} -// *********************************************************************// -// OLE Server Properties Proxy Class -// Server Object : TDOMFreeThreadedDocument -// (This object is used by the IDE's Property Inspector to allow editing -// of the properties of this server) -// *********************************************************************// + + + + + TDOMFreeThreadedDocumentProperties = class(TPersistent) private FServer: TDOMFreeThreadedDocument; @@ -1961,28 +1823,22 @@ TDOMFreeThreadedDocumentProperties = class(TPersistent) {$ENDIF} -// *********************************************************************// -// The Class CoXMLHTTPRequest provides a Create and CreateRemote method to -// create instances of the default interface IXMLHttpRequest exposed by -// the CoClass XMLHTTPRequest. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + CoXMLHTTPRequest = class class function Create: IXMLHttpRequest; class function CreateRemote(const MachineName: string): IXMLHttpRequest; end; -// *********************************************************************// -// OLE Server Proxy class declaration -// Server Object : TXMLHTTPRequest -// Help String : XML HTTP Request class. -// Default Interface: IXMLHttpRequest -// Def. Intf. DISP?: No -// Event Interface: -// TypeFlags : (2) CanCreate -// *********************************************************************// + + + + + + {$IFDEF LIVE_SERVER_AT_DESIGN_TIME} TXMLHTTPRequestProperties= class; {$ENDIF} @@ -2038,12 +1894,11 @@ TXMLHTTPRequest = class(TOleServer) end; {$IFDEF LIVE_SERVER_AT_DESIGN_TIME} -// *********************************************************************// -// OLE Server Properties Proxy Class -// Server Object : TXMLHTTPRequest -// (This object is used by the IDE's Property Inspector to allow editing -// of the properties of this server) -// *********************************************************************// + + + + + TXMLHTTPRequestProperties = class(TPersistent) private FServer: TXMLHTTPRequest; @@ -2065,28 +1920,22 @@ TXMLHTTPRequestProperties = class(TPersistent) {$ENDIF} -// *********************************************************************// -// The Class CoXMLDSOControl provides a Create and CreateRemote method to -// create instances of the default interface IXMLDSOControl exposed by -// the CoClass XMLDSOControl. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + CoXMLDSOControl = class class function Create: IXMLDSOControl; class function CreateRemote(const MachineName: string): IXMLDSOControl; end; -// *********************************************************************// -// OLE Server Proxy class declaration -// Server Object : TXMLDSOControl -// Help String : XML Data Source Object -// Default Interface: IXMLDSOControl -// Def. Intf. DISP?: No -// Event Interface: -// TypeFlags : (2) CanCreate -// *********************************************************************// + + + + + + {$IFDEF LIVE_SERVER_AT_DESIGN_TIME} TXMLDSOControlProperties= class; {$ENDIF} @@ -2122,12 +1971,11 @@ TXMLDSOControl = class(TOleServer) end; {$IFDEF LIVE_SERVER_AT_DESIGN_TIME} -// *********************************************************************// -// OLE Server Properties Proxy Class -// Server Object : TXMLDSOControl -// (This object is used by the IDE's Property Inspector to allow editing -// of the properties of this server) -// *********************************************************************// + + + + + TXMLDSOControlProperties = class(TPersistent) private FServer: TXMLDSOControl; @@ -2148,28 +1996,22 @@ TXMLDSOControlProperties = class(TPersistent) {$ENDIF} -// *********************************************************************// -// The Class CoXMLDocument provides a Create and CreateRemote method to -// create instances of the default interface IXMLDocument2 exposed by -// the CoClass XMLDocument. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + CoXMLDocument = class class function Create: IXMLDocument2; class function CreateRemote(const MachineName: string): IXMLDocument2; end; -// *********************************************************************// -// OLE Server Proxy class declaration -// Server Object : TXMLDocument -// Help String : XMLDocument extends IXML Document. It is obsolete. You should use DOMDocument. This object should not be confused with the XMLDocument property on the XML data island. -// Default Interface: IXMLDocument2 -// Def. Intf. DISP?: No -// Event Interface: -// TypeFlags : (2) CanCreate -// *********************************************************************// + + + + + + {$IFDEF LIVE_SERVER_AT_DESIGN_TIME} TXMLDocumentProperties= class; {$ENDIF} @@ -2208,12 +2050,11 @@ TXMLDocument = class(TOleServer) end; {$IFDEF LIVE_SERVER_AT_DESIGN_TIME} -// *********************************************************************// -// OLE Server Properties Proxy Class -// Server Object : TXMLDocument -// (This object is used by the IDE's Property Inspector to allow editing -// of the properties of this server) -// *********************************************************************// + + + + + TXMLDocumentProperties = class(TPersistent) private FServer: TXMLDocument; @@ -2237,9 +2078,6 @@ TXMLDocumentProperties = class(TPersistent) {$ENDIF} -// XML-components should not be regisgtered in Delphi by this unit. -// procedure Register; - implementation uses ComObj; @@ -2328,7 +2166,7 @@ function TDOMDocument.GetServerProperties: TDOMDocumentProperties; procedure TDOMDocument.InvokeEvent(DispID: TDispID; var Params: TVariantArray); begin case DispID of - -1: Exit; // DISPID_UNKNOWN + -1: Exit; 198: if Assigned(FOnondataavailable) then FOnondataavailable(Self); -609: if Assigned(FOnonreadystatechange) then @@ -2690,7 +2528,7 @@ function TDOMFreeThreadedDocument.GetServerProperties: TDOMFreeThreadedDocumentP procedure TDOMFreeThreadedDocument.InvokeEvent(DispID: TDispID; var Params: TVariantArray); begin case DispID of - -1: Exit; // DISPID_UNKNOWN + -1: Exit; 198: if Assigned(FOnondataavailable) then FOnondataavailable(Self); -609: if Assigned(FOnonreadystatechange) then diff --git a/Source/Common/Queue/BoldAbstractDequeuer.pas b/Source/Common/Queue/BoldAbstractDequeuer.pas index bd93fc21..3b0a2ba0 100644 --- a/Source/Common/Queue/BoldAbstractDequeuer.pas +++ b/Source/Common/Queue/BoldAbstractDequeuer.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAbstractDequeuer; interface @@ -12,21 +15,38 @@ TBoldAbstractDequeuer = class; { TBoldAbstractDequeuer } TBoldAbstractDequeuer = class(TBoldSubscribableComponent) - private - fQueue: TBoldThreadSafeStringQueue; protected - procedure HandleMessage(aMsg: String); virtual; abstract; procedure DequeueMessages(Sender: TObject); public destructor Destroy; override; procedure QueueNotEmpty; - procedure DequeueAll; + procedure DequeueAll; virtual; abstract; + end; + + TBoldObjectDequeuer = class(TBoldAbstractDequeuer) + private + fQueue: TBoldThreadSafeObjectQueue; + protected + procedure HandleMessage(const AOSSMessage: TObject); virtual; abstract; + public + procedure DequeueAll; override; + property Queue: TBoldThreadSafeObjectQueue read fQueue write fQueue; + end; + + TBoldStringDequeuer = class(TBoldAbstractDequeuer) + private + fQueue: TBoldThreadSafeStringQueue; + protected + procedure HandleMessage(const aMsg: String); virtual; abstract; + public + procedure DequeueAll; override; property Queue: TBoldThreadSafeStringQueue read fQueue write fQueue; end; implementation uses + Classes, BoldQueue; { TBoldDequeuerHandle } @@ -47,19 +67,25 @@ procedure TBoldAbstractDequeuer.QueueNotEmpty; TBoldQueueable.AddToPreDisplayQueue(DequeueMessages, nil, Self); end; -procedure TBoldAbstractDequeuer.DequeueAll; -var - aMsg: String; +{ TBoldObjectDequeuer } + +procedure TBoldObjectDequeuer.DequeueAll; begin - if Assigned(Queue) then - begin - aMsg := Queue.Dequeue; - while aMsg <> '' do - begin - HandleMessage(aMsg); - aMsg := Queue.Dequeue; - end; - end; + if not Assigned(Queue) or Queue.Empty then + exit; + while not Queue.Empty do + HandleMessage(Queue.Dequeue); end; +{ TBoldStringDequeuer } + +procedure TBoldStringDequeuer.DequeueAll; +begin + if not Assigned(Queue) or Queue.Empty then + exit; + while not Queue.Empty do + HandleMessage(Queue.Dequeue); +end; + + end. diff --git a/Source/Common/Queue/BoldEventQueue.pas b/Source/Common/Queue/BoldEventQueue.pas index fed5d1ed..8e4d7742 100644 --- a/Source/Common/Queue/BoldEventQueue.pas +++ b/Source/Common/Queue/BoldEventQueue.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldEventQueue; interface @@ -24,20 +27,22 @@ TBoldEventQueueItem = class(TBoldMemoryManagedObject) property Event: TNotifyEvent read fEvent; property Sender: Tobject read fSender; property Receiver: TObject read fReceiver; - procedure SendEvent; + procedure SendEvent; {$IFDEF BOLD_INLINE} inline; {$ENDIF} end; { TBoldEventQueue } TBoldEventQueue = class(TBoldMemoryManagedObject) private fItemIndex: TBoldEventQueueItemReceiverIndex; + function GetCount: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public constructor Create; destructor Destroy; override; procedure Add(Event: TNotifyEvent; Sender: TObject; Receiver: TObject); - procedure DequeueOne; + procedure DequeueOne; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure DequeueAll; procedure RemoveAllForReceiver(Receiver: TObject); + property Count: integer read GetCount; end; { TBoldEventQueueItemReceiverIndex } @@ -79,26 +84,26 @@ constructor TBoldEventQueue.Create; fItemIndex := TBoldEventQueueItemReceiverIndex.Create; end; -procedure TBoldEventQueue.DequeueAll; -var - InternalCount, - i: Integer; +function TBoldEventQueue.GetCount: integer; begin - InternalCount := fItemIndex.Count; - for i := 0 to InternalCount - 1 do - DequeueOne; + result := fItemIndex.Count; end; procedure TBoldEventQueue.DequeueOne; var item: TBoldEventQueueItem; begin - item := TBoldEventQueueItem(fItemIndex.Any); - fItemIndex.Remove(item); + item := TBoldEventQueueItem(fItemIndex.GetAndRemoveAny); item.SendEvent; Item.Free; end; +procedure TBoldEventQueue.DequeueAll; +begin + while Count > 0 do + DequeueOne; +end; + destructor TBoldEventQueue.Destroy; begin FreeAndNil(fItemIndex); @@ -112,6 +117,8 @@ procedure TBoldEventQueue.RemoveAllForReceiver(Receiver: TObject); MatchingItems: TList; g: IBoldGuard; begin + if fItemIndex.Count = 0 then + exit; g := TBoldGuard.Create(MatchingItems); MatchingItems := TList.Create; fItemIndex.FindAllByObject(Receiver, MatchingItems); @@ -130,4 +137,6 @@ function TBoldEventQueueItemReceiverIndex.ItemASKeyObject(Item: TObject): TObjec result := TBoldEventQueueItem(Item).Receiver; end; +initialization + end. diff --git a/Source/Common/Queue/BoldQueue.pas b/Source/Common/Queue/BoldQueue.pas index b90d04c5..f478fd23 100644 --- a/Source/Common/Queue/BoldQueue.pas +++ b/Source/Common/Queue/BoldQueue.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldQueue; interface @@ -11,8 +14,11 @@ interface { Queueable } befIsInDisplayList = BoldElementFlag0; befStronglyDependedOfPrioritized = BoldElementFlag1; +{$IFDEF BoldQueue_Optimization} + befToBeRemovedFromDisplayList = BoldElementFlag2; +{$ENDIF} { Follower } - befFollowerSelected = BoldElementFlag2; + befFollowerSelected = BoldElementFlag3; type { forward declarations } @@ -30,13 +36,17 @@ TBoldQueueable = class(TBoldFlaggedObject) procedure AddToApplyList; procedure RemoveFromApplyList; procedure AddToDisplayList; virtual; - procedure RemoveFromDisplayList; + procedure RemoveFromDisplayList(ADestroying: boolean); function MostPrioritizedQueuable: TBoldQueueable; function MostPrioritizedQueuableOrSelf: TBoldQueueable; function AfterInPriority(Queueable: TBoldQueueable): Boolean; procedure Display; virtual; abstract; function StronglyPrioritizedSibbling(Queueable: TBoldQueueable): Boolean; +{$IFDEF BoldQueue_Optimization} + property ToBeRemovedFromDisplayList: Boolean index befToBeRemovedFromDisplayList read GetElementFlag write SetElementFlag; +{$ENDIF} class function DisplayOne: Boolean; + function GetDebugInfo: string; override; public constructor Create(aMatchObject: TObject); destructor Destroy; override; @@ -45,8 +55,11 @@ TBoldQueueable = class(TBoldFlaggedObject) class procedure ApplyAllMatching(anObject: TObject); class procedure DiscardChangeAll; class procedure DiscardChangeAllMatching(anObject: TObject); - class procedure AddToPreDisplayQueue(Event: TNotifyEvent; Sender: TObject; Receiver: TObject); - class procedure RemoveFromPreDisplayQueue(Receiver: TObject); + class procedure AddToPreDisplayQueue(Event: TNotifyEvent; Sender: TObject; Receiver: TObject); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + class procedure AddToPostDisplayQueue(Event: TNotifyEvent; Sender: TObject; Receiver: TObject); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + class procedure RemoveFromPreDisplayQueue(Receiver: TObject); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + class function IsDisplayQueueEmpty: Boolean; + class function IsDisplaying: Boolean; procedure Apply; virtual; abstract; procedure DiscardChange; virtual; abstract; property MatchObject: TObject read fMatchObject; @@ -61,36 +74,53 @@ TBoldQueue = class(TBoldMemoryManagedObject) fIsDisplaying: Boolean; fDisplayMode: TBoldQueueDisplayMode; fPreDisplayQueue: TBoldEventQueue; + fPostDisplayQueue: TBoldEventQueue; fDisplayList: TList; fApplyList: TList; +{$IFDEF BoldQueue_Optimization} + fDisplayListIndex: Integer; +{$ENDIF} + function GetApplyCount: integer; + function GetDisplayCount: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetPostDisplayCount: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetPreDisplayCount: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetEmpty: boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected function DisplayOne: Boolean; function DisplayAll: Boolean; procedure AddToApplyList(Queueable: TBoldQueueable); procedure RemoveFromApplyList(Queueable: TBoldQueueable); procedure AddToDisplayList(Queueable: TBoldQueueable); - procedure RemoveFromDisplayList(Queueable: TBoldQueueable); + procedure RemoveFromDisplayList(Queueable: TBoldQueueable; ADestroying: boolean); procedure EnsureDequeing; virtual; public constructor Create; virtual; destructor Destroy; override; procedure AddEventToPredisplayQueue(Event: TNotifyEvent; Sender: TObject; Receiver: TObject); - procedure RemoveFromPreDisplayQueue(Receiver: TObject); + procedure AddEventToPostDisplayQueue(Event: TNotifyEvent; Sender: TObject; Receiver: TObject); + procedure RemoveFromPreDisplayQueue(Receiver: TObject); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure RemoveFromPostDisplayQueue(Receiver: TObject); procedure PerformPreDisplayQueue; + procedure PerformPostDisplayQueue; procedure DeActivateDisplayQueue; virtual; abstract; procedure ActivateDisplayQueue; virtual; abstract; property DisplayMode: TBoldQueueDisplayMode read fDisplayMode write fDisplayMode; + property DisplayCount: integer read GetDisplayCount; + property ApplyCount: integer read GetApplyCount; + property PreDisplayCount: integer read GetPreDisplayCount; + property PostDisplayCount: integer read GetPostDisplayCount; + property Empty: boolean read GetEmpty; end; - function BoldQueueFinalized: Boolean; - function BoldInstalledQueue: TBoldQueue; + function BoldQueueFinalized: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function BoldInstalledQueue: TBoldQueue; {$IFDEF BOLD_INLINE} inline; {$ENDIF} implementation uses SysUtils, BoldUtils, - Forms, // Application object + Forms, BoldEnvironment, BoldGuard; @@ -101,10 +131,7 @@ function BoldQueueFinalized: Boolean; function BoldInstalledQueue: TBoldQueue; begin - if not BoldEnvironmentsFinalized then - Result := BoldEffectiveEnvironment.Queue - else - Result := nil; + result := BoldEnvironment.BoldInstalledQueue; end; { TBoldQuable } @@ -118,11 +145,22 @@ constructor TBoldQueueable.Create(aMatchObject: TObject); destructor TBoldQueueable.Destroy; begin RemoveFromApplyList; - if IsInDisplayList then - RemoveFromDisplayList; + RemoveFromDisplayList(true); +{$IFDEF BoldQueue_Optimization} + Assert(not (IsInDisplayList or ToBeRemovedFromDisplayList)); +{$ELSE} + Assert(not IsInDisplayList); +{$ENDIF} inherited Destroy; end; +function TBoldQueueable.GetDebugInfo: string; +begin + result := Format('%s', [className]); + if Assigned(MatchObject) then + result := result + ' (' + MatchObject.ClassName + ')'; +end; + procedure TBoldQueueable.AddToApplyList; begin if not (BoldQueueFinalized) then @@ -140,16 +178,27 @@ procedure TBoldQueueable.AddToDisplayList; if not BoldQueueFinalized then begin Assert(not IsInDisplayList); - BoldInstalledQueue.AddToDisplayList(self); +{$IFDEF BoldQueue_Optimization} + if ToBeRemovedFromDisplayList then + ToBeRemovedFromDisplayList := false + else +{$ENDIF} + BoldInstalledQueue.AddToDisplayList(self); SetElementflag(befIsInDisplayList, True); end; end; -procedure TBoldQueueable.RemoveFromDisplayList; +procedure TBoldQueueable.RemoveFromDisplayList(ADestroying: boolean); begin - if not (BoldQueueFinalized) then - BoldInstalledQueue.RemoveFromDisplayList(self); - SetElementflag(befIsInDisplayList, False); +{$IFDEF BoldQueue_Optimization} + if not (BoldQueueFinalized) and (IsInDisplayList or ToBeRemovedFromDisplayList) then +{$ELSE} + if not BoldQueueFinalized and IsInDisplayList then +{$ENDIF} + begin + BoldInstalledQueue.RemoveFromDisplayList(self, ADestroying); + SetElementflag(befIsInDisplayList, False); + end; end; function TBoldQueueable.MostPrioritizedQueuableOrSelf: TBoldQueueable; @@ -168,13 +217,17 @@ function TBoldQueueable.MostPrioritizedQueuable: TBoldQueueable; begin Result := PrioritizedQueuable.MostPrioritizedQueuableOrSelf; if not Assigned(Result) and StronglyDependedOfPrioritized then - for i := 0 to BoldInstalledQueue.fDisplayList.Count - 1 do + with BoldInstalledQueue do + for i := fDisplayList.Count - 1 downto 0 do begin - Queueable := BoldInstalledQueue.fDisplayList[i]; + Queueable := fDisplayList[i]; if assigned(Queueable) and +{$IFDEF BoldQueue_Optimization} + Queueable.IsInDisplayList and +{$ENDIF} Queueable.AfterInPriority(PrioritizedQueuable) and not StronglyPrioritizedSibbling(Queueable) and - not Queueable.AfterInPriority(self) then // will also eliminate self + not Queueable.AfterInPriority(self) then begin Result := Queueable.MostPrioritizedQueuableOrSelf; break; @@ -187,50 +240,59 @@ function TBoldQueueable.MostPrioritizedQueuable: TBoldQueueable; class function TBoldQueueable.DisplayOne: Boolean; begin - if BoldInstalledQueue <> nil then - Result := BoldInstalledQueue.DisplayOne - else - Result := False; + Result := (BoldInstalledQueue <> nil) and BoldInstalledQueue.DisplayOne; end; class function TBoldQueueable.DisplayAll: Boolean; begin - Result := (BoldInstalledQueue <> nil) and (BoldInstalledQueue.fDisplayList.Count <> 0); + Result := DisplayOne; if Result then while DisplayOne do {nothing}; end; +class function TBoldQueueable.IsDisplaying: Boolean; +begin + Result := (BoldInstalledQueue <> nil) and BoldInstalledQueue.fIsDisplaying; +end; + +class function TBoldQueueable.IsDisplayQueueEmpty: Boolean; +begin + Result := (BoldInstalledQueue = nil) or (BoldInstalledQueue.fDisplayList.Count = 0); +end; + class procedure TBoldQueueable.ApplyAll; var Queueable: TBoldQueueable; tempList: TList; i: integer; g: IBoldGuard; + vApplyList: TList; begin g := TBoldGuard.Create(TempList); if BoldInstalledQueue <> nil then begin tempList := TList.Create; - while BoldInstalledQueue.fApplyList.Count > 0 do + vApplyList := BoldInstalledQueue.fApplyList; + while vApplyList.Count > 0 do begin - Queueable := BoldInstalledQueue.fApplyList.Last; + Queueable := vApplyList.Last; if Assigned(Queueable) then begin - Queueable.Apply; // This will remove object from list - if (BoldInstalledQueue.fApplyList.Count > 0) and (Queueable = BoldInstalledQueue.fApplyList.LAst) then + Queueable.Apply; + if (vApplyList.Count > 0) and (Queueable = vApplyList.Last) then begin // for some reason the apply failed, // remove the queueable from the applylist and put it back when it is empty... TempList.Add(Queueable); - BoldInstalledQueue.fApplyList.Count := BoldInstalledQueue.fApplyList.Count - 1; + vApplyList.Count := vApplyList.Count - 1; end; end else - BoldInstalledQueue.fApplyList.Count := BoldInstalledQueue.fApplyList.Count - 1; //Skip nil items + vApplyList.Count := vApplyList.Count - 1; end; for i := 0 to TempList.Count - 1 do - BoldInstalledQueue.fApplyList.Add(TempList[i]); + vApplyList.Add(TempList[i]); end; end; @@ -240,11 +302,12 @@ class procedure TBoldQueueable.ApplyAllMatching(anObject: TObject); I: Integer; begin if BoldInstalledQueue <> nil then - for I := BoldInstalledQueue.fApplyList.Count - 1 downto 0 do + with BoldInstalledQueue do + for I := fApplyList.Count - 1 downto 0 do begin - Queueable := TBoldQueueable(BoldInstalledQueue.fApplyList[I]); + Queueable := TBoldQueueable(fApplyList[I]); if Assigned(Queueable) and (Queueable.MatchObject = anObject) then - Queueable.Apply; // This will remove from list + Queueable.Apply; end; end; @@ -254,11 +317,12 @@ class procedure TBoldQueueable.DiscardChangeAll; I: Integer; begin if BoldInstalledQueue <> nil then - for I := BoldInstalledQueue.fApplyList.Count - 1 downto 0 do + with BoldInstalledQueue do + for I := fApplyList.Count - 1 downto 0 do begin - Queueable := TBoldQueueable(BoldInstalledQueue.fApplyList[I]); + Queueable := TBoldQueueable(fApplyList[I]); if Assigned(Queueable) then - Queueable.DiscardChange; // This will remove from list + Queueable.DiscardChange; end; end; @@ -268,14 +332,22 @@ class procedure TBoldQueueable.DiscardChangeAllMatching(anObject: TObject); I: Integer; begin if BoldInstalledQueue <> nil then - for I := BoldInstalledQueue.fApplyList.Count - 1 downto 0 do + with BoldInstalledQueue do + for I := fApplyList.Count - 1 downto 0 do begin - Queueable := TBoldQueueable(BoldInstalledQueue.fApplyList[I]); + Queueable := TBoldQueueable(fApplyList[I]); if Assigned(Queueable) and (Queueable.MatchObject = anObject) then - Queueable.DiscardChange; // This will remove from list + Queueable.DiscardChange; end; end; +class procedure TBoldQueueable.AddToPostDisplayQueue(Event: TNotifyEvent; + Sender, Receiver: TObject); +begin + if not BoldQueueFinalized then + BoldInstalledQueue.AddEventToPostDisplayQueue(Event, Sender, Receiver); +end; + class procedure TBoldQueueable.AddToPreDisplayQueue(Event: TNotifyEvent; Sender, Receiver: TObject); begin @@ -291,6 +363,13 @@ class procedure TBoldQueueable.RemoveFromPreDisplayQueue(Receiver: TObject); { TBoldQueue } +procedure TBoldQueue.AddEventToPostDisplayQueue(Event: TNotifyEvent; Sender, + Receiver: TObject); +begin + fPostDisplayQueue.Add(Event, Sender, Receiver); + EnsureDequeing; +end; + procedure TBoldQueue.AddEventToPredisplayQueue(Event: TNotifyEvent; Sender, Receiver: TObject); begin @@ -313,12 +392,10 @@ constructor TBoldQueue.Create; begin inherited; fPreDisplayQueue := TBoldEventQueue.Create; + fPostDisplayQueue := TBoldEventQueue.Create; fDisplayList := TList.Create; fApplyList := TList.Create; - if BoldRunningAsDesignTimePackage then - DisplayMode := dmDisplayAll - else - DisplayMode := dmDisplayOne; + DisplayMode := dmDisplayAll; ActivateDisplayQueue; end; @@ -327,6 +404,7 @@ destructor TBoldQueue.Destroy; FreeAndNil(fDisplayList); FreeAndNil(fApplyList); FreeAndNil(fPreDisplayQueue); + FreeAndNil(fPostDisplayQueue); inherited; end; @@ -336,39 +414,87 @@ function TBoldQueue.DisplayAll: Boolean; end; function TBoldQueue.DisplayOne: Boolean; +{$IFDEF BoldQueue_Optimization} +var + Queueable, vPrioritizedQueuable: TBoldQueueable; +begin + result := not fIsDisplaying and (fDisplayList.Count > 0); + if result then + begin + Queueable := nil; + fIsDisplaying := true; + try + while (fDisplayListIndex < fDisplayList.Count) do + begin + Queueable := TBoldQueueable(fDisplayList[fDisplayListIndex]); + + if not Assigned(Queueable) then + inc(fDisplayListIndex) + else + if not Queueable.IsInDisplayList then + begin + fDisplayList[fDisplayListIndex] := nil; + Queueable.ToBeRemovedFromDisplayList := false; + inc(fDisplayListIndex); + end + else + break; + end; + if fDisplayListIndex < fDisplayList.Count then + begin + vPrioritizedQueuable := Queueable.MostPrioritizedQueuableOrSelf; + if Queueable = vPrioritizedQueuable then + begin + Queueable.Display; + if Queueable.ToBeRemovedFromDisplayList and (fDisplayList[fDisplayListIndex] = Queueable) then + begin + fDisplayList[fDisplayListIndex] := nil; + Queueable.ToBeRemovedFromDisplayList := false; + end; + end + else + vPrioritizedQueuable.Display; + end; + finally + fIsDisplaying := false; + if fDisplayListIndex >= fDisplayList.Count then + begin + fDisplayListIndex := 0; + fDisplayList.Count := 0; + end; + end; + end; +end; +{$ELSE} var Index: Integer; ExchangeWith, Queueable: TBoldQueueable; begin - if fIsDisplaying then + if fIsDisplaying or (fDisplayList.Count = 0) then result := false else begin fIsDisplaying := true; try Queueable := nil; - //Remove Empty slots from the end of the queue. while (fDisplayList.Count>0) and (fDisplayList.Last=nil) do fDisplayList.Count := fDisplayList.Count - 1; Result := fDisplayList.Count>0; if Result then begin try - //Check if there is a queueable that must be displayed before. ExchangeWith := TBoldQueueable(fDisplayList.Last).MostPrioritizedQueuable; if Assigned(ExchangeWith) then begin - //Exchange place Index := fDisplayList.IndexOf(ExchangeWith); if Index <> -1 then fDisplayList.Exchange(Index, fDisplayList.Count - 1); end; - //Display Last queueable in list. Queueable := TBoldQueueable(fDisplayList.Last); Queueable.Display; except - Application.HandleException(Queueable); + raise; // patch this used to directly call Application.HandleException(Queueable); end; end; finally @@ -376,6 +502,7 @@ function TBoldQueue.DisplayOne: Boolean; end; end; end; +{$ENDIF} function TBoldQueueable.AfterInPriority(Queueable: TBoldQueueable): Boolean; begin @@ -399,6 +526,36 @@ procedure TBoldQueue.EnsureDequeing; end; +function TBoldQueue.GetApplyCount: integer; +begin + result := fApplyList.Count; +end; + +function TBoldQueue.GetDisplayCount: integer; +begin + result := fDisplayList.Count; +end; + +function TBoldQueue.GetPreDisplayCount: integer; +begin + result := fPreDisplayQueue.Count; +end; + +function TBoldQueue.GetPostDisplayCount: integer; +begin + result := fPostDisplayQueue.Count; +end; + +function TBoldQueue.GetEmpty: boolean; +begin + result := (DisplayCount = 0) and (ApplyCount = 0) and (PreDisplayCount = 0) and (PostDisplayCount = 0); +end; + +procedure TBoldQueue.PerformPostDisplayQueue; +begin + fPostDisplayQueue.DequeueAll; +end; + procedure TBoldQueue.PerformPreDisplayQueue; begin fPreDisplayQueue.DequeueAll; @@ -408,11 +565,9 @@ procedure TBoldQueue.RemoveFromApplyList(Queueable: TBoldQueueable); var index: integer; begin - //Implemented own IndexOf because it is more effective to search the list from the end in this case. Index := fApplyList.Count - 1; - while (Index >= 0) and (fApplyList.List[Index] <> Queueable) do // marco + while (Index >= 0) and (fApplyList.List[Index] <> Queueable) do Dec(Index); - //Insert nil element in list or decrement count if it's the last object if Index > -1 then if Index = fApplyList.Count - 1 then fApplyList.Count := fApplyList.Count - 1 @@ -420,25 +575,49 @@ procedure TBoldQueue.RemoveFromApplyList(Queueable: TBoldQueueable); fApplyList[Index] := nil; end; -procedure TBoldQueue.RemoveFromDisplayList(Queueable: TBoldQueueable); +procedure TBoldQueue.RemoveFromDisplayList(Queueable: TBoldQueueable; ADestroying: boolean); var index: integer; begin - //Implemented own IndexOf because it is more effective to search the list from the end in this case. - Index := fdisplayList.Count - 1; - while (Index >=0 ) and (fdisplayList.List[Index] <> Queueable) do // marco removed ^ (also above) +// Log('R:'+Queueable.ClassName); +{$IFDEF BoldQueue_Optimization} + if (fDisplayList.Last = Queueable) then + begin + Queueable.ToBeRemovedFromDisplayList := false; + fDisplayList.Delete(fDisplayList.Count-1); + exit; + end; + if not ADestroying then + begin + Queueable.ToBeRemovedFromDisplayList := true; + exit; + end; +{$ENDIF} + Index := fDisplayList.Count - 1; + while (Index >=0 ) and (fDisplayList.List[Index] <> Queueable) do Dec(Index); - //Insert nil element in list or decrement count if it's the last object if Index > -1 then + begin +{$IFDEF BoldQueue_Optimization} + Queueable.ToBeRemovedFromDisplayList := false; +{$ENDIF} if Index = fdisplayList.Count - 1 then - fdisplayList.Count := fdisplayList.Count - 1 + fDisplayList.Count := fDisplayList.Count - 1 else - fdisplayList[Index] := nil; + fDisplayList[Index] := nil; + end; +end; + +procedure TBoldQueue.RemoveFromPostDisplayQueue(Receiver: TObject); +begin + fPostDisplayQueue.RemoveAllForReceiver(Receiver); end; procedure TBoldQueue.RemoveFromPreDisplayQueue(Receiver: TObject); begin - fPreDisplayQueue.RemoveAllForReceiver(Receiver); + fPreDisplayQueue.RemoveAllForReceiver(Receiver); end; +initialization + end. diff --git a/Source/Common/Rose2000/BoldRose2000Support.pas b/Source/Common/Rose2000/BoldRose2000Support.pas index 2638f26f..e27a797f 100644 --- a/Source/Common/Rose2000/BoldRose2000Support.pas +++ b/Source/Common/Rose2000/BoldRose2000Support.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldRose2000Support; interface @@ -70,27 +73,29 @@ implementation BoldLogHandler, BoldDefs, BoldUtils, - BoldDefaultTaggedValues, - BoldCommonConst; + BoldDefaultTaggedValues; function StringToBoolean(inString: String): Boolean; begin Result := False; - if (UpperCase(inString)= 'Y') or (UpperCase(inString) = 'T') or (UpperCase(inString) = 'TRUE') then // do not localize + if (UpperCase(inString)= 'Y') or (UpperCase(inString) = 'T') or (UpperCase(inString) = 'TRUE') then Result := True; end; function BooleanToString(inValue: Boolean): String; begin if inValue then - Result := 'True' // do not localize + Result := 'True' else - Result := 'False'; // do not localize + Result := 'False'; end; class function TBoldRose2000Support.BooleanToString(Value: Boolean): string; begin - Result := BooleanToString(Value); + if Value then + Result := 'True' + else + Result := 'False'; end; class function TBoldRose2000Support.FindClassByName(RoseModel: IRoseModel; const Name: string): IRoseClass; @@ -104,7 +109,7 @@ class function TBoldRose2000Support.FindClassByName(RoseModel: IRoseModel; const begin Result := ClsCol.GetAt(1); if ClsCol.Count > 1 then - raise EBoldImport.CreateFmt(sClassNameNotUnique, [Name]); + raise EBoldImport.CreateFmt('Found multiple classes with name %s, don''t know which one to use', [Name]); end; end; @@ -129,7 +134,7 @@ class function TBoldRose2000Support.GetApplication: IRoseApplication; class function TBoldRose2000Support.GetCalculatedAssociationName(RoseAssociation: IRoseAssociation; const PluralSuffix: string): string; begin - Result := Format('%s%s', // do not localize + Result := Format('%s%s', [GetEffectiveRoleName(RoseAssociation.Role1,PluralSuffix), GetEffectiveRoleName(RoseAssociation.Role2,PluralSuffix)]); end; @@ -145,9 +150,9 @@ class function TBoldRose2000Support.GetCalculatedRoleName(RoseRole: IRoseRole; c else otherRole := RoseRole.Association.Role1; if assigned(RoseRole) and assigned(RoseRole.Class_) then - result := 'x_' + otherRole.Name + '_' + RoseRole.Class_.Name // do not localize + result := 'x_' + otherRole.Name + '_' + RoseRole.Class_.Name else - result := 'x_' + otherRole.Name + '_unknown'; // do not localize + result := 'x_' + otherRole.Name + '_unknown'; end else begin @@ -179,12 +184,12 @@ class function TBoldRose2000Support.GetEffectiveMultiplicity(RoseRole: IRoseRole Result := RoseRole.Cardinality; Trim(Result); if Result = '' then - Result := '0..1' // do not localize + Result := '0..1' else Result := StringReplace(Result, 'n', '*', [rfReplaceAll]); if Length(Result) < 2 then - Result := '0..' + Result; // do not localize + Result := '0..' + Result; end; class function TBoldRose2000Support.ParametersToSignature(Parameters: IRoseParameterCollection): string; @@ -202,7 +207,7 @@ class function TBoldRose2000Support.ParametersToSignature(Parameters: IRoseParam else Result := Result + '; '; Parameter := Parameters.GetAt(P) as IRoseParameter; - Result := Result + Format('%s: %s',[Parameter.Name, Parameter.Type_]); // do not localize + Result := Result + Format('%s: %s',[Parameter.Name, Parameter.Type_]); end; end; @@ -236,7 +241,7 @@ function TBoldRose2000Properties.GetBooleanString(RoseItem: IRoseItem; const Nam Result := DefaultValue else begin - if AnsiCompareText(Value, 'True') = 0 then // do not localize + if AnsiCompareText(Value, 'True') = 0 then Result := TV_TRUE else Result := TV_FALSE; @@ -254,7 +259,7 @@ function TBoldRose2000Properties.GetBoolean(RoseItem: IRoseItem; const Name: str if Value = '' then Result := DefaultValue else - Result := (AnsiCompareText(Value, 'True') = 0); // do not localize + Result := (AnsiCompareText(Value, 'True') = 0); end; function TBoldRose2000Properties.GetDefaultPropertyBoolean(RoseModel: IRoseModel; PropName: String): Boolean; @@ -265,7 +270,7 @@ function TBoldRose2000Properties.GetDefaultPropertyBoolean(RoseModel: IRoseModel Prop: IRoseProperty; begin DefaultProps := RoseModel.DefaultProperties; - PropCollection := DefaultProps.GetDefaultPropertySet(RoseModel.GetPropertyClassName, ToolName, DEFAULTVALUE); + PropCollection := DefaultProps.GetDefaultPropertySet(RoseModel.GetPropertyClassName, ToolName, 'default'); Index := PropCollection.FindFirst(PropName); if Index > 0 then @@ -286,7 +291,7 @@ function TBoldRose2000Properties.GetDefaultPropertyString(RoseModel: IRoseModel; Prop: IRoseProperty; begin DefaultProps := RoseModel.DefaultProperties; - PropCollection := DefaultProps.GetDefaultPropertySet(RoseModel.GetPropertyClassName, ToolName, DEFAULTVALUE); + PropCollection := DefaultProps.GetDefaultPropertySet(RoseModel.GetPropertyClassName, ToolName, 'default'); Index := PropCollection.FindFirst(PropName); if Index > 0 then @@ -305,14 +310,13 @@ procedure TBoldRose2000Properties.SetDefaultPropertyBoolean(RoseModel: IRoseMode Prop: IRoseProperty; begin DefaultProps := RoseModel.DefaultProperties; - PropCollection := DefaultProps.GetDefaultPropertySet(RoseModel.GetPropertyClassName, ToolName, DEFAULTVALUE); + PropCollection := DefaultProps.GetDefaultPropertySet(RoseModel.GetPropertyClassName, ToolName, 'default'); Index := PropCollection.FindFirst(PropName); if Index > 0 then Prop := PropCollection.GetAt(Index) else Exit; - //ShowMessage('Fel'); Prop.Value := BooleanToString(PropValue); end; @@ -325,7 +329,7 @@ procedure TBoldRose2000Properties.SetDefaultPropertyString(RoseModel: IRoseModel Prop: IRoseProperty; begin DefaultProps := RoseModel.DefaultProperties; - PropCollection := DefaultProps.GetDefaultPropertySet(RoseModel.GetPropertyClassName, ToolName, DEFAULTVALUE); + PropCollection := DefaultProps.GetDefaultPropertySet(RoseModel.GetPropertyClassName, ToolName, 'default'); Index := PropCollection.FindFirst(PropName); if Index > 0 then @@ -374,7 +378,7 @@ procedure TBoldRose2000Properties.SetBooleanString(RoseItem: IRoseItem; const Na begin if GetBooleanString(RoseItem, Name, DefaultValue) <> Value then begin - BoldLog.LogFmt(sSettingValue, [LoggString, Name, Value]); + BoldLog.LogFmt('Setting %s.%s to %s', [LoggString, Name, Value]); RoseItem.OverrideProperty(ToolName, Name, Value); end; end; @@ -387,7 +391,7 @@ procedure TBoldRose2000Properties.SetBoolean(RoseItem: IRoseItem; begin if GetBoolean(RoseItem, Name, DefaultValue) <> Value then begin - BoldLog.LogFmt(sSettingValue, [LoggString, Name, TBoldRose2000Support.BooleanToString(Value)]); + BoldLog.LogFmt('Setting %s.%s to %s', [LoggString, Name, TBoldRose2000Support.BooleanToString(Value)]); RoseItem.OverrideProperty(ToolName, Name, TBoldRose2000Support.BooleanToString(Value)); end; end; @@ -400,7 +404,7 @@ procedure TBoldRose2000Properties.SetInteger(RoseItem: IRoseItem; begin if GetInteger(RoseItem, Name, DefaultValue) <> Value then begin - BoldLog.LogFmt(sSettingValue, [LoggString, Name, IntToStr(Value)]); + BoldLog.LogFmt('Setting %s.%s to %s', [LoggString, Name, IntToStr(Value)]); RoseItem.OverrideProperty(ToolName, Name, IntToStr(Value)); end end; @@ -410,7 +414,7 @@ procedure TBoldRose2000Properties.SetString(RoseItem: IRoseItem; const Name, Def begin if AnsiCompareText(GetString(RoseItem, Name, DefaultValue),Value) <> 0 then begin - BoldLog.LogFmt(sSettingValue, [LoggString, Name, Value]); + BoldLog.LogFmt('Setting %s.%s to %s', [LoggString, Name, Value]); RoseItem.OverrideProperty(ToolName, Name, Value); end; end; @@ -420,7 +424,7 @@ procedure TBoldRose2000Properties.SetText(RoseItem: IRoseItem; const Name, Defau begin if AnsiCompareText(GetString(RoseItem, Name, DefaultValue),Value) <> 0 then begin - BoldLog.LogFmt(sSettingValue, [LoggString, Name, Value]); + BoldLog.LogFmt('Setting %s.%s to %s', [LoggString, Name, Value]); RoseItem.OverrideProperty(ToolName, Name, Value); end; end; @@ -467,7 +471,7 @@ class function TBoldRose2000Support.RoseExportControlToVisibility(ExportControl: 1: Result := vkProtected; 2: Result := vkPrivate; else - BoldLog.Log(sUnknownVisibility); + BoldLog.Log('Unknown visibility, public is set.'); end; end; @@ -481,4 +485,6 @@ class procedure TBoldRose2000Support.SetExportControl(Visibility: TVisibilityKin end; end; +initialization + end. diff --git a/Source/Common/Rose2000/RationalRose2000_TLB.pas b/Source/Common/Rose2000/RationalRose2000_TLB.pas index 972701b0..2597a784 100644 --- a/Source/Common/Rose2000/RationalRose2000_TLB.pas +++ b/Source/Common/Rose2000/RationalRose2000_TLB.pas @@ -1,45 +1,41 @@ + +{ Global compiler directives } +{$include bold.inc} unit RationalRose2000_TLB; +{$INCLUDE Bold.inc} {$WARNINGS OFF} {$WARN SYMBOL_PLATFORM OFF} -// ************************************************************************ // -// WARNING -// ------- -// The types declared in this file were generated from data read from a -// Type Library. If this type library is explicitly or indirectly (via -// another type library referring to this type library) re-imported, or the -// 'Refresh' command of the Type Library Editor activated while editing the -// Type Library, the contents of this file will be regenerated and all -// manual modifications will be lost. -// ************************************************************************ // - -// PASTLWTR: 1.1 -// File generated on 2000-03-16 14:06:15 from Type Library described below. - -// ************************************************************************ // -// Type Lib: C:\Program Files\Rational\Rose 2000\rationalrose.tlb (1) -// IID\LCID: {860CC660-1C2B-11D0-B1B1-444553540000}\0 -// Helpfile: -// DepndLst: -// (1) v1.0 stdole, (C:\WINNT\System32\stdole32.tlb) -// (2) v1.0 StdVCL, (C:\WINNT\System32\STDVCL32.DLL) -// ************************************************************************ // -{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. + + + + + + + + + + + + + + + + + +{$TYPEDADDRESS OFF} interface uses Windows, ActiveX, Classes, Graphics, OleCtrls, StdVCL; -// *********************************************************************// -// GUIDS declared in the TypeLibrary. Following prefixes are used: -// Type Libraries : LIBID_xxxx -// CoClasses : CLASS_xxxx -// DISPInterfaces : DIID_xxxx -// Non-DISP interfaces: IID_xxxx -// *********************************************************************// + + + + + const - // TypeLibrary Major and minor versions RationalRoseMajorVersion = 4; RationalRoseMinorVersion = 2; @@ -318,16 +314,12 @@ interface DIID_IRoseExternalDocument: TGUID = '{906FF583-276B-11D0-8980-00A024774419}'; CLASS_RoseExternalDocument: TGUID = '{86652277-EBF7-11D0-BC10-00A024C67143}'; -// *********************************************************************// -// Declaration of Enumerations defined in Type Library -// *********************************************************************// -// Constants for enum RoseAddinEventTypes + + type RoseAddinEventTypes = TOleEnum; const rsOnNewModel = $00000002; - -// Constants for enum RoseContextMenuItemType type RoseContextMenuItemType = TOleEnum; const @@ -350,30 +342,22 @@ interface rsSynchronization = $00000010; rsDecision = $00000011; rsSwimlane = $00000012; - -// Constants for enum RoseNotationTypes type RoseNotationTypes = TOleEnum; const BoochNotation = $00000000; OMTNotation = $00000001; UMLNotation = $00000002; - -// Constants for enum RoseClientRelKind type RoseClientRelKind = TOleEnum; const rsAnyKind = $00000000; rsFriend = $00000001; - -// Constants for enum RosePersistence type RosePersistence = TOleEnum; const rsPersistent = $00000000; rsTransient = $00000001; - -// Constants for enum RoseSynchronization type RoseSynchronization = TOleEnum; const @@ -382,15 +366,11 @@ interface rsBalking = $00000002; rsTimeout = $00000003; rsAsynchronous = $00000004; - -// Constants for enum RoseFrequency type RoseFrequency = TOleEnum; const rsAperiodic = $00000000; rsPeriodic = $00000001; - -// Constants for enum RoseClientRelType type RoseClientRelType = TOleEnum; const @@ -401,8 +381,6 @@ interface rsTypeAssociation = $00000004; rsTypeDependency = $00000005; rsTypeRealizes = $00000006; - -// Constants for enum RoseMenuState type RoseMenuState = TOleEnum; const @@ -415,9 +393,7 @@ interface type -// *********************************************************************// -// Forward declaration of types defined in TypeLibrary -// *********************************************************************// + IRoseActivityViewCollection = dispinterface; IRoseProcessorCollection = dispinterface; IRoseCategoryCollection = dispinterface; @@ -555,10 +531,8 @@ interface IRosePackageCollection = dispinterface; IRoseExternalDocument = dispinterface; -// *********************************************************************// -// Declaration of CoClasses defined in Type Library -// (NOTE: Here we map each CoClass to its Default Interface) -// *********************************************************************// + + RoseActivityViewCollection = IRoseActivityViewCollection; RoseProcessorCollection = IRoseProcessorCollection; RoseCategoryCollection = IRoseCategoryCollection; @@ -697,11 +671,8 @@ interface RoseExternalDocument = IRoseExternalDocument; -// *********************************************************************// -// DispIntf: IRoseActivityViewCollection -// Flags: (4096) Dispatchable -// GUID: {BEAED5FE-578D-11D2-92AA-004005141253} -// *********************************************************************// + + IRoseActivityViewCollection = dispinterface ['{BEAED5FE-578D-11D2-92AA-004005141253}'] property Count: Smallint dispid 202; @@ -718,11 +689,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseActivityView; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseProcessorCollection -// Flags: (4096) Dispatchable -// GUID: {97B3835C-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseProcessorCollection = dispinterface ['{97B3835C-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -739,11 +708,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseProcessor; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseCategoryCollection -// Flags: (4096) Dispatchable -// GUID: {97B3835B-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseCategoryCollection = dispinterface ['{97B3835B-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -760,11 +727,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseCategory; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseDeploymentUnit -// Flags: (4096) Dispatchable -// GUID: {4335FBE3-F0A0-11D1-9FAD-0060975306FE} -// *********************************************************************// + + + IRoseDeploymentUnit = dispinterface ['{4335FBE3-F0A0-11D1-9FAD-0060975306FE}'] property Name: WideString dispid 100; @@ -777,7 +742,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -788,7 +753,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -825,11 +790,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseItem -// Flags: (4096) Dispatchable -// GUID: {BC57D1C2-863E-11CF-B3D4-00A0241DB1D0} -// *********************************************************************// + + + IRoseItem = dispinterface ['{BC57D1C2-863E-11CF-B3D4-00A0241DB1D0}'] property Name: WideString dispid 100; @@ -842,7 +805,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -853,7 +816,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -871,11 +834,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseContextMenuItemCollection -// Flags: (4096) Dispatchable -// GUID: {EE0B16E2-FF91-11D1-9FAD-0060975306FE} -// *********************************************************************// + + + IRoseContextMenuItemCollection = dispinterface ['{EE0B16E2-FF91-11D1-9FAD-0060975306FE}'] property Count: Smallint dispid 202; @@ -892,11 +853,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseContextMenuItem; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseAddIn -// Flags: (4096) Dispatchable -// GUID: {D5352FC0-346C-11D1-883B-3C8B00C10000} -// *********************************************************************// + + + IRoseAddIn = dispinterface ['{D5352FC0-346C-11D1-883B-3C8B00C10000}'] property EventHandler: IDispatch dispid 12528; @@ -917,23 +876,21 @@ interface procedure Activate; dispid 12543; function IsActive: WordBool; dispid 12553; procedure ExecuteScript(const FileName: WideString); dispid 12595; - function ReadSetting(const Section: WideString; const Entry: WideString; + function ReadSetting(const Section: WideString; const Entry: WideString; const Default: WideString): WideString; dispid 12596; - function WriteSetting(const Section: WideString; const Entry: WideString; + function WriteSetting(const Section: WideString; const Entry: WideString; const Value: WideString): WordBool; dispid 12597; function IdentifyClass: WideString; dispid 12668; function IsClass(const theClassName: WideString): WordBool; dispid 12669; - function AddContextMenuItem(itemType: Smallint; const fullCaption: WideString; + function AddContextMenuItem(itemType: Smallint; const fullCaption: WideString; const internalName: WideString): IRoseContextMenuItem; dispid 12684; function GetContextMenuItems(itemType: Smallint): IRoseContextMenuItemCollection; dispid 12685; function GetDisplayName: WideString; dispid 12689; end; -// *********************************************************************// -// DispIntf: IRoseDecisionViewCollection -// Flags: (4096) Dispatchable -// GUID: {BEAED601-578D-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseDecisionViewCollection = dispinterface ['{BEAED601-578D-11D2-92AA-004005141253}'] property Count: Smallint dispid 202; @@ -950,11 +907,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseDecisionView; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseStateVertex -// Flags: (4096) Dispatchable -// GUID: {BEAED5E2-578D-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseStateVertex = dispinterface ['{BEAED5E2-578D-11D2-92AA-004005141253}'] property Name: WideString dispid 100; @@ -970,7 +925,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -981,7 +936,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -1003,11 +958,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseUseCaseCollection -// Flags: (4096) Dispatchable -// GUID: {97B38356-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseUseCaseCollection = dispinterface ['{97B38356-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -1024,11 +977,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseUseCase; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseConnectionRelation -// Flags: (4096) Dispatchable -// GUID: {4467F442-F24E-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseConnectionRelation = dispinterface ['{4467F442-F24E-11D2-92AA-004005141253}'] property Name: WideString dispid 100; @@ -1044,7 +995,7 @@ interface property SupplierIsDevice: WordBool dispid 12816; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -1055,7 +1006,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -1077,11 +1028,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseRelation -// Flags: (4096) Dispatchable -// GUID: {BA242E02-8961-11CF-B3D4-00A0241DB1D0} -// *********************************************************************// + + + IRoseRelation = dispinterface ['{BA242E02-8961-11CF-B3D4-00A0241DB1D0}'] property Name: WideString dispid 100; @@ -1095,7 +1044,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -1106,7 +1055,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -1128,11 +1077,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseApplication -// Flags: (4096) Dispatchable -// GUID: {D7BC1B40-8618-11CF-B3D4-00A0241DB1D0} -// *********************************************************************// + + + IRoseApplication = dispinterface ['{D7BC1B40-8618-11CF-B3D4-00A0241DB1D0}'] property Visible: WordBool dispid 202; @@ -1154,7 +1101,7 @@ interface procedure WriteErrorLog(const theMsg: WideString); dispid 213; procedure Save(bSaveUnits: WordBool); dispid 214; procedure SaveAs(const theFile: WideString; bSaveUnits: WordBool); dispid 215; - procedure CompileScriptFile(const FileName: WideString; const BinaryName: WideString; + procedure CompileScriptFile(const FileName: WideString; const BinaryName: WideString; bDebug: WordBool); dispid 218; function OpenModelAsTemplate(const szFileName: WideString): IRoseModel; dispid 223; procedure OpenScript(const FileName: WideString); dispid 225; @@ -1163,9 +1110,9 @@ interface procedure ExecuteScript(const pFileName: WideString); dispid 236; function OpenURL(const theURL: WideString): WordBool; dispid 12587; function OpenExternalDocument(const FileName: WideString): WordBool; dispid 12588; - function GetProfileString(const Section: WideString; const Entry: WideString; + function GetProfileString(const Section: WideString; const Entry: WideString; const Default: WideString): WideString; dispid 12589; - function WriteProfileString(const Section: WideString; const Entry: WideString; + function WriteProfileString(const Section: WideString; const Entry: WideString; const Value: WideString): WordBool; dispid 12590; function UpdateBrowserOverlayImage(const theItem: IRoseItem): WordBool; dispid 12679; function UpdateBrowserDocOverlayImage(const theDocument: IRoseExternalDocument): WordBool; dispid 12688; @@ -1173,11 +1120,9 @@ interface function GetRoseIniPath: WideString; dispid 12698; end; -// *********************************************************************// -// DispIntf: IRoseDecisionCollection -// Flags: (4096) Dispatchable -// GUID: {BEAED5F2-578D-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseDecisionCollection = dispinterface ['{BEAED5F2-578D-11D2-92AA-004005141253}'] property Count: Smallint dispid 202; @@ -1194,11 +1139,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseDecision; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseDecision -// Flags: (4096) Dispatchable -// GUID: {BEAED5E3-578D-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseDecision = dispinterface ['{BEAED5E3-578D-11D2-92AA-004005141253}'] property Name: WideString dispid 100; @@ -1214,7 +1157,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -1225,7 +1168,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -1247,11 +1190,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseLineVertexCollection -// Flags: (4096) Dispatchable -// GUID: {11A235B2-3095-11D2-8153-00104B97EBD5} -// *********************************************************************// + + + IRoseLineVertexCollection = dispinterface ['{11A235B2-3095-11D2-8153-00104B97EBD5}'] property Count: Smallint dispid 202; @@ -1268,11 +1209,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseLineVertex; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseInstantiateRelationCollection -// Flags: (4096) Dispatchable -// GUID: {B91D8F06-DDBB-11D1-9FAD-0060975306FE} -// *********************************************************************// + + + IRoseInstantiateRelationCollection = dispinterface ['{B91D8F06-DDBB-11D1-9FAD-0060975306FE}'] property Count: Smallint dispid 202; @@ -1289,11 +1228,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseInstantiateRelation; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseMessageCollection -// Flags: (4096) Dispatchable -// GUID: {97B38359-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseMessageCollection = dispinterface ['{97B38359-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -1310,11 +1247,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseMessage; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseClassDiagramCollection -// Flags: (4096) Dispatchable -// GUID: {97B38343-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseClassDiagramCollection = dispinterface ['{97B38343-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -1331,11 +1266,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseClassDiagram; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseScenarioDiagram -// Flags: (4096) Dispatchable -// GUID: {F819833A-FC55-11CF-BBD3-00A024C67143} -// *********************************************************************// + + + IRoseScenarioDiagram = dispinterface ['{F819833A-FC55-11CF-BBD3-00A024C67143}'] property Name: WideString dispid 100; @@ -1350,7 +1283,7 @@ interface property ZoomFactor: Smallint dispid 12690; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -1361,7 +1294,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -1387,7 +1320,7 @@ interface function GetSelectedObjects: IRoseObjectInstanceCollection; dispid 412; function GetMessages: IRoseMessageCollection; dispid 413; function GetSelectedMessages: IRoseMessageCollection; dispid 414; - function CreateMessage(const theName: WideString; const theSender: IRoseObjectInstance; + function CreateMessage(const theName: WideString; const theSender: IRoseObjectInstance; const theReceiver: IRoseObjectInstance; theSequence: Smallint): IRoseMessage; dispid 416; function GetSelectedLinks: IRoseLinkCollection; dispid 417; function GetDiagramType: Smallint; dispid 418; @@ -1405,11 +1338,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseRealizeRelation -// Flags: (4096) Dispatchable -// GUID: {6AC2BA81-454D-11D1-883B-3C8B00C10000} -// *********************************************************************// + + + IRoseRealizeRelation = dispinterface ['{6AC2BA81-454D-11D1-883B-3C8B00C10000}'] property Name: WideString dispid 100; @@ -1423,7 +1354,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -1434,7 +1365,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -1460,11 +1391,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseHasRelationship -// Flags: (4096) Dispatchable -// GUID: {BA242E04-8961-11CF-B3D4-00A0241DB1D0} -// *********************************************************************// + + + IRoseHasRelationship = dispinterface ['{BA242E04-8961-11CF-B3D4-00A0241DB1D0}'] property Name: WideString dispid 100; @@ -1483,7 +1412,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -1494,7 +1423,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -1518,11 +1447,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseClassView -// Flags: (4096) Dispatchable -// GUID: {5F735F36-F9EA-11CF-BBD3-00A024C67143} -// *********************************************************************// + + + IRoseClassView = dispinterface ['{5F735F36-F9EA-11CF-BBD3-00A024C67143}'] property Name: WideString dispid 100; @@ -1548,7 +1475,7 @@ interface property LineVertices: IRoseLineVertexCollection dispid 12696; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -1559,7 +1486,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -1586,11 +1513,9 @@ interface function GetDisplayedOperations: IRoseItemCollection; dispid 12827; end; -// *********************************************************************// -// DispIntf: IRoseView_FillColor -// Flags: (4096) Dispatchable -// GUID: {CE5BE563-0380-11D1-BC11-00A024C67143} -// *********************************************************************// + + + IRoseView_FillColor = dispinterface ['{CE5BE563-0380-11D1-BC11-00A024C67143}'] property Red: Smallint dispid 12493; @@ -1601,11 +1526,9 @@ interface function IsClass(const theClassName: WideString): WordBool; dispid 12669; end; -// *********************************************************************// -// DispIntf: IRoseActionCollection -// Flags: (4096) Dispatchable -// GUID: {97B3835F-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseActionCollection = dispinterface ['{97B3835F-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -1622,11 +1545,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseAction; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseSyncItemCollection -// Flags: (4096) Dispatchable -// GUID: {94CA188F-5D13-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseSyncItemCollection = dispinterface ['{94CA188F-5D13-11D2-92AA-004005141253}'] property Count: Smallint dispid 202; @@ -1643,11 +1564,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseSyncItem; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseActivityCollection -// Flags: (4096) Dispatchable -// GUID: {BEAED5F0-578D-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseActivityCollection = dispinterface ['{BEAED5F0-578D-11D2-92AA-004005141253}'] property Count: Smallint dispid 202; @@ -1664,11 +1583,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseActivity; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseActivity -// Flags: (4096) Dispatchable -// GUID: {BEAED5E7-578D-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseActivity = dispinterface ['{BEAED5E7-578D-11D2-92AA-004005141253}'] property Name: WideString dispid 100; @@ -1688,7 +1605,7 @@ interface property SubSynchronizations: IRoseSyncItemCollection dispid 12804; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -1699,7 +1616,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -1739,11 +1656,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseProcess -// Flags: (4096) Dispatchable -// GUID: {62C43884-DB5A-11CF-B091-00A0241E3F73} -// *********************************************************************// + + + IRoseProcess = dispinterface ['{62C43884-DB5A-11CF-B091-00A0241E3F73}'] property Name: WideString dispid 100; @@ -1758,7 +1673,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -1769,7 +1684,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -1787,11 +1702,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseAddInCollection -// Flags: (4096) Dispatchable -// GUID: {C87D2BC1-352A-11D1-883B-3C8B00C10000} -// *********************************************************************// + + + IRoseAddInCollection = dispinterface ['{C87D2BC1-352A-11D1-883B-3C8B00C10000}'] property Count: Smallint dispid 202; @@ -1808,11 +1721,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseAddIn; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseSwimLaneView -// Flags: (4096) Dispatchable -// GUID: {68F63C21-B047-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseSwimLaneView = dispinterface ['{68F63C21-B047-11D2-92AA-004005141253}'] property Name: WideString dispid 100; @@ -1832,7 +1743,7 @@ interface property LineVertices: IRoseLineVertexCollection dispid 12696; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -1843,7 +1754,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -1868,11 +1779,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseControllableUnitCollection -// Flags: (4096) Dispatchable -// GUID: {97B38360-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseControllableUnitCollection = dispinterface ['{97B38360-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -1889,11 +1798,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseControllableUnit; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseModuleCollection -// Flags: (4096) Dispatchable -// GUID: {97B3834B-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseModuleCollection = dispinterface ['{97B3834B-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -1910,11 +1817,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseModule; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseLinkCollection -// Flags: (4096) Dispatchable -// GUID: {9DE9A9C1-F2D0-11D0-883A-3C8B00C10000} -// *********************************************************************// + + + IRoseLinkCollection = dispinterface ['{9DE9A9C1-F2D0-11D0-883A-3C8B00C10000}'] property Count: Smallint dispid 202; @@ -1931,11 +1836,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseLink; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseAction -// Flags: (4096) Dispatchable -// GUID: {13881143-93C1-11D0-A214-00A024FFFE40} -// *********************************************************************// + + + IRoseAction = dispinterface ['{13881143-93C1-11D0-A214-00A024FFFE40}'] property Name: WideString dispid 100; @@ -1950,7 +1853,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -1961,7 +1864,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -1979,11 +1882,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseParameterCollection -// Flags: (4096) Dispatchable -// GUID: {97B38352-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseParameterCollection = dispinterface ['{97B38352-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -2000,11 +1901,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseParameter; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseAttributeCollection -// Flags: (4096) Dispatchable -// GUID: {97B3834C-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseAttributeCollection = dispinterface ['{97B3834C-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -2021,11 +1920,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseAttribute; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseDevice -// Flags: (4096) Dispatchable -// GUID: {62C43882-DB5A-11CF-B091-00A0241E3F73} -// *********************************************************************// + + + IRoseDevice = dispinterface ['{62C43882-DB5A-11CF-B091-00A0241E3F73}'] property Name: WideString dispid 100; @@ -2040,7 +1937,7 @@ interface property Connections: IRoseConnectionRelationCollection dispid 12818; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -2051,7 +1948,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -2075,11 +1972,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseClassDependency -// Flags: (4096) Dispatchable -// GUID: {4ACE1899-6CD3-11D1-BC1E-00A024C67143} -// *********************************************************************// + + + IRoseClassDependency = dispinterface ['{4ACE1899-6CD3-11D1-BC1E-00A024C67143}'] property Name: WideString dispid 100; @@ -2097,7 +1992,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -2108,7 +2003,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -2132,11 +2027,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseRole -// Flags: (4096) Dispatchable -// GUID: {BA242E00-8961-11CF-B3D4-00A0241DB1D0} -// *********************************************************************// + + + IRoseRole = dispinterface ['{BA242E00-8961-11CF-B3D4-00A0241DB1D0}'] property Name: WideString dispid 100; @@ -2163,7 +2056,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -2174,7 +2067,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -2200,11 +2093,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseClass -// Flags: (4096) Dispatchable -// GUID: {BC57D1C0-863E-11CF-B3D4-00A0241DB1D0} -// *********************************************************************// + + + IRoseClass = dispinterface ['{BC57D1C0-863E-11CF-B3D4-00A0241DB1D0}'] property Name: WideString dispid 100; @@ -2231,7 +2122,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -2242,7 +2133,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -2257,9 +2148,9 @@ interface function GetSuperclasses: IRoseClassCollection; dispid 424; function GetAssociations: IRoseAssociationCollection; dispid 425; function AddOperation(const theName: WideString; const retType: WideString): IRoseOperation; dispid 427; - function AddAttribute(const theName: WideString; const theType: WideString; + function AddAttribute(const theName: WideString; const theType: WideString; const initVal: WideString): IRoseAttribute; dispid 428; - function AddAssociation(const theSupplierRoleName: WideString; + function AddAssociation(const theSupplierRoleName: WideString; const theSupplierRoleType: WideString): IRoseAssociation; dispid 429; function AddHas(const theSupplierName: WideString; const theSupplierType: WideString): IRoseHasRelationship; dispid 430; function DeleteHas(const theHas: IRoseHasRelationship): WordBool; dispid 432; @@ -2290,7 +2181,7 @@ interface function GetClassDependencies: IRoseClassDependencyCollection; dispid 12662; function AddClassDependency(const theSupplerName: WideString; const theSupplierType: WideString): IRoseClassDependency; dispid 12663; function DeleteClassDependency(const theClassDependency: IRoseClassDependency): WordBool; dispid 12664; - function AddParameter(const theName: WideString; const theType: WideString; + function AddParameter(const theName: WideString; const theType: WideString; const theDef: WideString; position: Smallint): IRoseParameter; dispid 12667; function IdentifyClass: WideString; dispid 12668; function IsClass(const theClassName: WideString): WordBool; dispid 12669; @@ -2305,11 +2196,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseElement -// Flags: (4096) Dispatchable -// GUID: {D067F15F-6987-11D0-BBF0-00A024C67143} -// *********************************************************************// + + + IRoseElement = dispinterface ['{D067F15F-6987-11D0-BBF0-00A024C67143}'] property Name: WideString dispid 100; @@ -2317,7 +2206,7 @@ interface property Model: IRoseModel dispid 12524; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -2328,7 +2217,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -2341,11 +2230,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseControllableUnit -// Flags: (4096) Dispatchable -// GUID: {32C862A7-8AA9-11D0-A70B-0000F803584A} -// *********************************************************************// + + + IRoseControllableUnit = dispinterface ['{32C862A7-8AA9-11D0-A70B-0000F803584A}'] property Name: WideString dispid 100; @@ -2358,7 +2245,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -2369,7 +2256,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -2406,11 +2293,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseModel -// Flags: (4096) Dispatchable -// GUID: {E38942A0-8621-11CF-B3D4-00A0241DB1D0} -// *********************************************************************// + + + IRoseModel = dispinterface ['{E38942A0-8621-11CF-B3D4-00A0241DB1D0}'] property Name: WideString dispid 100; @@ -2432,7 +2317,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -2443,7 +2328,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -2509,11 +2394,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseTransition -// Flags: (4096) Dispatchable -// GUID: {574130A1-93B8-11D0-A214-00A024FFFE40} -// *********************************************************************// + + + IRoseTransition = dispinterface ['{574130A1-93B8-11D0-A214-00A024FFFE40}'] property Name: WideString dispid 100; @@ -2527,7 +2410,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -2538,7 +2421,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -2568,11 +2451,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseSubsystemCollection -// Flags: (4096) Dispatchable -// GUID: {97B3834A-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseSubsystemCollection = dispinterface ['{97B3834A-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -2589,11 +2470,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseSubsystem; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseProcessor -// Flags: (4096) Dispatchable -// GUID: {62C43886-DB5A-11CF-B091-00A0241E3F73} -// *********************************************************************// + + + IRoseProcessor = dispinterface ['{62C43886-DB5A-11CF-B091-00A0241E3F73}'] property Name: WideString dispid 100; @@ -2610,7 +2489,7 @@ interface property Connections: IRoseConnectionRelationCollection dispid 12819; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -2621,7 +2500,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -2647,11 +2526,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseCategoryDependencyCollection -// Flags: (4096) Dispatchable -// GUID: {4ACE189D-6CD3-11D1-BC1E-00A024C67143} -// *********************************************************************// + + + IRoseCategoryDependencyCollection = dispinterface ['{4ACE189D-6CD3-11D1-BC1E-00A024C67143}'] property Count: Smallint dispid 202; @@ -2668,11 +2545,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseCategoryDependency; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseProperty -// Flags: (4096) Dispatchable -// GUID: {93461A23-8811-11CF-B1B0-D227D5210B2C} -// *********************************************************************// + + + IRoseProperty = dispinterface ['{93461A23-8811-11CF-B1B0-D227D5210B2C}'] property Name: WideString dispid 202; @@ -2681,11 +2556,9 @@ interface property Type_: WideString dispid 206; end; -// *********************************************************************// -// DispIntf: IRoseStateDiagram -// Flags: (4096) Dispatchable -// GUID: {7ADDA701-9B06-11D0-A214-00A024FFFE40} -// *********************************************************************// + + + IRoseStateDiagram = dispinterface ['{7ADDA701-9B06-11D0-A214-00A024FFFE40}'] property Name: WideString dispid 100; @@ -2701,7 +2574,7 @@ interface property IsActivityDiagram: WordBool dispid 12761; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -2712,7 +2585,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -2772,11 +2645,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseEvent -// Flags: (4096) Dispatchable -// GUID: {A69CAB22-9179-11D0-A214-00A024FFFE40} -// *********************************************************************// + + + IRoseEvent = dispinterface ['{A69CAB22-9179-11D0-A214-00A024FFFE40}'] property Arguments: WideString dispid 215; @@ -2786,7 +2657,7 @@ interface property GuardCondition: WideString dispid 12622; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -2797,7 +2668,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -2811,11 +2682,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseRichType -// Flags: (4096) Dispatchable -// GUID: {EB7AAB60-939C-11CF-B091-00A0241E3F73} -// *********************************************************************// + + + IRoseRichType = dispinterface ['{EB7AAB60-939C-11CF-B091-00A0241E3F73}'] property Value: Smallint dispid 202; @@ -2825,11 +2694,9 @@ interface function IsClass(const theClassName: WideString): WordBool; dispid 12669; end; -// *********************************************************************// -// DispIntf: IRoseScenarioDiagramCollection -// Flags: (4096) Dispatchable -// GUID: {97B3835E-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseScenarioDiagramCollection = dispinterface ['{97B3835E-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -2846,11 +2713,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseScenarioDiagram; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseParameter -// Flags: (4096) Dispatchable -// GUID: {C78E7028-86E4-11CF-B3D4-00A0241DB1D0} -// *********************************************************************// + + + IRoseParameter = dispinterface ['{C78E7028-86E4-11CF-B3D4-00A0241DB1D0}'] property Name: WideString dispid 100; @@ -2866,7 +2731,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -2877,7 +2742,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -2895,11 +2760,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseOperation -// Flags: (4096) Dispatchable -// GUID: {C78E7020-86E4-11CF-B3D4-00A0241DB1D0} -// *********************************************************************// + + + IRoseOperation = dispinterface ['{C78E7020-86E4-11CF-B3D4-00A0241DB1D0}'] property Name: WideString dispid 100; @@ -2926,7 +2789,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -2937,7 +2800,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -2947,7 +2810,7 @@ interface function AddExternalDocument(const szName: WideString; iType: Smallint): IRoseExternalDocument; dispid 214; function DeleteExternalDocument(const pIDispatch: IRoseExternalDocument): WordBool; dispid 215; function OpenSpecification: WordBool; dispid 216; - function AddParameter(const theName: WideString; const theType: WideString; + function AddParameter(const theName: WideString; const theType: WideString; const theDef: WideString; position: Smallint): IRoseParameter; dispid 416; procedure RemoveAllParameters; dispid 417; function DeleteParameter(const theParameter: IRoseParameter): WordBool; dispid 426; @@ -2959,11 +2822,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseView_LineColor -// Flags: (4096) Dispatchable -// GUID: {CE5BE565-0380-11D1-BC11-00A024C67143} -// *********************************************************************// + + + IRoseView_LineColor = dispinterface ['{CE5BE565-0380-11D1-BC11-00A024C67143}'] property Blue: Smallint dispid 12502; @@ -2973,11 +2834,9 @@ interface function IsClass(const theClassName: WideString): WordBool; dispid 12669; end; -// *********************************************************************// -// DispIntf: IRoseAddInManager -// Flags: (4096) Dispatchable -// GUID: {D5352FC2-346C-11D1-883B-3C8B00C10000} -// *********************************************************************// + + + IRoseAddInManager = dispinterface ['{D5352FC2-346C-11D1-883B-3C8B00C10000}'] property AddIns: IRoseAddInCollection dispid 12529; @@ -2987,11 +2846,9 @@ interface function EnableEvents(theEvents: Integer): Integer; dispid 12693; end; -// *********************************************************************// -// DispIntf: IRoseStateDiagramCollection -// Flags: (4096) Dispatchable -// GUID: {97B38368-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseStateDiagramCollection = dispinterface ['{97B38368-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -3008,11 +2865,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseStateDiagram; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseSwimLaneViewCollection -// Flags: (4096) Dispatchable -// GUID: {7FFC5F46-C0C2-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseSwimLaneViewCollection = dispinterface ['{7FFC5F46-C0C2-11D2-92AA-004005141253}'] property Count: Smallint dispid 202; @@ -3029,11 +2884,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseSwimLaneView; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseSwimLane -// Flags: (4096) Dispatchable -// GUID: {BEAED5EA-578D-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseSwimLane = dispinterface ['{BEAED5EA-578D-11D2-92AA-004005141253}'] property Name: WideString dispid 100; @@ -3050,7 +2903,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -3061,7 +2914,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -3083,11 +2936,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseItemViewCollection -// Flags: (4096) Dispatchable -// GUID: {97B38362-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseItemViewCollection = dispinterface ['{97B38362-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -3104,11 +2955,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseItemView; dispid 213; end; -// *********************************************************************// -// DispIntf: IRosePropertyCollection -// Flags: (4096) Dispatchable -// GUID: {97B3835D-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRosePropertyCollection = dispinterface ['{97B3835D-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -3125,11 +2974,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseProperty; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseOperationCollection -// Flags: (4096) Dispatchable -// GUID: {97B3834D-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseOperationCollection = dispinterface ['{97B3834D-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -3146,11 +2993,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseOperation; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseDeviceCollection -// Flags: (4096) Dispatchable -// GUID: {97B38342-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseDeviceCollection = dispinterface ['{97B38342-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -3167,11 +3012,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseDevice; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseInstantiateRelation -// Flags: (4096) Dispatchable -// GUID: {B91D8F03-DDBB-11D1-9FAD-0060975306FE} -// *********************************************************************// + + + IRoseInstantiateRelation = dispinterface ['{B91D8F03-DDBB-11D1-9FAD-0060975306FE}'] property Name: WideString dispid 100; @@ -3185,7 +3028,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -3196,7 +3039,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -3220,11 +3063,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseContextMenuItem -// Flags: (4096) Dispatchable -// GUID: {EE0B16E0-FF91-11D1-9FAD-0060975306FE} -// *********************************************************************// + + + IRoseContextMenuItem = dispinterface ['{EE0B16E0-FF91-11D1-9FAD-0060975306FE}'] property Caption: WideString dispid 12682; @@ -3235,11 +3076,9 @@ interface function IsClass(const theClassName: WideString): WordBool; dispid 12669; end; -// *********************************************************************// -// DispIntf: IRoseLineVertex -// Flags: (4096) Dispatchable -// GUID: {B53888D2-3094-11D2-8153-00104B97EBD5} -// *********************************************************************// + + + IRoseLineVertex = dispinterface ['{B53888D2-3094-11D2-8153-00104B97EBD5}'] function IdentifyClass: WideString; dispid 12668; @@ -3248,22 +3087,18 @@ interface function GetYPosition: Smallint; dispid 12695; end; -// *********************************************************************// -// DispIntf: IRoseObject -// Flags: (4096) Dispatchable -// GUID: {7D8474B2-2C33-11D0-BBDA-00A024C67143} -// *********************************************************************// + + + IRoseObject = dispinterface ['{7D8474B2-2C33-11D0-BBDA-00A024C67143}'] function IdentifyClass: WideString; dispid 12668; function IsClass(const theClassName: WideString): WordBool; dispid 12669; end; -// *********************************************************************// -// DispIntf: IRoseSwimLaneCollection -// Flags: (4096) Dispatchable -// GUID: {7FFC5F42-C0C2-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseSwimLaneCollection = dispinterface ['{7FFC5F42-C0C2-11D2-92AA-004005141253}'] property Count: Smallint dispid 202; @@ -3280,11 +3115,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseSwimLane; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseModuleVisibilityRelationship -// Flags: (4096) Dispatchable -// GUID: {9EF8DDD6-E697-11CF-BBD1-00A024C67143} -// *********************************************************************// + + + IRoseModuleVisibilityRelationship = dispinterface ['{9EF8DDD6-E697-11CF-BBD1-00A024C67143}'] property Name: WideString dispid 100; @@ -3304,7 +3137,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -3315,7 +3148,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -3337,11 +3170,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseComponentViewCollection -// Flags: (4096) Dispatchable -// GUID: {C640C861-F2D3-11D0-883A-3C8B00C10000} -// *********************************************************************// + + + IRoseComponentViewCollection = dispinterface ['{C640C861-F2D3-11D0-883A-3C8B00C10000}'] property Count: Smallint dispid 202; @@ -3358,11 +3189,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseComponentView; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseHasRelationshipCollection -// Flags: (4096) Dispatchable -// GUID: {97B38351-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseHasRelationshipCollection = dispinterface ['{97B38351-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -3379,11 +3208,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseHasRelationship; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseClassViewCollection -// Flags: (4096) Dispatchable -// GUID: {97B38341-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseClassViewCollection = dispinterface ['{97B38341-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -3400,13 +3227,11 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseClassView; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseDeploymentDiagram -// Flags: (4096) Dispatchable -// GUID: {C2C15EC4-E028-11CF-B091-00A0241E3F73} -// *********************************************************************// - IRoseDeploymentDiagram = dispinterface - ['{C2C15EC4-E028-11CF-B091-00A0241E3F73}'] + + + + IRoseDeploymentDiagram = dispinterface + ['{C2C15EC4-E028-11CF-B091-00A0241E3F73}'] property Name: WideString dispid 100; property ItemViews: IRoseItemViewCollection dispid 202; property Visible: WordBool dispid 203; @@ -3418,7 +3243,7 @@ interface property ZoomFactor: Smallint dispid 12690; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -3429,7 +3254,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -3467,11 +3292,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseInstanceView -// Flags: (4096) Dispatchable -// GUID: {348B1AD4-D5C4-11D0-89F8-0020AFD6C181} -// *********************************************************************// + + + IRoseInstanceView = dispinterface ['{348B1AD4-D5C4-11D0-89F8-0020AFD6C181}'] property Name: WideString dispid 100; @@ -3491,7 +3314,7 @@ interface property LineVertices: IRoseLineVertexCollection dispid 12696; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -3502,7 +3325,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -3528,11 +3351,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseLink -// Flags: (4096) Dispatchable -// GUID: {195D7852-D5B6-11D0-89F8-0020AFD6C181} -// *********************************************************************// + + + IRoseLink = dispinterface ['{195D7852-D5B6-11D0-89F8-0020AFD6C181}'] property Name: WideString dispid 100; @@ -3551,7 +3372,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -3562,7 +3383,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -3576,7 +3397,7 @@ interface function DeleteMessage(const TheMessage: IRoseMessage): WordBool; dispid 419; function AssignAssociation(const TheAssoc: IRoseAssociation): WordBool; dispid 420; function UnassignAssociation: WordBool; dispid 421; - function AddMessageTo(const Name: WideString; const ToInstance: IRoseObjectInstance; + function AddMessageTo(const Name: WideString; const ToInstance: IRoseObjectInstance; SequenceNumber: Smallint): IRoseMessage; dispid 422; function GetQualifiedName: WideString; dispid 12555; function IdentifyClass: WideString; dispid 12668; @@ -3587,11 +3408,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseObjectInstance -// Flags: (4096) Dispatchable -// GUID: {F8198337-FC55-11CF-BBD3-00A024C67143} -// *********************************************************************// + + + IRoseObjectInstance = dispinterface ['{F8198337-FC55-11CF-BBD3-00A024C67143}'] property Name: WideString dispid 100; @@ -3608,7 +3427,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -3619,7 +3438,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -3640,11 +3459,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseCategoryDependency -// Flags: (4096) Dispatchable -// GUID: {4ACE189B-6CD3-11D1-BC1E-00A024C67143} -// *********************************************************************// + + + IRoseCategoryDependency = dispinterface ['{4ACE189B-6CD3-11D1-BC1E-00A024C67143}'] property Name: WideString dispid 100; @@ -3658,7 +3475,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -3669,7 +3486,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -3693,11 +3510,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseInheritRelation -// Flags: (4096) Dispatchable -// GUID: {00C99560-9200-11CF-B1B0-D227D5210B2C} -// *********************************************************************// + + + IRoseInheritRelation = dispinterface ['{00C99560-9200-11CF-B1B0-D227D5210B2C}'] property Name: WideString dispid 100; @@ -3714,7 +3529,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -3725,7 +3540,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -3749,11 +3564,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseView_Font -// Flags: (4096) Dispatchable -// GUID: {CE5BE567-0380-11D1-BC11-00A024C67143} -// *********************************************************************// + + + IRoseView_Font = dispinterface ['{CE5BE567-0380-11D1-BC11-00A024C67143}'] property Size: Smallint dispid 12497; @@ -3769,11 +3582,9 @@ interface function IsClass(const theClassName: WideString): WordBool; dispid 12669; end; -// *********************************************************************// -// DispIntf: IRoseStateMachine -// Flags: (4096) Dispatchable -// GUID: {A69CAB21-9179-11D0-A214-00A024FFFE40} -// *********************************************************************// + + + IRoseStateMachine = dispinterface ['{A69CAB21-9179-11D0-A214-00A024FFFE40}'] property Name: WideString dispid 100; @@ -3795,7 +3606,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -3806,7 +3617,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -3843,11 +3654,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseModule -// Flags: (4096) Dispatchable -// GUID: {C78E702A-86E4-11CF-B3D4-00A0241DB1D0} -// *********************************************************************// + + + IRoseModule = dispinterface ['{C78E702A-86E4-11CF-B3D4-00A0241DB1D0}'] property Name: WideString dispid 100; @@ -3867,7 +3676,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -3878,7 +3687,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -3906,11 +3715,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseUseCase -// Flags: (4096) Dispatchable -// GUID: {7E7F6EE0-16DE-11D0-8976-00A024774419} -// *********************************************************************// + + + IRoseUseCase = dispinterface ['{7E7F6EE0-16DE-11D0-8976-00A024774419}'] property Name: WideString dispid 100; @@ -3929,7 +3736,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -3940,7 +3747,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -3957,7 +3764,7 @@ interface function AddInheritRel(const szName: WideString; const szParentName: WideString): IRoseInheritRelation; dispid 421; function DeleteInheritRel(const pIDispatchRelation: IRoseInheritRelation): WordBool; dispid 422; function GetAssociations: IRoseAssociationCollection; dispid 426; - function AddAssociation(const szSupplierRoleName: WideString; + function AddAssociation(const szSupplierRoleName: WideString; const szSupplierRoleType: WideString): IRoseAssociation; dispid 430; function DeleteAssociation(const pDispatchAssociation: IRoseAssociation): WordBool; dispid 431; function GetSuperUseCases: IRoseUseCaseCollection; dispid 432; @@ -3973,11 +3780,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseItemCollection -// Flags: (4096) Dispatchable -// GUID: {0DD9ACF8-D06E-11D0-BC0B-00A024C67143} -// *********************************************************************// + + + IRoseItemCollection = dispinterface ['{0DD9ACF8-D06E-11D0-BC0B-00A024C67143}'] property Count: Smallint dispid 202; @@ -3994,11 +3799,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseItem; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseNoteViewCollection -// Flags: (4096) Dispatchable -// GUID: {97B38358-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseNoteViewCollection = dispinterface ['{97B38358-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -4015,11 +3818,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseNoteView; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseInheritRelationCollection -// Flags: (4096) Dispatchable -// GUID: {97B38354-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseInheritRelationCollection = dispinterface ['{97B38354-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -4036,11 +3837,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseInheritRelation; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseDeploymentDiagramCollection -// Flags: (4096) Dispatchable -// GUID: {97B383A1-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseDeploymentDiagramCollection = dispinterface ['{97B383A1-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -4057,22 +3856,18 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseDeploymentDiagram; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseStringCollection -// Flags: (4096) Dispatchable -// GUID: {6A7FC311-C893-11D0-BC0B-00A024C67143} -// *********************************************************************// + + + IRoseStringCollection = dispinterface ['{6A7FC311-C893-11D0-BC0B-00A024C67143}'] property Count: Smallint dispid 50; function GetAt(id: Smallint): WideString; dispid 51; end; -// *********************************************************************// -// DispIntf: IRoseStateViewCollection -// Flags: (4096) Dispatchable -// GUID: {97B3836A-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseStateViewCollection = dispinterface ['{97B3836A-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -4089,11 +3884,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseStateView; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseDecisionView -// Flags: (4096) Dispatchable -// GUID: {BEAED5F9-578D-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseDecisionView = dispinterface ['{BEAED5F9-578D-11D2-92AA-004005141253}'] property Name: WideString dispid 100; @@ -4113,7 +3906,7 @@ interface property LineVertices: IRoseLineVertexCollection dispid 12696; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -4124,7 +3917,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -4150,11 +3943,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseStateMachineOwner -// Flags: (4096) Dispatchable -// GUID: {94CA1882-5D13-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseStateMachineOwner = dispinterface ['{94CA1882-5D13-11D2-92AA-004005141253}'] property Name: WideString dispid 100; @@ -4163,7 +3954,7 @@ interface property StateMachines: IRoseStateMachineCollection dispid 12744; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -4174,7 +3965,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -4189,11 +3980,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseProcessCollection -// Flags: (4096) Dispatchable -// GUID: {97B38366-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseProcessCollection = dispinterface ['{97B38366-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -4210,11 +3999,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseProcess; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseAssociationCollection -// Flags: (4096) Dispatchable -// GUID: {97B3834E-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseAssociationCollection = dispinterface ['{97B3834E-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -4231,11 +4018,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseAssociation; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseModuleDiagramCollection -// Flags: (4096) Dispatchable -// GUID: {97B38348-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseModuleDiagramCollection = dispinterface ['{97B38348-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -4252,11 +4037,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseModuleDiagram; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseDiagram -// Flags: (4096) Dispatchable -// GUID: {3FD9D000-93B0-11CF-B3D4-00A0241DB1D0} -// *********************************************************************// + + + IRoseDiagram = dispinterface ['{3FD9D000-93B0-11CF-B3D4-00A0241DB1D0}'] property Name: WideString dispid 100; @@ -4270,7 +4053,7 @@ interface property ZoomFactor: Smallint dispid 12690; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -4281,7 +4064,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -4313,11 +4096,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseAbstractStateCollection -// Flags: (4096) Dispatchable -// GUID: {BEAED5EE-578D-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseAbstractStateCollection = dispinterface ['{BEAED5EE-578D-11D2-92AA-004005141253}'] property Count: Smallint dispid 202; @@ -4334,11 +4115,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseAbstractState; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseRichTypeValuesCollection -// Flags: (4096) Dispatchable -// GUID: {BF8C1040-96DD-11CF-B091-00A0241E3F73} -// *********************************************************************// + + + IRoseRichTypeValuesCollection = dispinterface ['{BF8C1040-96DD-11CF-B091-00A0241E3F73}'] property Count: Smallint dispid 202; @@ -4347,11 +4126,9 @@ interface function IsClass(const theClassName: WideString): WordBool; dispid 12669; end; -// *********************************************************************// -// DispIntf: IRoseSubsystemView -// Flags: (4096) Dispatchable -// GUID: {14028C92-C06C-11D0-89F5-0020AFD6C181} -// *********************************************************************// + + + IRoseSubsystemView = dispinterface ['{14028C92-C06C-11D0-89F5-0020AFD6C181}'] property Name: WideString dispid 100; @@ -4371,7 +4148,7 @@ interface property LineVertices: IRoseLineVertexCollection dispid 12696; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -4382,7 +4159,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -4408,11 +4185,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseComponentView -// Flags: (4096) Dispatchable -// GUID: {14028C94-C06C-11D0-89F5-0020AFD6C181} -// *********************************************************************// + + + IRoseComponentView = dispinterface ['{14028C94-C06C-11D0-89F5-0020AFD6C181}'] property Name: WideString dispid 100; @@ -4432,7 +4207,7 @@ interface property LineVertices: IRoseLineVertexCollection dispid 12696; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -4443,7 +4218,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -4469,11 +4244,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseAttribute -// Flags: (4096) Dispatchable -// GUID: {C78E7024-86E4-11CF-B3D4-00A0241DB1D0} -// *********************************************************************// + + + IRoseAttribute = dispinterface ['{C78E7024-86E4-11CF-B3D4-00A0241DB1D0}'] property Name: WideString dispid 100; @@ -4493,7 +4266,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -4504,7 +4277,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -4522,11 +4295,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseClassDiagram -// Flags: (4096) Dispatchable -// GUID: {3FD9D002-93B0-11CF-B3D4-00A0241DB1D0} -// *********************************************************************// + + + IRoseClassDiagram = dispinterface ['{3FD9D002-93B0-11CF-B3D4-00A0241DB1D0}'] property Name: WideString dispid 100; @@ -4541,7 +4312,7 @@ interface property ZoomFactor: Smallint dispid 12690; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -4552,7 +4323,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -4600,11 +4371,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseNoteView -// Flags: (4096) Dispatchable -// GUID: {015655CA-72DF-11D0-95EB-0000F803584A} -// *********************************************************************// + + + IRoseNoteView = dispinterface ['{015655CA-72DF-11D0-95EB-0000F803584A}'] property Name: WideString dispid 100; @@ -4625,7 +4394,7 @@ interface property LineVertices: IRoseLineVertexCollection dispid 12696; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -4636,7 +4405,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -4664,11 +4433,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRosePackage -// Flags: (4096) Dispatchable -// GUID: {47D975C1-8A8D-11D0-A214-444553540000} -// *********************************************************************// + + + IRosePackage = dispinterface ['{47D975C1-8A8D-11D0-A214-444553540000}'] property Name: WideString dispid 100; @@ -4681,7 +4448,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -4692,7 +4459,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -4730,11 +4497,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRosePathMap -// Flags: (4096) Dispatchable -// GUID: {4C9E2241-84C5-11D0-A214-444553540000} -// *********************************************************************// + + + IRosePathMap = dispinterface ['{4C9E2241-84C5-11D0-A214-444553540000}'] function DeleteEntry(const Symbol: WideString): WordBool; dispid 50; @@ -4746,11 +4511,9 @@ interface function GetVirtualPathWithContext(const ActualPath: WideString; const Context: WideString): WideString; dispid 12675; end; -// *********************************************************************// -// DispIntf: IRoseSyncItemViewCollection -// Flags: (4096) Dispatchable -// GUID: {94CA1891-5D13-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseSyncItemViewCollection = dispinterface ['{94CA1891-5D13-11D2-92AA-004005141253}'] property Count: Smallint dispid 202; @@ -4767,11 +4530,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseSyncItemView; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseAbstractState -// Flags: (4096) Dispatchable -// GUID: {BEAED5EC-578D-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseAbstractState = dispinterface ['{BEAED5EC-578D-11D2-92AA-004005141253}'] property Name: WideString dispid 100; @@ -4791,7 +4552,7 @@ interface property SubSynchronizations: IRoseSyncItemCollection dispid 12804; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -4802,7 +4563,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -4842,11 +4603,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseModuleVisibilityRelationshipCollection -// Flags: (4096) Dispatchable -// GUID: {97B38363-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseModuleVisibilityRelationshipCollection = dispinterface ['{97B38363-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -4863,11 +4622,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseModuleVisibilityRelationship; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseClassCollection -// Flags: (4096) Dispatchable -// GUID: {97B38349-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseClassCollection = dispinterface ['{97B38349-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -4884,11 +4641,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseClass; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseMessage -// Flags: (4096) Dispatchable -// GUID: {F819833C-FC55-11CF-BBD3-00A024C67143} -// *********************************************************************// + + + IRoseMessage = dispinterface ['{F819833C-FC55-11CF-BBD3-00A024C67143}'] property Name: WideString dispid 100; @@ -4903,7 +4658,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -4914,7 +4669,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -4939,11 +4694,9 @@ interface function GetSequenceInformation: WideString; dispid 12825; end; -// *********************************************************************// -// DispIntf: IRoseConnectionRelationCollection -// Flags: (4096) Dispatchable -// GUID: {4467F446-F24E-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseConnectionRelationCollection = dispinterface ['{4467F446-F24E-11D2-92AA-004005141253}'] property Count: Smallint dispid 202; @@ -4960,11 +4713,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseConnectionRelation; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseClassDependencyCollection -// Flags: (4096) Dispatchable -// GUID: {ED042E4F-6CDE-11D1-BC1E-00A024C67143} -// *********************************************************************// + + + IRoseClassDependencyCollection = dispinterface ['{ED042E4F-6CDE-11D1-BC1E-00A024C67143}'] property Count: Smallint dispid 202; @@ -4981,11 +4732,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseClassDependency; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseAssociation -// Flags: (4096) Dispatchable -// GUID: {C78E7026-86E4-11CF-B3D4-00A0241DB1D0} -// *********************************************************************// + + + IRoseAssociation = dispinterface ['{C78E7026-86E4-11CF-B3D4-00A0241DB1D0}'] property Name: WideString dispid 100; @@ -5005,7 +4754,7 @@ interface property ParentCategory: IRoseCategory dispid 12798; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -5016,7 +4765,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -5041,11 +4790,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseEventCollection -// Flags: (4096) Dispatchable -// GUID: {97B38361-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseEventCollection = dispinterface ['{97B38361-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -5062,11 +4809,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseEvent; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseStateCollection -// Flags: (4096) Dispatchable -// GUID: {97B38367-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseStateCollection = dispinterface ['{97B38367-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -5083,11 +4828,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseState; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseSyncItemView -// Flags: (4096) Dispatchable -// GUID: {94CA1888-5D13-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseSyncItemView = dispinterface ['{94CA1888-5D13-11D2-92AA-004005141253}'] property Name: WideString dispid 100; @@ -5108,7 +4851,7 @@ interface property Horizontal: WordBool dispid 12789; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -5119,7 +4862,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -5145,11 +4888,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseActivityView -// Flags: (4096) Dispatchable -// GUID: {BEAED5FC-578D-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseActivityView = dispinterface ['{BEAED5FC-578D-11D2-92AA-004005141253}'] property Name: WideString dispid 100; @@ -5169,7 +4910,7 @@ interface property LineVertices: IRoseLineVertexCollection dispid 12696; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -5180,7 +4921,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -5206,11 +4947,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseStateView -// Flags: (4096) Dispatchable -// GUID: {7BD909E1-9AF9-11D0-A214-00A024FFFE40} -// *********************************************************************// + + + IRoseStateView = dispinterface ['{7BD909E1-9AF9-11D0-A214-00A024FFFE40}'] property Name: WideString dispid 100; @@ -5230,7 +4969,7 @@ interface property LineVertices: IRoseLineVertexCollection dispid 12696; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -5241,7 +4980,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -5267,11 +5006,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseStateVertexCollection -// Flags: (4096) Dispatchable -// GUID: {BEAED5F7-578D-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseStateVertexCollection = dispinterface ['{BEAED5F7-578D-11D2-92AA-004005141253}'] property Count: Smallint dispid 202; @@ -5288,11 +5025,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseStateVertex; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseSubsystemViewCollection -// Flags: (4096) Dispatchable -// GUID: {CA3AD902-BFCE-11D0-89F5-0020AFD6C181} -// *********************************************************************// + + + IRoseSubsystemViewCollection = dispinterface ['{CA3AD902-BFCE-11D0-89F5-0020AFD6C181}'] property Count: Smallint dispid 202; @@ -5309,11 +5044,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseSubsystemView; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseModuleDiagram -// Flags: (4096) Dispatchable -// GUID: {3FD9D004-93B0-11CF-B3D4-00A0241DB1D0} -// *********************************************************************// + + + IRoseModuleDiagram = dispinterface ['{3FD9D004-93B0-11CF-B3D4-00A0241DB1D0}'] property Name: WideString dispid 100; @@ -5330,7 +5063,7 @@ interface property ZoomFactor: Smallint dispid 12690; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -5341,7 +5074,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -5381,11 +5114,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseSubsystem -// Flags: (4096) Dispatchable -// GUID: {C78E702C-86E4-11CF-B3D4-00A0241DB1D0} -// *********************************************************************// + + + IRoseSubsystem = dispinterface ['{C78E702C-86E4-11CF-B3D4-00A0241DB1D0}'] property Name: WideString dispid 100; @@ -5402,7 +5133,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -5413,7 +5144,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -5470,11 +5201,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseExternalDocumentCollection -// Flags: (4096) Dispatchable -// GUID: {97B38357-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseExternalDocumentCollection = dispinterface ['{97B38357-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -5491,11 +5220,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseExternalDocument; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseInstanceViewCollection -// Flags: (4096) Dispatchable -// GUID: {C640C864-F2D3-11D0-883A-3C8B00C10000} -// *********************************************************************// + + + IRoseInstanceViewCollection = dispinterface ['{C640C864-F2D3-11D0-883A-3C8B00C10000}'] property Count: Smallint dispid 202; @@ -5512,11 +5239,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseInstanceView; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseItemView -// Flags: (4096) Dispatchable -// GUID: {7DFAFE40-A29D-11CF-B3D4-00A0241DB1D0} -// *********************************************************************// + + + IRoseItemView = dispinterface ['{7DFAFE40-A29D-11CF-B3D4-00A0241DB1D0}'] property Name: WideString dispid 100; @@ -5536,7 +5261,7 @@ interface property LineVertices: IRoseLineVertexCollection dispid 12696; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -5547,7 +5272,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -5572,11 +5297,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseTransitionCollection -// Flags: (4096) Dispatchable -// GUID: {97B3836B-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseTransitionCollection = dispinterface ['{97B3836B-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -5593,11 +5316,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseTransition; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseState -// Flags: (4096) Dispatchable -// GUID: {A69CAB23-9179-11D0-A214-00A024FFFE40} -// *********************************************************************// + + + IRoseState = dispinterface ['{A69CAB23-9179-11D0-A214-00A024FFFE40}'] property Name: WideString dispid 100; @@ -5619,7 +5340,7 @@ interface property SubSynchronizations: IRoseSyncItemCollection dispid 12804; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -5630,7 +5351,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -5674,11 +5395,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseObjectInstanceCollection -// Flags: (4096) Dispatchable -// GUID: {97B3835A-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseObjectInstanceCollection = dispinterface ['{97B3835A-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -5695,11 +5414,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseObjectInstance; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseRoleCollection -// Flags: (4096) Dispatchable -// GUID: {97B38353-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseRoleCollection = dispinterface ['{97B38353-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -5716,11 +5433,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseRole; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseClassRelation -// Flags: (4096) Dispatchable -// GUID: {00C99564-9200-11CF-B1B0-D227D5210B2C} -// *********************************************************************// + + + IRoseClassRelation = dispinterface ['{00C99564-9200-11CF-B1B0-D227D5210B2C}'] property Name: WideString dispid 100; @@ -5734,7 +5449,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -5745,7 +5460,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -5769,11 +5484,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseCategory -// Flags: (4096) Dispatchable -// GUID: {D7BC1B45-8618-11CF-B3D4-00A0241DB1D0} -// *********************************************************************// + + + IRoseCategory = dispinterface ['{D7BC1B45-8618-11CF-B3D4-00A0241DB1D0}'] property Name: WideString dispid 100; @@ -5794,7 +5507,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -5805,7 +5518,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -5850,7 +5563,7 @@ interface function GetQualifiedName: WideString; dispid 12555; function IsModified: WordBool; dispid 12654; function Uncontrol: WordBool; dispid 12655; - function AddCategoryDependency(const theName: WideString; + function AddCategoryDependency(const theName: WideString; const theSupplierCategoryName: WideString): IRoseCategoryDependency; dispid 12659; function GetCategoryDependencies: IRoseCategoryDependencyCollection; dispid 12660; function DeleteCategoryDependency(const theDependency: IRoseCategoryDependency): WordBool; dispid 12661; @@ -5869,11 +5582,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseDefaultModelProperties -// Flags: (4096) Dispatchable -// GUID: {76ACC49D-FA18-11D0-BC11-00A024C67143} -// *********************************************************************// + + + IRoseDefaultModelProperties = dispinterface ['{76ACC49D-FA18-11D0-BC11-00A024C67143}'] property Name: WideString dispid 100; @@ -5886,7 +5597,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -5896,7 +5607,7 @@ interface function GetToolProperties(const theToolName: WideString): IRosePropertyCollection; dispid 123; function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetToolNames: IRoseStringCollection; dispid 130; @@ -5905,22 +5616,22 @@ interface function AddExternalDocument(const szName: WideString; iType: Smallint): IRoseExternalDocument; dispid 214; function DeleteExternalDocument(const pIDispatch: IRoseExternalDocument): WordBool; dispid 215; function OpenSpecification: WordBool; dispid 216; - function AddDefaultProperty(const ClassName: WideString; const ToolName: WideString; - const SetName: WideString; const PropName: WideString; + function AddDefaultProperty(const ClassName: WideString; const ToolName: WideString; + const SetName: WideString; const PropName: WideString; const PropType: WideString; const Value: WideString): WordBool; dispid 440; - function CloneDefaultPropertySet(const ClassName: WideString; const ToolName: WideString; - const ExistingSetName: WideString; + function CloneDefaultPropertySet(const ClassName: WideString; const ToolName: WideString; + const ExistingSetName: WideString; const NewSetName: WideString): WordBool; dispid 441; - function CreateDefaultPropertySet(const ClassName: WideString; const ToolName: WideString; + function CreateDefaultPropertySet(const ClassName: WideString; const ToolName: WideString; const NewSetName: WideString): WordBool; dispid 442; - function DeleteDefaultPropertySet(const ClassName: WideString; const ToolName: WideString; + function DeleteDefaultPropertySet(const ClassName: WideString; const ToolName: WideString; const SetName: WideString): WordBool; dispid 443; - function GetDefaultPropertySet(const ClassName: WideString; const ToolName: WideString; + function GetDefaultPropertySet(const ClassName: WideString; const ToolName: WideString; const SetName: WideString): IRosePropertyCollection; dispid 444; - function FindDefaultProperty(const ClassName: WideString; const ToolName: WideString; + function FindDefaultProperty(const ClassName: WideString; const ToolName: WideString; const SetName: WideString; const PropName: WideString): IRoseProperty; dispid 445; function GetDefaultSetNames(const ClassName: WideString; const ToolName: WideString): IRoseStringCollection; dispid 447; - function DeleteDefaultProperty(const ClassName: WideString; const ToolName: WideString; + function DeleteDefaultProperty(const ClassName: WideString; const ToolName: WideString; const SetName: WideString; const PropName: WideString): WordBool; dispid 449; function IsControlled: WordBool; dispid 12433; function Control(const Path: WideString): WordBool; dispid 12434; @@ -5951,11 +5662,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseStateMachineCollection -// Flags: (4096) Dispatchable -// GUID: {97B38369-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRoseStateMachineCollection = dispinterface ['{97B38369-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -5972,11 +5681,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseStateMachine; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseSyncItem -// Flags: (4096) Dispatchable -// GUID: {94CA188B-5D13-11D2-92AA-004005141253} -// *********************************************************************// + + + IRoseSyncItem = dispinterface ['{94CA188B-5D13-11D2-92AA-004005141253}'] property Name: WideString dispid 100; @@ -5992,7 +5699,7 @@ interface property StateMachineOwner: IRoseStateMachineOwner dispid 12790; function GetUniqueID: WideString; dispid 102; function GetCurrentPropertySetName(const ToolName: WideString): WideString; dispid 109; - function OverrideProperty(const theToolName: WideString; const thePropName: WideString; + function OverrideProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString): WordBool; dispid 110; function InheritProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 111; function GetPropertyValue(const theToolName: WideString; const thePropName: WideString): WideString; dispid 119; @@ -6003,7 +5710,7 @@ interface function IsOverriddenProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 124; function IsDefaultProperty(const theToolName: WideString; const thePropName: WideString): WordBool; dispid 125; function FindDefaultProperty(const theToolName: WideString; const thePropName: WideString): IRoseProperty; dispid 126; - function CreateProperty(const theToolName: WideString; const thePropName: WideString; + function CreateProperty(const theToolName: WideString; const thePropName: WideString; const theValue: WideString; const theType: WideString): WordBool; dispid 127; function GetPropertyClassName: WideString; dispid 128; function GetDefaultSetNames(const ToolName: WideString): IRoseStringCollection; dispid 129; @@ -6025,11 +5732,9 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// DispIntf: IRoseRealizeRelationCollection -// Flags: (4096) Dispatchable -// GUID: {67448181-4553-11D1-883B-3C8B00C10000} -// *********************************************************************// + + + IRoseRealizeRelationCollection = dispinterface ['{67448181-4553-11D1-883B-3C8B00C10000}'] property Count: Smallint dispid 202; @@ -6046,11 +5751,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRoseRealizeRelation; dispid 213; end; -// *********************************************************************// -// DispIntf: IRosePackageCollection -// Flags: (4096) Dispatchable -// GUID: {97B38364-A4E3-11D0-BFF0-00AA003DEF5B} -// *********************************************************************// + + + IRosePackageCollection = dispinterface ['{97B38364-A4E3-11D0-BFF0-00AA003DEF5B}'] property Count: Smallint dispid 202; @@ -6067,11 +5770,9 @@ interface function GetWithUniqueID(const UniqueID: WideString): IRosePackage; dispid 213; end; -// *********************************************************************// -// DispIntf: IRoseExternalDocument -// Flags: (4096) Dispatchable -// GUID: {906FF583-276B-11D0-8980-00A024774419} -// *********************************************************************// + + + IRoseExternalDocument = dispinterface ['{906FF583-276B-11D0-8980-00A024774419}'] property Path: WideString dispid 1; @@ -6087,1633 +5788,1361 @@ interface function GetIconIndex: Smallint; dispid 12824; end; -// *********************************************************************// -// The Class CoRoseActivityViewCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseActivityViewCollection exposed by -// the CoClass RoseActivityViewCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseActivityViewCollection = class class function Create: IRoseActivityViewCollection; class function CreateRemote(const MachineName: string): IRoseActivityViewCollection; end; -// *********************************************************************// -// The Class CoRoseProcessorCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseProcessorCollection exposed by -// the CoClass RoseProcessorCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseProcessorCollection = class class function Create: IRoseProcessorCollection; class function CreateRemote(const MachineName: string): IRoseProcessorCollection; end; -// *********************************************************************// -// The Class CoRoseCategoryCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseCategoryCollection exposed by -// the CoClass RoseCategoryCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseCategoryCollection = class class function Create: IRoseCategoryCollection; class function CreateRemote(const MachineName: string): IRoseCategoryCollection; end; -// *********************************************************************// -// The Class CoRoseDeploymentUnit provides a Create and CreateRemote method to -// create instances of the default interface IRoseDeploymentUnit exposed by -// the CoClass RoseDeploymentUnit. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseDeploymentUnit = class class function Create: IRoseDeploymentUnit; class function CreateRemote(const MachineName: string): IRoseDeploymentUnit; end; -// *********************************************************************// -// The Class CoRoseItem provides a Create and CreateRemote method to -// create instances of the default interface IRoseItem exposed by -// the CoClass RoseItem. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseItem = class class function Create: IRoseItem; class function CreateRemote(const MachineName: string): IRoseItem; end; -// *********************************************************************// -// The Class CoRoseContextMenuItemCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseContextMenuItemCollection exposed by -// the CoClass RoseContextMenuItemCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseContextMenuItemCollection = class class function Create: IRoseContextMenuItemCollection; class function CreateRemote(const MachineName: string): IRoseContextMenuItemCollection; end; -// *********************************************************************// -// The Class CoRoseAddIn provides a Create and CreateRemote method to -// create instances of the default interface IRoseAddIn exposed by -// the CoClass RoseAddIn. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseAddIn = class class function Create: IRoseAddIn; class function CreateRemote(const MachineName: string): IRoseAddIn; end; -// *********************************************************************// -// The Class CoRoseDecisionViewCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseDecisionViewCollection exposed by -// the CoClass RoseDecisionViewCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseDecisionViewCollection = class class function Create: IRoseDecisionViewCollection; class function CreateRemote(const MachineName: string): IRoseDecisionViewCollection; end; -// *********************************************************************// -// The Class CoRoseStateVertex provides a Create and CreateRemote method to -// create instances of the default interface IRoseStateVertex exposed by -// the CoClass RoseStateVertex. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseStateVertex = class class function Create: IRoseStateVertex; class function CreateRemote(const MachineName: string): IRoseStateVertex; end; -// *********************************************************************// -// The Class CoRoseUseCaseCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseUseCaseCollection exposed by -// the CoClass RoseUseCaseCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseUseCaseCollection = class class function Create: IRoseUseCaseCollection; class function CreateRemote(const MachineName: string): IRoseUseCaseCollection; end; -// *********************************************************************// -// The Class CoRoseConnectionRelation provides a Create and CreateRemote method to -// create instances of the default interface IRoseConnectionRelation exposed by -// the CoClass RoseConnectionRelation. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseConnectionRelation = class class function Create: IRoseConnectionRelation; class function CreateRemote(const MachineName: string): IRoseConnectionRelation; end; -// *********************************************************************// -// The Class CoRoseRelation provides a Create and CreateRemote method to -// create instances of the default interface IRoseRelation exposed by -// the CoClass RoseRelation. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseRelation = class class function Create: IRoseRelation; class function CreateRemote(const MachineName: string): IRoseRelation; end; -// *********************************************************************// -// The Class CoRoseApplication provides a Create and CreateRemote method to -// create instances of the default interface IRoseApplication exposed by -// the CoClass RoseApplication. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseApplication = class class function Create: IRoseApplication; class function CreateRemote(const MachineName: string): IRoseApplication; end; -// *********************************************************************// -// The Class CoRoseDecisionCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseDecisionCollection exposed by -// the CoClass RoseDecisionCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseDecisionCollection = class class function Create: IRoseDecisionCollection; class function CreateRemote(const MachineName: string): IRoseDecisionCollection; end; -// *********************************************************************// -// The Class CoRoseDecision provides a Create and CreateRemote method to -// create instances of the default interface IRoseDecision exposed by -// the CoClass RoseDecision. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseDecision = class class function Create: IRoseDecision; class function CreateRemote(const MachineName: string): IRoseDecision; end; -// *********************************************************************// -// The Class CoRoseLineVertexCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseLineVertexCollection exposed by -// the CoClass RoseLineVertexCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseLineVertexCollection = class class function Create: IRoseLineVertexCollection; class function CreateRemote(const MachineName: string): IRoseLineVertexCollection; end; -// *********************************************************************// -// The Class CoRoseInstantiateRelationCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseInstantiateRelationCollection exposed by -// the CoClass RoseInstantiateRelationCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseInstantiateRelationCollection = class class function Create: IRoseInstantiateRelationCollection; class function CreateRemote(const MachineName: string): IRoseInstantiateRelationCollection; end; -// *********************************************************************// -// The Class CoRoseMessageCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseMessageCollection exposed by -// the CoClass RoseMessageCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseMessageCollection = class class function Create: IRoseMessageCollection; class function CreateRemote(const MachineName: string): IRoseMessageCollection; end; -// *********************************************************************// -// The Class CoRoseClassDiagramCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseClassDiagramCollection exposed by -// the CoClass RoseClassDiagramCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseClassDiagramCollection = class class function Create: IRoseClassDiagramCollection; class function CreateRemote(const MachineName: string): IRoseClassDiagramCollection; end; -// *********************************************************************// -// The Class CoRoseScenarioDiagram provides a Create and CreateRemote method to -// create instances of the default interface IRoseScenarioDiagram exposed by -// the CoClass RoseScenarioDiagram. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseScenarioDiagram = class class function Create: IRoseScenarioDiagram; class function CreateRemote(const MachineName: string): IRoseScenarioDiagram; end; -// *********************************************************************// -// The Class CoRoseRealizeRelation provides a Create and CreateRemote method to -// create instances of the default interface IRoseRealizeRelation exposed by -// the CoClass RoseRealizeRelation. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseRealizeRelation = class class function Create: IRoseRealizeRelation; class function CreateRemote(const MachineName: string): IRoseRealizeRelation; end; -// *********************************************************************// -// The Class CoRoseHasRelationship provides a Create and CreateRemote method to -// create instances of the default interface IRoseHasRelationship exposed by -// the CoClass RoseHasRelationship. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseHasRelationship = class class function Create: IRoseHasRelationship; class function CreateRemote(const MachineName: string): IRoseHasRelationship; end; -// *********************************************************************// -// The Class CoRoseClassView provides a Create and CreateRemote method to -// create instances of the default interface IRoseClassView exposed by -// the CoClass RoseClassView. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseClassView = class class function Create: IRoseClassView; class function CreateRemote(const MachineName: string): IRoseClassView; end; -// *********************************************************************// -// The Class CoRoseView_FillColor provides a Create and CreateRemote method to -// create instances of the default interface IRoseView_FillColor exposed by -// the CoClass RoseView_FillColor. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseView_FillColor = class class function Create: IRoseView_FillColor; class function CreateRemote(const MachineName: string): IRoseView_FillColor; end; -// *********************************************************************// -// The Class CoRoseActionCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseActionCollection exposed by -// the CoClass RoseActionCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseActionCollection = class class function Create: IRoseActionCollection; class function CreateRemote(const MachineName: string): IRoseActionCollection; end; -// *********************************************************************// -// The Class CoRoseSyncItemCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseSyncItemCollection exposed by -// the CoClass RoseSyncItemCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseSyncItemCollection = class class function Create: IRoseSyncItemCollection; class function CreateRemote(const MachineName: string): IRoseSyncItemCollection; end; -// *********************************************************************// -// The Class CoRoseActivityCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseActivityCollection exposed by -// the CoClass RoseActivityCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseActivityCollection = class class function Create: IRoseActivityCollection; class function CreateRemote(const MachineName: string): IRoseActivityCollection; end; -// *********************************************************************// -// The Class CoRoseActivity provides a Create and CreateRemote method to -// create instances of the default interface IRoseActivity exposed by -// the CoClass RoseActivity. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseActivity = class class function Create: IRoseActivity; class function CreateRemote(const MachineName: string): IRoseActivity; end; -// *********************************************************************// -// The Class CoRoseProcess provides a Create and CreateRemote method to -// create instances of the default interface IRoseProcess exposed by -// the CoClass RoseProcess. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseProcess = class class function Create: IRoseProcess; class function CreateRemote(const MachineName: string): IRoseProcess; end; -// *********************************************************************// -// The Class CoRoseAddInCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseAddInCollection exposed by -// the CoClass RoseAddInCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseAddInCollection = class class function Create: IRoseAddInCollection; class function CreateRemote(const MachineName: string): IRoseAddInCollection; end; -// *********************************************************************// -// The Class CoRoseSwimLaneView provides a Create and CreateRemote method to -// create instances of the default interface IRoseSwimLaneView exposed by -// the CoClass RoseSwimLaneView. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseSwimLaneView = class class function Create: IRoseSwimLaneView; class function CreateRemote(const MachineName: string): IRoseSwimLaneView; end; -// *********************************************************************// -// The Class CoRoseControllableUnitCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseControllableUnitCollection exposed by -// the CoClass RoseControllableUnitCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseControllableUnitCollection = class class function Create: IRoseControllableUnitCollection; class function CreateRemote(const MachineName: string): IRoseControllableUnitCollection; end; -// *********************************************************************// -// The Class CoRoseModuleCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseModuleCollection exposed by -// the CoClass RoseModuleCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseModuleCollection = class class function Create: IRoseModuleCollection; class function CreateRemote(const MachineName: string): IRoseModuleCollection; end; -// *********************************************************************// -// The Class CoRoseLinkCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseLinkCollection exposed by -// the CoClass RoseLinkCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseLinkCollection = class class function Create: IRoseLinkCollection; class function CreateRemote(const MachineName: string): IRoseLinkCollection; end; -// *********************************************************************// -// The Class CoRoseAction provides a Create and CreateRemote method to -// create instances of the default interface IRoseAction exposed by -// the CoClass RoseAction. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseAction = class class function Create: IRoseAction; class function CreateRemote(const MachineName: string): IRoseAction; end; -// *********************************************************************// -// The Class CoRoseParameterCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseParameterCollection exposed by -// the CoClass RoseParameterCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseParameterCollection = class class function Create: IRoseParameterCollection; class function CreateRemote(const MachineName: string): IRoseParameterCollection; end; -// *********************************************************************// -// The Class CoRoseAttributeCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseAttributeCollection exposed by -// the CoClass RoseAttributeCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseAttributeCollection = class class function Create: IRoseAttributeCollection; class function CreateRemote(const MachineName: string): IRoseAttributeCollection; end; -// *********************************************************************// -// The Class CoRoseDevice provides a Create and CreateRemote method to -// create instances of the default interface IRoseDevice exposed by -// the CoClass RoseDevice. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseDevice = class class function Create: IRoseDevice; class function CreateRemote(const MachineName: string): IRoseDevice; end; -// *********************************************************************// -// The Class CoRoseClassDependency provides a Create and CreateRemote method to -// create instances of the default interface IRoseClassDependency exposed by -// the CoClass RoseClassDependency. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseClassDependency = class class function Create: IRoseClassDependency; class function CreateRemote(const MachineName: string): IRoseClassDependency; end; -// *********************************************************************// -// The Class CoRoseRole provides a Create and CreateRemote method to -// create instances of the default interface IRoseRole exposed by -// the CoClass RoseRole. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseRole = class class function Create: IRoseRole; class function CreateRemote(const MachineName: string): IRoseRole; end; -// *********************************************************************// -// The Class CoRoseClass provides a Create and CreateRemote method to -// create instances of the default interface IRoseClass exposed by -// the CoClass RoseClass. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseClass = class class function Create: IRoseClass; class function CreateRemote(const MachineName: string): IRoseClass; end; -// *********************************************************************// -// The Class CoRoseElement provides a Create and CreateRemote method to -// create instances of the default interface IRoseElement exposed by -// the CoClass RoseElement. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseElement = class class function Create: IRoseElement; class function CreateRemote(const MachineName: string): IRoseElement; end; -// *********************************************************************// -// The Class CoRoseControllableUnit provides a Create and CreateRemote method to -// create instances of the default interface IRoseControllableUnit exposed by -// the CoClass RoseControllableUnit. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseControllableUnit = class class function Create: IRoseControllableUnit; class function CreateRemote(const MachineName: string): IRoseControllableUnit; end; -// *********************************************************************// -// The Class CoRoseModel provides a Create and CreateRemote method to -// create instances of the default interface IRoseModel exposed by -// the CoClass RoseModel. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseModel = class class function Create: IRoseModel; class function CreateRemote(const MachineName: string): IRoseModel; end; -// *********************************************************************// -// The Class CoRoseTransition provides a Create and CreateRemote method to -// create instances of the default interface IRoseTransition exposed by -// the CoClass RoseTransition. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseTransition = class class function Create: IRoseTransition; class function CreateRemote(const MachineName: string): IRoseTransition; end; -// *********************************************************************// -// The Class CoRoseSubsystemCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseSubsystemCollection exposed by -// the CoClass RoseSubsystemCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseSubsystemCollection = class class function Create: IRoseSubsystemCollection; class function CreateRemote(const MachineName: string): IRoseSubsystemCollection; end; -// *********************************************************************// -// The Class CoRoseProcessor provides a Create and CreateRemote method to -// create instances of the default interface IRoseProcessor exposed by -// the CoClass RoseProcessor. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseProcessor = class class function Create: IRoseProcessor; class function CreateRemote(const MachineName: string): IRoseProcessor; end; -// *********************************************************************// -// The Class CoRoseCategoryDependencyCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseCategoryDependencyCollection exposed by -// the CoClass RoseCategoryDependencyCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseCategoryDependencyCollection = class class function Create: IRoseCategoryDependencyCollection; class function CreateRemote(const MachineName: string): IRoseCategoryDependencyCollection; end; -// *********************************************************************// -// The Class CoRoseProperty provides a Create and CreateRemote method to -// create instances of the default interface IRoseProperty exposed by -// the CoClass RoseProperty. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseProperty = class class function Create: IRoseProperty; class function CreateRemote(const MachineName: string): IRoseProperty; end; -// *********************************************************************// -// The Class CoRoseStateDiagram provides a Create and CreateRemote method to -// create instances of the default interface IRoseStateDiagram exposed by -// the CoClass RoseStateDiagram. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseStateDiagram = class class function Create: IRoseStateDiagram; class function CreateRemote(const MachineName: string): IRoseStateDiagram; end; -// *********************************************************************// -// The Class CoRoseEvent provides a Create and CreateRemote method to -// create instances of the default interface IRoseEvent exposed by -// the CoClass RoseEvent. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseEvent = class class function Create: IRoseEvent; class function CreateRemote(const MachineName: string): IRoseEvent; end; -// *********************************************************************// -// The Class CoRoseRichType provides a Create and CreateRemote method to -// create instances of the default interface IRoseRichType exposed by -// the CoClass RoseRichType. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseRichType = class class function Create: IRoseRichType; class function CreateRemote(const MachineName: string): IRoseRichType; end; -// *********************************************************************// -// The Class CoRoseScenarioDiagramCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseScenarioDiagramCollection exposed by -// the CoClass RoseScenarioDiagramCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseScenarioDiagramCollection = class class function Create: IRoseScenarioDiagramCollection; class function CreateRemote(const MachineName: string): IRoseScenarioDiagramCollection; end; -// *********************************************************************// -// The Class CoRoseParameter provides a Create and CreateRemote method to -// create instances of the default interface IRoseParameter exposed by -// the CoClass RoseParameter. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseParameter = class class function Create: IRoseParameter; class function CreateRemote(const MachineName: string): IRoseParameter; end; -// *********************************************************************// -// The Class CoRoseOperation provides a Create and CreateRemote method to -// create instances of the default interface IRoseOperation exposed by -// the CoClass RoseOperation. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseOperation = class class function Create: IRoseOperation; class function CreateRemote(const MachineName: string): IRoseOperation; end; -// *********************************************************************// -// The Class CoRoseView_LineColor provides a Create and CreateRemote method to -// create instances of the default interface IRoseView_LineColor exposed by -// the CoClass RoseView_LineColor. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseView_LineColor = class class function Create: IRoseView_LineColor; class function CreateRemote(const MachineName: string): IRoseView_LineColor; end; -// *********************************************************************// -// The Class CoRoseAddInManager provides a Create and CreateRemote method to -// create instances of the default interface IRoseAddInManager exposed by -// the CoClass RoseAddInManager. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseAddInManager = class class function Create: IRoseAddInManager; class function CreateRemote(const MachineName: string): IRoseAddInManager; end; -// *********************************************************************// -// The Class CoRoseStateDiagramCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseStateDiagramCollection exposed by -// the CoClass RoseStateDiagramCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseStateDiagramCollection = class class function Create: IRoseStateDiagramCollection; class function CreateRemote(const MachineName: string): IRoseStateDiagramCollection; end; -// *********************************************************************// -// The Class CoRoseSwimLaneViewCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseSwimLaneViewCollection exposed by -// the CoClass RoseSwimLaneViewCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseSwimLaneViewCollection = class class function Create: IRoseSwimLaneViewCollection; class function CreateRemote(const MachineName: string): IRoseSwimLaneViewCollection; end; -// *********************************************************************// -// The Class CoRoseSwimLane provides a Create and CreateRemote method to -// create instances of the default interface IRoseSwimLane exposed by -// the CoClass RoseSwimLane. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseSwimLane = class class function Create: IRoseSwimLane; class function CreateRemote(const MachineName: string): IRoseSwimLane; end; -// *********************************************************************// -// The Class CoRoseItemViewCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseItemViewCollection exposed by -// the CoClass RoseItemViewCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseItemViewCollection = class class function Create: IRoseItemViewCollection; class function CreateRemote(const MachineName: string): IRoseItemViewCollection; end; -// *********************************************************************// -// The Class CoRosePropertyCollection provides a Create and CreateRemote method to -// create instances of the default interface IRosePropertyCollection exposed by -// the CoClass RosePropertyCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRosePropertyCollection = class class function Create: IRosePropertyCollection; class function CreateRemote(const MachineName: string): IRosePropertyCollection; end; -// *********************************************************************// -// The Class CoRoseOperationCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseOperationCollection exposed by -// the CoClass RoseOperationCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseOperationCollection = class class function Create: IRoseOperationCollection; class function CreateRemote(const MachineName: string): IRoseOperationCollection; end; -// *********************************************************************// -// The Class CoRoseDeviceCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseDeviceCollection exposed by -// the CoClass RoseDeviceCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseDeviceCollection = class class function Create: IRoseDeviceCollection; class function CreateRemote(const MachineName: string): IRoseDeviceCollection; end; -// *********************************************************************// -// The Class CoRoseInstantiateRelation provides a Create and CreateRemote method to -// create instances of the default interface IRoseInstantiateRelation exposed by -// the CoClass RoseInstantiateRelation. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseInstantiateRelation = class class function Create: IRoseInstantiateRelation; class function CreateRemote(const MachineName: string): IRoseInstantiateRelation; end; -// *********************************************************************// -// The Class CoRoseContextMenuItem provides a Create and CreateRemote method to -// create instances of the default interface IRoseContextMenuItem exposed by -// the CoClass RoseContextMenuItem. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseContextMenuItem = class class function Create: IRoseContextMenuItem; class function CreateRemote(const MachineName: string): IRoseContextMenuItem; end; -// *********************************************************************// -// The Class CoRoseLineVertex provides a Create and CreateRemote method to -// create instances of the default interface IRoseLineVertex exposed by -// the CoClass RoseLineVertex. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseLineVertex = class class function Create: IRoseLineVertex; class function CreateRemote(const MachineName: string): IRoseLineVertex; end; -// *********************************************************************// -// The Class CoRoseObject provides a Create and CreateRemote method to -// create instances of the default interface IRoseObject exposed by -// the CoClass RoseObject. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseObject = class class function Create: IRoseObject; class function CreateRemote(const MachineName: string): IRoseObject; end; -// *********************************************************************// -// The Class CoRoseSwimLaneCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseSwimLaneCollection exposed by -// the CoClass RoseSwimLaneCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseSwimLaneCollection = class class function Create: IRoseSwimLaneCollection; class function CreateRemote(const MachineName: string): IRoseSwimLaneCollection; end; -// *********************************************************************// -// The Class CoRoseModuleVisibilityRelationship provides a Create and CreateRemote method to -// create instances of the default interface IRoseModuleVisibilityRelationship exposed by -// the CoClass RoseModuleVisibilityRelationship. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseModuleVisibilityRelationship = class class function Create: IRoseModuleVisibilityRelationship; class function CreateRemote(const MachineName: string): IRoseModuleVisibilityRelationship; end; -// *********************************************************************// -// The Class CoRoseComponentViewCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseComponentViewCollection exposed by -// the CoClass RoseComponentViewCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseComponentViewCollection = class class function Create: IRoseComponentViewCollection; class function CreateRemote(const MachineName: string): IRoseComponentViewCollection; end; -// *********************************************************************// -// The Class CoRoseHasRelationshipCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseHasRelationshipCollection exposed by -// the CoClass RoseHasRelationshipCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseHasRelationshipCollection = class class function Create: IRoseHasRelationshipCollection; class function CreateRemote(const MachineName: string): IRoseHasRelationshipCollection; end; -// *********************************************************************// -// The Class CoRoseClassViewCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseClassViewCollection exposed by -// the CoClass RoseClassViewCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseClassViewCollection = class class function Create: IRoseClassViewCollection; class function CreateRemote(const MachineName: string): IRoseClassViewCollection; end; -// *********************************************************************// -// The Class CoRoseDeploymentDiagram provides a Create and CreateRemote method to -// create instances of the default interface IRoseDeploymentDiagram exposed by -// the CoClass RoseDeploymentDiagram. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseDeploymentDiagram = class class function Create: IRoseDeploymentDiagram; class function CreateRemote(const MachineName: string): IRoseDeploymentDiagram; end; -// *********************************************************************// -// The Class CoRoseInstanceView provides a Create and CreateRemote method to -// create instances of the default interface IRoseInstanceView exposed by -// the CoClass RoseInstanceView. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseInstanceView = class class function Create: IRoseInstanceView; class function CreateRemote(const MachineName: string): IRoseInstanceView; end; -// *********************************************************************// -// The Class CoRoseLink provides a Create and CreateRemote method to -// create instances of the default interface IRoseLink exposed by -// the CoClass RoseLink. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseLink = class class function Create: IRoseLink; class function CreateRemote(const MachineName: string): IRoseLink; end; -// *********************************************************************// -// The Class CoRoseObjectInstance provides a Create and CreateRemote method to -// create instances of the default interface IRoseObjectInstance exposed by -// the CoClass RoseObjectInstance. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseObjectInstance = class class function Create: IRoseObjectInstance; class function CreateRemote(const MachineName: string): IRoseObjectInstance; end; -// *********************************************************************// -// The Class CoRoseCategoryDependency provides a Create and CreateRemote method to -// create instances of the default interface IRoseCategoryDependency exposed by -// the CoClass RoseCategoryDependency. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseCategoryDependency = class class function Create: IRoseCategoryDependency; class function CreateRemote(const MachineName: string): IRoseCategoryDependency; end; -// *********************************************************************// -// The Class CoRoseInheritRelation provides a Create and CreateRemote method to -// create instances of the default interface IRoseInheritRelation exposed by -// the CoClass RoseInheritRelation. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseInheritRelation = class class function Create: IRoseInheritRelation; class function CreateRemote(const MachineName: string): IRoseInheritRelation; end; -// *********************************************************************// -// The Class CoRoseView_Font provides a Create and CreateRemote method to -// create instances of the default interface IRoseView_Font exposed by -// the CoClass RoseView_Font. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseView_Font = class class function Create: IRoseView_Font; class function CreateRemote(const MachineName: string): IRoseView_Font; end; -// *********************************************************************// -// The Class CoRoseStateMachine provides a Create and CreateRemote method to -// create instances of the default interface IRoseStateMachine exposed by -// the CoClass RoseStateMachine. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseStateMachine = class class function Create: IRoseStateMachine; class function CreateRemote(const MachineName: string): IRoseStateMachine; end; -// *********************************************************************// -// The Class CoRoseModule provides a Create and CreateRemote method to -// create instances of the default interface IRoseModule exposed by -// the CoClass RoseModule. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseModule = class class function Create: IRoseModule; class function CreateRemote(const MachineName: string): IRoseModule; end; -// *********************************************************************// -// The Class CoRoseUseCase provides a Create and CreateRemote method to -// create instances of the default interface IRoseUseCase exposed by -// the CoClass RoseUseCase. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseUseCase = class class function Create: IRoseUseCase; class function CreateRemote(const MachineName: string): IRoseUseCase; end; -// *********************************************************************// -// The Class CoRoseItemCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseItemCollection exposed by -// the CoClass RoseItemCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseItemCollection = class class function Create: IRoseItemCollection; class function CreateRemote(const MachineName: string): IRoseItemCollection; end; -// *********************************************************************// -// The Class CoRoseNoteViewCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseNoteViewCollection exposed by -// the CoClass RoseNoteViewCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// - CoRoseNoteViewCollection = class - class function Create: IRoseNoteViewCollection; - class function CreateRemote(const MachineName: string): IRoseNoteViewCollection; - end; -// *********************************************************************// -// The Class CoRoseInheritRelationCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseInheritRelationCollection exposed by -// the CoClass RoseInheritRelationCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseNoteViewCollection = class + class function Create: IRoseNoteViewCollection; + class function CreateRemote(const MachineName: string): IRoseNoteViewCollection; + end; + + + + + + CoRoseInheritRelationCollection = class class function Create: IRoseInheritRelationCollection; class function CreateRemote(const MachineName: string): IRoseInheritRelationCollection; end; -// *********************************************************************// -// The Class CoRoseDeploymentDiagramCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseDeploymentDiagramCollection exposed by -// the CoClass RoseDeploymentDiagramCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseDeploymentDiagramCollection = class class function Create: IRoseDeploymentDiagramCollection; class function CreateRemote(const MachineName: string): IRoseDeploymentDiagramCollection; end; -// *********************************************************************// -// The Class CoRoseStringCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseStringCollection exposed by -// the CoClass RoseStringCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseStringCollection = class class function Create: IRoseStringCollection; class function CreateRemote(const MachineName: string): IRoseStringCollection; end; -// *********************************************************************// -// The Class CoRoseStateViewCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseStateViewCollection exposed by -// the CoClass RoseStateViewCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseStateViewCollection = class class function Create: IRoseStateViewCollection; class function CreateRemote(const MachineName: string): IRoseStateViewCollection; end; -// *********************************************************************// -// The Class CoRoseDecisionView provides a Create and CreateRemote method to -// create instances of the default interface IRoseDecisionView exposed by -// the CoClass RoseDecisionView. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseDecisionView = class class function Create: IRoseDecisionView; class function CreateRemote(const MachineName: string): IRoseDecisionView; end; -// *********************************************************************// -// The Class CoRoseStateMachineOwner provides a Create and CreateRemote method to -// create instances of the default interface IRoseStateMachineOwner exposed by -// the CoClass RoseStateMachineOwner. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseStateMachineOwner = class class function Create: IRoseStateMachineOwner; class function CreateRemote(const MachineName: string): IRoseStateMachineOwner; end; -// *********************************************************************// -// The Class CoRoseProcessCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseProcessCollection exposed by -// the CoClass RoseProcessCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseProcessCollection = class class function Create: IRoseProcessCollection; class function CreateRemote(const MachineName: string): IRoseProcessCollection; end; -// *********************************************************************// -// The Class CoRoseAssociationCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseAssociationCollection exposed by -// the CoClass RoseAssociationCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseAssociationCollection = class class function Create: IRoseAssociationCollection; class function CreateRemote(const MachineName: string): IRoseAssociationCollection; end; -// *********************************************************************// -// The Class CoRoseModuleDiagramCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseModuleDiagramCollection exposed by -// the CoClass RoseModuleDiagramCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseModuleDiagramCollection = class class function Create: IRoseModuleDiagramCollection; class function CreateRemote(const MachineName: string): IRoseModuleDiagramCollection; end; -// *********************************************************************// -// The Class CoRoseDiagram provides a Create and CreateRemote method to -// create instances of the default interface IRoseDiagram exposed by -// the CoClass RoseDiagram. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseDiagram = class class function Create: IRoseDiagram; class function CreateRemote(const MachineName: string): IRoseDiagram; end; -// *********************************************************************// -// The Class CoRoseAbstractStateCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseAbstractStateCollection exposed by -// the CoClass RoseAbstractStateCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseAbstractStateCollection = class class function Create: IRoseAbstractStateCollection; class function CreateRemote(const MachineName: string): IRoseAbstractStateCollection; end; -// *********************************************************************// -// The Class CoRoseRichTypeValuesCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseRichTypeValuesCollection exposed by -// the CoClass RoseRichTypeValuesCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseRichTypeValuesCollection = class class function Create: IRoseRichTypeValuesCollection; class function CreateRemote(const MachineName: string): IRoseRichTypeValuesCollection; end; -// *********************************************************************// -// The Class CoRoseSubsystemView provides a Create and CreateRemote method to -// create instances of the default interface IRoseSubsystemView exposed by -// the CoClass RoseSubsystemView. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseSubsystemView = class class function Create: IRoseSubsystemView; class function CreateRemote(const MachineName: string): IRoseSubsystemView; end; -// *********************************************************************// -// The Class CoRoseComponentView provides a Create and CreateRemote method to -// create instances of the default interface IRoseComponentView exposed by -// the CoClass RoseComponentView. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseComponentView = class class function Create: IRoseComponentView; class function CreateRemote(const MachineName: string): IRoseComponentView; end; -// *********************************************************************// -// The Class CoRoseAttribute provides a Create and CreateRemote method to -// create instances of the default interface IRoseAttribute exposed by -// the CoClass RoseAttribute. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseAttribute = class class function Create: IRoseAttribute; class function CreateRemote(const MachineName: string): IRoseAttribute; end; -// *********************************************************************// -// The Class CoRoseClassDiagram provides a Create and CreateRemote method to -// create instances of the default interface IRoseClassDiagram exposed by -// the CoClass RoseClassDiagram. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseClassDiagram = class class function Create: IRoseClassDiagram; class function CreateRemote(const MachineName: string): IRoseClassDiagram; end; -// *********************************************************************// -// The Class CoRoseNoteView provides a Create and CreateRemote method to -// create instances of the default interface IRoseNoteView exposed by -// the CoClass RoseNoteView. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseNoteView = class class function Create: IRoseNoteView; class function CreateRemote(const MachineName: string): IRoseNoteView; end; -// *********************************************************************// -// The Class CoRosePackage provides a Create and CreateRemote method to -// create instances of the default interface IRosePackage exposed by -// the CoClass RosePackage. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRosePackage = class class function Create: IRosePackage; class function CreateRemote(const MachineName: string): IRosePackage; end; -// *********************************************************************// -// The Class CoRosePathMap provides a Create and CreateRemote method to -// create instances of the default interface IRosePathMap exposed by -// the CoClass RosePathMap. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRosePathMap = class class function Create: IRosePathMap; class function CreateRemote(const MachineName: string): IRosePathMap; end; -// *********************************************************************// -// The Class CoRoseSyncItemViewCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseSyncItemViewCollection exposed by -// the CoClass RoseSyncItemViewCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseSyncItemViewCollection = class class function Create: IRoseSyncItemViewCollection; class function CreateRemote(const MachineName: string): IRoseSyncItemViewCollection; end; -// *********************************************************************// -// The Class CoRoseAbstractState provides a Create and CreateRemote method to -// create instances of the default interface IRoseAbstractState exposed by -// the CoClass RoseAbstractState. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseAbstractState = class class function Create: IRoseAbstractState; class function CreateRemote(const MachineName: string): IRoseAbstractState; end; -// *********************************************************************// -// The Class CoRoseModuleVisibilityRelationshipCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseModuleVisibilityRelationshipCollection exposed by -// the CoClass RoseModuleVisibilityRelationshipCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseModuleVisibilityRelationshipCollection = class class function Create: IRoseModuleVisibilityRelationshipCollection; class function CreateRemote(const MachineName: string): IRoseModuleVisibilityRelationshipCollection; end; -// *********************************************************************// -// The Class CoRoseClassCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseClassCollection exposed by -// the CoClass RoseClassCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseClassCollection = class class function Create: IRoseClassCollection; class function CreateRemote(const MachineName: string): IRoseClassCollection; end; -// *********************************************************************// -// The Class CoRoseMessage provides a Create and CreateRemote method to -// create instances of the default interface IRoseMessage exposed by -// the CoClass RoseMessage. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseMessage = class class function Create: IRoseMessage; class function CreateRemote(const MachineName: string): IRoseMessage; end; -// *********************************************************************// -// The Class CoRoseConnectionRelationCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseConnectionRelationCollection exposed by -// the CoClass RoseConnectionRelationCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseConnectionRelationCollection = class class function Create: IRoseConnectionRelationCollection; class function CreateRemote(const MachineName: string): IRoseConnectionRelationCollection; end; -// *********************************************************************// -// The Class CoRoseClassDependencyCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseClassDependencyCollection exposed by -// the CoClass RoseClassDependencyCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseClassDependencyCollection = class class function Create: IRoseClassDependencyCollection; class function CreateRemote(const MachineName: string): IRoseClassDependencyCollection; end; -// *********************************************************************// -// The Class CoRoseAssociation provides a Create and CreateRemote method to -// create instances of the default interface IRoseAssociation exposed by -// the CoClass RoseAssociation. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseAssociation = class class function Create: IRoseAssociation; class function CreateRemote(const MachineName: string): IRoseAssociation; end; -// *********************************************************************// -// The Class CoRoseEventCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseEventCollection exposed by -// the CoClass RoseEventCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseEventCollection = class class function Create: IRoseEventCollection; class function CreateRemote(const MachineName: string): IRoseEventCollection; end; -// *********************************************************************// -// The Class CoRoseStateCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseStateCollection exposed by -// the CoClass RoseStateCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseStateCollection = class class function Create: IRoseStateCollection; class function CreateRemote(const MachineName: string): IRoseStateCollection; end; -// *********************************************************************// -// The Class CoRoseSyncItemView provides a Create and CreateRemote method to -// create instances of the default interface IRoseSyncItemView exposed by -// the CoClass RoseSyncItemView. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseSyncItemView = class class function Create: IRoseSyncItemView; class function CreateRemote(const MachineName: string): IRoseSyncItemView; end; -// *********************************************************************// -// The Class CoRoseActivityView provides a Create and CreateRemote method to -// create instances of the default interface IRoseActivityView exposed by -// the CoClass RoseActivityView. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseActivityView = class class function Create: IRoseActivityView; class function CreateRemote(const MachineName: string): IRoseActivityView; end; -// *********************************************************************// -// The Class CoRoseStateView provides a Create and CreateRemote method to -// create instances of the default interface IRoseStateView exposed by -// the CoClass RoseStateView. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseStateView = class class function Create: IRoseStateView; class function CreateRemote(const MachineName: string): IRoseStateView; end; -// *********************************************************************// -// The Class CoRoseStateVertexCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseStateVertexCollection exposed by -// the CoClass RoseStateVertexCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseStateVertexCollection = class class function Create: IRoseStateVertexCollection; class function CreateRemote(const MachineName: string): IRoseStateVertexCollection; end; -// *********************************************************************// -// The Class CoRoseSubsystemViewCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseSubsystemViewCollection exposed by -// the CoClass RoseSubsystemViewCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseSubsystemViewCollection = class class function Create: IRoseSubsystemViewCollection; class function CreateRemote(const MachineName: string): IRoseSubsystemViewCollection; end; -// *********************************************************************// -// The Class CoRoseModuleDiagram provides a Create and CreateRemote method to -// create instances of the default interface IRoseModuleDiagram exposed by -// the CoClass RoseModuleDiagram. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseModuleDiagram = class class function Create: IRoseModuleDiagram; class function CreateRemote(const MachineName: string): IRoseModuleDiagram; end; -// *********************************************************************// -// The Class CoRoseSubsystem provides a Create and CreateRemote method to -// create instances of the default interface IRoseSubsystem exposed by -// the CoClass RoseSubsystem. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseSubsystem = class class function Create: IRoseSubsystem; class function CreateRemote(const MachineName: string): IRoseSubsystem; end; -// *********************************************************************// -// The Class CoRoseExternalDocumentCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseExternalDocumentCollection exposed by -// the CoClass RoseExternalDocumentCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseExternalDocumentCollection = class class function Create: IRoseExternalDocumentCollection; class function CreateRemote(const MachineName: string): IRoseExternalDocumentCollection; end; -// *********************************************************************// -// The Class CoRoseInstanceViewCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseInstanceViewCollection exposed by -// the CoClass RoseInstanceViewCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseInstanceViewCollection = class class function Create: IRoseInstanceViewCollection; class function CreateRemote(const MachineName: string): IRoseInstanceViewCollection; end; -// *********************************************************************// -// The Class CoRoseItemView provides a Create and CreateRemote method to -// create instances of the default interface IRoseItemView exposed by -// the CoClass RoseItemView. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseItemView = class class function Create: IRoseItemView; class function CreateRemote(const MachineName: string): IRoseItemView; end; -// *********************************************************************// -// The Class CoRoseTransitionCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseTransitionCollection exposed by -// the CoClass RoseTransitionCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseTransitionCollection = class class function Create: IRoseTransitionCollection; class function CreateRemote(const MachineName: string): IRoseTransitionCollection; end; -// *********************************************************************// -// The Class CoRoseState provides a Create and CreateRemote method to -// create instances of the default interface IRoseState exposed by -// the CoClass RoseState. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseState = class class function Create: IRoseState; class function CreateRemote(const MachineName: string): IRoseState; end; -// *********************************************************************// -// The Class CoRoseObjectInstanceCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseObjectInstanceCollection exposed by -// the CoClass RoseObjectInstanceCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseObjectInstanceCollection = class class function Create: IRoseObjectInstanceCollection; class function CreateRemote(const MachineName: string): IRoseObjectInstanceCollection; end; -// *********************************************************************// -// The Class CoRoseRoleCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseRoleCollection exposed by -// the CoClass RoseRoleCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseRoleCollection = class class function Create: IRoseRoleCollection; class function CreateRemote(const MachineName: string): IRoseRoleCollection; end; -// *********************************************************************// -// The Class CoRoseClassRelation provides a Create and CreateRemote method to -// create instances of the default interface IRoseClassRelation exposed by -// the CoClass RoseClassRelation. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseClassRelation = class class function Create: IRoseClassRelation; class function CreateRemote(const MachineName: string): IRoseClassRelation; end; -// *********************************************************************// -// The Class CoRoseCategory provides a Create and CreateRemote method to -// create instances of the default interface IRoseCategory exposed by -// the CoClass RoseCategory. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseCategory = class class function Create: IRoseCategory; class function CreateRemote(const MachineName: string): IRoseCategory; end; -// *********************************************************************// -// The Class CoRoseDefaultModelProperties provides a Create and CreateRemote method to -// create instances of the default interface IRoseDefaultModelProperties exposed by -// the CoClass RoseDefaultModelProperties. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseDefaultModelProperties = class class function Create: IRoseDefaultModelProperties; class function CreateRemote(const MachineName: string): IRoseDefaultModelProperties; end; -// *********************************************************************// -// The Class CoRoseStateMachineCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseStateMachineCollection exposed by -// the CoClass RoseStateMachineCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseStateMachineCollection = class class function Create: IRoseStateMachineCollection; class function CreateRemote(const MachineName: string): IRoseStateMachineCollection; end; -// *********************************************************************// -// The Class CoRoseSyncItem provides a Create and CreateRemote method to -// create instances of the default interface IRoseSyncItem exposed by -// the CoClass RoseSyncItem. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseSyncItem = class class function Create: IRoseSyncItem; class function CreateRemote(const MachineName: string): IRoseSyncItem; end; -// *********************************************************************// -// The Class CoRoseRealizeRelationCollection provides a Create and CreateRemote method to -// create instances of the default interface IRoseRealizeRelationCollection exposed by -// the CoClass RoseRealizeRelationCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseRealizeRelationCollection = class class function Create: IRoseRealizeRelationCollection; class function CreateRemote(const MachineName: string): IRoseRealizeRelationCollection; end; -// *********************************************************************// -// The Class CoRosePackageCollection provides a Create and CreateRemote method to -// create instances of the default interface IRosePackageCollection exposed by -// the CoClass RosePackageCollection. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRosePackageCollection = class class function Create: IRosePackageCollection; class function CreateRemote(const MachineName: string): IRosePackageCollection; end; -// *********************************************************************// -// The Class CoRoseExternalDocument provides a Create and CreateRemote method to -// create instances of the default interface IRoseExternalDocument exposed by -// the CoClass RoseExternalDocument. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoRoseExternalDocument = class class function Create: IRoseExternalDocument; class function CreateRemote(const MachineName: string): IRoseExternalDocument; @@ -9084,5 +8513,3 @@ class function CoRoseExternalDocument.CreateRemote(const MachineName: string): I end; end. - - diff --git a/Source/Common/Rose98/BoldRose98Support.pas b/Source/Common/Rose98/BoldRose98Support.pas index 924505ac..2b5b6543 100644 --- a/Source/Common/Rose98/BoldRose98Support.pas +++ b/Source/Common/Rose98/BoldRose98Support.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldRose98Support; interface @@ -12,7 +15,7 @@ interface TBoldRose98Support = class; TBoldRose98Properties = class; TBoldRose98AddIns = class; - + { TBoldRose98Support } TBoldRose98Support = class public @@ -63,8 +66,7 @@ implementation BoldUtils, BoldDefaultTaggedValues, ActiveX, - BoldLogHandler, - BoldCommonConst; + BoldLogHandler; class function TBoldRose98Support.FindClassByName(RoseModel: IRoseModel; const Name: string): IRoseClass; var @@ -77,7 +79,7 @@ class function TBoldRose98Support.FindClassByName(RoseModel: IRoseModel; const N begin Result := ClsCol.GetAt(1); if ClsCol.Count > 1 then - raise EBoldImport.CreateFmt(sClassNameNotUnique, [Name]); + raise EBoldImport.CreateFmt('Found multiple classes with name %s, don''t know which one to use', [Name]); end; end; @@ -120,7 +122,7 @@ function TBoldRose98Properties.GetBooleanString(RoseItem: IRoseItem; const Name: Result := DefaultValue else begin - if AnsiCompareText(Value, 'True') = 0 then // do not localize + if AnsiCompareText(Value, 'True') = 0 then Result := TV_TRUE else Result := TV_FALSE; @@ -138,7 +140,7 @@ function TBoldRose98Properties.GetBoolean(RoseItem: IRoseItem; const Name: strin if Value = '' then Result := DefaultValue else - Result := (AnsiCompareText(Value, 'True') = 0); // do not localize + Result := (AnsiCompareText(Value, 'True') = 0); end; function TBoldRose98Properties.GetDefaultPropertyBoolean(RoseModel: IRoseModel; PropName: String): Boolean; @@ -148,7 +150,7 @@ function TBoldRose98Properties.GetDefaultPropertyBoolean(RoseModel: IRoseModel; Prop: IRoseProperty; begin DefaultProps := RoseModel.DefaultProperties; - PropCollection := DefaultProps.GetDefaultPropertySet(RoseModel.GetPropertyClassName, ToolName, DEFAULTVALUE); + PropCollection := DefaultProps.GetDefaultPropertySet(RoseModel.GetPropertyClassName, ToolName, 'default'); Index := PropCollection.FindFirst(PropName); if Index > 0 then @@ -168,14 +170,13 @@ function TBoldRose98Properties.GetDefaultPropertyString(RoseModel: IRoseModel; P Prop: IRoseProperty; begin DefaultProps := RoseModel.DefaultProperties; - PropCollection := DefaultProps.GetDefaultPropertySet(RoseModel.GetPropertyClassName, ToolName, DEFAULTVALUE); + PropCollection := DefaultProps.GetDefaultPropertySet(RoseModel.GetPropertyClassName, ToolName, 'default'); Index := PropCollection.FindFirst(PropName); if Index > 0 then Prop := PropCollection.GetAt(Index) else Exit; - //ShowMessage('Fel'); Result := Prop.Value; end; @@ -187,14 +188,13 @@ procedure TBoldRose98Properties.SetDefaultPropertyBoolean(RoseModel: IRoseModel; Prop: IRoseProperty; begin DefaultProps := RoseModel.DefaultProperties; - PropCollection := DefaultProps.GetDefaultPropertySet(RoseModel.GetPropertyClassName, ToolName, DEFAULTVALUE); + PropCollection := DefaultProps.GetDefaultPropertySet(RoseModel.GetPropertyClassName, ToolName, 'default'); Index := PropCollection.FindFirst(PropName); if Index > 0 then Prop := PropCollection.GetAt(Index) else Exit; - //ShowMessage('Fel'); Prop.Value := BooleanToString(PropValue); end; @@ -207,14 +207,13 @@ procedure TBoldRose98Properties.SetDefaultPropertyString(RoseModel: IRoseModel; Prop: IRoseProperty; begin DefaultProps := RoseModel.DefaultProperties; - PropCollection := DefaultProps.GetDefaultPropertySet(RoseModel.GetPropertyClassName, ToolName, DEFAULTVALUE); + PropCollection := DefaultProps.GetDefaultPropertySet(RoseModel.GetPropertyClassName, ToolName, 'default'); Index := PropCollection.FindFirst(PropName); if Index > 0 then Prop := PropCollection.GetAt(Index) else Exit; - //ShowMessage('Fel'); Prop.Value := PropValue; end; @@ -255,7 +254,7 @@ procedure TBoldRose98Properties.SetBooleanString(RoseItem: IRoseItem; const Name begin if GetBooleanString(RoseItem, Name, DefaultValue) <> Value then begin - BoldLog.LogFmt(sSettingValue, [LoggString, Name, Value]); + BoldLog.LogFmt('Setting %s.%s to %s', [LoggString, Name, Value]); RoseItem.OverrideProperty(ToolName, Name, Value); end; end; @@ -265,7 +264,7 @@ procedure TBoldRose98Properties.SetBoolean(RoseItem: IRoseItem; const Name: stri begin if GetBoolean(RoseItem, Name, DefaultValue) <> Value then begin - BoldLog.LogFmt(sSettingValue, [LoggString, Name, BooleanToString(Value)]); + BoldLog.LogFmt('Setting %s.%s to %s', [LoggString, Name, BooleanToString(Value)]); RoseItem.OverrideProperty(ToolName, Name, BooleanToString(Value)); end; end; @@ -275,7 +274,7 @@ procedure TBoldRose98Properties.SetInteger(RoseItem: IRoseItem; const Name: stri begin if GetInteger(RoseItem, Name, DefaultValue) <> Value then begin - BoldLog.LogFmt(sSettingValue, [LoggString, Name, IntToStr(Value)]); + BoldLog.LogFmt('Setting %s.%s to %s', [LoggString, Name, IntToStr(Value)]); RoseItem.OverrideProperty(ToolName, Name, IntToStr(Value)); end end; @@ -285,7 +284,7 @@ procedure TBoldRose98Properties.SetString(RoseItem: IRoseItem; const Name, Defau begin if AnsiCompareText(GetString(RoseItem, Name, DefaultValue),Value) <> 0 then begin - BoldLog.LogFmt(sSettingValue, [LoggString, Name, Value]); + BoldLog.LogFmt('Setting %s.%s to %s', [LoggString, Name, Value]); RoseItem.OverrideProperty(ToolName, Name, Value); end; end; @@ -295,7 +294,7 @@ procedure TBoldRose98Properties.SetText(RoseItem: IRoseItem; const Name, Default begin if AnsiCompareText(GetString(RoseItem, Name, DefaultValue),Value) <> 0 then begin - BoldLog.LogFmt(sSettingValue, [LoggString, Name, Value]); + BoldLog.LogFmt('Setting %s.%s to %s', [LoggString, Name, Value]); RoseItem.OverrideProperty(ToolName, Name, Value); end; end; @@ -323,7 +322,7 @@ class function TBoldRose98Support.GetContainment(RoseRole, OtherRole: IRoseRole) 2: Result := akAggregate; end else if RoseRole.Containment.Value = 2 then - BoldLog.Log(sContainmentByValueButNotAggregate); + BoldLog.Log('Warning: containment by value, but not aggregate'); end; class procedure TBoldRose98Support.SetContainment(Aggregation: TAggregationKind; RoseRole, OtherRole: IRoseRole; const LoggString: string); @@ -337,23 +336,23 @@ class procedure TBoldRose98Support.SetContainment(Aggregation: TAggregationKind; begin OtherRole.Aggregate := false; RoseRole.Containment.Value := 0; - ContainmentName := 'None'; // do not localize + ContainmentName := 'None'; end; akComposite: begin OtherRole.Aggregate := true; RoseRole.Containment.Value := 1; - ContainmentName := 'Composite'; // do not localize + ContainmentName := 'Composite'; end; akAggregate: begin OtherRole.Aggregate := true; RoseRole.Containment.Value := 2; - ContainmentName := 'Aggregate'; // do not localize + ContainmentName := 'Aggregate'; end; end; - BoldLog.LogFmt(sSettingValue, [LoggString, 'containment', ContainmentName]); // do not localize - BoldLog.LogFmt(sSettingValue, [LoggString, 'Aggregate', BooleanToString(aggregation <> aknone)]); // do not localize + BoldLog.LogFmt('Setting %s.containment to %s', [LoggString, ContainmentName]); + BoldLog.LogFmt('Setting %s.Aggregate to %s', [LoggString, BooleanToString(aggregation <> aknone)]); end; end; @@ -365,7 +364,7 @@ class function TBoldRose98Support.RoseExportControlToVisibility(ExportControl: I 1: Result := vkProtected; 2: Result := vkPrivate; else - BoldLog.Log(sUnknownVisibility); + BoldLog.Log('Unknown visibility, public is set.'); end; end; @@ -379,22 +378,22 @@ class procedure TBoldRose98Support.SetExportControl(Visibility: TVisibilityKind; vkPublic: begin ExportControl.Value := 0; - VisibilityName := 'public'; // do not localize + VisibilityName := 'public'; end; vkProtected: begin ExportControl.Value := 1; - VisibilityName := 'protected'; // do not localize + VisibilityName := 'protected'; end; vkPrivate: begin ExportControl.Value := 2; - VisibilityName := 'private'; // do not localize + VisibilityName := 'private'; end; end; - BoldLog.LogFmt(sSettingValue, [LoggString, 'Visibility', VisibilityName]); // do not localize + BoldLog.LogFmt('Setting %s.Visibility to %s', [LoggString, VisibilityName]); end; -end; +end; class function TBoldRose98Support.GetVersion: Double; var @@ -410,14 +409,14 @@ class function TBoldRose98Support.GetVersion: Double; for i := 1 to length(VersionStr) do begin case VersionStr[i] of - '0'..'9': if Start = -1 then // The first digit starts the number + '0'..'9': if Start = -1 then Start := i; '.': begin inc(DotCount); - if (start <> -1) and (DotCount = 2) then // The second dot terminates the number + if (start <> -1) and (DotCount = 2) then stop := i; end - else if (start <> -1) and (stop = -1) then // any non-digit/non-dot after the first digit terminates the number + else if (start <> -1) and (stop = -1) then stop := i; end; end; @@ -427,10 +426,13 @@ class function TBoldRose98Support.GetVersion: Double; begin if stop = -1 then stop := length(VersionStr); - OldDecimalSeparator := FormatSettings.DecimalSeparator; - FormatSettings.DecimalSeparator := '.'; - result := StrtoFloat(copy(VersionStr, start, stop-start)); - FormatSettings.DecimalSeparator := OldDecimalSeparator; + OldDecimalSeparator := {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}DecimalSeparator; + {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}DecimalSeparator := '.'; + try + result := StrToFloat(copy(VersionStr, start, stop-start)); + finally + {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}DecimalSeparator := OldDecimalSeparator; + end; end; end; @@ -439,4 +441,6 @@ class function TBoldRose98Support.GetVersionString: String; result := GetApplication.Version; end; +initialization + end. diff --git a/Source/Common/Rose98/RationalRose98_TLB.pas b/Source/Common/Rose98/RationalRose98_TLB.pas index 2dc8a7f4..10d77c8b 100644 --- a/Source/Common/Rose98/RationalRose98_TLB.pas +++ b/Source/Common/Rose98/RationalRose98_TLB.pas @@ -1,8 +1,11 @@ -{$WARNINGS OFF} -{$WARN SYMBOL_PLATFORM OFF} +{ Global compiler directives } +{$include bold.inc} unit RationalRose98_TLB; +{$WARNINGS OFF} +{$WARN SYMBOL_PLATFORM OFF} + { This file contains pascal declarations imported from a type library. This file will be written during each import or refresh of the type library editor. Changes to this file will be discarded during the diff --git a/Source/Common/SOAP/BoldSOAP2_TLB.pas b/Source/Common/SOAP/BoldSOAP2_TLB.pas index da118010..fa5e0e38 100644 --- a/Source/Common/SOAP/BoldSOAP2_TLB.pas +++ b/Source/Common/SOAP/BoldSOAP2_TLB.pas @@ -1,53 +1,49 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSOAP2_TLB; -// ************************************************************************ // -// WARNING -// ------- -// The types declared in this file were generated from data read from a -// Type Library. If this type library is explicitly or indirectly (via -// another type library referring to this type library) re-imported, or the -// 'Refresh' command of the Type Library Editor activated while editing the -// Type Library, the contents of this file will be regenerated and all -// manual modifications will be lost. -// ************************************************************************ // - -// PASTLWTR : 1.1 -// File generated on 4/20/2001 2:02:34 PM from Type Library described below. - -// *************************************************************************// -// NOTE: -// Items guarded by $IFDEF_LIVE_SERVER_AT_DESIGN_TIME are used by properties -// which return objects that may need to be explicitly created via a function -// call prior to any access via the property. These items have been disabled -// in order to prevent accidental use from within the object inspector. You -// may enable them by defining LIVE_SERVER_AT_DESIGN_TIME or by selectively -// removing them from the $IFDEF blocks. However, such items must still be -// programmatically created via a method of the appropriate CoClass before -// they can be used. -// ************************************************************************ // -// Type Lib: C:\Work\BfD\Source\Common\SOAP\BoldSOAP2.tlb (1) -// IID\LCID: {430A7A46-55F8-49B7-82A2-539FA3580ABE}\0 -// Helpfile: -// DepndLst: -// (1) v2.0 stdole, (C:\WINNT\System32\stdole2.tlb) -// (2) v4.0 StdVCL, (C:\WINNT\System32\STDVCL40.DLL) -// (3) v1.0 BoldSOAP, (C:\Work\BfD\Source\Common\SOAP\BoldSOAP.tlb) -// ************************************************************************ // -{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +{$TYPEDADDRESS OFF} interface uses Windows, ActiveX, Classes, Graphics, OleServer, OleCtrls, StdVCL, BoldSOAP_TLB; -// *********************************************************************// -// GUIDS declared in the TypeLibrary. Following prefixes are used: -// Type Libraries : LIBID_xxxx -// CoClasses : CLASS_xxxx -// DISPInterfaces : DIID_xxxx -// Non-DISP interfaces: IID_xxxx -// *********************************************************************// + + + + + const - // TypeLibrary Major and minor versions BoldSOAP2MajorVersion = 1; BoldSOAP2MinorVersion = 0; @@ -56,27 +52,21 @@ interface IID_IBoldSOAPService2: TGUID = '{D349D000-EDDB-4F8C-886F-CB00F640DB6A}'; type -// *********************************************************************// -// Forward declaration of types defined in TypeLibrary -// *********************************************************************// + IBoldSOAPService2 = interface; IBoldSOAPService2Disp = dispinterface; -// *********************************************************************// -// Interface: IBoldSOAPService2 -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {D349D000-EDDB-4F8C-886F-CB00F640DB6A} -// *********************************************************************// + + + IBoldSOAPService2 = interface(IBoldSOAPService) ['{D349D000-EDDB-4F8C-886F-CB00F640DB6A}'] function Get2(const request: WideString): WideString; safecall; end; -// *********************************************************************// -// DispIntf: IBoldSOAPService2Disp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {D349D000-EDDB-4F8C-886F-CB00F640DB6A} -// *********************************************************************// + + + IBoldSOAPService2Disp = dispinterface ['{D349D000-EDDB-4F8C-886F-CB00F640DB6A}'] function Get2(const request: WideString): WideString; dispid 2; diff --git a/Source/Common/SOAP/BoldSOAP_TLB.pas b/Source/Common/SOAP/BoldSOAP_TLB.pas index bbf50cad..5d2ab46a 100644 --- a/Source/Common/SOAP/BoldSOAP_TLB.pas +++ b/Source/Common/SOAP/BoldSOAP_TLB.pas @@ -1,52 +1,48 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSOAP_TLB; -// ************************************************************************ // -// WARNING -// ------- -// The types declared in this file were generated from data read from a -// Type Library. If this type library is explicitly or indirectly (via -// another type library referring to this type library) re-imported, or the -// 'Refresh' command of the Type Library Editor activated while editing the -// Type Library, the contents of this file will be regenerated and all -// manual modifications will be lost. -// ************************************************************************ // - -// PASTLWTR : 1.1 -// File generated on 4/20/2001 2:02:34 PM from Type Library described below. - -// *************************************************************************// -// NOTE: -// Items guarded by $IFDEF_LIVE_SERVER_AT_DESIGN_TIME are used by properties -// which return objects that may need to be explicitly created via a function -// call prior to any access via the property. These items have been disabled -// in order to prevent accidental use from within the object inspector. You -// may enable them by defining LIVE_SERVER_AT_DESIGN_TIME or by selectively -// removing them from the $IFDEF blocks. However, such items must still be -// programmatically created via a method of the appropriate CoClass before -// they can be used. -// ************************************************************************ // -// Type Lib: C:\Work\BfD\Source\Common\SOAP\BoldSOAP.tlb (1) -// IID\LCID: {9BF07220-6C8A-11D4-BBAC-0010A4F9E114}\0 -// Helpfile: -// DepndLst: -// (1) v2.0 stdole, (C:\WINNT\System32\stdole2.tlb) -// Parent TypeLibrary: -// (0) v1.0 BoldSOAP2, (C:\Work\BfD\Source\Common\SOAP\BoldSOAP2.tlb) -// ************************************************************************ // -{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +{$TYPEDADDRESS OFF} interface uses Windows, ActiveX, Classes, Graphics, OleServer, OleCtrls, StdVCL; -// *********************************************************************// -// GUIDS declared in the TypeLibrary. Following prefixes are used: -// Type Libraries : LIBID_xxxx -// CoClasses : CLASS_xxxx -// DISPInterfaces : DIID_xxxx -// Non-DISP interfaces: IID_xxxx -// *********************************************************************// + + + + + const - // TypeLibrary Major and minor versions BoldSOAPMajorVersion = 1; BoldSOAPMinorVersion = 0; @@ -55,27 +51,21 @@ interface IID_IBoldSOAPService: TGUID = '{9BF07221-6C8A-11D4-BBAC-0010A4F9E114}'; type -// *********************************************************************// -// Forward declaration of types defined in TypeLibrary -// *********************************************************************// + IBoldSOAPService = interface; IBoldSOAPServiceDisp = dispinterface; -// *********************************************************************// -// Interface: IBoldSOAPService -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {9BF07221-6C8A-11D4-BBAC-0010A4F9E114} -// *********************************************************************// + + + IBoldSOAPService = interface(IDispatch) ['{9BF07221-6C8A-11D4-BBAC-0010A4F9E114}'] procedure Get(const request: WideString; out reply: WideString); safecall; end; -// *********************************************************************// -// DispIntf: IBoldSOAPServiceDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {9BF07221-6C8A-11D4-BBAC-0010A4F9E114} -// *********************************************************************// + + + IBoldSOAPServiceDisp = dispinterface ['{9BF07221-6C8A-11D4-BBAC-0010A4F9E114}'] procedure Get(const request: WideString; out reply: WideString); dispid 1; diff --git a/Source/Common/SOAP/BoldXMLRequests.pas b/Source/Common/SOAP/BoldXMLRequests.pas index 7a1757db..a783b6cb 100644 --- a/Source/Common/SOAP/BoldXMLRequests.pas +++ b/Source/Common/SOAP/BoldXMLRequests.pas @@ -1,9 +1,11 @@ +{ Global compiler directives } +{$include bold.inc} unit BoldXMLRequests; interface uses - MSXML_TLB, + Bold_MSXML_TLB, Classes, BoldStringList, BoldDefs; @@ -62,7 +64,7 @@ TBoldXMLRequest = class procedure AddIdentifiedValue(const IdString: string; const Value: string; const DomElementTag: string = DEFAULT_IDENTIFIEDVALUE_TAG; const AttributeTag: string = DEFAULT_IDSTRING_TAG); - procedure ReloadIdentifiedValues; + procedure ReloadIdentifiedValues; property DomDocument: IXMLDomDocument read FDomDocument; property Params: TBoldStringList read getParams; property IdentifiedValues: TBoldStringList read getIdentifiedValues; @@ -77,7 +79,9 @@ implementation SysUtils, BoldUtils, Windows, - BoldCommonConst; + BoldRev; + + {TBoldXMLRequest} @@ -155,10 +159,10 @@ procedure TBoldXMLRequest.SetIdentifiedValues(const Values: TStrings; if Assigned(ActionElement) then LoadIdentifiedValues(ActionElement, Values, DomElementTag, AttributeTag) else - raise EBold.CreateFmt(sSOAPActionNotSet, [ClassName, 'SetIdentifiedValues']); // do not localize + raise EBold.CreateFmt('%s.SetIdentifiedValues: Action not set', [ClassName]); end else - raise EBold.CreateFmt(sCannotSetPropertyWhenReadOnly, [ClassName, 'SetIdentifiedValues']); // do not localize + raise EBold.CreateFmt('%s.SetIdentifiedValues: cannot set BoldIds in ReadOnly mode', [ClassName]); end; procedure TBoldXMLRequest.SetParams(const Params: TStrings); @@ -168,10 +172,10 @@ procedure TBoldXMLRequest.SetParams(const Params: TStrings); if Assigned(ActionElement) then LoadParams(ActionElement, Params) else - raise EBold.CreateFmt(sSOAPActionNotSet, [ClassName, 'SetParams']); // do not localize + raise EBold.CreateFmt('%s.SetParams: Action not set', [ClassName]); end else - raise EBold.CreateFmt(sCannotSetPropertyWhenReadOnly, [ClassName, 'SetParams']); // do not localize + raise EBold.CreateFmt('%s.SetParams: cannot set Params in ReadOnly mode', [ClassName]); end; function TBoldXMLRequest.getActionName: string; @@ -222,7 +226,7 @@ procedure TBoldXMLRequest.setActionPath(const Value: string); end end else - raise EBold.CreateFmt(sCannotSetPropertyWhenReadOnly, [ClassName, 'ActionPath']);; // do not localize + raise EBold.CreateFmt('%s.ActionPath: property cannot be set', [ClassName]);; end; constructor TBoldXMLRequest.CreateInitialized(const VersionNo: string = DEFAULT_VERSION_NO; const Encoding: string = DEFAULT_ENCODING; @@ -230,9 +234,9 @@ constructor TBoldXMLRequest.CreateInitialized(const VersionNo: string = DEFAULT_ function BooleanToStr(value: Boolean): string; begin if Value then - result := 'yes' // do not localize + result := 'yes' else - result := 'no'; // do not localize + result := 'no'; end; var ProcessingInstruction: IXMLDOMProcessingInstruction; @@ -241,9 +245,9 @@ constructor TBoldXMLRequest.CreateInitialized(const VersionNo: string = DEFAULT_ FIsReadOnly := false; FDomDocument := CoDOMDocument.Create; FDomDocument.async := FALSE; - ProcessingInstruction := FDomDocument.createProcessingInstruction('xml', Format('version="%s" encoding="%s" standalone="%s"', [VersionNo, Encoding, BooleantoStr(StandAlone)])); // do not localize + ProcessingInstruction := FDomDocument.createProcessingInstruction('xml', Format('version="%s" encoding="%s" standalone="%s"', [VersionNo, Encoding, BooleantoStr(StandAlone)])); FDomDocument.appendChild(ProcessingInstruction); - FActionPath := DEFAULT_ACTION_PATH; + FActionPath := DEFAULT_ACTION_PATH; end; function TBoldXMLRequest.SetAction( const ActionName: string; const ActionPath: string = DEFAULT_ACTION_PATH): IXMLDomElement; @@ -259,7 +263,7 @@ function TBoldXMLRequest.SetAction( const ActionName: string; const ActionPath: if (Trim(ActionPath) = '') or (Trim(ActionName) = '') then begin Result := nil; - raise EBold.CreateFmt(sSetActionInvalidArgs, [ClassName]); + raise EBold.CreateFmt('%s.SetAction: Invalid arguments "ActionPath" or "ActionName"', [ClassName]); end; if ((Trim(ActionPath) <> FActionPath) and (ActionName <> self.ActionName)) or not Assigned(ActionElement) then @@ -277,12 +281,10 @@ function TBoldXMLRequest.SetAction( const ActionName: string; const ActionPath: Tag := Copy(temp, p+1, Maxint); temp := Copy(temp, 1, p - 1); NewElement := DomDocument.CreateElement(Tag); - //****************************************************************************// - if IsDefault and (Tag = 'SOAP:Envelope') then // do not localize - NewElement.setAttribute('xmlns:SOAP', 'urn:schemas-xmlssoap-org:soap.v1'); // do not localize - if IsDefault and (AnsiPos('m:', Tag) > 0) then // do not localize - NewElement.setAttribute('xmlns:m', 'www.borland.com/products/boldfordelphi'); // do not localize - //****************************************************************************// + if IsDefault and (Tag = 'SOAP:Envelope') then + NewElement.setAttribute('xmlns:SOAP', 'urn:schemas-xmlssoap-org:soap.v1'); + if IsDefault and (Pos('m:', Tag) > 0) then + NewElement.setAttribute('xmlns:m', 'www.boldsoft.com/products/boldfordelphi'); if Assigned(ChildElement) then NewElement.appendChild(ChildElement); ChildElement := NewElement; @@ -312,7 +314,7 @@ procedure TBoldXMLRequest.EnsureRoot(const TagName: string); if not FIsReadOnly then begin if not assigned(DomDocument) then - raise EBold.CreateFmt(sSOAPDOMDocumentMissing, [classname]); + raise EBold.CreateFmt('%s.EnsureRoot: The XMLRequest has no DomDocument. ', [classname]); RootElement := DomDocument.Get_documentElement; if not Assigned(RootElement) then begin @@ -359,7 +361,7 @@ procedure TBoldXMLRequest.AddParam(const Name, Value: string); NewElement: IXMLDomElement; begin if FIsReadOnly then - raise EBold.CreateFmt(sCannotPerformInReadOnlyMode, [ClassName, 'AddParam']) // do not localize + raise EBold.CreateFmt('%s.AddParam: cannot AddParam in ReadOnly mode', [ClassName]) else if Assigned(ActionElement) then begin NewElement := DomDocument.createElement(Name); @@ -367,7 +369,7 @@ procedure TBoldXMLRequest.AddParam(const Name, Value: string); ActionElement.appendChild(NewElement); end else - raise EBold.CreateFmt(sSOAPActionNotSet, [ClassName, 'AddParam']); // do not localize + raise EBold.CreateFmt('%s.AddParam: no action set', [ClassName]); end; procedure TBoldXMLRequest.DeleteAction; @@ -375,7 +377,7 @@ procedure TBoldXMLRequest.DeleteAction; parentNode: IXMLDomNode; begin if FIsReadOnly then - raise EBold.CreateFmt(sCannotPerformInReadOnlyMode, [ClassName, 'DeleteAction']) // do not localize + raise EBold.CreateFmt('%s.DeleteAction: cannot perform this operation in ReadOnly mode', [ClassName]) else begin parentNode := ActionElement.parentNode; @@ -391,14 +393,16 @@ procedure TBoldXMLRequest.AddIdentifiedValue(const IdString, Value, DomElementTa NewElement: IXMLDomElement; begin if FIsReadOnly then - raise EBold.CreateFmt(sCannotPerformInReadOnlyMode, [ClassName, 'AddIdentifiedValue']); // do not localize - if not Assigned(ActionElement) then - raise EBold.CreateFmt(sSOAPActionNotSet, [ClassName, 'AddIdentifiedValue']); // do not localize - - NewElement := DomDocument.createElement(DomElementTag); - NewElement.setAttribute(AttributeTag, IdString); - NewElement.Set_text(Value); - ActionElement.appendChild(NewElement); + raise EBold.CreateFmt('%s.AddIdentifiedValue: cannot AddParam in ReadOnly mode', [ClassName]) + else if Assigned(ActionElement) then + begin + NewElement := DomDocument.createElement(DomElementTag); + NewElement.setAttribute(AttributeTag, IdString); + NewElement.Set_text(Value); + ActionElement.appendChild(NewElement); + end + else + raise EBold.CreateFmt('%s.AddIdentifiedValue: no action set', [ClassName]); end; procedure TBoldXMLRequest.ReloadIdentifiedValues; @@ -412,7 +416,9 @@ procedure TBoldXMLRequest.ReloadIdentifiedValues; constructor TBoldXMLRequest.Create; begin - raise EBold.CreateFmt(sSOAPBadConstructorToUse, [ClassName]); + raise EBold.CreateFmt('%s.Create: Use the constructors CreateFromXML or CreateInitialized', [ClassName]); end; +initialization + end. diff --git a/Source/Common/Subscription/BoldDeriver.pas b/Source/Common/Subscription/BoldDeriver.pas index cf156363..0395182d 100644 --- a/Source/Common/Subscription/BoldDeriver.pas +++ b/Source/Common/Subscription/BoldDeriver.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDeriver; interface @@ -21,13 +24,15 @@ TBoldDeriver = class; { TBoldAbstractDeriver } TBoldAbstractDeriver = class(TBoldSubscriber) - private - fDerivedObject: TObject; - fSubscribe: Boolean; - procedure SetDeriverState(Value: TBoldDeriverState); - procedure SetSubscribe(value: boolean); + strict private function GetIsDeriving: Boolean; - protected + function GetIsCurrent: Boolean; + procedure DeriveAndSubscribe(subscribe: Boolean); + strict protected + procedure SetSubscribe(value: boolean); virtual; + function GetSubscribe: Boolean; virtual; + function GetDerivedObject: TObject; virtual; abstract; + procedure SetDeriverState(Value: TBoldDeriverState); procedure SetInternalDeriverState(const Value: TBoldDeriverState); virtual; abstract; function GetInternalDeriverState: TBoldDeriverState; virtual; abstract; procedure Receive(Originator: TObject; OriginalEvent: TBoldEvent; @@ -36,28 +41,27 @@ TBoldAbstractDeriver = class(TBoldSubscriber) procedure DoDeriveAndSubscribe(subscribe: Boolean); virtual; abstract; procedure DoNotifyOutOfDate; virtual; procedure DoReverseDerive; virtual; - function GetCanReverseDerive: Boolean; virtual; abstract; + function GetCanReverseDerive: Boolean; virtual; abstract; property InternalDeriverState: TBoldDeriverState read GetInternalDeriverState write SetInternalDeriverState; + function GetContextString: string; override; public - constructor Create(DerivedObject: TObject); procedure MarkSubscriptionOutOfdate; procedure MarkOutOfdate; procedure EnsureCurrent; procedure Derive; procedure ReverseDerive; - property DerivedObject: TObject read fDerivedObject; - property Subscribe: Boolean read fSubscribe write SetSubscribe; + property DerivedObject: TObject read GetDerivedObject; + property Subscribe: Boolean read GetSubscribe write SetSubscribe; property IsDeriving: Boolean read GetIsDeriving; - property CanReverseDerive: Boolean read GetCanReverseDerive; + property IsCurrent: Boolean read GetIsCurrent; end; - { TBoldEventPluggedDeriver } - TBoldEventPluggedDeriver = class(TBoldAbstractDeriver) - private - fOnDeriveAndSubscribe: TBoldDeriveAndResubscribe; + TBoldEventPluggedDeriver = class (TBoldAbstractDeriver) + strict private + fOnderiveAndSubscribe: TBoldDeriveAndResubscribe; fOnReverseDerive: TBoldReverseDerive; fOnNotifyOutOfDate: TBoldJustNotifyEvent; - protected + strict protected procedure DoDeriveAndSubscribe(subscribe: Boolean); override; procedure DoNotifyOutOfDate; override; procedure DoReverseDerive; override; @@ -70,11 +74,18 @@ TBoldEventPluggedDeriver = class(TBoldAbstractDeriver) { TBoldDeriver } TBoldDeriver = class(TBoldEventPluggedDeriver) - private + strict private + fDerivedObject: TObject; fInternalDeriverState: TBoldDeriverState; - protected + fSubscribe: Boolean; + strict protected + procedure SetSubscribe(value: boolean); override; + function GetSubscribe: Boolean; override; procedure SetInternalDeriverState(const Value: TBoldDeriverState); override; function GetInternalDeriverState: TBoldDeriverState; override; + function GetDerivedObject: TObject; override; + public + constructor Create(DerivedObject: TObject); end; const @@ -83,28 +94,27 @@ TBoldDeriver = class(TBoldEventPluggedDeriver) implementation uses -SysUtils, - BoldCommonConst; - + SysUtils, + Classes, + BoldSystem, + BoldRev; { TBoldDeriver } - -constructor TBoldAbstractDeriver.Create(DerivedObject: TObject); -begin - inherited Create; - fDerivedObject := DerivedObject; - Subscribe := True; -end; - procedure TBoldAbstractDeriver.Derive; var NewState: TBoldDeriverState; begin - NewState := bdsSubscriptionOutOfdate; + if Subscribe then + NewState := bdsSubscriptionOutOfdate + else + NewState := bdsOutOfdate; try repeat if (DeriverState = bdsSubscriptionOutOfdate) then + begin + CancelAllSubscriptions; DeriverState := bdsDerivingAndSubscribing + end else DeriverState := bdsDeriving; if not (DeriverState in bdsIsDeriving) then @@ -116,27 +126,54 @@ procedure TBoldAbstractDeriver.Derive; end; end; +procedure TBoldAbstractDeriver.DeriveAndSubscribe(subscribe: Boolean); +begin; + DoDeriveAndSubscribe(Subscribe); +end; + procedure TBoldAbstractDeriver.DoNotifyOutOfDate; begin - // no action end; procedure TBoldAbstractDeriver.DoReverseDerive; begin - raise EBold.CreateFmt(sCannotReverseDerive, [ClassName]); + raise EBold.CreateFmt('%s: can''t reverse derive', [ClassName]); end; procedure TBoldAbstractDeriver.EnsureCurrent; -begin +begin if (DeriverState in [bdsOutOfDate, bdsSubscriptionOutOfDate]) then Derive; end; +function TBoldAbstractDeriver.GetContextString: string; +begin + result := ''; + if Assigned(DerivedObject) then + if DerivedObject is TComponent then + result := TComponent(DerivedObject).Name + else + if DerivedObject is TBoldSubscribableObject then + result := TBoldSubscribableObject(DerivedObject).ContextString + else + Result := DerivedObject.ClassName; +end; + +function TBoldAbstractDeriver.GetIsCurrent: Boolean; +begin + result := DeriverState = bdsCurrent; +end; + function TBoldAbstractDeriver.GetIsDeriving: Boolean; begin Result := DeriverState in bdsIsDeriving; end; +function TBoldAbstractDeriver.GetSubscribe: Boolean; +begin + Result := true; +end; + procedure TBoldAbstractDeriver.MarkSubscriptionOutOfdate; begin DeriverState := bdsSubscriptionOutOfDate; @@ -144,7 +181,6 @@ procedure TBoldAbstractDeriver.MarkSubscriptionOutOfdate; procedure TBoldAbstractDeriver.MarkOutOfdate; begin - // avoids going from Subscriptionoutofdate to OutOfDate if DeriverState = bdsCurrent then DeriverState := bdsOutOfDate; end; @@ -165,7 +201,7 @@ procedure TBoldAbstractDeriver.Receive(Originator: TObject; DeriverState := bdsReverseDerivingSubscriptionOutOfDate; end; else - raise EBold.CreateFmt(sUnknownMessageReceived, [ClassName, RequestedEvent]); + raise EBold.CreateFmt('%s.Receive: Unknown message received (%d)', [ClassName, RequestedEvent]); end; end; @@ -178,15 +214,13 @@ procedure TBoldAbstractDeriver.SetDeriverState(Value: TBoldDeriverState); var OldState: TBoldDeriverState; begin - // FIXME check legal transitions; - if Value <> DeriverState then + OldState := InternalDeriverState; + if Value <> OldState then begin - OldState := InternalDeriverState; - // exit actions - None... + if not (OldState in [bdsCurrent, bdsOutOfDate, bdsSubscriptionOutOfDate, bdsDeriving, bdsDerivingAndSubscribing, bdsReverseDeriving, bdsReverseDerivingSubscriptionOutOfDate]) then + raise Exception.Create('TBoldAbstractDeriver.SetDeriverState old state is ' + IntToStr(Integer(oldState))); InternalDeriverState := Value; - - // entry actions - if (OldState <> bdsOutOfDate) and // Check on OldState is primarily an optimization not to notify multiple times! + if (OldState <> bdsOutOfDate) and (value in [bdsOutOfDate, bdsSubscriptionOutOfDate]) then DoNotifyOutOfDate; @@ -195,14 +229,20 @@ procedure TBoldAbstractDeriver.SetDeriverState(Value: TBoldDeriverState); bdsReverseDerivingSubscriptionOutOfDate: CancelAllSubscriptions; bdsDerivingAndSubscribing: - DoDeriveAndSubscribe(True); + DeriveAndSubscribe(True); bdsDeriving: - DoDeriveAndSubscribe(False); + DeriveAndSubscribe(False); end; end end; procedure TBoldAbstractDeriver.SetSubscribe(value: boolean); +begin + raise Exception.Create('Subscribe not settable for this class'); + +end; + +procedure TBoldDeriver.SetSubscribe(value: boolean); begin if value <> Subscribe then begin @@ -235,10 +275,15 @@ procedure TBoldEventPluggedDeriver.DoNotifyOutOfDate; procedure TBoldEventPluggedDeriver.DoReverseDerive; begin - SetDeriverState(bdsReverseDeriving); - if Assigned(fOnReverseDerive) then + if DeriverState = bdsSubscriptionOutOfDate then begin + SetDeriverState(bdsReverseDerivingSubscriptionOutOfDate); + end else begin + SetDeriverState(bdsReverseDeriving); + end; + if Assigned(fOnReverseDerive) then begin fOnReverseDerive(DerivedObject); - case deriverstate of + end; + case DeriverState of bdsReverseDeriving: SetDeriverState(bdsOutOfDate); bdsReverseDerivingSubscriptionOutOfDate: SetDeriverState(bdsSubscriptionOutOfDate); end; @@ -249,15 +294,34 @@ function TBoldEventPluggedDeriver.GetCanReverseDerive: Boolean; Result := Assigned(OnReverseDerive); end; +function TBoldDeriver.GetSubscribe: Boolean; +begin + Result := fSubscribe; +end; + procedure TBoldDeriver.SetInternalDeriverState( const Value: TBoldDeriverState); begin FInternalDeriverState := Value; end; +constructor TBoldDeriver.Create(DerivedObject: TObject); +begin + inherited Create; + fDerivedObject := DerivedObject; + Subscribe := true; +end; + +function TBoldDeriver.GetDerivedObject: TObject; +begin + Result := fDerivedObject; +end; + function TBoldDeriver.GetInternalDeriverState: TBoldDeriverState; begin Result := FInternalDeriverState; end; +initialization + end. diff --git a/Source/Common/Subscription/BoldSubscribableCollection.pas b/Source/Common/Subscription/BoldSubscribableCollection.pas index eaebb3ae..5a027a89 100644 --- a/Source/Common/Subscription/BoldSubscribableCollection.pas +++ b/Source/Common/Subscription/BoldSubscribableCollection.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSubscribableCollection; interface @@ -28,7 +31,9 @@ TBoldSubscribableCollection = class(TCollection) OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); procedure SendEvent(OriginalEvent: TBoldEvent); procedure SendExtendedEvent(OriginalEvent: TBoldEvent; const Args: array of const); +{$IFNDEF BOLD_NO_QUERIES} function SendQuery(OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; +{$ENDIF} property HasSubscribers: Boolean read GetHasSubscribers; end; @@ -49,14 +54,17 @@ TBoldSubscribableCollectionItem = class(TCollectionItem) OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); procedure SendEvent(OriginalEvent: TBoldEvent); procedure SendExtendedEvent(OriginalEvent: TBoldEvent; const Args: array of const); +{$IFNDEF BOLD_NO_QUERIES} function SendQuery(OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; +{$ENDIF} property HasSubscribers: Boolean read GetHasSubscribers; end; implementation uses - SysUtils; + SysUtils, + BoldRev; {---TBoldSubscribableCollection---} @@ -99,10 +107,12 @@ procedure TBoldSubscribableCollection.SendEvent(OriginalEvent: TBoldEvent); fPublisher.SendExtendedEvent(Self, OriginalEvent, []); end; +{$IFNDEF BOLD_NO_QUERIES} function TBoldSubscribableCollection.SendQuery(OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; begin result := not Assigned(fPublisher) or fPublisher.SendQuery(Self, OriginalEvent, Args, Subscriber); end; +{$ENDIF} procedure TBoldSubscribableCollection.SendExtendedEvent( OriginalEvent: TBoldEvent; @@ -156,11 +166,12 @@ procedure TBoldSubscribableCollectionItem.SendEvent(OriginalEvent: TBoldEvent); if Assigned(fPublisher) then fPublisher.SendExtendedEvent(Self, OriginalEvent, []); end; - +{$IFNDEF BOLD_NO_QUERIES} function TBoldSubscribableCollectionItem.SendQuery(OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; begin result := not Assigned(fPublisher) or fPublisher.SendQuery(Self, OriginalEvent, Args, Subscriber); end; +{$ENDIF} procedure TBoldSubscribableCollectionItem.SendExtendedEvent( OriginalEvent: TBoldEvent; @@ -174,4 +185,6 @@ function TBoldSubscribableCollectionItem.GetHasSubscribers: Boolean; result := assigned(fPublisher) and Publisher.HasSubscribers; end; + + end. diff --git a/Source/Common/Subscription/BoldSubscription.pas b/Source/Common/Subscription/BoldSubscription.pas index 643d62f1..2f739f74 100644 --- a/Source/Common/Subscription/BoldSubscription.pas +++ b/Source/Common/Subscription/BoldSubscription.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSubscription; interface @@ -8,37 +11,49 @@ interface const beMinSmallReserved = 0; - beMaxSmallReserved = 23; - beMinSmallUser = 24; - beMaxSmallUser = 31; + beMaxSmallReserved = 27; + beMinSmallUser = 28; + beMaxSmallUser = 29; + beBigEventFlag = 1 shl 30; beMaxEvent = 32767; beMinUser = 4096; beMaxUser = beMaxEvent; bqMinQuery = beMaxEvent+1; bpeMinReserved = 1024; + bqMaxQuery = 100000; + beDestroying = 0; {General message for all subscribables} - beMemberChanged = 2; beObjectDeleted = 3; beObjectCreated = 11; {Object events} + beMemberChanged = 1; beObjectDeleted = 2; beObjectCreated = 3; {Object events} beItemAdded = 4; beItemDeleted = 5; beItemReplaced = 6; beOrderChanged = 7; {ObjectList events} beValueChanged = 8; {value of attribute or ObjectReference changed} beValueIdentityChanged = 9; {Actual identity of anElement.value changed} + breReSubscribe = 10; + beDirtyListInvalidOrItemDeleted = 11; beValueInvalid = 12; - beDerivedSoonDestroyed = 13; - beLocatorDestroying = 14; - beDirtyListInvalidOrItemDeleted = 15; - beQualifierChanged = 16; - beDeactivating = 17; // sent by persistencehandles - beRolledBack = 18; // sent by TBoldSystem - bePostUpdateId = 19; // send by TBoldObject when the ID is updated to allow regions to rehash themselves - bePreUpdateId = 20; // send by TBoldObject when the ID is updated to allow regions to rehash themselves - beObjectFetched = 21; // sent by TBoldObject when it has been recreated in memory + beLocatorDestroying = 13; + beObjectTimestampChanged = beValueIdentityChanged; // or perhaps use a separate integer ? + beQualifierChanged = 14; + beDeactivating = 15; + beRolledBack = 16; + bePostUpdateId = 17; + bePreUpdateId = 18; + beObjectFetched = 19; + beObjectUnloaded = 20; // sent by TBoldSystem before an object gets unloaded from memory breReEvaluate = beValueChanged; {backwards compatibility} - breReSubscribe = 10; - beServerSubscriberRemoved = 22; + beDefaultRequestedEvent = breReEvaluate; - beValueEvents = [beItemAdded, beItemDeleted, beItemReplaced, beOrderChanged, beValueChanged, beValueInvalid]; + beServerSubscriberRemoved = 21; + + beBeginUpdate = 22; // sent by TBoldObjectList before loops + beEndUpdate = 23; // sent by TBoldObjectList after loops + beObjectBecomingClean = 24; + beObjectBecomingDirty = 25; + beMemberBecomingClean = 26; + beMemberBecomingDirty = 27; + beDirtyListEvents = [beObjectBecomingDirty, beObjectBecomingClean, beMemberBecomingDirty, beMemberBecomingClean]; - // BoldPersistenceEvents + beValueEvents = [beItemAdded, beItemDeleted, beItemReplaced, beOrderChanged, beValueChanged, beValueInvalid]; bpeStartFetch = bpeMinReserved + 0; bpeEndFetch = bpeMinReserved + 1; bpeStartUpdate = bpeMinReserved + 2; @@ -55,22 +70,63 @@ interface bpeProgressEnd = bpeMinReserved + 13; bpeMaxReserved = bpeMinReserved + 13; + // additional persistence events + bpeStartFetchMember = 42; + bpeEndFetchMember = 43; + bpeStartFetchObjectById = 44; + bpeEndFetchObjectById = 45; + bpeStartFetchClass = 46; + bpeEndFetchClass = 47; + bpeStartFetchAllInClassWithRawSQL = 48; + bpeEndFetchAllInClassWithRawSQL = 49; + bpeStartFetchAllInClassWithSQL = 50; + bpeEndFetchAllInClassWithSQL = 51; + + // OSS Events + boeClassChanged = 52; + boeEmbeddedStateOfObjectChanged = 53; + boeObjectCreated = 54; + boeObjectDeleted = 55; + boeNonEmbeddedStateOfObjectChanged = 56; + boeMemberChanged = 57; + beOssEvents = [boeClassChanged, boeEmbeddedStateOfObjectChanged, boeObjectCreated, boeObjectDeleted, boeNonEmbeddedStateOfObjectChanged, boeMemberChanged]; + + // Undo Events + beUndoBlock = 60; + beRedoBlock = 61; + beUndoSetCheckpoint = 62; + beUndoChanged = 63; + bePrepareModify = 38; beCompleteModify = 39; bePrepareDelete = 41; - + {$IFNDEF BOLD_NO_QUERIES} bqMayUpdate = bqMinQuery + 1; bqMayModify = bqMinQuery + 2; bqMayDelete = bqMinQuery + 3; bqMayCommit = bqMinQuery + 4; - + {$ENDIF} bqMaxSubscription = bqMinQuery + 6; +{$IFDEF BoldSystemBroadcastMemberEvents} + beBroadcastMemberEvents = beValueEvents + [beCompleteModify] + beDirtyListEvents; +{$ENDIF} + + { Subscription Statistics } +var + PublisherCount: Integer = 0; + SubscriberCount: Integer = 0; + ActiveSubscriptionCount: Integer = 0; + _SendEventMatch: Int64 = 0; + _SendExtendedEvent: Int64 = 0; +{$IFNDEF BOLD_NO_QUERIES} + _SendQuery: Int64 = 0; + _QueryMatch: Int64 = 0; +{$ENDIF} + {Forward declarations of all classes} type TBoldPublisher = class; - TBoldSubscription = class; - TBoldSmallEventSubscription = class; TBoldSubscriber = class; TBoldPassthroughSubscriber = class; TBoldSubscribableObject = class; @@ -79,11 +135,11 @@ TBoldSubscribablePersistent = class; {TBoldEvent itself is a Smallint. TBoldEventset is a set of of small values (0..31) It is possible to subscribe either to one particular event, or to a set of small events. Of the small - events, 0..23 are reserved for Bold and 24..31 are available for users. Of the larger events, + events, 0..23 are reserved for Bold and 24..30 are available for users. Of the larger events, 32..64 are reserved for the future use of Bold, the rest are available for user programming} {TBoldEvent} - TBoldEvent = Integer; + TBoldEvent = 0..bqMaxQuery; TBoldRequestedEvent = Integer; TBoldSmallEvent = beMinSmallReserved..beMaxSmallUser; @@ -101,210 +157,362 @@ TBoldSubscribablePersistent = class; TBoldPublisherFlag = (bpfNeedsPacking); TBoldPublisherFlags = set of TBoldPublisherFlag; - TBoldSubscriptionList = TList; + + {---TBoldSubscription---} + TBoldSubscription = record + public + Subscriber: TBoldSubscriber; + IndexInSubscriber: integer; + RequestedEvent: TBoldRequestedEvent; + MatchCondition: Integer; + function GetIsSmallEventSubscription: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure ClearEntry; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure ReIndexsSubscriber(NewPublisherIndex: integer); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function IsMatchingEvent(OriginalEvent: TBoldEvent): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure ExtendEvents(Events: TBoldSmallEventSet); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + property IsSmallEventSubscription: Boolean read GetIsSmallEventSubscription; + end; + + TBoldPublisherReference = record + public + Publisher: TBoldPublisher; + Index: integer; // index in the publishers subscriptionarray + end; + + TBoldPublisherReferenceArray = array of TBoldPublisherReference; + + TBoldSubscriptionArray = array of TBoldSubscription; {---TBoldPublisher---} TBoldPublisher = class(TBoldMemoryManagedObject) - private - fSubscriptions: TBoldSubscriptionList; + strict private + fSubscriptionArray: TBoldSubscriptionArray; + fSubscriptionCount: integer; fPublisherFlags: TBoldPublisherFlags; - property Subscriptions: TBoldSubscriptionList read fSubscriptions; - function GetHasSubscribers: Boolean; - procedure AddToSubscriptions(Subscription: TBoldSubscription); {called by TBoldSubcrition} - function GetNeedsPacking: Boolean; + fSubscribableObject: TObject; + fHoleCount: Integer; + function GetHasSubscribers: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure EnsureFreeSpace; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetNeedsPacking: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetNeedsPacking(Value: Boolean); - class procedure DelayTillAfterNotification(Event: TNotifyEvent; Sender: TObject; Receiver: TObject); class procedure RemoveFromPostNotificationQueue(Receiver: TObject); procedure PackSubscriptions(dummy: TObject); property NeedsPacking: Boolean read GetNeedsPacking write SetNeedsPacking; {Set by TBoldSubscription} - protected - procedure SetPublisherFlag(Flag: TBoldPublisherFlag; Value: Boolean); - function GetPublisherFlag(Flag: TBoldPublisherFlag): Boolean; + class var G_NotificationNesting: integer; + class var G_InPostNotification: Boolean; + private // actually unit internal + class procedure DelayTillAfterNotification(Event: TNotifyEvent; Sender: TObject; Receiver: TObject); + procedure ClearEntry(Subscriber: TBoldSubscriber; index: integer); // Do not use inline due to D2007 bug + function GetSubscriptionsAsText: string; + strict protected + procedure SetPublisherFlag(Flag: TBoldPublisherFlag; Value: Boolean); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetPublisherFlag(Flag: TBoldPublisherFlag): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetContextString: string; virtual; + function GetDebugInfo: string; override; public constructor Create; destructor Destroy; override; - class procedure StartNotify; + class procedure StartNotify; {$IFDEF BOLD_INLINE} inline; {$ENDIF} class procedure EndNotify; - procedure NotifySubscribersAndClearSubscriptions(Originator: TObject); + procedure BoldForcedDequeuePostNotify; + procedure NotifySubscribersAndClearSubscriptions(Originator: TObject); {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure AddSmallSubscription(Subscriber: TBoldSubscriber; - Events: TBoldSmallEventSet; RequestedEvent: TBoldRequestedEvent); + Events: TBoldSmallEventSet; RequestedEvent: TBoldRequestedEvent = beDefaultRequestedEvent); {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure AddSubscription(Subscriber: TBoldSubscriber; - OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); + OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent = beDefaultRequestedEvent); {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SendExtendedEvent(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const); - function SendQuery(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; +{$IFNDEF BOLD_NO_QUERIES} + function SendQuery(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; +{$ENDIF} + function HasMatchingSubscription(Subscriber: TBoldSubscriber): boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure CancelSubscriptionTo(Subscriber: TBoldSubscriber); property HasSubscribers: Boolean read GetHasSubscribers; - end; - - {---TBoldSubscription---} - TBoldSubscription = class(TBoldMemoryManagedObject) - private - fPublisher: TBoldPublisher; - fRequestedEvent: TBoldRequestedEvent; - fSubscriber: TBoldSubscriber; - protected - constructor Create(Publisher: TBoldPublisher; - Subscriber: TBoldSubscriber; RequestedEvent: TBoldRequestedEvent); - function IsMatchingEvent(OriginalEvent: TBoldEvent): Boolean; virtual; abstract; - procedure CloneTo(Subscriber: TBoldSubscriber; NewRequestedEvent: TBoldRequestedEvent); virtual; abstract; - procedure UnlinkFromSubscriber; - procedure UnlinkFromPublisher; - property Publisher: TBoldPublisher read fPublisher; - property RequestedEvent: TBoldRequestedEvent read fRequestedEvent; - property Subscriber: TBoldSubscriber read fSubscriber; - end; - - {---TBoldEventSubscription---} - TBoldEventSubscription = class(TBoldSubscription) - private - fEvent: TBoldEvent; - protected - function IsMatchingEvent(OriginalEvent: TBoldEvent): Boolean; override; - procedure CloneTo(Subscriber: TBoldSubscriber; NewRequestedEvent: TBoldRequestedEvent); override; - public - constructor Create(Publisher: TBoldPublisher; Subscriber: TBoldSubscriber; - OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); - end; - - {---TBoldSmallEventSubscription---} - TBoldSmallEventSubscription = class(TBoldSubscription) - private - fEvents: TBoldSmallEventSet; - protected - procedure ExtendEvents(Events: TBoldSmallEventSet); - function IsMatchingEvent(OriginalEvent: TBoldEvent): Boolean; override; - procedure CloneTo(Subscriber: TBoldSubscriber; NewRequestedEvent: TBoldRequestedEvent); override; - public - constructor Create(Publisher: TBoldPublisher; Subscriber: TBoldSubscriber; - Events: TBoldSmallEventSet; RequestedEvent: TBoldRequestedEvent); + property SubscribableObject : TObject read fSubscribableObject write fSubscribableObject; + property SubscriptionCount: integer read fSubscriptionCount; + property ContextString: string read GetContextString; + property SubscriptionsAsText: string read GetSubscriptionsAsText; end; {---TBoldSubscriber---} TBoldSubscriber = class(TBoldMemoryManagedObject) - private - fSubscriptions: TList; - function GetSubscriptions: TList; - property Subscriptions: TList read GetSubscriptions; - procedure AddToSubscriptions(Subscription: TBoldSubscription); {called by TBoldSubcrition} + strict private + fSubscriptionArray: TBoldPublisherReferenceArray; + fSubscriptionCount: integer; + private // unit internal + procedure AddToSubscriptions(Publisher: TBoldPublisher; Index: integer); {$IFDEF BOLD_INLINE} inline; {$ENDIF} {called by TBoldSubscription} + procedure ClearEntry(Index: integer); {$IFDEF BOLD_INLINE} inline; {$ENDIF} {called by TBoldSubscription} + function GetSubscriptionsAsText: string; protected procedure Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); virtual; abstract; procedure ReceiveExtended(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const); virtual; + {$IFNDEF BOLD_NO_QUERIES} function Answer(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; virtual; +{$ENDIF} function GetContextString: string; virtual; function GetHandlesExtendedEvents: Boolean; virtual; + function GetDebugInfo: string; override; public - destructor Destroy; override; - procedure CancelAllSubscriptions; - procedure CloneSubscriptions(Subscriber: TBoldSubscriber; OldRequestedEvent: TBoldRequestedEvent; NewRequestedEvent: TBoldRequestedEvent); + procedure AfterConstruction; override; + procedure BeforeDestruction; override; + procedure CancelAllSubscriptions; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function HasMatchingSubscription(APublisher: TBoldPublisher): boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure CancelSubscriptionTo(APublisher: TBoldPublisher); property ContextString: string read GetContextString; property HandlesExtendedEvents: Boolean read GetHandlesExtendedEvents; + property SubscriptionCount: integer read fSubscriptionCount; + property Subscriptions: TBoldPublisherReferenceArray read fSubscriptionArray; + property SubscriptionsAsText: string read GetSubscriptionsAsText; end; {---TBoldPassthroughSubscriber---} TBoldPassthroughSubscriber = class(TBoldSubscriber) - private + strict private fReceiveFunc: TBoldEventHandler; - fExtendedReceiveFunc: TBoldExtendedEventHandler; - fAnswerFunc: TBoldQueryHandler; protected procedure Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); override; + function GetHandlesExtendedEvents: Boolean; override; + function GetContextString: string; override; + public + constructor Create(AReceiveFunc: TBoldEventHandler); + property receiveFunc: TBoldEventHandler read fReceiveFunc write fReceiveFunc; + end; + + {---TBoldPassthroughSubscriber---} + TBoldExtendedPassthroughSubscriber = class(TBoldPassthroughSubscriber) + strict private + fExtendedReceiveFunc: TBoldExtendedEventHandler; + {$IFNDEF BOLD_NO_QUERIES} + fAnswerFunc: TBoldQueryHandler; +{$ENDIF} + protected procedure ReceiveExtended(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const); override; + {$IFNDEF BOLD_NO_QUERIES} function Answer(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; override; +{$ENDIF} function GetHandlesExtendedEvents: Boolean; override; public - constructor Create(receiveFunc: TBoldEventHandler); - constructor CreateWithExtendedReceive(ExtendedReceiveFunc: TBoldExtendedEventHandler); - constructor CreateWithReceiveAndAnswer(ReceiveFunc: TBoldEventHandler; - AnswerFunc: TBoldQueryHandler); - property receiveFunc: TBoldEventHandler read fReceiveFunc write fReceiveFunc; + constructor CreateWithExtendedReceive(AExtendedReceiveFunc: TBoldExtendedEventHandler); +{$IFNDEF BOLD_NO_QUERIES} + constructor CreateWithReceiveAndAnswer(AReceiveFunc: TBoldEventHandler; + AAnswerFunc: TBoldQueryHandler); +{$ENDIF} end; {---TBoldSubscribableObject---} TBoldSubscribableObject = class(TBoldFlaggedObject) - private + strict private fPublisher: TBoldPublisher; - function GetHasSubscribers: Boolean; - function GetPublisher: TBoldPublisher; + function GetHasSubscribers: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetPublisher: TBoldPublisher; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetSubscriptionsAsText: string; protected - procedure FreePublisher; + function GetDebugInfo: string; override; + procedure FreePublisher; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetContextString: string; virtual; property HasSubscribers: Boolean read GetHasSubscribers; property Publisher: TBoldPublisher read GetPublisher; public destructor Destroy; override; procedure AddSmallSubscription(Subscriber: TBoldSubscriber; - Events: TBoldSmallEventSet; RequestedEvent: TBoldRequestedEvent); + Events: TBoldSmallEventSet; RequestedEvent: TBoldRequestedEvent = beDefaultRequestedEvent); {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure AddSubscription(Subscriber: TBoldSubscriber; - OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); + OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent = beDefaultRequestedEvent); {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SendEvent(OriginalEvent: TBoldEvent); virtual; procedure SendExtendedEvent(OriginalEvent: TBoldEvent; const Args: array of const); virtual; - function SendQuery(OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; virtual; - end; +{$IFNDEF BOLD_NO_QUERIES} + function SendQuery(OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber; Originator: TObject = nil): Boolean; virtual; +{$ENDIF} + property ContextString: string read GetContextString; + property SubscriptionsAsText: string read GetSubscriptionsAsText; +end; {---TBoldSubscribableComponent---} TBoldSubscribableComponent = class(TComponent) - private + strict private fPublisher: TBoldPublisher; - function GetPublisher: TBoldPublisher; - protected + function GetPublisher: TBoldPublisher; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetSubscriptionsAsText: string; + strict protected function GetHasSubscribers: Boolean; virtual; property Publisher: TBoldPublisher read GetPublisher; - procedure FreePublisher; + procedure FreePublisher; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public destructor Destroy; override; procedure AddSmallSubscription(Subscriber: TBoldSubscriber; - Events: TBoldSmallEventSet; RequestedEvent: TBoldRequestedEvent); + Events: TBoldSmallEventSet; RequestedEvent: TBoldRequestedEvent = beDefaultRequestedEvent); {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure AddSubscription(Subscriber: TBoldSubscriber; - OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); - procedure SendEvent(Originator: TObject; OriginalEvent: TBoldEvent); + OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent = beDefaultRequestedEvent); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SendEvent(Originator: TObject; OriginalEvent: TBoldEvent); {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SendExtendedEvent(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const); + {$IFNDEF BOLD_NO_QUERIES} function SendQuery(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; + {$ENDIF} property HasSubscribers: Boolean read GetHasSubscribers; + property SubscriptionsAsText: string read GetSubscriptionsAsText; end; {--- TBoldSubscribablePersistent ---} TBoldSubscribablePersistent = class(TPersistent) - private + strict private fPublisher: TBoldPublisher; - function GetPublisher: TBoldPublisher; + function GetPublisher: TBoldPublisher; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetSubscriptionsAsText: string; + strict protected + function GetHasSubscribers: Boolean; virtual; + property Publisher: TBoldPublisher read GetPublisher; protected + procedure FreePublisher; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + public + destructor Destroy; override; + procedure AddSmallSubscription(Subscriber: TBoldSubscriber; + Events: TBoldSmallEventSet; RequestedEvent: TBoldRequestedEvent = beDefaultRequestedEvent); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure AddSubscription(Subscriber: TBoldSubscriber; + OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent = beDefaultRequestedEvent); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SendEvent(Originator: TObject; OriginalEvent: TBoldEvent); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SendExtendedEvent(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const); +{$IFNDEF BOLD_NO_QUERIES} + function SendQuery(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; +{$ENDIF} + property HasSubscribers: Boolean read GetHasSubscribers; + property SubscriptionsAsText: string read GetSubscriptionsAsText; + end; + + TBoldSubscribableNonRefCountedObject = class(TBoldNonRefCountedObject) + strict private + fPublisher: TBoldPublisher; + function GetPublisher: TBoldPublisher; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetSubscriptionsAsText: string; + strict protected function GetHasSubscribers: Boolean; virtual; property Publisher: TBoldPublisher read GetPublisher; - procedure FreePublisher; + procedure FreePublisher; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public - constructor Create; destructor Destroy; override; procedure AddSmallSubscription(Subscriber: TBoldSubscriber; - Events: TBoldSmallEventSet; RequestedEvent: TBoldRequestedEvent); + Events: TBoldSmallEventSet; RequestedEvent: TBoldRequestedEvent = beDefaultRequestedEvent); {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure AddSubscription(Subscriber: TBoldSubscriber; - OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); - procedure SendEvent(Originator: TObject; OriginalEvent: TBoldEvent); + OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent = beDefaultRequestedEvent); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SendEvent(Originator: TObject; OriginalEvent: TBoldEvent); {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SendExtendedEvent(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const); + {$IFNDEF BOLD_NO_QUERIES} function SendQuery(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; + {$ENDIF} property HasSubscribers: Boolean read GetHasSubscribers; + property SubscriptionsAsText: string read GetSubscriptionsAsText; end; - procedure BoldForcedDequeuePostNotify; procedure BoldAddEventToPostNotifyQueue(Event: TNotifyEvent; Sender: TObject; Receiver: TObject); + function BoldEventToString(aEvent: integer): string; implementation uses SysUtils, BoldDefs, - BoldEventQueue, - BoldCommonConst; + BoldEventQueue; + +function BoldEventToString(aEvent: integer): string; +begin + case aEvent of + beDestroying: result := 'beDestroying'; + beMemberChanged: result := 'beMemberChanged'; + beObjectDeleted: result := 'beObjectDeleted'; + beObjectCreated: result := 'beObjectCreated'; + beItemAdded: result := 'beItemAdded'; + beItemDeleted: result := 'beItemDeleted'; + beItemReplaced: result := 'beItemReplaced'; + beOrderChanged: result := 'beOrderChanged'; + beValueChanged: result := 'beValueChanged'; + beValueIdentityChanged: result := 'beValueIdentityChanged'; + beValueInvalid: result := 'beValueInvalid'; +// beDerivedSoonDestroyed: result := 'beDerivedSoonDestroyed'; + beLocatorDestroying: result := 'beLocatorDestroying'; + beDirtyListInvalidOrItemDeleted: result := 'beDirtyListInvalidOrItemDeleted'; + beQualifierChanged: result := 'beQualifierChanged'; + beDeactivating: result := 'beDeactivating'; + beRolledBack: result := 'beRolledBack'; + bePostUpdateId: result := 'bePostUpdateId'; + bePreUpdateId: result := 'bePreUpdateId'; + beObjectFetched: result := 'beObjectFetched'; + bePrepareModify: result := 'bePrepareModify'; + beCompleteModify: result := 'beCompleteModify'; + bePrepareDelete: result := 'bePrepareDelete'; + breReSubscribe: result := 'breReSubscribe'; + beServerSubscriberRemoved: result := 'beServerSubscriberRemoved'; + // Begin/EndUpdate, not yet in use + beBeginUpdate: result := 'beBeginUpdate'; + beEndUpdate: result := 'beEndUpdate'; + //DirtyList events + beObjectBecomingClean: result := 'beObjectBecomingClean'; + beObjectBecomingDirty: result := 'beObjectBecomingDirty'; + beMemberBecomingClean: result := 'beMemberBecomingClean'; + beMemberBecomingDirty: result := 'beMemberBecomingDirty'; + //Persistence events + bpeStartFetch: result := 'bpeStartFetch'; + bpeEndFetch: result := 'bpeEndFetch'; + bpeStartUpdate: result := 'bpeStartUpdate'; + bpeEndUpdate: result := 'bpeEndUpdate'; + bpeFetchObject: result := 'bpeFetchObject'; + bpeFetchMember: result := 'bpeFetchMember'; + bpeUpdateObject: result := 'bpeUpdateObject'; + bpeDeleteObject: result := 'bpeDeleteObject'; + bpeCreateObject: result := 'bpeCreateObject'; + bpeStartFetchID: result := 'bpeStartFetchID'; + bpeEndFetchID: result := 'bpeEndFetchID'; + bpeFetchId: result := 'bpeFetchId'; + bpeProgressStart: result := 'bpeProgressStart'; + bpeProgressEnd: result := 'bpeProgressEnd'; + // OSS events + boeClassChanged: result := 'boeClassChanged'; + boeEmbeddedStateOfObjectChanged: result := 'boeEmbeddedStateOfObjectChanged'; + boeObjectCreated: result := 'boeObjectCreated'; + boeObjectDeleted: result := 'boeObjectDeleted'; + boeNonEmbeddedStateOfObjectChanged: result := 'boeNonEmbeddedStateOfObjectChanged'; + boeMemberChanged: result := 'boeMemberChanged'; + // Undo events + beUndoBlock: result := 'beUndoBlock'; + beRedoBlock: result := 'beRedoBlock'; + beUndoSetCheckpoint: result := 'beUndoSetCheckpoint'; + beUndoChanged: result := 'beUndoChanged'; + + {$IFNDEF BOLD_NO_QUERIES} + bqMayUpdate: result := 'bqMayUpdate'; + bqMayModify: result := 'bqMayModify'; + bqMayDelete: result := 'bqMayDelete'; + bqMayCommit: result := 'bqMayCommit'; + {$ENDIF} + else + case aEvent of + beMinSmallReserved..beMaxSmallReserved : result := 'Unknown SmallReserved event: ' + IntToStr(aEvent); + beMinSmallUser..beMaxSmallUser : result := 'Unknown SmallUser event: ' + IntToStr(aEvent); + beMinUser..beMaxEvent : result := 'Unknown UserEvent event: ' + IntToStr(aEvent); + bqMinQuery..bqMaxQuery : result := 'Unknown Query event: ' + IntToStr(aEvent); + else + result:= 'Unknown event: ' + IntToStr(aEvent); + end; + end; +end; var - G_NotificationNesting: integer = 0; G_PostNotifyQueue: TboldEventQueue = nil; - G_InPostNotification: Boolean = false; -procedure BoldForcedDequeuePostNotify; +function GetNewLength(oldLength: integer): integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} +begin + if oldLength > 64 then + Result := oldLength + oldLength div 4 + else if oldLength > 8 then + Result := oldLength + 16 + else + Result := oldLength + 4; +end; + +procedure TBoldPublisher.BoldForcedDequeuePostNotify; var OldInPostNotification: Boolean; begin @@ -323,154 +531,367 @@ procedure BoldAddEventToPostNotifyQueue(Event: TNotifyEvent; Sender: TObject; Re TBoldPublisher.DelayTillAfterNotification(Event, Sender, Receiver); end; +class procedure TBoldPublisher.StartNotify; +begin + Inc(G_NotificationNesting); +end; + +class procedure TBoldPublisher.EndNotify; +begin + Dec(G_NotificationNesting); + if (G_NotificationNesting = 0) and Assigned(G_PostNotifyQueue) and (not G_InPostNotification) then + begin + G_InPostNotification := True; + G_PostNotifyQueue.DequeueAll; {may add and delete entries, Eventqueue can handle it} + G_InPostNotification := False; + end; +end; + +{---TBoldSubscription---} + +function TBoldSubscription.GetIsSmallEventSubscription: Boolean; +begin + Result := (MatchCondition and beBigEventFlag) = 0; +end; + +function TBoldSubscription.IsMatchingEvent(OriginalEvent: TBoldEvent): Boolean; +begin + if (OriginalEvent <= beMaxSmallUser) then + result := (OriginalEvent in TBoldSmallEventSet(MatchCondition)) and ((MatchCondition and beBigEventFlag) = 0) + else + Result := (OriginalEvent or beBigEventFlag) = MatchCondition; +end; + +procedure TBoldSubscription.ReIndexsSubscriber(NewPublisherIndex: integer); +begin + Subscriber.Subscriptions[IndexInSubscriber].Index := NewPublisherIndex; +end; + +procedure TBoldSubscription.ExtendEvents(Events: TBoldSmallEventSet); +begin + if (MatchCondition and beBigEventFlag) <> 0 then + raise EBoldInternal.Create('TBoldSubscription.ExtendEvents called for big event'); +{$IFDEF DEBUG} + if Integer(TBoldSmallEventSet(MatchCondition) + Events) <> MatchCondition then +{$ENDIF} + MatchCondition := Integer(TBoldSmallEventSet(MatchCondition) + Events); +end; + +procedure TBoldSubscriber.ClearEntry(Index: integer); +begin + Subscriptions[Index].Publisher := nil; + // Attempt to reuse empty places + if fSubscriptionCount-1 = index then + begin + while (fSubscriptionCount > 0) and (Subscriptions[fSubscriptionCount-1].Publisher = nil) do + Dec(fSubscriptionCount); + if (fSubscriptionCount < length(fSubscriptionArray) div 2) and (length(fSubscriptionArray) > 4) then + SetLength(fSubscriptionArray, fSubscriptionCount); + end; +end; + +procedure TBoldSubscriber.AddToSubscriptions(Publisher: TBoldPublisher; Index: integer); +begin + if fSubscriptionCount = Length(fSubscriptionArray) then + SetLength(fSubscriptionArray, GetNewLength(fSubscriptionCount)); + fSubscriptionArray[fSubscriptionCount].Publisher := Publisher; + fSubscriptionArray[fSubscriptionCount].Index := Index; + Inc(fSubscriptionCount); + Inc(ActiveSubscriptionCount); +end; + +procedure TBoldSubscription.ClearEntry; +begin + if Assigned(subscriber) then + begin + Subscriber.ClearEntry(IndexInSubscriber); + Subscriber := nil; + Dec(ActiveSubscriptionCount); + end; +end; + {---TBoldPublisher---} -constructor TBoldPublisher.Create; +function TBoldPublisher.GetContextString: string; begin - inherited; - fSubscriptions := TBoldSubscriptionList.Create; + if Assigned(fSubscribableObject) then + result := fSubscribableObject.ClassName + else + result := ClassName; end; -destructor TBoldPublisher.Destroy; +function TBoldPublisher.GetDebugInfo: string; begin - Assert(not Assigned(fSubscriptions)); - if NeedsPacking then - RemoveFromPostNotificationQueue(self); - inherited; + result := GetContextString; end; -procedure TBoldPublisher.NotifySubscribersAndClearSubscriptions(Originator: TObject); +function TBoldPublisher.GetHasSubscribers: Boolean; +begin + result := fSubscriptionCount > 0; +end; + +function TBoldPublisher.GetPublisherFlag(Flag: TBoldPublisherFlag): Boolean; +begin + result := Flag in fPublisherFlags; +end; + +function TBoldPublisher.GetSubscriptionsAsText: string; var - I: Integer; + i,j: integer; begin - if not Assigned(fSubscriptions) then - Exit; - SendExtendedEvent(Originator, beDestroying, []); - for I := 0 to Subscriptions.Count - 1 do - TBoldSubscription(Subscriptions[I]).UnlinkFromPublisher; - FreeAndNil(fSubscriptions); + result := ''; + j := 0; + for I := 0 to Length(fSubscriptionArray) - 1 do + begin + if Assigned(fSubscriptionArray[i].Subscriber) then + begin + result := result + IntToStr(j) + ':' + fSubscriptionArray[i].Subscriber.ContextString+ #13#10; + inc(j); + end; + end; end; -procedure TBoldPublisher.SendExtendedEvent(Originator: TObject; - OriginalEvent: TBoldEvent; - const Args: array of const); +function TBoldPublisher.HasMatchingSubscription( + Subscriber: TBoldSubscriber): boolean; var - I: Integer; - Subscription: TBoldSubscription; + i: integer; begin - if Assigned(Subscriptions) then + if fSubscriptionCount < Subscriber.SubscriptionCount then begin - StartNotify; - for I := 0 to Subscriptions.Count - 1 do + for I := fSubscriptionCount - 1 downto 0 do + if (fSubscriptionArray[I].Subscriber = Subscriber) then + begin + result := true; + exit; + end; + end + else + for I := Subscriber.SubscriptionCount - 1 downto 0 do + if (Subscriber.Subscriptions[I].Publisher = Self) then begin - Subscription := TBoldSubscription(fSubscriptions.Items[I]); - if Assigned(Subscription.Subscriber) and Subscription.IsMatchingEvent(OriginalEvent) then - if Subscription.Subscriber.HandlesExtendedEvents then - Subscription.Subscriber.ReceiveExtended(Originator, OriginalEvent, Subscription.RequestedEvent, Args) - else - Subscription.Subscriber.Receive(Originator, OriginalEvent, Subscription.RequestedEvent); + result := true; + exit; end; + result := false; +end; + +procedure TBoldPublisher.CancelSubscriptionTo(Subscriber: TBoldSubscriber); +var + i: integer; +begin + StartNotify; + try + if fSubscriptionCount <= Subscriber.SubscriptionCount then + begin + for I := 0 to SubscriptionCount-1 do + if (fSubscriptionArray[I].Subscriber = Subscriber) then + ClearEntry(Subscriber, i); + end + else + for I := 0 to Subscriber.SubscriptionCount - 1 do + if (Subscriber.Subscriptions[I].Publisher = Self) then + ClearEntry(Subscriber, Subscriber.Subscriptions[I].Index); + finally EndNotify; end; end; -procedure TBoldPublisher.AddToSubscriptions(Subscription: TBoldSubscription); +procedure TBoldPublisher.SetPublisherFlag(Flag: TBoldPublisherFlag; + Value: Boolean); +begin + if Value then + Include(fPublisherFlags, Flag) + else + Exclude(fPublisherFlags, Flag); +end; + +function TBoldPublisher.GetNeedsPacking: Boolean; +begin + result := GetPublisherFlag(bpfNeedsPacking); +end; + +procedure TBoldPublisher.SetNeedsPacking(Value: Boolean); +begin + if NeedsPacking <> Value then + begin + SetPublisherFlag(bpfNeedsPacking, Value); + // the postnotify queue will be gone if we are in finalization, + // but then we don't need to pack since we will be destroyed soon anyway... + if Value and assigned(G_PostNotifyQueue) then + DelayTillAfterNotification(PackSubscriptions, nil, Self); + end; +end; + +procedure TBoldPublisher.EnsureFreeSpace; +begin + if fSubscriptionCount = Length(fSubscriptionArray) then + SetLength(fSubscriptionArray, GetNewLength(fSubscriptionCount)); +end; + +procedure TBoldPublisher.ClearEntry(Subscriber: TboldSubscriber; index: integer); begin - Subscriptions.Add(Subscription); + if fSubscriptionArray[index].Subscriber <> Subscriber then + begin + if Assigned(fSubscriptionArray[index].Subscriber) and Assigned(Subscriber) then + Assert(false, Format('TBoldPublisher.ClearEntry: %s <> %s; index = %d', [fSubscriptionArray[index].Subscriber.ContextString, Subscriber.ContextString, Index])) + else + Assert(false, Format('TBoldPublisher.ClearEntry: %s; index = %d', [Subscriber.ContextString, Index])); + end; + fSubscriptionArray[index].ClearEntry; + // attempt to rewind empty slots + if fSubscriptionCount - 1 = index then + begin + Dec(fSubscriptionCount); + while (fSubscriptionCount <> 0) and (fSubscriptionArray[fSubscriptionCount-1].Subscriber = nil) do + begin + Dec(fSubscriptionCount); + Dec(fHoleCount); + end; + end + else + Inc(fHoleCount); + if (fSubscriptionCount-fHoleCount < Length(fSubscriptionArray) div 2) then + NeedsPacking := True; end; procedure TBoldPublisher.AddSmallSubscription(Subscriber: TBoldSubscriber; Events: TBoldSmallEventSet; RequestedEvent: TBoldRequestedEvent); var - I: Integer; - Subscription: TBoldSubscription; - LocalSubscriptions: TBoldSubscriptionList; + I, index: Integer; begin if not assigned(Subscriber) then exit; - if Subscriptions.Count < Subscriber.Subscriptions.Count then + if fSubscriptionCount <= Subscriber.SubscriptionCount then begin - localSubscriptions := Subscriptions; - for I := 0 to localSubscriptions.Count - 1 do + for I := 0 to fSubscriptionCount - 1 do begin - Subscription := TBoldSubscription(LocalSubscriptions.Items[I]); - if (Subscription.Subscriber = Subscriber) and - (Subscription.RequestedEvent = RequestedEvent) and - (Subscription is TBoldSmallEventSubscription) then + if (fSubscriptionArray[I].Subscriber = Subscriber) and + (fSubscriptionArray[I].RequestedEvent = RequestedEvent) and + (fSubscriptionArray[I].isSmallEventSubscription) then begin - TBoldSmallEventSubscription(Subscription).ExtendEvents(Events); + fSubscriptionArray[I].ExtendEvents(Events); Exit; end; end; end else - begin - localSubscriptions := Subscriber.Subscriptions; - for I := 0 to localSubscriptions.Count - 1 do + begin + for I := 0 to Subscriber.SubscriptionCount - 1 do begin - Subscription := TBoldSubscription(LocalSubscriptions.Items[I]); - if (Subscription.Publisher = Self) and - (Subscription.RequestedEvent = RequestedEvent) and - (Subscription is TBoldSmallEventSubscription) then + if (Subscriber.Subscriptions[I].Publisher = Self) then begin - TBoldSmallEventSubscription(Subscription).ExtendEvents(Events); - Exit; + Index := Subscriber.Subscriptions[I].Index; + if (fSubscriptionArray[Index].RequestedEvent = RequestedEvent) and + fSubscriptionArray[Index].isSmallEventSubscription then + begin + fSubscriptionArray[Index].ExtendEvents(Events); + Exit; + end; end; end; end; - TBoldSmallEventSubscription.Create(Self, Subscriber, Events, RequestedEvent); + if Events = [] then + Raise EBold.CreateFmt('%s.AddSmallSubscription: Events is empty set, probably event is a not small event.', [ClassName]); + EnsureFreeSpace; + fSubscriptionArray[fSubscriptionCount].Subscriber := Subscriber; + fSubscriptionArray[fSubscriptionCount].IndexInSubscriber := Subscriber.SubscriptionCount; + fSubscriptionArray[fSubscriptionCount].RequestedEvent := RequestedEvent; + fSubscriptionArray[fSubscriptionCount].MatchCondition := Integer(Events); +{$IFDEF DEBUG} + Assert(fSubscriptionArray[fSubscriptionCount].IsSmallEventSubscription); +{$ENDIF} + Subscriber.AddToSubscriptions(self, fSubscriptionCount); + Inc(fSubscriptionCount); end; procedure TBoldPublisher.AddSubscription(Subscriber: TBoldSubscriber; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); var - I: Integer; - Subscription: TBoldSubscription; - LocalSubscriptions: TBoldSubscriptionList; + I, index: Integer; begin if not assigned(Subscriber) then exit; - if Subscriptions.Count < Subscriber.Subscriptions.Count then + if (OriginalEvent <= beMaxSmallUser) then begin - LocalSubscriptions := Subscriptions; - for I := 0 to LocalSubscriptions.Count - 1 do + AddSmallSubscription(Subscriber, [OriginalEvent], RequestedEvent); + Exit; + end; + if fSubscriptionCount <= Subscriber.SubscriptionCount then + begin + for I := 0 to fSubscriptionCount - 1 do begin - Subscription := TBoldSubscription(LocalSubscriptions.Items[I]); - if (Subscription.Subscriber = Subscriber) and - (Subscription.RequestedEvent = RequestedEvent) and - Subscription.IsMatchingEvent(OriginalEvent) then + if (fSubscriptionArray[I].Subscriber = Subscriber) and + (fSubscriptionArray[I].RequestedEvent = RequestedEvent) and + fSubscriptionArray[I].IsMatchingEvent(OriginalEvent) then Exit; end; end else begin - LocalSubscriptions := Subscriber.Subscriptions; - for I := 0 to localSubscriptions.Count - 1 do + for I := 0 to Subscriber.SubscriptionCount - 1 do begin - Subscription := TBoldSubscription(localSubscriptions.Items[I]); - if (Subscription.Publisher = Self) and - (Subscription.RequestedEvent = RequestedEvent) and - Subscription.IsMatchingEvent(OriginalEvent) then - Exit; + if (Subscriber.Subscriptions[I].Publisher = Self) then + begin + Index := Subscriber.Subscriptions[I].Index; + if (fSubscriptionArray[Index].RequestedEvent = RequestedEvent) and + fSubscriptionArray[Index].IsMatchingEvent(OriginalEvent) then + Exit; + end; end; end; - TBoldEventSubscription.Create(Self, Subscriber, OriginalEvent, RequestedEvent); + EnsureFreeSpace; + fSubscriptionArray[fSubscriptionCount].Subscriber := Subscriber; + fSubscriptionArray[fSubscriptionCount].IndexInSubscriber := Subscriber.SubscriptionCount; + fSubscriptionArray[fSubscriptionCount].RequestedEvent := RequestedEvent; + fSubscriptionArray[fSubscriptionCount].MatchCondition := OriginalEvent or beBigEventFlag; +{$IFDEF DEBUG} + Assert(fSubscriptionArray[fSubscriptionCount].IsMatchingEvent(OriginalEvent)); +{$ENDIF} + Subscriber.AddToSubscriptions(self, fSubscriptionCount); + Inc(fSubscriptionCount); end; +procedure TBoldPublisher.SendExtendedEvent(Originator: TObject; + OriginalEvent: TBoldEvent; + const Args: array of const); +var + I: Integer; + Subscriber: TBoldSubscriber; +begin + if fSubscriptionCount = 0 then + Exit; + Inc(_SendExtendedEvent); + StartNotify; + for I := 0 to fSubscriptionCount - 1 do + begin + Subscriber := fSubscriptionArray[I].Subscriber; + if Assigned(Subscriber) and fSubscriptionArray[I].IsMatchingEvent(OriginalEvent) then + begin + if Subscriber.HandlesExtendedEvents then + Subscriber.ReceiveExtended(Originator, OriginalEvent, fSubscriptionArray[I].RequestedEvent, Args) + else + Subscriber.Receive(Originator, OriginalEvent, fSubscriptionArray[I].RequestedEvent); + Inc(_SendEventMatch); + end; + end; + EndNotify; +end; + +{$IFNDEF BOLD_NO_QUERIES} function TBoldPublisher.SendQuery(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; var I: Integer; - Subscription: TBoldSubscription; begin - if Assigned(Subscriptions) then + if fSubscriptionCount > 0 then begin + Inc(_SendQuery); StartNotify; - for I := 0 to Subscriptions.Count - 1 do + for I := 0 to fSubscriptionCount - 1 do begin - Subscription := TBoldSubscription(Subscriptions.Items[I]); - if Assigned(Subscription.Subscriber) and Subscription.IsMatchingEvent(OriginalEvent) then - if not Subscription.Subscriber.Answer(Originator, OriginalEvent, Subscription.RequestedEvent, Args, Subscriber) then + if Assigned( fSubscriptionArray[I].Subscriber) and fSubscriptionArray[I].IsMatchingEvent(OriginalEvent) then + if not fSubscriptionArray[I].Subscriber.Answer(Originator, OriginalEvent, fSubscriptionArray[I].RequestedEvent, Args, Subscriber) then begin + Inc(_QueryMatch); result := false; Exit; end; @@ -479,121 +900,50 @@ function TBoldPublisher.SendQuery(Originator: TObject; OriginalEvent: TBoldEvent end; result := true; end; +{$ENDIF} -function TBoldPublisher.GetHasSubscribers: Boolean; -begin - result := assigned(fSubscriptions) and (Subscriptions.Count > 0); -end; - -{---TBoldSubscription---} - -constructor TBoldSubscription.Create(Publisher: TBoldPublisher; Subscriber: TBoldSubscriber; RequestedEvent: TBoldRequestedEvent); -begin - inherited Create; - fPublisher := Publisher; - fSubscriber := Subscriber; - fRequestedEvent := RequestedEvent; - Publisher.AddToSubscriptions(Self); - Subscriber.AddToSubscriptions(Self); -end; - -procedure TBoldSubscription.UnlinkFromSubscriber; -begin - fSubscriber := nil; - if Assigned(Publisher) then - Publisher.NeedsPacking := True - else - Free; {commit suicide when both links gone} -end; - -procedure TBoldSubscription.UnlinkFromPublisher; -begin - fPublisher := nil; - if not Assigned(Subscriber) then - Free; {commit suicide when both links gone} -end; - -{---TBoldEventSubscription---} - -procedure TBoldEventSubscription.CloneTo(Subscriber: TBoldSubscriber; - NewRequestedEvent: TBoldRequestedEvent); -begin - inherited; - Publisher.AddSubscription(Subscriber,fEvent, NewRequestedEvent); -end; - -constructor TBoldEventSubscription.Create(Publisher: TBoldPublisher; - Subscriber: TBoldSubscriber; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); -begin - inherited Create(Publisher, Subscriber, RequestedEvent); - fEvent := OriginalEvent; -end; - -function TBoldEventSubscription.IsMatchingEvent(OriginalEvent: TBoldEvent): Boolean; -begin - Result := OriginalEvent = fEvent; -end; - -{---TBoldSmallEventSubscription---} - -procedure TBoldSmallEventSubscription.CloneTo(Subscriber: TBoldSubscriber; NewRequestedEvent: TBoldRequestedEvent); -begin - inherited; - Publisher.AddSmallSubscription(Subscriber,fEvents, NewRequestedEvent); -end; - -constructor TBoldSmallEventSubscription.Create(Publisher: TBoldPublisher; - Subscriber: TBoldSubscriber; Events: TBoldSmallEventSet; RequestedEvent: TBoldRequestedEvent); -begin - inherited Create(Publisher, Subscriber, RequestedEvent); - fEvents := Events; -end; - -procedure TBoldSmallEventSubscription.ExtendEvents(Events: TBoldSmallEventSet); -begin - fEvents := fEvents + Events; -end; - -function TBoldSmallEventSubscription.IsMatchingEvent(OriginalEvent: TBoldEvent): Boolean; -begin - Result := (OriginalEvent < 32) and (OriginalEvent in fEvents); -end; - -{---TBoldSubscriber---} - -destructor TBoldSubscriber.Destroy; +procedure TBoldPublisher.NotifySubscribersAndClearSubscriptions(Originator: TObject); +var + I: Integer; begin - if Assigned(fSubscriptions) then - begin - CancelAllSubscriptions; - FreeAndNil(fSubscriptions); - end; - inherited Destroy; + if fSubscriptionCount = 0 then + Exit; + SendExtendedEvent(Originator, beDestroying, []); + for I := 0 to fSubscriptionCount - 1 do + fSubscriptionArray[I].ClearEntry; + SetLength(fSubscriptionArray, 0); + fSubscriptionCount := 0; end; -function TBoldSubscriber.GetSubscriptions: TList; +constructor TBoldPublisher.Create; begin - if not Assigned(fSubscriptions) then - fSubscriptions := TList.Create; - Result := fSubscriptions; + Inc(PublisherCount); end; -procedure TBoldSubscriber.AddToSubscriptions(Subscription: TBoldSubscription); +destructor TBoldPublisher.Destroy; begin - Subscriptions.Add(Subscription); + Assert(fSubscriptionCount = 0); + if NeedsPacking then + RemoveFromPostNotificationQueue(self); + Dec(PublisherCount); end; procedure TBoldSubscriber.CancelAllSubscriptions; var I: Integer; + Publisher: TBoldPublisher; begin - if Subscriptions.Count = 0 then + if fSubscriptionCount = 0 then Exit; TBoldPublisher.StartNotify; try - for I := 0 to Subscriptions.Count - 1 do - TBoldSubscription(Subscriptions[I]).UnlinkFromSubscriber; - fSubscriptions.Count := 0; {remove entires but retain size} + for I := 0 to fSubscriptionCount - 1 do + begin + Publisher := fSubscriptionArray[I].Publisher; + if Assigned(Publisher) then + Publisher.ClearEntry(self, fSubscriptionArray[I].Index); + end; + fSubscriptionCount := 0; {remove entires but retain size} finally TBoldPublisher.EndNotify; end; @@ -601,18 +951,31 @@ procedure TBoldSubscriber.CancelAllSubscriptions; {---TBoldPassthroughSubscriber---} -constructor TBoldPassthroughSubscriber.Create(receiveFunc: TBoldEventHandler); +constructor TBoldPassthroughSubscriber.Create(AReceiveFunc: TBoldEventHandler); begin inherited Create; - fReceiveFunc := receiveFunc; + fReceiveFunc := AReceiveFunc; end; -constructor TBoldPassthroughSubscriber.CreateWithReceiveAndAnswer(ReceiveFunc: TBoldEventHandler; - AnswerFunc: TBoldQueryHandler); +function TBoldPassthroughSubscriber.GetContextString: string; +var + vObject: TObject; begin - inherited Create; - fReceiveFunc := ReceiveFunc; - fAnswerFunc := AnswerFunc; + vObject := TObject(TMethod(fReceiveFunc).Data); +{$IFNDEF BOLD_DISABLEMEMORYMANAGER} + if vObject is TBoldMemoryManagedObject then + result := TBoldMemoryManagedObject(vObject).DebugInfo + else +{$ENDIF} + if vObject is TComponent then + result := TComponent(vObject).Name + else + Result := vObject.ClassName; +end; + +function TBoldPassthroughSubscriber.GetHandlesExtendedEvents: Boolean; +begin + Result := false; end; procedure TBoldPassthroughSubscriber.Receive(Originator: TObject; OriginalEvent: TBoldEvent; @@ -622,7 +985,18 @@ procedure TBoldPassthroughSubscriber.Receive(Originator: TObject; OriginalEvent: fReceiveFunc(Originator, OriginalEvent, RequestedEvent); end; -function TBoldPassthroughSubscriber.Answer(Originator: TObject; OriginalEvent: TBoldEvent; +{---TBoldExtendedPassthroughSubscriber---} + +{$IFNDEF BOLD_NO_QUERIES} +constructor TBoldExtendedPassthroughSubscriber.CreateWithReceiveAndAnswer(AReceiveFunc: TBoldEventHandler; + AAnswerFunc: TBoldQueryHandler); +begin + inherited Create(nil); + ReceiveFunc := AReceiveFunc; + fAnswerFunc := AAnswerFunc; +end; + +function TBoldExtendedPassthroughSubscriber.Answer(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; begin if Assigned(fAnswerFunc) then @@ -630,16 +1004,25 @@ function TBoldPassthroughSubscriber.Answer(Originator: TObject; OriginalEvent: T else result := true; end; +{$ENDIF} {--- TBoldSubscribableObject ---} function TBoldSubscribableObject.GetPublisher: TBoldPublisher; begin if not Assigned(fPublisher) then + begin fPublisher := TBoldPublisher.Create; + fPublisher.SubscribableObject := self; + end; Result := fPublisher end; +function TBoldSubscribableObject.GetSubscriptionsAsText: string; +begin + result := Publisher.SubscriptionsAsText; +end; + procedure TBoldSubscribableObject.FreePublisher; begin if Assigned(fPublisher) then @@ -649,12 +1032,6 @@ procedure TBoldSubscribableObject.FreePublisher; end; end; -destructor TBoldSubscribableObject.Destroy; -begin - FreePublisher; - inherited; -end; - procedure TBoldSubscribableObject.AddSmallSubscription(Subscriber: TBoldSubscriber; Events: TBoldSmallEventSet; RequestedEvent: TBoldRequestedEvent); begin @@ -673,9 +1050,29 @@ procedure TBoldSubscribableObject.SendEvent(OriginalEvent: TBoldEvent); fPublisher.SendExtendedEvent(self, OriginalEvent, []); end; -function TBoldSubscribableObject.SendQuery(OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; +destructor TBoldSubscribableObject.Destroy; +begin + FreePublisher; +end; + +{$IFNDEF BOLD_NO_QUERIES} +function TBoldSubscribableObject.SendQuery(OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber; Originator: TObject = nil): Boolean; +begin + if Assigned(Originator) then + result := not Assigned(fPublisher) or fPublisher.SendQuery(Originator, OriginalEvent, Args, Subscriber) + else + result := not Assigned(fPublisher) or fPublisher.SendQuery(self, OriginalEvent, Args, Subscriber); +end; +{$ENDIF} + +function TBoldSubscribableObject.GetContextString: string; begin - result := not Assigned(fPublisher) or fPublisher.SendQuery(self, OriginalEvent, Args, Subscriber); + result := ClassName; +end; + +function TBoldSubscribableObject.GetDebugInfo: string; +begin + result := ContextString; end; function TBoldSubscribableObject.GetHasSubscribers: Boolean; @@ -685,6 +1082,26 @@ function TBoldSubscribableObject.GetHasSubscribers: Boolean; {--- TBoldSubscribableComponent ---} +function TBoldSubscribableComponent.GetPublisher: TBoldPublisher; +begin + if not Assigned(fPublisher) then + begin + fPublisher := TBoldPublisher.Create; + fPublisher.SubscribableObject := self; + end; + Result := fPublisher +end; + +function TBoldSubscribableComponent.GetSubscriptionsAsText: string; +begin + result := Publisher.SubscriptionsAsText; +end; + +function TBoldSubscribableComponent.GetHasSubscribers: Boolean; +begin + result := assigned(fPublisher) and Publisher.HasSubscribers; +end; + procedure TBoldSubscribableComponent.FreePublisher; begin if Assigned(fPublisher) then @@ -718,17 +1135,36 @@ procedure TBoldSubscribableComponent.SendEvent(Originator: TObject; OriginalEven fPublisher.SendExtendedEvent(Originator, OriginalEvent, []); end; +{$IFNDEF BOLD_NO_QUERIES} function TBoldSubscribableComponent.SendQuery(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; begin result := not Assigned(fPublisher) or fPublisher.SendQuery(Originator, OriginalEvent, Args, Subscriber); end; +{$ENDIF} {---TBoldSubscribablePersistent---} -constructor TBoldSubscribablePersistent.Create; +function TBoldSubscribablePersistent.GetPublisher: TBoldPublisher; begin - inherited; - fPublisher := TBoldPublisher.Create; + if not Assigned(fPublisher) then + begin + fPublisher := TBoldPublisher.Create; + fPublisher.SubscribableObject := self; + end; + Result := fPublisher +end; + +function TBoldSubscribablePersistent.GetSubscriptionsAsText: string; +begin + if assigned(fPublisher) then + result := fPublisher.SubscriptionsAsText + else + result := ''; +end; + +function TBoldSubscribablePersistent.GetHasSubscribers: Boolean; +begin + result := assigned(fPublisher) and Publisher.HasSubscribers; end; procedure TBoldSubscribablePersistent.FreePublisher; @@ -764,6 +1200,7 @@ procedure TBoldSubscribablePersistent.SendEvent(Originator: TObject; OriginalEve fPublisher.SendExtendedEvent(Originator, OriginalEvent, []); end; +{$IFNDEF BOLD_NO_QUERIES} function TBoldSubscribablePersistent.SendQuery(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; begin result := not Assigned(fPublisher) or fPublisher.SendQuery(Originator, OriginalEvent, Args, Subscriber); @@ -772,22 +1209,27 @@ function TBoldSubscribablePersistent.SendQuery(Originator: TObject; OriginalEven function TBoldSubscriber.Answer(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; begin - raise EBold.CreateFmt(sAnswerNotImplemented, [classname, Originator.Classname]); + raise EBold.CreateFmt('%s.Answer: You have subscribed to a query without implementing the virtual Answer method... (triggered by: %s)', [classname, Originator.Classname]); end; +{$ENDIF} function TBoldSubscriber.GetContextString: string; begin - Result := ''; + Result := ClassName; +end; + +function TBoldSubscriber.GetDebugInfo: string; +begin + result := ContextString; end; procedure TBoldSubscriber.ReceiveExtended(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const); begin - // do nothing end; -procedure TBoldPassthroughSubscriber.ReceiveExtended(Originator: TObject; +procedure TBoldExtendedPassthroughSubscriber.ReceiveExtended(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const); begin @@ -800,13 +1242,48 @@ function TBoldSubscriber.GetHandlesExtendedEvents: Boolean; result := false; end; -constructor TBoldPassthroughSubscriber.CreateWithExtendedReceive( - ExtendedReceiveFunc: TBoldExtendedEventHandler); +function TBoldSubscriber.GetSubscriptionsAsText: string; +var + i,j: integer; + SubscribableObject: TObject; begin - fExtendedReceiveFunc := ExtendedReceiveFunc; + result := ''; + j := 0; + for I := 0 to Length(fSubscriptionArray) - 1 do + if Assigned(fSubscriptionArray[i].Publisher) and Assigned(fSubscriptionArray[i].Publisher.SubscribableObject) then + begin + SubscribableObject := fSubscriptionArray[i].Publisher.SubscribableObject; + if fSubscriptionArray[i].Publisher.SubscribableObject is TBoldMemoryManagedObject + then + result := result + IntToStr(j) + ':' + TBoldMemoryManagedObject(fSubscriptionArray[i].Publisher.SubscribableObject).DebugInfo + #13#10 + else + if fSubscriptionArray[i].Publisher.SubscribableObject is TComponent then + result := result + IntToStr(j) + ':' + TComponent(fSubscriptionArray[i].Publisher.SubscribableObject).Name + #13#10 + else + result := result + IntToStr(j) + ':' + fSubscriptionArray[i].Publisher.SubscribableObject.ClassName + #13#10; + inc(j); + end; end; -function TBoldPassthroughSubscriber.GetHandlesExtendedEvents: Boolean; +function TBoldSubscriber.HasMatchingSubscription( + APublisher: TBoldPublisher): boolean; +begin + result := APublisher.HasMatchingSubscription(self); +end; + +procedure TBoldSubscriber.CancelSubscriptionTo(APublisher: TBoldPublisher); +begin + APublisher.CancelSubscriptionTo(self); +end; + +constructor TBoldExtendedPassthroughSubscriber.CreateWithExtendedReceive( + AExtendedReceiveFunc: TBoldExtendedEventHandler); +begin + inherited Create(nil); + fExtendedReceiveFunc := AExtendedReceiveFunc; +end; + +function TBoldExtendedPassthroughSubscriber.GetHandlesExtendedEvents: Boolean; begin result := assigned(fExtendedReceiveFunc); end; @@ -833,125 +1310,161 @@ procedure TBoldSubscribablePersistent.SendExtendedEvent(Originator: TObject; Publisher.SendExtendedEvent(Originator, OriginalEvent, Args); end; -function TBoldPublisher.GetPublisherFlag(Flag: TBoldPublisherFlag): Boolean; +procedure TBoldSubscriber.AfterConstruction; begin - result := Flag in fPublisherFlags; + inherited; + Inc(SubscriberCount); end; -procedure TBoldPublisher.SetPublisherFlag(Flag: TBoldPublisherFlag; - Value: Boolean); +procedure TBoldSubscriber.BeforeDestruction; begin - if Value then - Include(fPublisherFlags, Flag) - else - Exclude(fPublisherFlags, Flag); + Dec(SubscriberCount); + CancelAllSubscriptions; + inherited; end; -function TBoldPublisher.GetNeedsPacking: Boolean; +class procedure TBoldPublisher.DelayTillAfterNotification( + Event: TNotifyEvent; Sender: TObject; Receiver: TObject); begin - result := GetPublisherFlag(bpfNeedsPacking); + if G_NotificationNesting = 0 then + Event(Sender) + else if Assigned(G_PostNotifyQueue) then + G_PostNotifyQueue.Add(Event, Sender, Receiver) + else + Raise EBold.CreateFmt('%s.DelayTillAfterNotification: Queue not allocated', [ClassName]); end; -procedure TBoldPublisher.SetNeedsPacking(Value: Boolean); +procedure TBoldPublisher.PackSubscriptions(dummy: TObject); +var + OldCount, i, Gap: integer; begin - if not NeedsPacking then + OldCount := fSubscriptionCount; + Gap := 0; + for i := 0 to OldCount-1 do begin - SetPublisherFlag(bpfNeedsPacking, Value); - // the postnotify queue will be gone if we are in finalization, - // but then we don't need to pack since we will be destroyed soon anyway... - if assigned(G_PostNotifyQueue) then - DelayTillAfterNotification(PackSubscriptions, nil, Self); - end + if FSubscriptionArray[i].Subscriber = nil then + begin + Inc(Gap); + end + else if gap > 0 then + begin + Assert((fSubscriptionArray[i].Subscriber.Subscriptions[fSubscriptionArray[i].IndexInSubscriber].Publisher = Self) and (fSubscriptionArray[i].Subscriber.Subscriptions[fSubscriptionArray[i].IndexInSubscriber].Index = i)); + fSubscriptionArray[i].ReIndexsSubscriber(i-gap); + fSubscriptionArray[i-gap] := fSubscriptionArray[i]; + fSubscriptionArray[i].Subscriber := nil; + end; + end; + fSubscriptionCount := fSubscriptionCount-Gap; + if fSubscriptionCount = 0 then + SetLength(FSubscriptionArray, 0) else - SetPublisherFlag(bpfNeedsPacking, Value); + // do not bother if it's less than 9 records + if (Length(FSubscriptionArray) > 8) and (fSubscriptionCount < Length(FSubscriptionArray) div 2) then + SetLength(FSubscriptionArray, fSubscriptionCount); + NeedsPacking := false; + fHoleCount := 0; end; -function TBoldSubscribablePersistent.GetHasSubscribers: Boolean; +class procedure TBoldPublisher.RemoveFromPostNotificationQueue(Receiver: TObject); begin - result := assigned(fPublisher) and Publisher.HasSubscribers; + if Assigned(G_PostNotifyQueue) then + G_PostNotifyQueue.RemoveAllForReceiver(Receiver); end; -function TBoldSubscribableComponent.GetHasSubscribers: Boolean; +procedure InitDebugMethods; begin - result := assigned(fPublisher) and Publisher.HasSubscribers; + exit; // intentionally do nothing, but code bellow forces compiler to include these debug methods so they can be inspected + TBoldPublisher.Create.SubscriptionsAsText; + TBoldPassthroughSubscriber.Create(nil).SubscriptionsAsText; + TBoldSubscribableObject.Create.SubscriptionsAsText; + TBoldSubscribablePersistent.Create.SubscriptionsAsText; + TBoldSubscribableComponent.Create(nil).SubscriptionsAsText; end; -procedure TBoldSubscriber.CloneSubscriptions(Subscriber: TBoldSubscriber; - OldRequestedEvent: TBoldRequestedEvent; - NewRequestedEvent: TBoldRequestedEvent); -var - i: integer; +{ TBoldSubscribableNonRefCountedObject } + +procedure TBoldSubscribableNonRefCountedObject.AddSmallSubscription( + Subscriber: TBoldSubscriber; Events: TBoldSmallEventSet; + RequestedEvent: TBoldRequestedEvent); begin - for i := 0 to Subscriptions.Count - 1 do - if TBoldSubscription(Subscriptions[i]).RequestedEvent = OldRequestedEvent then - TBoldSubscription(Subscriptions[i]).CloneTo(Subscriber, newRequestedEvent); + Publisher.AddSmallSubscription(Subscriber, Events, RequestedEvent); end; -class procedure TBoldPublisher.DelayTillAfterNotification( - Event: TNotifyEvent; Sender: TObject; Receiver: TObject); +procedure TBoldSubscribableNonRefCountedObject.AddSubscription( + Subscriber: TBoldSubscriber; OriginalEvent: TBoldEvent; + RequestedEvent: TBoldRequestedEvent); begin - if G_NotificationNesting = 0 then - Event(Sender) - else if Assigned(G_PostNotifyQueue) then - G_PostNotifyQueue.Add(Event, Sender, Receiver) - else - raise EBold.CreateFmt(sQueueNotAllocated, [ClassName]); + Publisher.AddSubscription(Subscriber, OriginalEvent, RequestedEvent); end; -class procedure TBoldPublisher.EndNotify; +destructor TBoldSubscribableNonRefCountedObject.Destroy; begin - Dec(G_NotificationNesting); - if (G_NotificationNesting = 0) and Assigned(G_PostNotifyQueue) and (not G_InPostNotification) then + FreePublisher; + inherited; +end; + +procedure TBoldSubscribableNonRefCountedObject.FreePublisher; +begin + if Assigned(fPublisher) then begin - G_InPostNotification := True; - G_PostNotifyQueue.DequeueAll; {may add and delete entries, Eventqueue can handle it} - G_InPostNotification := False; + fPublisher.NotifySubscribersAndClearSubscriptions(Self); + FreeAndNil(fPublisher); end; end; -class procedure TBoldPublisher.StartNotify; +function TBoldSubscribableNonRefCountedObject.GetHasSubscribers: Boolean; begin - Inc(G_NotificationNesting); + result := assigned(fPublisher) and Publisher.HasSubscribers; end; -procedure TBoldPublisher.PackSubscriptions(dummy: TObject); -var - i: integer; +function TBoldSubscribableNonRefCountedObject.GetPublisher: TBoldPublisher; begin - for i := Subscriptions.Count - 1 downto 0 do - if TBoldSubscription(Subscriptions[i]).Subscriber = nil then - begin - TBoldSubscription(Subscriptions[i]).UnlinkFromPublisher; - Subscriptions[i] := Subscriptions.Last; - Subscriptions.Delete(Subscriptions.Count - 1); - end; - NeedsPacking := false; + if not Assigned(fPublisher) then + begin + fPublisher := TBoldPublisher.Create; + fPublisher.SubscribableObject := self; + end; + Result := fPublisher end; -class procedure TBoldPublisher.RemoveFromPostNotificationQueue(Receiver: TObject); +function TBoldSubscribableNonRefCountedObject.GetSubscriptionsAsText: string; begin - if Assigned(G_PostNotifyQueue) then - G_PostNotifyQueue.RemoveAllForReceiver(Receiver); + result := Publisher.SubscriptionsAsText; end; -function TBoldSubscribableComponent.GetPublisher: TBoldPublisher; +procedure TBoldSubscribableNonRefCountedObject.SendEvent(Originator: TObject; + OriginalEvent: TBoldEvent); begin - if not assigned(fPublisher) then - fPublisher := TBoldPublisher.Create; - result := fPublisher; + if Assigned(fPublisher) then + fPublisher.SendExtendedEvent(Originator, OriginalEvent, []); end; -function TBoldSubscribablePersistent.GetPublisher: TBoldPublisher; +procedure TBoldSubscribableNonRefCountedObject.SendExtendedEvent( + Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const); begin - if not assigned(fPublisher) then - fPublisher := TBoldPublisher.Create; - result := fPublisher; + if Assigned(fPublisher) then + fPublisher.SendExtendedEvent(self, OriginalEvent, Args); end; +{$IFNDEF BOLD_NO_QUERIES} +function TBoldSubscribableNonRefCountedObject.SendQuery(Originator: TObject; + OriginalEvent: TBoldEvent; const Args: array of const; + Subscriber: TBoldSubscriber): Boolean; +begin + if Assigned(Originator) then + result := not Assigned(fPublisher) or fPublisher.SendQuery(Originator, OriginalEvent, Args, Subscriber) + else + result := not Assigned(fPublisher) or fPublisher.SendQuery(self, OriginalEvent, Args, Subscriber); +end; +{$ENDIF} + initialization G_PostNotifyQueue := TboldEventQueue.Create; + InitDebugMethods; finalization FreeAndNil(G_PostNotifyQueue); - + if (DebugHook <> 0) then + if (ActiveSubscriptionCount + PublisherCount + SubscriberCount) > 0 then + Assert(false, Format('ActiveSubscriptionCount = %d, PublisherCount = %d, SubscriberCount = %d', [ActiveSubscriptionCount, PublisherCount, SubscriberCount])); end. diff --git a/Source/Common/Support/BoldBase64.pas b/Source/Common/Support/BoldBase64.pas index 795ca830..58e38064 100644 --- a/Source/Common/Support/BoldBase64.pas +++ b/Source/Common/Support/BoldBase64.pas @@ -1,3 +1,7 @@ +///////////////////////////////////////////////////////// + +{ Global compiler directives } +{$include bold.inc} unit BoldBase64; // uTBase64 v1.0 - Simple Base64 encoding/decoding class @@ -45,18 +49,20 @@ interface +uses + BoldDefs; + type TBase64 = class(TObject) private ffilterdecodeinput:boolean; function ValueToCharacter(value: Byte; var character: char):boolean; function CharacterToValue(character: char; var value: byte):boolean; - function filterLine(InputData: string):string; - protected + function filterLine(const InputData: string): string; public constructor Create; - function EncodeData(InputData:string; var OutputData: string): Byte; - function DecodeData(InputData:string; var OutputData: string): Byte; + function EncodeData(InputData: TBoldAnsiString; var OutputData: string): Byte; + function DecodeData(InputData: string; var OutputData: TBoldAnsiString): Byte; property FilterdecodeInput: boolean read ffilterdecodeinput write ffilterdecodeinput; end; @@ -70,9 +76,20 @@ TBase64 = class(TObject) implementation +uses + BoldRev; + const AlphabetLength = 64; - Alphabet: string[AlphabetLength] = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; + Alphabet: array[1..AlphabetLength] of AnsiChar = ( + 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', + 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', + 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', + 'Y', 'Z', 'a', 'b', 'c', 'd', 'e', 'f', + 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', + 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', + 'w', 'x', 'y', 'z', '0', '1', '2', '3', + '4', '5', '6', '7', '8', '9', '+', '/'); Pad = '='; @@ -94,7 +111,7 @@ function TBase64.ValueToCharacter(value: Byte; var character: char): boolean; if (value > AlphabetLength-1) then Result := false else - character := Char (Alphabet[value+1]); // marco + character := Char(Alphabet[value+1]); end; @@ -105,7 +122,7 @@ function TBase64.ValueToCharacter(value: Byte; var character: char): boolean; function TBase64.CharacterToValue(character: char; var value: byte): boolean; begin Result := true; - value := Pos(character, Alphabet); + value := Pos(AnsiChar(character), Alphabet); if value = 0 then Result := false else @@ -117,12 +134,12 @@ function TBase64.CharacterToValue(character: char; var value: byte): boolean; // Encodes a string to its base64 representation in ASCII Format // returns BASE64_OK if conversion was done without errors //****************************************************************** -function TBase64.EncodeData(InputData: string; var OutputData: string): Byte; +function TBase64.EncodeData(InputData: TBoldAnsiString; var OutputData: string): Byte; var i: integer; currentb, prevb: Byte; c: Byte; - s: char; + s: Char; InputLength: integer; begin OutPutData := ''; @@ -135,7 +152,7 @@ function TBase64.EncodeData(InputData: string; var OutputData: string): Byte; end; repeat - // process first group + // process first group currentb := ord(InputData[i]); i := i+1; InputLength := InputLength-1; @@ -212,7 +229,7 @@ function TBase64.EncodeData(InputData: string; var OutputData: string): Byte; // ignores all characters not in base64 alphabet // and returns the filtered string //****************************************************************** -function TBase64.filterLine(InputData: string): string; +function TBase64.filterLine(const InputData: string): string; var f:byte; i:integer; @@ -229,13 +246,13 @@ function TBase64.filterLine(InputData: string): string; // Decodes a base64 representation in ASCII format into a string // returns BASE64_OK if conversion was done without errors //****************************************************************** -function TBase64.DecodeData(InputData: string; var OutputData: string): Byte; +function TBase64.DecodeData(InputData: string; var OutputData: TBoldAnsiString): Byte; var i: integer; InputLength: integer; currentb, prevb: Byte; c: Byte; - s: char; + s: Char; begin if (InputData = '') then @@ -274,7 +291,7 @@ function TBase64.DecodeData(InputData: string; var OutputData: string): Byte; end; c := ((currentb shl 2)+(prevb shr 4)) and 255; - OutPutData := OutPutData+chr(c); + OutPutData := OutPutData + AnsiChar(Chr(c)); // process second Byte i := i+1;s := InputData[i]; @@ -299,7 +316,7 @@ function TBase64.DecodeData(InputData: string; var OutputData: string): Byte; exit; end; c := ((prevb shl 4) + (currentb shr 2)) and 255; - OutPutData := OutPutData + chr(c); + OutPutData := OutPutData + AnsiChar(Chr(c)); end; // process third Byte i := i+1; @@ -320,11 +337,10 @@ function TBase64.DecodeData(InputData: string; var OutputData: string): Byte; exit; end; c := ((currentb shl 6) + (prevb)) and 255; - OutPutData := OutPutData + chr(c); + OutPutData := OutPutData + AnsiChar(Chr(c)); end; until (i >= InputLength); result := BASE64_OK; end; end. - diff --git a/Source/Common/Support/BoldCollections.pas b/Source/Common/Support/BoldCollections.pas index 9f62d16e..e30cf1a3 100644 --- a/Source/Common/Support/BoldCollections.pas +++ b/Source/Common/Support/BoldCollections.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldCollections; interface @@ -18,7 +21,7 @@ TBoldUniquelyNamedCollectionItemClass = class of TBoldUniquelyNamedCollectionI TBoldUniqueNameItemIndex = class(TBoldStringHashIndex) protected - function ItemAsKeyString(Item: TObject): string; override; + function ItemASKeyString(Item: TObject): string; override; end; { TBoldUniquelyNamedCollectionItem } @@ -60,7 +63,7 @@ TBoldCollectionWithUniquelyNamedItems = class(TOwnedCollection) property ItemIndex: TBoldUniqueNameItemIndex read GetItemIndex; public constructor Create(AOwner: TPersistent; ItemClass: TBoldUniquelyNamedCollectionItemClass); - destructor Destroy; override; + destructor destroy; override; property ItemByName[const Name: String]: TBoldUniquelyNamedCollectionItem read GetItemByName; end; @@ -71,14 +74,14 @@ implementation SysUtils, BoldDefs, BoldIndex, - BoldCommonConst; + BoldRev; { TBoldUniquelyNamedCollectionItem } procedure TBoldUniquelyNamedCollectionItem.EnsureNameUnique(const Value: string); begin if assigned(Collection.ItemByName[value]) then - raise EBold.CreateFmt(sDuplicateName, [value]); + raise EBold.CreateFmt('There is already an item with name "%s"', [value]); end; function TBoldUniquelyNamedCollectionItem.GetCollection: TBoldCollectionWithUniquelyNamedItems; @@ -103,7 +106,7 @@ procedure TBoldUniquelyNamedCollectionItem.InternalSetUniqueName(const Value: st begin if Value <> UniqueName then begin - EnsureNameUnique(Value); // will ensure the index as well + EnsureNameUnique(Value); Collection.ItemIndex.Remove(self); SetUniqueName(Value); Collection.ItemIndex.Add(self); @@ -125,7 +128,7 @@ constructor TBoldCollectionWithUniquelyNamedItems.Create(AOwner: TPersistent; It inherited Create(aOwner, ItemClass); end; -destructor TBoldCollectionWithUniquelyNamedItems.Destroy; +destructor TBoldCollectionWithUniquelyNamedItems.destroy; begin FreeAndNil(fItemIndex); inherited; @@ -151,7 +154,6 @@ function TBoldCollectionWithUniquelyNamedItems.GetItemIndex: TBoldUniqueNameItem procedure TBoldCollectionWithUniquelyNamedItems.Update(Item: TCollectionItem); begin - // implementation in superclass is empty FreeAndNil(fItemIndex); end; diff --git a/Source/Common/Support/BoldCommonBitmaps.RES b/Source/Common/Support/BoldCommonBitmaps.RES new file mode 100644 index 00000000..fde30574 Binary files /dev/null and b/Source/Common/Support/BoldCommonBitmaps.RES differ diff --git a/Source/Common/Support/BoldCommonBitmaps.pas b/Source/Common/Support/BoldCommonBitmaps.pas index 80378ac2..66cb72c4 100644 --- a/Source/Common/Support/BoldCommonBitmaps.pas +++ b/Source/Common/Support/BoldCommonBitmaps.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldCommonBitmaps; interface @@ -24,7 +27,7 @@ interface implementation -{.$R *.res} +{$R *.res} uses SysUtils; @@ -82,3 +85,4 @@ finalization end. + diff --git a/Source/Common/Support/BoldCommonBitmaps.rc b/Source/Common/Support/BoldCommonBitmaps.rc index 596effce..1bc57132 100644 --- a/Source/Common/Support/BoldCommonBitmaps.rc +++ b/Source/Common/Support/BoldCommonBitmaps.rc @@ -1,19 +1,19 @@ /* Grid bitmaps */ -BOLDGRID_CURRENT BITMAP LOADONCALL "BoldGrid Current.bmp" -BOLDGRID_SELECTED BITMAP LOADONCALL "BoldGrid Selected.bmp" -BOLDGRID_CONSTRAINT_TRUE BITMAP LOADONCALL "BoldGrid Constraint True.bmp" -BOLDGRID_CONSTRAINT_FALSE BITMAP LOADONCALL "BoldGrid Constraint False.bmp" +BOLDGRID_CURRENT BITMAP LOADONCALL "..\..\..\Images\BoldGrid Current.bmp" +BOLDGRID_SELECTED BITMAP LOADONCALL "..\..\..\Images\BoldGrid Selected.bmp" +BOLDGRID_CONSTRAINT_TRUE BITMAP LOADONCALL "..\..\..\Images\BoldGrid Constraint True.bmp" +BOLDGRID_CONSTRAINT_FALSE BITMAP LOADONCALL "..\..\..\Images\BoldGrid Constraint False.bmp" /* Navigator bitmaps */ -BOLDNAV_DELETE BITMAP LOADONCALL "BoldNavigator Delete.bmp" -BOLDNAV_FIRST BITMAP LOADONCALL "BoldNavigator First.bmp" -BOLDNAV_LAST BITMAP LOADONCALL "BoldNavigator Last.bmp" -BOLDNAV_INSERT BITMAP LOADONCALL "BoldNavigator Insert.bmp" -BOLDNAV_NEXT BITMAP LOADONCALL "BoldNavigator Next.bmp" -BOLDNAV_PRIOR BITMAP LOADONCALL "BoldNavigator Prior.bmp" -BOLDNAV_MOVEUP BITMAP LOADONCALL "BoldNavigator MoveUp.bmp" -BOLDNAV_MOVEDOWN BITMAP LOADONCALL "BoldNavigator MoveDown.bmp" +BOLDNAV_DELETE BITMAP LOADONCALL "..\..\..\Images\BoldNavigator Delete.bmp" +BOLDNAV_FIRST BITMAP LOADONCALL "..\..\..\Images\BoldNavigator First.bmp" +BOLDNAV_LAST BITMAP LOADONCALL "..\..\..\Images\BoldNavigator Last.bmp" +BOLDNAV_INSERT BITMAP LOADONCALL "..\..\..\Images\BoldNavigator Insert.bmp" +BOLDNAV_NEXT BITMAP LOADONCALL "..\..\..\Images\BoldNavigator Next.bmp" +BOLDNAV_PRIOR BITMAP LOADONCALL "..\..\..\Images\BoldNavigator Prior.bmp" +BOLDNAV_MOVEUP BITMAP LOADONCALL "..\..\..\Images\BoldNavigator MoveUp.bmp" +BOLDNAV_MOVEDOWN BITMAP LOADONCALL "..\..\..\Images\BoldNavigator MoveDown.bmp" /* Editbox bitmaps */ -BOLDEDIT_ELLIPSIS BITMAP LOADONCALL "BoldEdit Ellipsis.bmp" +BOLDEDIT_ELLIPSIS BITMAP LOADONCALL "..\..\..\Images\BoldEdit Ellipsis.bmp" diff --git a/Source/Common/Support/BoldControlPackDefs.pas b/Source/Common/Support/BoldControlPackDefs.pas index 63722e89..f0bdaf38 100644 --- a/Source/Common/Support/BoldControlPackDefs.pas +++ b/Source/Common/Support/BoldControlPackDefs.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldControlPackDefs; interface @@ -33,6 +36,10 @@ interface beListPartEnabledChanged = 100; + DefaultBoldDragMode = bdgSelection; + DefaultBoldDropMode = bdpAppend; + implementation + end. diff --git a/Source/Common/Support/BoldControlsDefs.pas b/Source/Common/Support/BoldControlsDefs.pas index b3dd9e8c..ac87a7eb 100644 --- a/Source/Common/Support/BoldControlsDefs.pas +++ b/Source/Common/Support/BoldControlsDefs.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldControlsDefs; interface @@ -26,7 +29,7 @@ interface TBoldComboSelectChangeAction = (bdscSetText, bdcsSetValue, bdcsNone, bdcsSetReference, bdcsSetListIndex); TBoldEditButtonStyle = (bbsNone, bbsCombo, bbsEllipsis, bbsCustom); - + const BoldPropertiesController_SupportedPropertyTypes = [{tkUnknown,} tkInteger, tkChar, tkEnumeration, tkFloat, @@ -35,4 +38,5 @@ interface implementation + end. diff --git a/Source/Common/Support/BoldExternalizedReferences.pas b/Source/Common/Support/BoldExternalizedReferences.pas index 8f110505..390ec74d 100644 --- a/Source/Common/Support/BoldExternalizedReferences.pas +++ b/Source/Common/Support/BoldExternalizedReferences.pas @@ -1,11 +1,14 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldExternalizedReferences; interface uses + BoldBase, BoldHashIndexes, - BoldIndexableList, - BoldBase; + BoldIndexableList; type { forward declarations } @@ -21,8 +24,8 @@ TBoldExternalizedReferenceList = class(TBoldMemoryManagedObject) function GetReferencedObject(Referee: TObject): TObject; procedure SetReferencedObject(Referee, Referenced: TObject); public - constructor Create; - destructor Destroy; override; + constructor create; + destructor destroy; override; property ManageReferencedObject: Boolean read FManageReferencedObject write SetManageReferencedObject; property ReferencedObjects[Referee: TObject]: TObject read GetReferencedObject write SetReferencedObject; property Count: integer read GetCount; @@ -32,10 +35,7 @@ implementation uses SysUtils, - BoldUtils; - -var - IX_ExternalRef: integer = -1; + BoldRev; type { TBoldExternalLink } @@ -50,24 +50,40 @@ TBoldExternalLink = class(TBoldMemoryManagedObject) { TBoldExternalizedIndexList } TBoldExternalizedIndexList = class(TBoldUnorderedIndexablelist) + private + class var IX_ExternalRef: integer; public - constructor create; - function FindByReferee(Referee: TObject): TBoldExternalLink; + constructor Create; + function FindByReferee(Referee: TObject): TBoldExternalLink; {$IFDEF BOLD_INLINE} inline; {$ENDIF} end; { TBoldExternalizedReferenceHashIndex } TBoldExternalizedReferenceHashIndex = class(TBoldObjectHashIndex) protected - function ItemAsKeyObject(Item: TObject): TObject; override; + function ItemASKeyObject(Item: TObject): TObject; override; end; +{ TBoldExternalizedIndexList } + +constructor TBoldExternalizedIndexList.Create; +begin + inherited; + SetIndexVariable(IX_ExternalRef, AddIndex(TBoldExternalizedReferenceHashIndex.Create)); + OwnsEntries := true; +end; + +function TBoldExternalizedIndexList.FindByReferee(Referee: TObject): TBoldExternalLink; +begin + result := TBoldExternalLink(TBoldExternalizedReferenceHashIndex(Indexes[IX_ExternalRef]).FindByObject(Referee)); +end; + constructor TBoldExternalizedReferenceList.create; begin inherited; flist := TBoldExternalizedIndexList.Create; end; -destructor TBoldExternalizedReferenceList.Destroy; +destructor TBoldExternalizedReferenceList.destroy; begin FreeAndNil(fList); inherited; @@ -103,6 +119,8 @@ procedure TBoldExternalizedReferenceList.SetReferencedObject(Referee, Referenced Link := TBoldExternalizedIndexList(flist).FindByReferee(Referee); if assigned(Link) then begin + if (Link.Referee = Referee) and (Link.Referenced = Referenced) then + exit; if ManageReferencedObject then FreeAndNil(Link.fReferenced); fList.Remove(Link); @@ -124,20 +142,7 @@ function TBoldExternalizedReferenceHashIndex.ItemASKeyObject(Item: TObject): TOb result := TBoldExternalLink(item).Referee; end; -{ TBoldExternalizedIndexList } - -constructor TBoldExternalizedIndexList.create; -begin - inherited; - SetIndexVariable(IX_ExternalRef, AddIndex(TBoldExternalizedReferenceHashIndex.Create)); - OwnsEntries := true; -end; - -function TBoldExternalizedIndexList.FindByReferee(Referee: TObject): TBoldExternalLink; -begin - result := TBoldExternalLink(TBoldExternalizedReferenceHashIndex(Indexes[IX_ExternalRef]).FindByObject(Referee)); -end; +initialization + TBoldExternalizedIndexList.IX_ExternalRef := -1; end. - - diff --git a/Source/Common/Support/BoldFileHandler.pas b/Source/Common/Support/BoldFileHandler.pas index fca1ec95..6119b04a 100644 --- a/Source/Common/Support/BoldFileHandler.pas +++ b/Source/Common/Support/BoldFileHandler.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldFileHandler; interface @@ -92,7 +95,7 @@ implementation uses SysUtils, Dialogs, - BoldCommonConst; + BoldRev; var G_FileHandlerList: TBoldObjectArray; @@ -109,7 +112,6 @@ function BoldFileHandlerForFile(path, FileName: String; ModuleType: TBoldModuleT i: integer; begin try - // see if we can find an existing filehandler for i := 0 to BoldFileHandlerList.Count - 1 do begin if AnsiUpperCase((BoldFileHandlerList[i] as TBoldFileHandler).SetFileName) = AnsiUpperCase(Filename) then @@ -123,7 +125,7 @@ function BoldFileHandlerForFile(path, FileName: String; ModuleType: TBoldModuleT result.InitializeStringList; except on e: exception do - raise EBold.CreateFmt(sUnableToCreateFileHandle, [FileName, e.message]); + raise EBold.CreateFmt('Unable to create filehandler for %s: %s', [FileName, e.message]); end; end; @@ -166,7 +168,7 @@ constructor TBoldFileHandler.Create(const FileName: string; ModuleType: TBoldMod fLastWasNewLIne := true; fIndentLevel := 0; FOnInitializeFileContents := OnInitializeFileContents; - fFileFilter := sFileHandlerMask; + fFileFilter := 'Pascal Unit (*.pas)|*.pas|Include files (*.inc)|*.inc|Text files (*.txt)|*.txt|All Files (*.*)|*.*'; BoldFileHandlerList.Add(self); end; @@ -176,7 +178,7 @@ destructor TBoldFileHandler.Destroy; FlushFile; except on e:Exception do - ShowMessage(SysUtils.Format(sFileSaveProblem, [e.Message])); + ShowMessage('File most likely not saved properly: ' + e.Message); end; FreeAndNil(fStringList); BoldFileHandlerList.remove(self); @@ -209,14 +211,14 @@ procedure TBoldfileHandler.AddString(const s: string); procedure TBoldfileHandler.StartBlock; begin - Writeln('begin'); // do not localize + Writeln('begin'); Indent; end; procedure TBoldfileHandler.EndBlock(const AddNewLine: boolean); begin Dedent; - Writeln('end;'); // do not localize + Writeln('end;'); if AddNewLine then NewLine; end; @@ -343,12 +345,12 @@ procedure TBoldDiskFileHandler.DoFlushFile; if CheckWriteable then begin StringList.SaveToFile(FileName); - BoldLog.LogFmt(sSaved, [FileName]); + BoldLog.Log('Saved ' + FileName); end else begin - BoldLog.LogFmt(sModuleReadOnly, [FFileName], ltError); - ShowMessage(SysUtils.Format(sModuleReadOnly, [fFileName])); + BoldLog.LogFmt('%s is readonly!', [FFileName], ltError); + ShowMessage(fFileName + ' is readonly!'); end; end; @@ -360,7 +362,6 @@ procedure TBoldDiskFileHandler.LoadStringList; function TBoldFileHandler.CheckWriteable(FName: string = ''): Boolean; begin - // If parameter is omitted use the FileName property if FName = '' then FName := FileName; Result := not (FileExists(FName) and FileIsReadOnly(FName)); @@ -368,13 +369,11 @@ function TBoldFileHandler.CheckWriteable(FName: string = ''): Boolean; procedure TBoldFileHandler.CloseFile; begin - // do nothing end; -initialization // empty +initialization finalization FreeAndNil(G_FileHandlerList); end. - diff --git a/Source/Common/Support/BoldGuard.pas b/Source/Common/Support/BoldGuard.pas index 53fd7b0f..1594b132 100644 --- a/Source/Common/Support/BoldGuard.pas +++ b/Source/Common/Support/BoldGuard.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldGuard; interface @@ -10,7 +13,7 @@ interface type { forward declarations } - TBoldGuard = class; + TBoldGuard = class; TBoldObjectVariableReference = ^TObject; @@ -40,8 +43,7 @@ TBoldGuard = class(TBoldRefCountedObject, IBoldGuard) implementation uses - SysUtils, - BoldUtils; + BoldRev; constructor TBoldGuard.Create(var v0); begin @@ -216,4 +218,6 @@ destructor TBoldGuard.Destroy; inherited; end; +initialization + end. diff --git a/Source/Common/Support/BoldHashIndexes.pas b/Source/Common/Support/BoldHashIndexes.pas index b2d9a772..044a3ce5 100644 --- a/Source/Common/Support/BoldHashIndexes.pas +++ b/Source/Common/Support/BoldHashIndexes.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldHashIndexes; interface @@ -19,8 +22,8 @@ TBoldCardinalHashIndex = class; {---TBoldStringKey---} TBoldStringKey = class public - class function HashString(const KeyString: String; CompareMode: TBoldStringCompareMode): Cardinal; - class function HashBuffer(P: PChar; length: integer; CompareMode: TBoldStringCompareMode): Cardinal; + class function HashString(const KeyString: String; CompareMode: TBoldStringCompareMode): Cardinal; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + class function HashBuffer(const P: PChar; const Length: Integer; const CompareMode: TBoldStringCompareMode): Cardinal; end; {---TBoldStringHashIndex---} @@ -31,8 +34,8 @@ TBoldStringHashIndex = class(TBoldHashIndex) function Match(const Key; Item:TObject):Boolean; override; function Hash(const Key): Cardinal; override; public - function FindByString(const KeyString: string): TObject; - procedure FindAllByString(const KeyString: string; List: TList); + function FindByString(const KeyString: string): TObject; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure FindAllByString(const KeyString: string; List: TList); {$IFDEF BOLD_INLINE} inline; {$ENDIF} end; {---TBoldCaseSensitiveStringHashIndex---} @@ -43,7 +46,7 @@ TBoldCaseSensitiveStringHashIndex = class(TBoldHashIndex) function Match(const Key; Item:TObject):Boolean; override; function Hash(const Key): Cardinal; override; public - function FindByString(const KeyString: string): TObject; + function FindByString(const KeyString: string): TObject; {$IFDEF BOLD_INLINE} inline; {$ENDIF} end; {---TBoldObjectHashIndex---} @@ -53,9 +56,10 @@ TBoldObjectHashIndex = class(TBoldHashIndex) function HashItem(Item: TObject): Cardinal; override; function Match(const Key; Item:TObject):Boolean; override; function Hash(const Key): Cardinal; override; - class function HashObject(KeyObject: TObject): Cardinal; - function FindByObject(KeyObject: TObject): TObject; - procedure FindAllByObject(const KeyObject: TObject; List: TList); + class function HashObject(KeyObject: TObject): Cardinal; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + public + function FindByObject(KeyObject: TObject): TObject; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure FindAllByObject(const KeyObject: TObject; List: TList); {$IFDEF BOLD_INLINE} inline; {$ENDIF} end; {---TBoldClassHashIndex---} @@ -65,8 +69,9 @@ TBoldClassHashIndex = class(TBoldHashIndex) function HashItem(Item: TObject): Cardinal; override; function Match(const Key; Item:TObject):Boolean; override; function Hash(const Key): Cardinal; override; - class function HashClass(KeyClass: TClass): Cardinal; - function FindByClass(KeyClass: TClass): TObject; + class function HashClass(KeyClass: TClass): Cardinal; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + public + function FindByClass(KeyClass: TClass): TObject; {$IFDEF BOLD_INLINE} inline; {$ENDIF} end; {---TBoldGuidHashIndex---} @@ -74,12 +79,13 @@ TBoldGUIDHashIndex = class(TBoldHashIndex) private function GuidEqual(const Guid1, Guid2: TGuid): Boolean; protected - function ItemASKeyGUID(O: TObject): TGUID; virtual; abstract; + function ItemASKeyGUID(Item: TObject): TGUID; virtual; abstract; function HashItem(Item: TObject): Cardinal; override; function Match(const Key; Item:TObject):Boolean; override; function Hash(const Key): Cardinal; override; - function HashGUID(const KeyGUID: TGUID): Cardinal; - function FindByGUID(const KeyGUID: TGUID): TObject; + function HashGUID(const KeyGUID: TGUID): Cardinal; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + public + function FindByGUID(const KeyGUID: TGUID): TObject; {$IFDEF BOLD_INLINE} inline; {$ENDIF} end; {---TBoldCardinalHashIndex---} @@ -89,47 +95,68 @@ TBoldCardinalHashIndex = class(TBoldHashIndex) function HashItem(Item: TObject): Cardinal; override; function Match(const Key; Item:TObject):Boolean; override; function Hash(const Key): Cardinal; override; - function FindByCardinal(const KeyCardinal: Cardinal): TObject; + function FindByCardinal(const KeyCardinal: Cardinal): TObject; {$IFDEF BOLD_INLINE} inline; {$ENDIF} end; implementation uses - Windows, // CharUpperBuff, fixme move to BoldUtils. - SysUtils, - BoldUtils; + Windows, + BoldUtils, + BoldRev; + +{$IFDEF USEGLOBALCHARBUFFER} +const + InitialBufferSize = 256; +var + _PBuffer: PChar; + _PBufferLength: integer = InitialBufferSize; +{$ENDIF} -class function TBoldStringKey.HashBuffer(P: PChar; Length: integer; CompareMode: TBoldStringCompareMode): Cardinal; +class function TBoldStringKey.HashBuffer(const P: PChar; const Length: Integer; const CompareMode: TBoldStringCompareMode): Cardinal; +{$IFNDEF USEGLOBALCHARBUFFER} function LIHash: Cardinal; // Separate function to avoid string handling overhead in main func var PUpper: PChar; begin - GetMem(PUpper, Length); + GetMem(PUpper, Length * SizeOf(Char)); try - Move(P^, PUpper^, Length); + Move(P^, PUpper^, Length * SizeOf(Char)); CharUpperBuff(PUpper, Length); // FIXME provide method in BoldUtils Result := HashBuffer(PUpper, Length, bscCaseDependent); finally Freemem(PUpper); end; end; +{$ENDIF} var i: integer; begin - Result := 0; - case CompareMode of - bscCaseDependent: - for i := 0 to Length-1 do - Result := ((Result shl 3) and 2147483647) or - (Result shr (32-3)) xor ord(P[i]); - bscCaseIndependent: - for i := 0 to Length-1 do - Result := ((Result shl 3) and 2147483647) or - (Result shr (32-3)) xor (ord(P[i]) or 32); + Result := 0; + case CompareMode of + bscCaseDependent: + for i := 0 to Length-1 do + Result := ((Result shl 3) and 2147483647) or + (Result shr (32-3)) xor ord(P[i]); + bscCaseIndependent: + for i := 0 to Length-1 do + Result := ((Result shl 3) and 2147483647) or + (Result shr (32-3)) xor (ord(P[i]) or 32); else + {$IFDEF USEGLOBALCHARBUFFER} + if Length > _PBufferLength then begin + Freemem(_PBuffer); + GetMem(_PBuffer, Length * SizeOf(Char)); + _PBufferLength := Length; + end; + Move(P^, _PBuffer^, Length * SizeOf(Char)); + CharUpperBuff(_PBuffer, Length); // FIXME provide method in BoldUtils + Result := HashBuffer(_PBuffer, Length, bscCaseDependent); + {$ELSE} Result := LIHash; - end; + {$ENDIF} + end; end; class function TBoldStringKey.HashString(const KeyString: String; CompareMode: TBoldStringCompareMode): Cardinal; @@ -138,6 +165,12 @@ class function TBoldStringKey.HashString(const KeyString: String; CompareMode: T end; {---TBoldStringHashIndex---} + +function TBoldStringHashIndex.Hash(const Key): Cardinal; +begin + Result := TBoldStringKey.HashString(string(Key), bscLocaleCaseIndependent); +end; + function TBoldStringHashIndex.HashItem(Item: TObject): Cardinal; begin Result := TBoldStringKey.Hashstring(ItemAsKeyString(Item), bscLocaleCaseIndependent); @@ -145,7 +178,7 @@ function TBoldStringHashIndex.HashItem(Item: TObject): Cardinal; function TBoldStringHashIndex.Match(const Key; Item:TObject):Boolean; begin - Result := BoldAnsiEqual(ItemAsKeyString(Item), string(Key)); + Result := BoldAnsiEqual(ItemAsKeyString(Item), string(Key)); end; function TBoldStringHashIndex.FindByString(const KeyString: string): TObject; @@ -154,6 +187,12 @@ function TBoldStringHashIndex.FindByString(const KeyString: string): TObject; end; {---TBoldCaseSensitiveStringHashIndex---} + +function TBoldCaseSensitiveStringHashIndex.Hash(const Key): Cardinal; +begin + Result := TBoldStringKey.HashString(string(Key), bscCaseDependent); +end; + function TBoldCaseSensitiveStringHashIndex.HashItem(Item: TObject): Cardinal; begin Result := TBoldStringKey.Hashstring(ItemAsKeyString(Item), bscCaseDependent); @@ -170,6 +209,17 @@ function TBoldCaseSensitiveStringHashIndex.FindByString(const KeyString: string) end; {---TBoldObjectHashIndex---} + +class function TBoldObjectHashIndex.HashObject(KeyObject: TObject): Cardinal; +begin + Result := Cardinal(KeyObject); +end; + +function TBoldObjectHashIndex.Hash(const Key): Cardinal; +begin + Result := Cardinal(Key); +end; + function TBoldObjectHashIndex.HashItem(Item: TObject): Cardinal; begin Result := HashObject(ItemAsKeyObject(Item)); @@ -186,6 +236,17 @@ function TBoldObjectHashIndex.FindByObject(KeyObject: TObject): TObject; end; {---TBoldClassHashIndex---} + +class function TBoldClassHashIndex.HashClass(KeyClass: TClass): Cardinal; +begin + Result := Cardinal(KeyClass); +end; + +function TBoldClassHashIndex.Hash(const Key): Cardinal; +begin + Result := Cardinal(Key); +end; + function TBoldClassHashIndex.HashItem(Item: TObject): Cardinal; begin Result := HashClass(ItemAsKeyClass(Item)); @@ -202,6 +263,24 @@ function TBoldClassHashIndex.FindByClass(KeyClass: TClass): TObject; end; {---TBoldGUIDHashIndex---} + +function TBoldGUIDHashIndex.HashGUID(const KeyGUID: TGUID): Cardinal; +var + I: integer; +begin + with KeyGUID do + begin + Result := D1 xor d2 xor (d3 shl 8); + for i := 0 to 7 do + result := result xor D4[I]; + end; +end; + +function TBoldGUIDHashIndex.Hash(const Key): Cardinal; +begin + Result := HashGUid(TGuid(Key)); +end; + function TBoldGUIDHashIndex.HashItem(Item: TObject): Cardinal; begin Result := HashGUID(ItemAsKeyGUID(Item)); @@ -218,7 +297,6 @@ function TBoldGUIDHashIndex.GuidEqual(const Guid1, Guid2: TGuid): Boolean; result := result and (Guid1.D4[i] = Guid2.D4[i]); end; - function TBoldGUIDHashIndex.Match(const Key; Item: TObject):Boolean; begin Result := GuidEqual(TGUID(Key), ItemAsKeyGUID(Item)); @@ -230,6 +308,12 @@ function TBoldGUIDHashIndex.FindByGUID(const KeyGUID: TGUID): TObject; end; {---TBoldCardinalHashIndex---} + +function TBoldCardinalHashIndex.Hash(const Key): Cardinal; +begin + Result := Cardinal(Key); +end; + function TBoldCardinalHashIndex.HashItem(Item: TObject): Cardinal; begin Result := ItemAsKeyCardinal(Item); @@ -255,57 +339,15 @@ procedure TBoldObjectHashIndex.FindAllByObject(const KeyObject: TObject; List: T FindAll(KeyObject, List); end; -function TBoldStringHashIndex.Hash(const Key): Cardinal; -begin - Result := TBoldStringKey.HashString(string(Key), bscLocaleCaseIndependent); -end; - -function TBoldCaseSensitiveStringHashIndex.Hash(const Key): Cardinal; -begin - Result := TBoldStringKey.HashString(string(Key), bscCaseDependent); -end; - -function TBoldObjectHashIndex.Hash(const Key): Cardinal; -begin - Result := Cardinal(Key); -end; - -function TBoldClassHashIndex.Hash(const Key): Cardinal; -begin - Result := Cardinal(Key); -end; - -function TBoldGUIDHashIndex.Hash(const Key): Cardinal; -begin - Result := HashGUid(TGuid(Key)); -end; - -function TBoldCardinalHashIndex.Hash(const Key): Cardinal; -begin - Result := Cardinal(Key); -end; - -class function TBoldObjectHashIndex.HashObject( - KeyObject: TObject): Cardinal; -begin - Result := Cardinal(KeyObject); -end; - -class function TBoldClassHashIndex.HashClass(KeyClass: TClass): Cardinal; -begin - Result := Cardinal(KeyClass); -end; - -function TBoldGUIDHashIndex.HashGUID(const KeyGUID: TGUID): Cardinal; -var - I: integer; -begin - with KeyGUID do - begin - Result := D1 xor d2 xor (d3 shl 8); - for i := 0 to 7 do - result := result xor D4[I]; - end; -end; +initialization +{$IFDEF USEGLOBALCHARBUFFER} + GetMem(_PBuffer, InitialBufferSize * SizeOf(Char)); +{$ENDIF} +finalization +{$IFDEF USEGLOBALCHARBUFFER} + Freemem(_PBuffer); + _PBufferLength := 0; +{$ENDIF} end. + diff --git a/Source/Common/Support/BoldIndex.pas b/Source/Common/Support/BoldIndex.pas index e3012880..06eb71d9 100644 --- a/Source/Common/Support/BoldIndex.pas +++ b/Source/Common/Support/BoldIndex.pas @@ -1,14 +1,24 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldIndex; interface uses BoldBase, - Classes; + Classes, + Contnrs; + +const + {$IFDEF BOLD_DELPHI16_OR_LATER} + MaxListSize = MaxInt div 16; + {$ELSE} + MaxListSize = Classes.MaxListSize; + {$ENDIF} type { forward declaration of classes } - TBoldHashIndexBucketEntry = class; TBoldIndexTraverser = class; TBoldHashIndexTraverser = class; TBoldIndex = class; @@ -18,8 +28,7 @@ TBoldIntegerIndex = class; PItemEntry = ^TBoldHashIndexItemEntryRec; PPItemEntry = ^PItemEntry; - PPItemEntryList = ^TPItemEntryList; - TPItemEntryList = array[0..MaxListSize - 1] of PItemEntry; + TIntegerIndexSortCompare = function (Item1, Item2: TObject): Integer; { TBoldHashIndexItemEntry } TBoldHashIndexItemEntryRec = record @@ -27,21 +36,44 @@ TBoldHashIndexItemEntryRec = record Item: TObject; end; + // Make class so it shows up in AQTime + TBoldItemRecBloc = class + private + fEntries: array[0..4094] of TBoldHashIndexItemEntryRec; + FFirstEntry: PItemEntry; + function GetFirstEntry: PItemEntry; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + public + constructor Create; + property FirstEntry: PItemEntry read GetFirstEntry; + end; - { TBoldHashIndexBucketEntry } - TBoldHashIndexBucketEntry = class(TBoldMemoryManagedObject) - Next: PItemEntry; + TBoldHashIndexItemEntryRecHandler = class + private + fCount: Integer; + fBlocks: TObjectList; + fFirstFree: PItemEntry; + public + function GetRec: PItemEntry; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure ReturnRec(rec: PItemEntry); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + public + constructor Create; + destructor Destroy; override; + property Count: Integer read fCount; end; { TBoldIndexTraverser } TBoldIndexTraverser = class(TBoldMemoryManagedObject) + private + fAutoMoveOnRemoveCurrent: boolean; + procedure ItemDestroyed(AItem: TObject); virtual; abstract; + procedure Clear; virtual; protected function GetItem: TObject; virtual; abstract; - function GetEol: Boolean; virtual; abstract; public - procedure Next; virtual; abstract; + procedure AfterConstruction; override; + function MoveNext: Boolean; virtual; abstract; property Item: TObject read GetItem; - property EndOfList: Boolean read GetEol; + property AutoMoveOnRemoveCurrent: boolean read fAutoMoveOnRemoveCurrent write fAutoMoveOnRemoveCurrent; end; { TBoldIndex } @@ -52,6 +84,8 @@ TBoldIndex = class (TBoldMemoryManagedObject) function Match(const Key; Item: TObject):Boolean; virtual; abstract; function GetSupportsTraverser: Boolean; virtual; function GetSupportsNilItems: Boolean; virtual; + function GetCapacity: integer; virtual; abstract; + procedure SetCapacity(const Value: integer); virtual; abstract; public procedure FillEmptyIndex(BoldIndex: TBoldIndex); virtual; abstract; procedure Add(Item: TObject); virtual; abstract; @@ -63,23 +97,35 @@ TBoldIndex = class (TBoldMemoryManagedObject) procedure Remove(Item: TObject); virtual; abstract; procedure RemoveChanged(Item: TObject); virtual; abstract; function CreateTraverser: TBoldIndexTraverser; virtual; + function GetAndRemoveAny: TObject; virtual; property Count: integer read GetCount; property Any: TObject read GetAny; property SupportsTraverser: Boolean read GetSupportsTraverser; property SupportsNilItems: Boolean read GetSupportsNilItems; + property Capacity: integer read GetCapacity write SetCapacity; end; + TObjectStaticArray = array[0..MaxListSize - 1] of TObject; + PObjectStaticArray = ^TObjectStaticArray; + { TBoldIntegerIndex } TBoldIntegerIndex = class(TBoldIndex) + strict private + FObjectStaticArray: PObjectStaticArray; + FCount: Integer; + FCapacity: Integer; + function GetItems(index: integer): TObject; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetItems(index: integer; const Value: TObject); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure Grow; {$IFDEF BOLD_INLINE} inline; {$ENDIF} private - fList: TLIst; - function GetItems(index: integer): TObject; - procedure SetItems(index: integer; const Value: TObject); + procedure RangeError(Index: integer); protected function GetAny: TObject; override; function GetCount: Integer; override; function Match(const key; Item: TObject):Boolean; override; function GetSupportsNilItems: Boolean; override; + function GetCapacity: integer; override; + procedure SetCapacity(const Value: integer); override; public constructor Create; destructor Destroy; override; @@ -92,13 +138,16 @@ TBoldIntegerIndex = class(TBoldIndex) function IsCorrectlyIndexed(Item: TObject): boolean; override; procedure Remove(Item: TObject); override; procedure RemoveChanged(Item: TObject); override; - procedure Move(CurIndex, NewIndex: Integer); - procedure Sort(Compare: TListSortCompare); - procedure Insert(Index: Integer; Item: TObject); - procedure Exchange(Index1, Index2: integer); - procedure RemoveByIndex(Index: Integer); - function IndexOf(Item: TObject): integer; + procedure Move(CurIndex, NewIndex: Integer); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure Sort(Compare: TIntegerIndexSortCompare); + procedure Insert(Index: Integer; Item: TObject); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure Exchange(Index1, Index2: integer); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure RemoveByIndex(Index: Integer); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetAndRemoveAny: TObject; override; + function IndexOf(Item: TObject): integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} property Items[index: integer]: TObject read GetItems write SetItems; + function Includes(Item: TObject): boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + property FastCount: Integer read fCount; end; { TBoldHashIndexTraverser } @@ -106,16 +155,16 @@ TBoldHashIndexTraverser = class(TBoldIndexTraverser) private fHashIndex: TBoldHashIndex; fCurrentItem: PItemEntry; - fNextItem: PItemEntry; fBucketIndex: integer; - function FirstItemOfNextBucket: PItemEntry; + function FirstItemOfNextBucket: PItemEntry; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure ItemDestroyed(AItem: TObject); override; + procedure Clear; override; protected function GetItem: TObject; override; - function GetEol: Boolean; override; public constructor Create(HashIndex: TBoldHashIndex); destructor Destroy; override; - procedure Next; override; + function MoveNext: Boolean; override; end; { TBoldHashIndexOptions } @@ -123,33 +172,36 @@ TBoldHashIndexTraverser = class(TBoldIndexTraverser) AutoResize: Boolean; PendingResize: Boolean; IsResizing: Boolean; - TraverserCount: Byte; end; { TBoldHashIndex } TBoldHashIndex = class(TBoldIndex) private fOptions: TBoldHashIndexOptions; - fBucketCount: integer; // Number of hashbuckets - fBucketArray: PPItemEntryList; - fItemCount: integer; // number of Items in table + fBucketArray: array of PItemEntry; + fItemCount: integer; fLastIndexForAny: integer; - function GetBucketArray: PPItemEntryList; - procedure InsertEntry(Entry: PItemEntry); - function MinimumBucketCount: integer; - function MaximumBucketCount: integer; - function PrefferedBucketCount: integer; - procedure SetAutoResize(Value: boolean); - procedure DecreaseTraverser; - property BucketArray: PPItemEntryList read GetBucketArray; + fTraverserList: TList; + procedure InsertEntry(Entry: PItemEntry); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function MinimumBucketCount: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function MaximumBucketCount: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function PrefferedBucketCount: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetAutoResize(Value: boolean); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure RemoveTraverser(ATraverser: TBoldIndexTraverser); + function GetTraverserCount: Integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function EnsuredTraverserList: TList; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetTraverser(AIndex: integer): TBoldIndexTraverser; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected - function PBucketForHash(Hash: Cardinal): PPItemEntry; - function PBucketForIndex(Index: Integer): PPItemEntry; + function IndexForHash(Hash: Cardinal): integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetCount: Integer; override; function HashItem(Item: TObject): Cardinal; virtual; abstract; function Hash(const Key): Cardinal; virtual; abstract; function GetAny: TObject; override; function GetSupportsTraverser: Boolean; override; + property Traversers[AIndex: integer]: TBoldIndexTraverser read GetTraverser; + property TraverserCount: Integer read GetTraverserCount; + function GetCapacity: integer; override; + procedure SetCapacity(const Value: integer); override; public constructor Create; destructor Destroy; override; @@ -159,6 +211,7 @@ TBoldHashIndex = class(TBoldIndex) function Find(const Key): TObject; override; procedure FindAll(const Key; Result: TList); override; function IsCorrectlyIndexed(Item: TObject): boolean; override; + procedure ItemChanged(Item: TObject); override; procedure Remove(Item: TObject); override; procedure RemoveChanged(Item: TObject); override; procedure Resize; @@ -167,20 +220,53 @@ TBoldHashIndex = class(TBoldIndex) procedure AssertIndex; end; -procedure ReturnItemEntry(Entry:PItemEntry; DestroyObjects: Boolean=false); +var + G_HashIndexItemEntryRecHandler: TBoldHashIndexItemEntryRecHandler; implementation uses SysUtils, BoldDefs, - BoldMemoryManager; + BoldRev; const AVERAGEBUCKETLENGTH = 2; MINIMUMHASHBUCKETS = 8; -// Utilityfunction +function TBoldIntegerIndex.GetItems(index: integer): TObject; +begin + // No range check, checked by caller + Result := FObjectStaticArray^[Index]; +end; + +function TBoldItemRecBloc.GetFirstEntry: PItemEntry; +begin + Result := @fEntries[0]; +end; + +function TBoldHashIndexItemEntryRecHandler.GetRec: PItemEntry; +var + Block: TBoldItemRecBloc; +begin + INC(fCount); + if not Assigned(fFirstFree) then + begin + Block := TBoldItemRecBloc.Create; + fFirstFree := Block.FirstEntry; + fBlocks.Add(Block) + end; + Result := fFirstFree; + fFirstFree := Result.Next; +end; + +procedure TBoldHashIndexItemEntryRecHandler.ReturnRec(rec: PItemEntry); +begin + DEC(fCount); + rec.Next := fFirstFree; + fFirstFree := rec; +end; + procedure ReturnItemEntry(Entry:PItemEntry; DestroyObjects: Boolean=false); begin if not Assigned(Entry) then @@ -189,7 +275,7 @@ procedure ReturnItemEntry(Entry:PItemEntry; DestroyObjects: Boolean=false); ReturnItemEntry(Entry.Next, DestroyObjects); if DestroyObjects then FreeAndNil(Entry.Item); - BoldMemoryManager_.DeAllocateMemory(entry, sizeof(TBoldHashIndexItemEntryRec)) + G_HashIndexItemEntryRecHandler.ReturnRec(entry); end; { TBoldIndex } @@ -199,6 +285,18 @@ function TBoldIndex.CreateTraverser: TBoldIndexTraverser; result := nil; end; +function TBoldIndex.GetAndRemoveAny: TObject; +begin + result := Any; + if Assigned(result) then + begin + if Count = 1 then + Clear + else + Remove(result); + end; +end; + function TBoldIndex.GetSupportsNilItems: Boolean; begin result := false; @@ -221,80 +319,124 @@ procedure TBoldIndex.ItemChanged(Item: TObject); { TBoldHashIndex } constructor TBoldHashIndex.Create; begin - fBucketCount := MinimumBucketCount; fOptions.AutoResize := True; end; destructor TBoldHashIndex.Destroy; begin Clear; - assert(fOptions.TraverserCount = 0, 'unreleased traversers on hashindex'); + assert(TraverserCount = 0, 'unreleased traversers on hashindex'); + FreeAndNil(fTraverserList); inherited end; +function TBoldHashIndex.EnsuredTraverserList: TList; +begin + if not Assigned(fTraverserList) then + fTraverserList := TList.Create; + result := fTraverserList; +end; + procedure TBoldHashIndex.SetAutoResize(Value: boolean); begin fOptions.AutoResize := Value; if Value then Resize; end; +function TBoldHashIndex.GetCapacity: integer; +begin + result := MaxInt; // Capacity not supported so return MaxInt +end; + +procedure TBoldHashIndex.SetCapacity(const Value: integer); +begin +// do nothing +end; + function TBoldHashIndex.GetCount: Integer; begin Result := fItemCount; end; +function TBoldHashIndex.PrefferedBucketCount: integer; +begin + Result := MINIMUMHASHBUCKETS shl 2 + fItemCount div AVERAGEBUCKETLENGTH; +end; + +function TBoldHashIndex.MinimumBucketCount: integer; +begin + Result := PrefferedBucketCount div 2; +end; + +function TBoldHashIndex.MaximumBucketCount: integer; +begin + Result := PrefferedBucketCount * 4; +end; + +function TBoldHashIndex.IndexForHash(Hash: Cardinal): integer; +begin + result := hash mod Cardinal(Length(fBucketArray)); +end; + +procedure TBoldHashIndex.InsertEntry(Entry: PItemEntry); +var + BucketIndex: integer; +begin + BucketIndex := IndexForHash(HashItem(Entry.Item)); + Entry.next := fBucketArray[BucketIndex]; + fBucketArray[BucketIndex] := Entry; + Inc(fItemCount); +end; + procedure TBoldHashIndex.Resize; -//FIXME: Check this code thouroughly before used!!! var TempChain: PItemEntry; Last: PPItemEntry; Current: PItemEntry; - i: integer; + i, oldBucketCount: integer; begin - if not fOptions.IsResizing and - ((fBucketCount < MinimumBucketCount) or (fBucketCount > MaximumBucketCount)) then + oldBucketCount := Length(fBucketArray); + if fOptions.IsResizing then + Exit; + if ((oldBucketCount >= MinimumBucketCount) and (oldBucketCount <= MaximumBucketCount)) then begin - if fOptions.TraverserCount > 0 then - begin - fOptions.PendingResize := true; - exit; - end; - try - fOptions.IsResizing := true; - - // collect all entries in one chain starting in TempChain - TempChain := Nil; - Last := @TempChain; + fOptions.PendingResize := false; + exit; + end; + if (TraverserCount > 0) and (fItemCount > 0) then + begin + fOptions.PendingResize := true; + exit; + end; + try + fOptions.IsResizing := true; + TempChain := nil; + Last := @TempChain; - for i := 0 to fBucketCount - 1 do - begin - Current := PBucketForIndex(i)^; - if Assigned(Current) then - begin - Last^ := Current; - while Assigned(Current.Next) do - Current := Current.Next; - Last := @Current.Next; - end; - end; - BoldMemoryManager_.DeAllocateMemory(fBucketArray, fBucketCount*sizeof(PItemEntry)); - fBucketArray := nil; - // BucketArray will be recreated through GetBucketArray - // calculate new size - fBucketCount := PrefferedBucketCount; - fItemCount := 0; - // reinsert all the entries; - while Assigned(TempChain) do + for i := 0 to Length(fBucketArray) - 1 do + begin + Current := fBucketArray[i]; + if Assigned(Current) then begin - // take first.next out of the chain and add it - Current := TempChain; - TempChain := TempChain.Next; - InsertEntry(Current); + Last^ := Current; + while Assigned(Current.Next) do + Current := Current.Next; + Last := @Current.Next; end; - - finally - fOptions.IsResizing := False; end; + SetLength(fBucketArray, PrefferedBucketCount); + for i := 0 to PrefferedBucketCount - 1 do + fBucketArray[i] := nil; + fItemCount := 0; + while Assigned(TempChain) do + begin + Current := TempChain; + TempChain := TempChain.Next; + InsertEntry(Current); + end; + + finally + fOptions.IsResizing := False; end; end; @@ -302,12 +444,17 @@ procedure TBoldHashIndex.Remove(Item: TObject); var Pre: PPItemEntry; ToBeRemoved: PItemEntry; + i: integer; begin - Pre := PBucketForHash(HashItem(Item)); + if Length(fBucketArray) = 0 then + exit; + Pre := @(fBucketArray[IndexForHash(HashItem(Item))]); while Assigned(Pre^) do begin if Pre^.Item = Item then begin + for I := 0 to TraverserCount - 1 do + Traversers[i].ItemDestroyed(Item); ToBeRemoved := Pre^; Pre^ := ToBeRemoved.Next; ToBeRemoved.next := nil; @@ -317,29 +464,23 @@ procedure TBoldHashIndex.Remove(Item: TObject); end else Pre := @Pre^.Next; - end; + end; if AutoResize then Resize; end; -procedure TBoldHashIndex.InsertEntry(Entry: PItemEntry); -// inserts the new element first in the hashbucket -var - Bucket: PPItemEntry; -begin - Bucket := PBucketForHash(HashItem(Entry.Item)); - Entry.next := Bucket^; - Bucket^ := Entry; - Inc(fItemCount); -end; - procedure TBoldHashIndex.Add(Item: TObject); var NewEntry: PItemEntry; begin if assigned(item) then begin - NewEntry := BoldMemoryManager_.AllocateMemory(sizeof(TBoldHashIndexItemEntryRec)); + if Length(fBucketArray) = 0 then + begin + Resize; + Assert(Length(fBucketArray) > 0); + end; + NewEntry := G_HashIndexItemEntryRecHandler.GetRec; NewEntry.Item := Item; InsertEntry(NewEntry); end; @@ -351,38 +492,58 @@ function TBoldHashIndex.Find(const Key): TObject; var Current: PItemEntry; begin - Current := PBucketForHash(Hash(Key))^; + Result := nil; + if Length(fBucketArray) = 0 then + Exit; + Current := fBucketArray[IndexForHash(Hash(Key))]; while Assigned(current) and (not Match(Key, Current.Item)) do Current := Current.Next; if Assigned(Current) then Result := Current.Item - else - Result := nil; end; function TBoldHashIndex.IsCorrectlyIndexed(Item: TObject): boolean; var Current: PItemEntry; begin - Current := PBucketForHash(HashItem(Item))^; + Current := fBucketArray[IndexForHash(HashItem(Item))]; while Assigned(Current) and (Item <> Current.Item) do Current := Current.Next; Result := Assigned(Current); end; +procedure TBoldHashIndex.ItemChanged(Item: TObject); +var + StoredAutoResize: boolean; +begin + if not IsCorrectlyIndexed(Item) then + begin + StoredAutoResize := AutoResize; + AutoResize := false; + try + RemoveChanged(Item); + Add(Item); + finally + AutoResize := StoredAutoResize; + end; + end; +end; + procedure TBoldHashIndex.RemoveChanged(Item: TObject); var - i: integer; + i,j: integer; Pre: PPItemEntry; ToBeRemoved: PItemEntry; begin - for i := 0 to fBucketCount - 1 do + for i := 0 to Length(fBucketArray) - 1 do begin - Pre := PBucketForIndex(i); + Pre := @(fBucketArray[i]); while Assigned(Pre^) do begin if Pre^.Item = Item then begin + for j := 0 to TraverserCount - 1 do + Traversers[j].ItemDestroyed(Item); ToBeRemoved := Pre^; Pre^ := ToBeRemoved.Next; ToBeRemoved.Next := nil; @@ -396,7 +557,6 @@ procedure TBoldHashIndex.RemoveChanged(Item: TObject); end; if AutoResize then Resize; - end; procedure TBoldHashIndex.FindAll(const Key; Result: TList); @@ -404,8 +564,9 @@ procedure TBoldHashIndex.FindAll(const Key; Result: TList); current: PItemEntry; begin Assert(Assigned(Result), 'Trying to find Entries to insert in an unassigned list'); - - Current := PBucketForHash(Hash(Key))^; + if Length(fBucketArray) = 0 then + Exit; + Current := fBucketArray[IndexForHash(Hash(Key))]; while Assigned(Current) do begin if Match(Key, Current.Item) then @@ -414,34 +575,18 @@ procedure TBoldHashIndex.FindAll(const Key; Result: TList); end; end; -function TBoldHashIndex.PrefferedBucketCount: integer; -begin - Result := MINIMUMHASHBUCKETS shl 2 + fItemCount div AVERAGEBUCKETLENGTH; -end; - -function TBoldHashIndex.MinimumBucketCount: integer; -begin - Result := PrefferedBucketCount div 2; -end; - -function TBoldHashIndex.GetBucketArray: PPItemEntryList; -begin - if not Assigned(fBucketArray) then - fBucketArray := BoldMemoryManager_.AllocateMemoryZeroFill(fBucketCount*sizeof(PItemEntry)); - result := fBucketArray; -end; - procedure TBoldHashIndex.Clear(DestroyObjects: Boolean=false); var i: integer; begin -// inherited; - if Assigned(fBucketArray) then - for i := 0 to fBucketCount - 1 do - ReturnItemEntry(PBucketForIndex(i)^, DestroyObjects); - BoldMemoryManager_.DeAllocateMemory(fBucketArray, fBucketCount*sizeof(PItemEntry)); - fBucketArray := nil; - fBucketCount := MinimumBucketCount; + if fItemCount = 0 then + exit; +// if DestroyObjects then + for i := 0 to Length(fBucketArray) - 1 do + ReturnItemEntry(fBucketArray[i], DestroyObjects); + for i := 0 to TraverserCount -1 do + Traversers[i].Clear; + SetLength(fBucketArray, 0); fItemCount := 0; end; @@ -450,22 +595,19 @@ function TBoldHashIndex.GetAny: TObject; BucketIndex: integer; begin result := nil; - if Count > 0 then + if Count = 0 then + Exit; + BucketIndex := fLastIndexForAny; + while not assigned(result) do begin - BucketIndex := fLastIndexForAny; - - while not assigned(result) do + if BucketIndex >= Length(fBucketArray) then + BucketIndex := 0; + if assigned(fBucketArray[BucketIndex]) then begin - if assigned(PBucketForHash(BucketIndex)^) then - begin - result := PBucketForHash(BucketIndex)^.Item; - fLastIndexForAny := BucketIndex; - end; - - inc(BucketIndex); - if BucketIndex > fBucketCount then - BucketIndex := 0; + result := fBucketArray[BucketIndex]^.Item; + fLastIndexForAny := BucketIndex; end; + inc(BucketIndex); end; end; @@ -474,9 +616,9 @@ procedure TBoldHashIndex.FillEmptyIndex(BoldIndex: TBoldIndex); i: integer; Current: PItemEntry; begin - for i := 0 to fBucketCount - 1 do + for i := 0 to Length(fBucketArray) - 1 do begin - Current := PBucketForHash(i)^; + Current := fBucketArray[i]; while assigned(Current) do begin BoldIndex.Add(Current.Item); @@ -490,75 +632,98 @@ function TBoldHashIndex.GetSupportsTraverser: Boolean; result := true; end; -function TBoldHashIndex.CreateTraverser: TBoldIndexTraverser; +function TBoldHashIndex.GetTraverser(AIndex: integer): TBoldIndexTraverser; begin - result := TBoldHashIndexTraverser.Create(self); - fOptions.TraverserCount := fOptions.TraverserCount + 1; + result := TBoldIndexTraverser(fTraverserList[AIndex]); end; -procedure TBoldHashIndex.DecreaseTraverser; +function TBoldHashIndex.GetTraverserCount: Integer; begin - fOptions.TraverserCount := fOptions.TraverserCount - 1; - if (fOptions.TraverserCount = 0) and fOptions.PendingResize then - Resize; -end; - -function TBoldHashIndex.MaximumBucketCount: integer; -begin - Result := PrefferedBucketCount * 4; + if Assigned(fTraverserList) then + result := fTraverserList.Count + else + result := 0; end; -function TBoldHashIndex.PBucketForHash( - Hash: Cardinal): PPItemEntry; -var - index: integer; +function TBoldHashIndex.CreateTraverser: TBoldIndexTraverser; begin - index := hash mod Cardinal(fBucketCount); - result := PBucketForIndex(index); + result := TBoldHashIndexTraverser.Create(self); + EnsuredTraverserList.Add(result); end; -function TBoldHashIndex.PBucketForIndex(Index: Integer): PPItemEntry; +procedure TBoldHashIndex.RemoveTraverser(ATraverser: TBoldIndexTraverser); begin - Assert((index>=0) and (Index< fBucketCount)); - result := @(BucketArray[Index]); + if TraverserCount <> 0 then + fTraverserList.Remove(ATraverser); + if (TraverserCount = 0) and fOptions.PendingResize then + Resize; end; procedure TBoldHashIndex.AssertIndex; +{$IFOPT C+} var i: integer; Pre: PPItemEntry; Start: PItemEntry; - {$IFOPT C+} // Assertions Cnt: integer; - {$ENDIF} +{$ENDIF} begin - {$IFOPT C+} // Assertions +{$IFOPT C+} Cnt := 0; - {$ENDIF} - for i := 0 to fBucketCount - 1 do + for i := 0 to Length(fBucketArray) - 1 do begin - Pre := PBucketForIndex(i); + Pre := @(fBucketArray[i]); Start := Pre^; while Assigned(Pre^) do begin - {$IFOPT C+} // Assertions Inc(cnt); - {$ENDIF} Assert(IsCorrectlyIndexed(Pre^.Item)); Pre := @(Pre^.Next); Assert(pre^ <> Start); end; end; - {$IFOPT C+} // Assertions - Assert(Count = Cnt, Format('%d, %d', [Count, cnt])); - {$ENDIF} + Assert(Count=Cnt, Format('%d, %d',[Count, cnt])); +{$ENDIF} end; { TBoldIntegerIndex } +procedure TBoldIntegerIndex.SetCapacity(const Value: integer); +begin + if Value <> FCapacity then + begin + if ((Value = 0) or (Value > Capacity)) and (Value >= fCount) then // only allow growth or set to 0, do not allow reduction in capacity + begin + Assert(Value >= fCount); + ReallocMem(FObjectStaticArray, Value * SizeOf(TObject)); + FCapacity := Value; + end; + end; +end; + +procedure TBoldIntegerIndex.Grow; +var + Delta: Integer; +begin + if FCapacity > 64 then + Delta := FCapacity div 4 + else + if FCapacity > 8 then + Delta := 16 + else + Delta := 4; + SetCapacity(FCapacity + Delta); +end; + procedure TBoldIntegerIndex.Add(Item: TObject); +var + Index: Integer; begin - fList.Add(item); + Index := FCount; + if Index = FCapacity then + Grow; + FObjectStaticArray^[Index] := Item; + Inc(FCount); end; procedure TBoldIntegerIndex.Clear(DestroyObjects: Boolean=false); @@ -568,26 +733,24 @@ procedure TBoldIntegerIndex.Clear(DestroyObjects: Boolean=false); begin if DestroyObjects then begin - for i := 0 to Count - 1 do + for i := 0 to fCount - 1 do begin - temp := fList[i]; - fList[i] := nil; + temp := FObjectStaticArray^[i]; + FObjectStaticArray^[i] := nil; temp.Free; end; end; - fList.Clear; + fCount := 0; end; constructor TBoldIntegerIndex.Create; begin - fList := TList.Create; end; function TBoldIntegerIndex.Find(const Key): TObject; begin - // Note: Count is actually an integer - if Cardinal(Key) < Cardinal(Count) then - result := fList[Cardinal(Key)] + if Cardinal(Key) < Cardinal(FCount) then + result := FObjectStaticArray^[Cardinal(Key)] else result := nil; end; @@ -601,15 +764,31 @@ procedure TBoldIntegerIndex.FindAll(const Key; Result: TList); result.Add(res); end; +function TBoldIntegerIndex.GetCapacity: integer; +begin + result := fCapacity; +end; + function TBoldIntegerIndex.GetCount: Integer; begin - result := fList.Count; + result := fCount; end; function TBoldIntegerIndex.GetAny: TObject; begin - if Count > 0 then - result := fList[0] + if fCount > 0 then + result := FObjectStaticArray[fCount-1] + else + result := nil; +end; + +function TBoldIntegerIndex.GetAndRemoveAny: TObject; +begin + if fCount > 0 then + begin + result := FObjectStaticArray[fCount-1]; + RemoveByIndex(fCount-1); + end else result := nil; end; @@ -621,79 +800,160 @@ function TBoldIntegerIndex.IsCorrectlyIndexed(Item: TObject): boolean; function TBoldIntegerIndex.Match(const Key; Item: TObject): Boolean; begin - // Note: Count is actually an integer - if Cardinal(Key) < Cardinal(Count) then - Result := item = fList[Cardinal(key)] + if Cardinal(Key) < Cardinal(fCount) then + Result := item = FObjectStaticArray[Cardinal(key)] else Result := False; end; -procedure TBoldIntegerIndex.Remove(Item: TObject); +procedure TBoldIntegerIndex.RangeError(Index: integer); begin - fList.Remove(item); + raise EBold.Create('Index out of range ' + IntToStr(Index)); end; -procedure TBoldIntegerIndex.RemoveChanged(Item: TObject); +function TBoldIntegerIndex.IndexOf(Item: TObject): integer; begin - fList.Remove(item); + Result := 0; + while (Result < FCount) and (FObjectStaticArray^[Result] <> Item) do + Inc(Result); + if Result = FCount then + Result := -1; end; -function TBoldIntegerIndex.GetItems(index: integer): TObject; +function TBoldIntegerIndex.Includes(Item: TObject): boolean; begin - result := fList[index]; + Result := IndexOf(Item) <> -1; end; -procedure TBoldIntegerIndex.SetItems(index: integer; const Value: TObject); +procedure TBoldIntegerIndex.RemoveByIndex(Index: Integer); +var + Temp: TObject; begin - fList[index] := value; + if (Index < 0) or (Index >= FCount) then + RangeError(Index); + Temp := FObjectStaticArray^[Index]; + Dec(FCount); + if Index < FCount then + System.Move(FObjectStaticArray^[Index + 1], FObjectStaticArray^[Index], + (FCount - Index) * SizeOf(TObject)); end; -procedure TBoldIntegerIndex.Exchange(Index1, Index2: integer); +procedure TBoldIntegerIndex.Remove(Item: TObject); +var + Index: Integer; begin - fList.Exchange(index1, index2); + Index := IndexOf(Item); + if Index >= 0 then + RemoveByIndex(Index); end; -function TBoldIntegerIndex.IndexOf(Item: TObject): integer; +procedure TBoldIntegerIndex.RemoveChanged(Item: TObject); begin - result := fList.IndexOf(item); + Remove(item); end; -procedure TBoldIntegerIndex.Move(CurIndex, NewIndex: Integer); +procedure TBoldIntegerIndex.SetItems(index: integer; const Value: TObject); begin - fList.Move(curIndex, NewIndex); + // No range check, checked by caller + FObjectStaticArray^[index] := value; end; -procedure TBoldIntegerIndex.Sort(Compare: TListSortCompare); +procedure TBoldIntegerIndex.Exchange(Index1, Index2: integer); +var + Item: TObject; begin - fList.Sort(Compare); + if (Index1 < 0) or (Index1 >= FCount) then + RangeError(Index1); + if (Index2 < 0) or (Index2 >= FCount) then + RangeError(Index2); + Item := FObjectStaticArray^[Index1]; + FObjectStaticArray^[Index1] := FObjectStaticArray^[Index2]; + FObjectStaticArray^[Index2] := Item; end; procedure TBoldIntegerIndex.Insert(Index: Integer; Item: TObject); begin - fList.Insert(index, item); + if (Index < 0) or (Index > FCount) then + RangeError(Index); + if FCount = FCapacity then + Grow; + if Index < FCount then + System.Move(FObjectStaticArray^[Index], FObjectStaticArray^[Index + 1], + (FCount - Index) * SizeOf(TObject)); + FObjectStaticArray^[Index] := Item; + Inc(FCount); end; -procedure TBoldIntegerIndex.RemoveByIndex(Index: Integer); +procedure TBoldIntegerIndex.Move(CurIndex, NewIndex: Integer); +var + Item: Pointer; +begin + if CurIndex <> NewIndex then + begin + if (NewIndex < 0) or (NewIndex >= FCount) then + RangeError(NewIndex); + if (CurIndex < 0) or (CurIndex >= FCount) then + RangeError(CurIndex); + Item := FObjectStaticArray^[CurIndex]; + FObjectStaticArray^[CurIndex] := nil; + RemoveByIndex(CurIndex); + Insert(NewIndex, nil); + FObjectStaticArray^[NewIndex] := Item; + end; +end; + +procedure QuickSort(SortList: PObjectStaticArray; L, R: Integer; + SCompare: TIntegerIndexSortCompare); +var + I, J: Integer; + P, T: TObject; begin - fList.Delete(index); + repeat + I := L; + J := R; + P := SortList^[(L + R) shr 1]; + repeat + while SCompare(SortList^[I], P) < 0 do + Inc(I); + while SCompare(SortList^[J], P) > 0 do + Dec(J); + if I <= J then + begin + T := SortList^[I]; + SortList^[I] := SortList^[J]; + SortList^[J] := T; + Inc(I); + Dec(J); + end; + until I > J; + if L < J then + QuickSort(SortList, L, J, SCompare); + L := I; + until I >= R; +end; + +procedure TBoldIntegerIndex.Sort(Compare: TIntegerIndexSortCompare); +begin + if (FObjectStaticArray <> nil) and (fCount > 0) then + QuickSort(FObjectStaticArray, 0, fCount - 1, Compare); end; procedure TBoldIntegerIndex.FillEmptyIndex(BoldIndex: TBoldIndex); var i: integer; begin - for i := 0 to Count - 1 do + for i := 0 to fCount - 1 do BoldIndex.Add(items[i]) end; procedure TBoldIntegerIndex.ItemChanged(Item: TObject); begin - // do nothing end; destructor TBoldIntegerIndex.Destroy; begin - FreeAndNil(fList); + Clear; + SetCapacity(0); inherited; end; @@ -704,48 +964,114 @@ function TBoldIntegerIndex.GetSupportsNilItems: Boolean; { TBoldHashIndexTraverser } +function TBoldHashIndexTraverser.FirstItemOfNextBucket: PItemEntry; +begin + result := nil; + while not Assigned(Result) and (fBucketIndex < (Length(fHashIndex.fBucketArray)-1)) do + begin + inc(fBucketIndex); + result := fHashIndex.fBucketArray[fBucketIndex]; + end; +end; + +procedure TBoldHashIndexTraverser.Clear; +begin + fCurrentItem := nil; +end; + constructor TBoldHashIndexTraverser.Create(HashIndex: TBoldHashIndex); begin inherited Create; fHashIndex := HashIndex; fBucketIndex := -1; - fNextItem := FirstItemOfNextBucket; - Next; end; destructor TBoldHashIndexTraverser.Destroy; begin + fHashIndex.RemoveTraverser(self); inherited; - fHashIndex.DecreaseTraverser; end; -function TBoldHashIndexTraverser.FirstItemOfNextBucket: PItemEntry; +function TBoldHashIndexTraverser.GetItem: TObject; begin - result := nil; - while not Assigned(Result) and (fBucketIndex < (fHashIndex.fBucketCount-1)) do + if Assigned(fCurrentItem) then begin - inc(fBucketIndex); - result := fHashIndex.PBucketForIndex(fBucketIndex)^; + result := fCurrentItem.Item; + Assert(Result is TObject); + end + else + result := nil; +end; + +function TBoldHashIndexTraverser.MoveNext: boolean; +begin + if Assigned(fCurrentItem) then + begin + if Assigned(fCurrentItem.Next) then + fCurrentItem := fCurrentItem.Next + else + fCurrentItem := FirstItemOfNextBucket; + end + else + begin + fCurrentItem := FirstItemOfNextBucket; end; + result := Assigned(fCurrentItem); end; -function TBoldHashIndexTraverser.GetEol: Boolean; +procedure TBoldHashIndexTraverser.ItemDestroyed(AItem: TObject); begin - result := not assigned(fCurrentItem); + if AutoMoveOnRemoveCurrent and Assigned(fCurrentItem) and (fCurrentItem.Item = AItem) then + begin + fCurrentItem := fCurrentItem.Next; + if not Assigned(fCurrentItem) then + fCurrentItem := FirstItemOfNextBucket; + end; end; -function TBoldHashIndexTraverser.GetItem: TObject; +{ TBoldHashIndexItemEntryRecHandler } + +constructor TBoldHashIndexItemEntryRecHandler.Create; begin - result := fCurrentItem.Item; + fBlocks := TObjectList.Create; + fBlocks.OwnsObjects := True; end; -procedure TBoldHashIndexTraverser.Next; +destructor TBoldHashIndexItemEntryRecHandler.Destroy; begin - fCurrentItem := fNextItem; - if assigned(fNextItem) and assigned(fNextItem.Next) then - fNExtItem := fNextItem.Next - else - fNextItem := FirstItemOfNextBucket; + // if fCount <> 0 then + // raise Exception.Create('TBoldHashIndexItemEntryRecHandler: Not all records freed'); + FreeAndNil(fBlocks); + inherited; +end; + +{ TBoldItemRecBloc } + +constructor TBoldItemRecBloc.Create; +var + I: Integer; +begin + for I :=low(fEntries) to high(fEntries)- 1 do + fEntries[i].Next := @fEntries[i+1]; + fEntries[high(fEntries)].Next := nil; end; +{ TBoldIndexTraverser } + +procedure TBoldIndexTraverser.AfterConstruction; +begin + inherited; + fAutoMoveOnRemoveCurrent := true; +end; + +procedure TBoldIndexTraverser.Clear; +begin +// nothing +end; + +initialization + G_HashIndexItemEntryRecHandler := TBoldHashIndexItemEntryRecHandler.Create; + +finalization + FreeAndNil(G_HashIndexItemEntryRecHandler); end. diff --git a/Source/Common/Support/BoldIndexCollection.pas b/Source/Common/Support/BoldIndexCollection.pas new file mode 100644 index 00000000..57782839 --- /dev/null +++ b/Source/Common/Support/BoldIndexCollection.pas @@ -0,0 +1,179 @@ +{ Global compiler directives } +{$include bold.inc} +unit BoldIndexCollection; + +interface + +uses + Classes; + +type + TBoldIndexCollection = class; + TBoldIndexCollectionClass = class of TBoldIndexCollection; + + TBoldIndexDefintion = class(TCollectionItem) + strict private + FTableName: String; + fColumns: String; + fUnique: Boolean; + fRemove: Boolean; + function GetAsString: string; + procedure SetAsString(const Value: string); + protected + function GetDisplayName: string; override; + procedure AssignTo(Dest: TPersistent); override; + public + property AsString: string read GetAsString write SetAsString; + function Equals(value: TBoldIndexDefintion): Boolean; reintroduce; + published + property TableName: String read FTableName write FTableName; + property Columns: String read fColumns write fColumns; + property Unique: Boolean read fUnique write fUnique; + property Remove: Boolean read fRemove write fRemove; + end; + + TBoldIndexCollection = class(TCollection) + private + fOwner: TComponent; + function GetDefinition(Index: integer): TBoldIndexDefintion; + procedure SaveToStringList(StrList: TStringList); + procedure LoadFromStringList(StrList: TStringList); + protected + function GetOwner: TPersistent; override; + public + constructor Create(Owner: TComponent); + property IndexDefinition[Index: integer]: TBoldIndexDefintion read GetDefinition; default; + procedure SaveToFile(const FileName: String); + procedure LoadFromFile(const FileName: String); + function AddIndexDefintion: TBoldIndexDefintion; + end; + + +implementation + +uses + SysUtils, + BoldDefs, + BoldNameExpander, + BoldTaggedValueSupport; + +{ TBoldTypeNameDictionary } + +function TBoldIndexCollection.AddIndexDefintion: TBoldIndexDefintion; +begin + result := Add as TBoldIndexDefintion; +end; + +constructor TBoldIndexCollection.Create(Owner: TComponent); +begin + inherited Create(TBoldIndexDefintion); + fOwner := Owner; +end; + +function TBoldIndexCollection.GetDefinition( + Index: integer): TBoldIndexDefintion; +begin + result := GetItem(index) as TBoldIndexDefintion; +end; + +function TBoldIndexCollection.GetOwner: TPersistent; +begin + result := fOwner; +end; + +procedure TBoldIndexCollection.LoadFromFile(const FileName: String); +var + StrList: TStringList; +begin + StrList := TStringList.Create; + try + StrList.LoadFromFile(FileName); + LoadFromStringList(StrList); + finally + StrList.Free; + end; +end; + +procedure TBoldIndexCollection.LoadFromStringList(StrList: TStringList); +var + i: integer; +begin + Clear; + for i := 0 to StrList.Count-1 do + if trim(StrList[i]) <> '' then + begin + Add; + IndexDefinition[Count-1].AsString := Trim(StrList[i]); + end; +end; + +procedure TBoldIndexCollection.SaveToFile(const FileName: String); +var + StrList: TStringLIst; +begin + StrList := TStringList.Create; + try + SaveToStringList(StrList); + StrList.SaveToFile(FileName); + finally + StrList.Free; + end; +end; + +procedure TBoldIndexCollection.SaveToStringList(StrList: TStringList); +var + i: integer; +begin + for i := 0 to Count-1 do + StrList.Add(IndexDefinition[i].AsString); +end; + +{ TBoldTypeNameMapping } + +function TBoldIndexDefintion.Equals(value: TBoldIndexDefintion): Boolean; +begin + result := (TableName = value.TableName) and (Columns = value.Columns) and + (Unique = value.Unique); + +end; + +function TBoldIndexDefintion.GetAsString: string; +begin + Result := Format('TableName=%s,Columns=%s', + [TableName, + Columns]); +end; + +function TBoldIndexDefintion.GetDisplayName: string; +begin + Result := Format('%s(%s)', [TableName, Columns]); + if Unique then + Result := Result + '[U]'; +end; + +procedure TBoldIndexDefintion.SetAsString(const Value: string); +begin + with TStringList.Create do + try + CommaText := value; + TableName := Values['TableName']; + Columns := Values['Columns']; + finally + Free; + end; +end; + +procedure TBoldIndexDefintion.AssignTo(Dest: TPersistent); +begin + if dest is TBoldIndexDefintion then + with dest as TBoldIndexDefintion do begin + TableName := self.TableName; + Columns := self.Columns; + Unique := self.Unique; + Remove := self.remove; + end + else + inherited; +end; + +end. diff --git a/Source/Common/Support/BoldIndexableList.pas b/Source/Common/Support/BoldIndexableList.pas index 5f1bc6bc..af475a40 100644 --- a/Source/Common/Support/BoldIndexableList.pas +++ b/Source/Common/Support/BoldIndexableList.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldIndexableList; interface @@ -5,7 +8,6 @@ interface uses Classes, BoldBase, - BoldContainers, BoldIndex; type @@ -14,7 +16,7 @@ TBoldIndexableList = class; TBoldUnOrderedIndexableList = class; TBoldIndexableListTraverser = class; TBoldIndexableListTraverserClass = class of TBoldIndexableListTraverser; - + TBoldIndexableListOptions = (iloOwnsEntries, iloDestroying, iloKnowsSupportsNil, iloSupportsNil); TBoldIndexableListOptionsSet = set of TBoldIndexableListOptions; @@ -22,40 +24,47 @@ TBoldIndexableListTraverser = class(TBoldMemoryManagedObject) private fIndexTraverser: TBoldIndexTraverser; fCurrentIndex: integer; + function GetAutoMoveOnRemoveCurrent: boolean; + procedure SetAutoMoveOnRemoveCurrent(const Value: boolean); protected - function GetItem: TObject; - function GetEol: Boolean; + function GetItem: TObject; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public constructor Create(IndexTraverser: TBoldIndexTraverser); destructor Destroy; override; - procedure Next; + function MoveNext: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} property Item: TObject read GetItem; - property EndOfList: Boolean read GetEol; property CurrentIndex: integer read fCurrentIndex; + property Current: TObject read GetItem; + property AutoMoveOnRemoveCurrent: boolean read GetAutoMoveOnRemoveCurrent write SetAutoMoveOnRemoveCurrent; end; {---TBoldUnOrderedIndexableList---} TBoldUnOrderedIndexableList = class(TBoldNonRefCountedObject) private - fIndexes: TList; + fIndexes: array of TBoldIndex; fOptions: TBoldIndexableListOptionsSet; - function GetCount: Integer; - function GetIndex(Index: Integer): TBoldIndex; - function GetIndexCount: Integer; + fFirstNilSupportingIndex: Integer; + function GetCount: Integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetIndex(Index: Integer): TBoldIndex; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetIndex(I: Integer; const Value: TBoldIndex); function GetAny: TObject; - function GetOwnsEntries: boolean; - procedure SetOwnsEntries(const Value: boolean); + function GetOwnsEntries: boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetOwnsEntries(const Value: boolean); {$IFDEF BOLD_INLINE} inline; {$ENDIF} function FirstNilSupportingIndex: TBoldIndex; function FirstAssignedIndex: TBoldIndex; - function GetKnowsSupportsNil: Boolean; - function GetSupportsNil: Boolean; - procedure SetKnowsSupportsNil(const Value: Boolean); - procedure SetSupportsNil(const Value: Boolean); - procedure CalculateSupportsNil; + function GetKnowsSupportsNil: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetSupportsNil: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetKnowsSupportsNil(const Value: Boolean); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetSupportsNil(const Value: Boolean); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure CalculateSupportsNil; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetAssignedIndexCount: integer; + function GetIndexCount: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetCapacity: integer; + procedure SetCapacity(const Value: integer); + function GetIsEmpty: boolean; protected + function GetDebugInfo: string; override; function AddIndex(BoldIndex: TBoldIndex): integer; procedure AddToAllIndexes(Item: TObject); procedure RemoveAndFreeIndex(var BoldIndex: TBoldIndex; DestroyObjects: Boolean); @@ -75,19 +84,23 @@ TBoldUnOrderedIndexableList = class(TBoldNonRefCountedObject) procedure ItemChanged(Item: TObject); procedure Remove(Item: TObject); function CreateTraverser: TBoldIndexableListTraverser; + function GetEnumerator: TBoldIndexableListTraverser; property Count: integer read GetCount; property Any: TObject read GetAny; property OwnsEntries: boolean read GetOwnsEntries write SetOwnsEntries; + property Capacity: integer read GetCapacity write SetCapacity; + property IsEmpty: boolean read GetIsEmpty; end; TBoldIndexableList = class(TBoldUnOrderedIndexableList) private fIndexIndex: TBoldIntegerIndex; - function GetItem(Index: integer): TObject; + function GetItem(Index: integer): TObject; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetItem(Index: integer; value: TObject); procedure AddToAllNonOrderedIndexes(item: TObject); procedure RemoveFromAllNonOrderedIndexes(item: TObject); - function GetUnorderedIndexCount: integer; + function GetUnorderedIndexCount: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure _DebugInfo(Index: Integer); protected property Items[I: Integer]: TObject read GetItem write SetItem; property UnorderedIndexCount: integer read GetUnorderedIndexCount; @@ -95,10 +108,12 @@ TBoldIndexableList = class(TBoldUnOrderedIndexableList) constructor Create; procedure Move(CurIndex, NewIndex: Integer); procedure RemoveByIndex(Index: Integer); - procedure Sort(Compare: TListSortCompare); + procedure Sort(Compare: TIntegerIndexSortCompare); procedure Exchange(Index1, Index2: integer); - function IndexOf(Item: TObject): integer; + function IndexOf(Item: TObject): integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure Insert(Index: Integer; Item: TObject); + function Includes(Item: TObject): boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure RemoveList(AList: TBoldIndexableList); end; @@ -107,13 +122,9 @@ procedure SetIndexVariable(var Index: integer; GivenPosition: integer); implementation uses - BoldCommonConst, SysUtils, BoldDefs; -const - DEFAULTINDEXCAPACITY = 1; - procedure SetIndexVariable(var Index: integer; GivenPosition: integer); begin assert((index = -1) or (index = GivenPosition), 'Erroneous index construction, please debug!'); @@ -121,9 +132,113 @@ procedure SetIndexVariable(var Index: integer; GivenPosition: integer); end; { TBoldUnOrderedIndexableList } + +function TBoldUnOrderedIndexableList.GetIndex(Index: Integer): TBoldIndex; +begin + Result := FIndexes[Index] +end; + +procedure TBoldUnOrderedIndexableList.SetSupportsNil(const Value: Boolean); +begin + if value then + Include(fOptions, iloSupportsNil) + else + Exclude(fOptions, iloSupportsNil); +end; + +function TBoldUnOrderedIndexableList.GetKnowsSupportsNil: Boolean; +begin + result := iloKnowsSupportsNil in fOptions; +end; + +procedure TBoldUnOrderedIndexableList.SetKnowsSupportsNil( + const Value: Boolean); +begin + if value then + Include(fOptions, iloKnowsSupportsNil) + else + Exclude(fOptions, iloKnowsSupportsNil); +end; + +function TBoldUnOrderedIndexableList.GetIndexCount: integer; +begin + Result := Length(fIndexes); +end; + +function TBoldUnOrderedIndexableList.GetIsEmpty: boolean; +begin + result := Count = 0; +end; + +function TBoldUnOrderedIndexableList.FirstNilSupportingIndex: TBoldIndex; +var + i: integer; +begin + if fFirstNilSupportingIndex > -1 then begin + result := Indexes[fFirstNilSupportingIndex]; + end else begin + result := nil; + for i := 0 to IndexCount-1 do + if Assigned(Indexes[i]) and Indexes[i].SupportsNilItems then + begin + result := Indexes[i]; + fFirstNilSupportingIndex := i; + break; + end; + end; +end; + +procedure TBoldUnOrderedIndexableList.CalculateSupportsNil; +begin + SupportsNil := FirstNilSupportingIndex <> nil; + KnowsSupportsNil := true; +end; + +function TBoldUnOrderedIndexableList.GetSupportsNil: Boolean; +begin + if not knowsSupportsNil then + CalculateSupportsNil; + result := iloSupportsNil in fOptions; +end; + +procedure TBoldIndexableList._DebugInfo(Index: Integer); +var + Info: string; + I: Integer; +begin + Info := Format('GetItem(%d): Self.Classname:%s Count:%d fIndexIndex.Count:%d SupportsNil:%s IndexCount:%d'#13#10, [Index, Classname, Count, fIndexIndex.Count, BoolToStr(SupportsNil, True), IndexCount]); + for i := 0 to IndexCount-1 do + if Assigned(Indexes[i]) then + Info := Info+Format('Indexes[%d] Classname:%s Count:%d SupportsNilItems:%s '#13#10, [I, Indexes[i].ClassName, Indexes[i].Count, BoolToStr(Indexes[i].SupportsNilItems, True)]) + else + Info := Info+Format('Indexes[%d] = nil '#13#10, [I]); +// asm nop; end; //Breakpoint here! +end; + +function TBoldIndexableList.GetItem(Index: integer): TObject; +begin + if (index < 0) or (index>=fIndexIndex.FastCount) then + raise EBold.CreateFmt('%s.GetItem: Index %d out of bounds, count is %d', [classname, Index, fIndexIndex.FastCount]);//_DebugInfo(Index); + Result := fIndexIndex.items[index]; +end; + +function TBoldUnOrderedIndexableList.GetOwnsEntries: boolean; +begin + result := iloOwnsEntries in fOptions; +end; + +procedure TBoldUnOrderedIndexableList.SetOwnsEntries(const Value: boolean); +begin + if value then + Include(fOptions, iloOwnsEntries) + else + Exclude(fOptions, iloOwnsEntries); +end; + constructor TBoldUnOrderedIndexableList.Create; begin inherited; + fFirstNilSupportingIndex := -1; OwnsEntries := True; SupportsNil := false; KnowsSupportsNil := true; @@ -147,11 +262,28 @@ destructor TBoldUnOrderedIndexableList.Destroy; dec(IndicesToGo); end; end; - - FreeAndNil(fIndexes); inherited; end; +function TBoldUnOrderedIndexableList.GetCapacity: integer; +var + i: integer; +begin + result := MaxInt; + for i := 0 to IndexCount - 1 do + if Assigned(Indexes[i]) and (Indexes[i].Capacity < result) then + result := Indexes[i].Capacity; +end; + +procedure TBoldUnOrderedIndexableList.SetCapacity(const Value: integer); +var + i: integer; +begin + for i := 0 to IndexCount - 1 do + if Assigned(Indexes[i]) then + Indexes[i].Capacity := Value; +end; + function TBoldUnOrderedIndexableList.GetCount: Integer; begin if IndexCount > 0 then @@ -165,30 +297,18 @@ function TBoldUnOrderedIndexableList.GetCount: Integer; Result := 0; end; - -function TBoldUnOrderedIndexableList.GetIndex(Index: Integer): TBoldIndex; -begin - if Assigned(fIndexes) then - Result := TBoldIndex(FIndexes[Index]) - else - Result := nil; -end; - -function TBoldUnOrderedIndexableList.GetIndexCount: Integer; +function TBoldUnOrderedIndexableList.GetDebugInfo: string; begin - if Assigned(fIndexes) then - Result := FIndexes.Count - else - Result := 0; + result := Format('%s.count=%d', [ClassName, count]); end; function TBoldUnOrderedIndexableList.AddIndex(BoldIndex: TBoldIndex): integer; var SourceIndex: TBoldIndex; begin - if not Assigned(fIndexes) then - SetIndexCapacity(DEFAULTINDEXCAPACITY); - Result := FIndexes.Add(BoldIndex); + Result := IndexCount; + SetLength(fIndexes, Result+1); + fIndexes[Result] := BoldIndex; if IndexCount > 1 then begin SourceIndex := FirstNilSupportingIndex; @@ -204,9 +324,11 @@ function TBoldUnOrderedIndexableList.AddIndex(BoldIndex: TBoldIndex): integer; end; procedure TBoldUnOrderedIndexableList.RemoveAndFreeIndex(var BoldIndex: TBoldIndex; DestroyObjects: Boolean); +var + i: Integer; begin if not (ilodestroying in fOptions) and (AssignedIndexCount = 1) then - raise EBold.CreateFmt(sCannotRemoveLastIndex, [classname]); + raise EBold.CreateFmt('%s.RemoveAndfreeIndex: Can not remove the last index unless during destruction', [classname]); if Assigned(BoldIndex) then begin if BoldIndex.SupportsNilItems then @@ -214,23 +336,27 @@ procedure TBoldUnOrderedIndexableList.RemoveAndFreeIndex(var BoldIndex: TBoldInd if DestroyObjects then BoldIndex.Clear(DestroyObjects); - fIndexes[fIndexes.IndexOf(BoldIndex)] := nil; + for i := 0 to IndexCount - 1 do + if fIndexes[i] = BoldIndex then + begin + fIndexes[i] := nil; + if i <= fFirstNilSupportingIndex then + fFirstNilSupportingIndex := -1; + break; + end; FreeAndNil(BoldIndex); end; end; procedure TBoldUnOrderedIndexableList.SetIndexCapacity(NewCapacity: integer); begin - if not Assigned(fIndexes) then - fIndexes := TList.Create; - fIndexes.Capacity := NewCapacity; + // No longer used end; procedure TBoldUnOrderedIndexableList.AddToAllIndexes(Item: TObject); var i: integer; begin - // ordered indexes must get nil-pointers too. for i := 0 to IndexCount-1 do if Assigned(Indexes[i]) then Indexes[i].Add(Item); @@ -247,9 +373,15 @@ procedure TBoldUnOrderedIndexableList.RemoveFromAllIndexes(Item: TObject); end; procedure TBoldUnOrderedIndexableList.Add(Item: TObject); + + procedure InternalRaise; + begin + raise EBold.CreateFmt('%s.Add(nil): This list does not support nil-pointers', [ClassName]); + end; + begin if not assigned(item) and not SupportsNil then - raise EBold.CreateFmt(sNilPointersNotSupported, [ClassName]); + InternalRaise; AddToAllIndexes(Item); end; @@ -276,8 +408,9 @@ procedure TBoldUnOrderedIndexableList.Clear; i: Integer; IndicesToGo: integer; begin + if count = 0 then + exit; IndicesToGo := AssignedIndexCount; - // if we own the entries, remove them with the last index to be removed. for i := 0 to IndexCount-1 do if assigned(Indexes[i]) then begin @@ -288,20 +421,20 @@ procedure TBoldUnOrderedIndexableList.Clear; procedure TBoldUnOrderedIndexableList.SetIndex(I: Integer; const Value: TBoldIndex); begin - if assigned(fIndexes) then + if value.Count <> 0 then + raise EBold.CreateFmt('%s.SetIndex: Can not set an index that is not empty (%s)', [ClassName, value.ClassName]); + if Assigned(fIndexes[i]) and TBoldIndex(fIndexes[i]).SupportsNilItems then + KnowsSupportsNil := false; + fIndexes[i] := Value; + if Value.SupportsNilItems then begin - if value.Count <> 0 then - raise EBold.CreateFmt(sCannotSetNonEmptyIndex, [ClassName, value.ClassName]); - fIndexes[i] := Value; - if Value.SupportsNilItems then - begin - SupportsNil := true; - KnowsSupportsNil := true; - end; - if AssignedIndexCount > 1 then - FirstAssignedIndex.FillEmptyIndex(Value); -// AddAllToIndex(Value); + SupportsNil := true; + KnowsSupportsNil := true; end; + if i >= fFirstNilSupportingIndex then + fFirstNilSupportingIndex := -1; + if AssignedIndexCount > 1 then + FirstAssignedIndex.FillEmptyIndex(Value); end; function TBoldUnOrderedIndexableList.GetAny: TObject; @@ -310,33 +443,16 @@ function TBoldUnOrderedIndexableList.GetAny: TObject; result := FirstAssignedIndex.Any else result := nil - -end; - -function TBoldUnOrderedIndexableList.GetOwnsEntries: boolean; -begin - result := iloOwnsEntries in fOptions; -end; - -procedure TBoldUnOrderedIndexableList.SetOwnsEntries(const Value: boolean); -begin - if value then - Include(fOptions, iloOwnsEntries) - else - Exclude(fOptions, iloOwnsEntries); end; { TBoldUnOrderedIndexableList } -function TBoldIndexableList.GetItem(Index: integer): TObject; -begin - Result := fIndexIndex.items[index]; -end; - procedure TBoldIndexableList.RemoveByIndex(Index: Integer); var Item: Tobject; begin + if (index < 0) or (index>=fIndexIndex.FastCount) then + raise EBold.CreateFmt('%s.RemoveByIndex: Index %d out of bounds, count is %d', [classname, Index, fIndexIndex.FastCount]);//_DebugInfo(Index); Item := fIndexIndex.Items[Index]; RemoveFromAllNonOrderedIndexes(Item); fIndexIndex.RemoveByIndex(Index); @@ -353,6 +469,10 @@ procedure TBoldIndexableList.SetItem(Index: integer; value: TObject); var temp: TObject; begin + if (index < 0) or (index>=fIndexIndex.FastCount) then + raise EBold.CreateFmt('%s.SetItem: Index %d out of bounds, count is %d', [classname, Index, fIndexIndex.FastCount]);//_DebugInfo(Index); + if Value = fIndexIndex.items[index] then + exit; RemoveFromAllNonOrderedIndexes(fIndexIndex.items[index]); if OwnsEntries then @@ -369,6 +489,8 @@ procedure TBoldIndexableList.SetItem(Index: integer; value: TObject); procedure TBoldIndexableList.Insert(Index: Integer; Item: TObject); begin + if (index < 0) or (index>fIndexIndex.FastCount) then + raise EBold.CreateFmt('%s.Insert: Index %d out of bounds, count is %d', [classname, Index, fIndexIndex.FastCount]);//_DebugInfo(Index); fIndexIndex.Insert(Index, Item); AddToAllNonOrderedIndexes(item); end; @@ -378,12 +500,17 @@ function TBoldIndexableList.IndexOf(Item: TObject): integer; result := fIndexIndex.IndexOf(Item); end; +function TBoldIndexableList.Includes(Item: TObject): boolean; +begin + result := IndexOf(Item) <> -1; +end; + procedure TBoldIndexableList.Exchange(Index1, Index2: integer); begin fIndexIndex.Exchange(Index1, Index2); end; -procedure TBoldIndexableList.Sort(Compare: TListSortCompare); +procedure TBoldIndexableList.Sort(Compare: TIntegerIndexSortCompare); begin fIndexIndex.Sort(Compare); end; @@ -415,6 +542,18 @@ procedure TBoldIndexableList.RemoveFromAllNonOrderedIndexes(item: TObject); Indexes[i].Remove(item); end; +procedure TBoldIndexableList.RemoveList(AList: TBoldIndexableList); +var + i,j: integer; +begin + for I := 0 to AList.Count - 1 do + begin + j := IndexOf(AList.Items[i]); + if j <> -1 then + self.RemoveByIndex(j); + end; +end; + function TBoldIndexableList.GetUnorderedIndexCount: integer; begin result := IndexCount-1; @@ -433,58 +572,14 @@ function TBoldUnOrderedIndexableList.CreateTraverser: TBoldIndexableListTraverse end; end; - -function TBoldUnOrderedIndexableList.TraverserClass: TBoldIndexableListTraverserClass; +function TBoldUnOrderedIndexableList.GetEnumerator: TBoldIndexableListTraverser; begin - result := TBoldIndexableListTraverser; + result := CreateTraverser; end; -function TBoldUnOrderedIndexableList.FirstNilSupportingIndex: TBoldIndex; -var - i: integer; -begin - result := nil; - for i := 0 to IndexCount-1 do - if Assigned(Indexes[i]) and Indexes[i].SupportsNilItems then - begin - result := Indexes[i]; - break; - end; -end; - -function TBoldUnOrderedIndexableList.GetKnowsSupportsNil: Boolean; -begin - result := iloKnowsSupportsNil in fOptions; -end; - -function TBoldUnOrderedIndexableList.GetSupportsNil: Boolean; -begin - if not KnowsSupportsNil then - CalculateSupportsNil; - result := iloSupportsNil in fOptions; -end; - -procedure TBoldUnOrderedIndexableList.SetKnowsSupportsNil( - const Value: Boolean); -begin - if value then - Include(fOptions, iloKnowsSupportsNil) - else - Exclude(fOptions, iloKnowsSupportsNil); -end; - -procedure TBoldUnOrderedIndexableList.SetSupportsNil(const Value: Boolean); -begin - if value then - Include(fOptions, iloSupportsNil) - else - Exclude(fOptions, iloSupportsNil); -end; - -procedure TBoldUnOrderedIndexableList.CalculateSupportsNil; +function TBoldUnOrderedIndexableList.TraverserClass: TBoldIndexableListTraverserClass; begin - SupportsNil := FirstNilSupportingIndex <> nil; - KnowsSupportsNil := true; + result := TBoldIndexableListTraverser; end; function TBoldUnOrderedIndexableList.GetAssignedIndexCount: integer; @@ -525,10 +620,15 @@ destructor TBoldIndexableListTraverser.Destroy; FreeAndNil(fIndexTraverser); end; +function TBoldIndexableListTraverser.GetAutoMoveOnRemoveCurrent: boolean; +begin + result := fIndexTraverser.AutoMoveOnRemoveCurrent; +end; -function TBoldIndexableListTraverser.GetEol: Boolean; +procedure TBoldIndexableListTraverser.SetAutoMoveOnRemoveCurrent( + const Value: boolean); begin - result := fIndexTraverser.EndOfList; + fIndexTraverser.AutoMoveOnRemoveCurrent := Value; end; function TBoldIndexableListTraverser.GetItem: TObject; @@ -536,10 +636,11 @@ function TBoldIndexableListTraverser.GetItem: TObject; result := fIndexTraverser.Item; end; -procedure TBoldIndexableListTraverser.Next; +function TBoldIndexableListTraverser.MoveNext: Boolean; begin - fIndexTraverser.Next; - Inc(fCurrentIndex); + result := fIndexTraverser.MoveNext; end; +initialization + end. diff --git a/Source/Common/Support/BoldIsoDateTime.pas b/Source/Common/Support/BoldIsoDateTime.pas index 884b86a5..e0dd6447 100644 --- a/Source/Common/Support/BoldIsoDateTime.pas +++ b/Source/Common/Support/BoldIsoDateTime.pas @@ -1,22 +1,43 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldIsoDateTime; interface uses - BoldDefs; + BoldDefs, + Controls; // for TDate + +function ParseISODate(const s: string): TDateTime; +function ParseISODateTime(const s: string): TDateTime; +function ParseISOTime(const str: string): TDateTime; + +function AsISODateTime(d: TDateTime): string; +function AsISODate(d: TDate): string; +function AsISOTime(t: TTime): string; -function ParseISODate(s: string): TDateTime; -function ParseISODateTime(s: string): TDateTime; -function ParseISOTime(str: string): TDateTime; +function AsISODateTimeMS(d: TDateTime): string; +function AsISOTimeMS(t: TTime): string; + +const + cIsoDateFormat = 'yyyy-mm-dd'; + cIsoTimeFormat = 'hh:mm:ss'; + cIsoTimeFormatMS = 'hh:mm:ss:zzz'; + cIsoDateTimeSeparator = 'T'; + cIsoDateTimeFormat = cIsoDateFormat + '"' + cIsoDateTimeSeparator + '"' + cIsoTimeFormat; // '2018-12-31T11:50:00'; + cIsoDateTimeFormatMS = cIsoDateFormat + '"' + cIsoDateTimeSeparator + '"' + cIsoTimeFormatMS; // '2018-12-31T11:50:00:123'; implementation uses SysUtils, - BoldUtils, - BoldSupportConst; + BoldUtils; + +var + FormatSettings: TFormatSettings; -function MatchPattern(pattern, s: string): boolean; +function MatchPattern(const pattern, s: string): boolean; var i: integer; begin @@ -24,12 +45,12 @@ function MatchPattern(pattern, s: string): boolean; if result then for i := 1 to length(pattern) do case pattern[i] of - '#': result := result and (s[i] in ['0'..'9']); + '#': result := result and CharInSet(s[i], ['0'..'9']); else result := result and (s[i] = pattern[i]); end; end; -function ParseISODate(s: string): TDateTime; +function ParseISODate(const s: string): TDateTime; var y, m, d: integer; const @@ -37,44 +58,81 @@ function ParseISODate(s: string): TDateTime; 31, 31, 30, 31, 30, 31); begin if not MatchPattern('####-##-##', s) then - raise EBold.CreateFmt(sInvalidDateFormatFormat, [s]); + raise EBold.CreateFmt('ParseISODate: Invalid date format %s. Should be YYYY-MM-DD', [s]); y := StrToInt(copy(s, 1, 4)); m := StrToInt(copy(s, 6, 2)); if m > 12 then - raise EBold.CreateFmt(sInnvalidDateFormatLargeMonth, [s]); + raise EBold.CreateFmt('ParseISODate: Invalid date format %s. month > 12', [s]); if m < 1 then - raise EBold.CreateFmt(sInvalidDateFormatSmallMonth, [s]); + raise EBold.CreateFmt('ParseISODate: Invalid date format %s. month < 1', [s]); d := StrToInt(copy(s, 9, 2)); if d < 1 then - raise EBold.CreateFmt(sInvalidDateFormatSmallDay, [s]); + raise EBold.CreateFmt('ParseISODate: Invalid date format %s. date < 1', [s]); if d > dayspermonth[m] then - raise EBold.CreateFmt(sInvalidDateFormatBadDay, [s, daysPerMonth[m], m]); + raise EBold.CreateFmt('ParseISODate: Invalid date format %s. there is only %d days in month %d', [s, daysPerMonth[m], m]); result := EncodeDate(y, m, d); end; -function ParseISODateTime(s: string): TDateTime; +function ParseISODateTime(const s: string): TDateTime; begin - if not matchPattern('####-##-## ##:##', s) and not matchPattern('####-##-## ##:##:##', s) then - raise EBold.CreateFmt(sInvalidDateTimeFormat, [s]); - result := ParseIsoDate(copy(s, 1, 10)) + ParseIsoTime(copy(s, 12, 8)); + if not matchPattern('####-##-## ##:##', s) + and not matchPattern('####-##-## ##:##:##', s) + and not matchPattern('####-##-## ##:##:##:###', s) + and not matchPattern('####-##-##T##:##:##:###', s) then + raise EBold.CreateFmt('ParseISODateTime: Invalid datatime format %s. Should be YYYY-MM-DD HH:MM[:SS][:ZZZ]', [s]); + result := ParseIsoDate(copy(s, 1, 10)) + ParseIsoTime(copy(s, 12, MaxInt)); end; -function ParseISOTime(str: string): TDateTime; +function ParseISOTime(const str: string): TDateTime; var - h, m, s: integer; + h, m, s, z: integer; begin - if not MatchPattern('##:##:##', str) and not MatchPattern('##:##', str) then - raise EBold.CreateFmt(sInvalidTimeFormat, [str]); + if not MatchPattern('##:##:##:###', str) + and not MatchPattern('##:##:##.###', str) + and not MatchPattern('##:##:##', str) + and not MatchPattern('##:##', str) then + raise EBold.CreateFmt('ParseISOTime: Invalid time format %s. Should be HH:MM[:SS:ZZZ]', [str]); h := StrToInt(copy(str, 1, 2)); if h > 23 then - raise EBold.CreateFmt(sInvalidTimeFormatLargeHour, [str]); + raise EBold.CreateFmt('ParseISODate: Invalid date format %s. h > 23', [str]); m := StrToInt(copy(str, 4, 2)); if m > 59 then - raise EBold.CreateFmt(sInvalidTimeFormatLargeMinute, [str]); + raise EBold.CreateFmt('ParseISODate: Invalid date format %s. m > 59', [str]); s := StrToInt(copy(str, 7, 2)); if s > 59 then - raise EBold.CreateFmt(sInvalidTimeFormatLargeSecond, [str]); - result := EncodeTime(h, m, s, 0); + raise EBold.CreateFmt('ParseISODate: Invalid date format %s. s > 59', [str]); + z := StrToIntDef(copy(str, 10, 3),0); + result := EncodeTime(h, m, s, z); +end; + +function AsISODateTime(d: TDateTime): string; +begin + result := formatDateTime(cIsoDateTimeFormat, d, FormatSettings); end; +function AsISODate(d: TDate): string; +begin + result := formatDateTime(cIsoDateFormat, d, FormatSettings); +end; + +function AsISOTime(t: TTime): string; +begin + result := formatDateTime(cIsoTimeFormat, t, FormatSettings); +end; + +function AsISODateTimeMS(d: TDateTime): string; +begin + result := formatDateTime(cIsoDateTimeFormatMS, d, FormatSettings); +end; + +function AsISOTimeMS(t: TTime): string; +begin + result := formatDateTime(cIsoTimeFormatMS, t, FormatSettings); +end; + +initialization + FormatSettings := TFormatSettings.Create; + FormatSettings.DateSeparator := '-'; + FormatSettings.TimeSeparator := ':' + end. diff --git a/Source/Common/Support/BoldLoggableCriticalSection.pas b/Source/Common/Support/BoldLoggableCriticalSection.pas index 22034a45..e50dffdb 100644 --- a/Source/Common/Support/BoldLoggableCriticalSection.pas +++ b/Source/Common/Support/BoldLoggableCriticalSection.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLoggableCriticalSection; interface @@ -6,11 +9,8 @@ interface SyncObjs, BoldThreadSafeLog; -type - { forward declarations } - TBoldLoggableCriticalSection = class; - { TBoldLoggableCriticalSection } +type TBoldLoggableCriticalSection = class(TCriticalSection) private fName: String; @@ -21,7 +21,6 @@ TBoldLoggableCriticalSection = class(TCriticalSection) end; implementation - uses SysUtils; @@ -29,7 +28,7 @@ implementation procedure TBoldLoggableCriticalSection.Acquire; begin - BoldLogThread('L='+fName); // do not localize + BoldLogThread('L='+fName); inherited; end; @@ -42,7 +41,7 @@ constructor TBoldLoggableCriticalSection.Create(name: string); procedure TBoldLoggableCriticalSection.Release; begin inherited; - BoldLogThread('U=' + fName); // do not localize + BoldLogThread('U=' + fName); end; end. diff --git a/Source/Common/Support/BoldMath.pas b/Source/Common/Support/BoldMath.pas index b689d7f9..e2f3af85 100644 --- a/Source/Common/Support/BoldMath.pas +++ b/Source/Common/Support/BoldMath.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldMath; interface @@ -11,8 +14,7 @@ function MinIntValue(const Data: array of Integer): Integer; implementation uses - SysUtils, - BoldUtils; + BoldRev; function Floor(X: Extended): Integer; begin @@ -62,4 +64,6 @@ function MinIntValue(const Data: array of Integer): Integer; Result := Data[I]; end; +initialization + end. diff --git a/Source/Common/Support/BoldMemoryManager.pas b/Source/Common/Support/BoldMemoryManager.pas index 2ff6aeec..52ffa3ab 100644 --- a/Source/Common/Support/BoldMemoryManager.pas +++ b/Source/Common/Support/BoldMemoryManager.pas @@ -1,3 +1,7 @@ +///////////////////////////////////////////////////////// + +{ Global compiler directives } +{$include bold.inc} unit BoldMemoryManager; interface @@ -32,10 +36,13 @@ class function T.NewInstance: TObject; ---------------------------------------------------------------------*) -{.$DEFINE DEBUG} +{.$DEFINE DEBUG_BOLDMEMORYMANAGER} +// Define this conditional, if your application maybe uses only one thread. +// Normaly every application is multithreaded and the check is waste. +{.$DEFINE CHECK_ISMULTITHREAD} uses - {$IFDEF DEBUG} + {$IFDEF DEBUG_BOLDMEMORYMANAGER} // Dialogs, {$ENDIF} BoldDefs, @@ -43,13 +50,27 @@ class function T.NewInstance: TObject; Classes; const - BoldMemoryManagerPageSize = 256; + BoldMemoryManagerPageSize = 2048; BoldMemoryManagerLSBZero = 2; {//} BoldMemoryManagerLSBFactor = (1 shl BoldMemoryManagerLSBZero); BoldMemoryManagerMaxPage = 16; // memoryblocks with 4*MaxPage will be handled, must be power of 2 {//} BoldMemoryManagerMask = ((1 shl BoldMemoryManagerLSBZero)-1) or (not Cardinal((BoldMemoryManagerMaxPage shl BoldMemoryManagerLSBZero)-1)); // mask for quick test of allowed size +// Temporarly moved from BoldCommonConst + sMemoryManagerCalledInFinalization = 'Attempt to allocate with BoldMemoryManager during finalization'; + sMemoryManagerDestroyed = 'MemoryManager destroyed'; + sMemMgrSize = 'Size: %3d InUse: %10d(%4.0f%%) Free: %10d'; + sMemMgrAllocated = 'Allocated'; + sMemMgrInUse = 'InUse'; + sMemMgrOverHead = 'Overhead'; + sMemMgrDisabled = 'The Bold Memorymanager has been disabled. '; + sMemMgrDisabledReason = '(caused by compilerdirective BOLD_DISABLEMEMORYMANAGER)'; + sMemMgrTotalBigBlocks = 'Total Big blks'; + sMemMgrBigBlockCount = 'Big block count'; + sMemMgrNonBold = 'Non-Bold'; + sMemMgrNonBoldCount = 'Non-Bold Count'; + type { forward declarations } TBoldMemoryManager = class; @@ -71,13 +92,13 @@ TBoldMemoryManager = class fBigBlockCount: integer; fCriticalSection: TCriticalSection; {$IFNDEF BOLD_DISABLEMEMORYMANAGER} - procedure AllocateNewPage(Size, PageNum: integer); + procedure AllocateNewPage(Size: integer); procedure GarbageCollectPage(PageNum: integer; Page: Pointer; PageSize: integer); procedure LinkIn(var Chain: Pointer; Item: POinter); function LinkOut(var Chain: Pointer): Pointer; {$ENDIF} function GetAllocated: integer; - function GetMemoryInfo: String; + function GetMemoryInfo: string; function GetOverhead: integer; function GetInUse: integer; function GetAllocatedPages: integer; @@ -106,10 +127,9 @@ function BoldMemoryManager_: TBoldMemoryManager; implementation uses - SysUtils, - BoldCommonConst; + SysUtils, Types; -{$IFDEF DEBUG} +{$IFDEF DEBUG_BOLDMEMORYMANAGER} const LOGFILE: string = 'c:\temp\BoldMemoryManager.Log'; @@ -120,7 +140,7 @@ implementation procedure Log(const Str: String); begin - {$IFDEF DEBUG} + {$IFDEF DEBUG_BOLDMEMORYMANAGER} if not assigned(Strl) then begin strl := TStringList.Create; @@ -144,20 +164,18 @@ procedure Log(const Str: String); procedure DestroyIfEmpty; begin - if Assigned(G_BoldMemoryManager) and (G_BoldMemoryManager.InUse = 0) then - FreeAndNil(G_BoldMemoryManager); + if Assigned(G_BoldMemoryManager) and (G_BoldMemoryManager.InUse = 0) then + FreeAndNil(G_BoldMemoryManager); end; function BoldMemoryManager_: TBoldMemoryManager; begin - Result := G_BoldMemoryManager; - if not assigned(Result) then - begin + if G_BoldMemoryManager = nil then begin if Finalized then raise EBold.Create(sMemoryManagerCalledInFinalization); - Result := TBoldMemoryManager.Create; - G_BoldMemoryManager := Result; + G_BoldMemoryManager := TBoldMemoryManager.Create; end; + Result := G_BoldMemoryManager; end; @@ -176,7 +194,7 @@ function TBoldMemoryManager.LinkOut(var Chain: Pointer): Pointer; Chain := Pointer(result^); end; -procedure TBoldMemoryManager.AllocateNewPage(Size, PageNum: integer); +procedure TBoldMemoryManager.AllocateNewPage(Size: integer); var i: integer; Page: ^TPage; @@ -186,7 +204,7 @@ procedure TBoldMemoryManager.AllocateNewPage(Size, PageNum: integer); Pages.Add(Page); PageSizes.Add(Pointer(Size * BoldMemoryManagerPageSize)); SizeInWords := Size shr BoldMemoryManagerLSBZero; - {$IFDEF DEBUG} + {$IFDEF DEBUG_BOLDMEMORYMANAGER} FillChar(Page^, Size * BoldMemoryManagerPageSize, 0); {$ENDIF} for i := 0 to BoldMemoryManagerPageSize-2 do @@ -195,9 +213,9 @@ procedure TBoldMemoryManager.AllocateNewPage(Size, PageNum: integer); end; Page^[(BoldMemoryManagerPageSize-1) * sizeInWords] := nil; - FreePointers[PageNum] := Page; + FreePointers[Size] := Page; - Inc(TotalAllocated[Pagenum], BoldMemoryManagerPageSize); + Inc(TotalAllocated[Size], BoldMemoryManagerPageSize); end; procedure TBoldMemoryManager.GarbageCollectPage(PageNum: integer; Page: Pointer; PageSize: integer); @@ -244,12 +262,16 @@ function TBoldMemoryManager.GetOverhead: integer; var i: integer; begin + {$IFDEF CHECK_ISMULTITHREAD} if (IsMultiThread) then + {$ENDIF} fCriticalSection.Acquire; result := 0; for i := Low(TotalAllocated) to High(TotalAllocated) do result := result + (TotalAllocated[i] - CurrentInUse[i]) * i; + {$IFDEF CHECK_ISMULTITHREAD} if (IsMultiThread) then + {$ENDIF} fCriticalSection.Leave; end; @@ -257,12 +279,16 @@ function TBoldMemoryManager.GetInUse: integer; var i: integer; begin + {$IFDEF CHECK_ISMULTITHREAD} if (IsMultiThread) then + {$ENDIF} fCriticalSection.Acquire; result := 0; for i := Low(CurrentInUse) to High(CurrentInUse) do result := result + CurrentInUse[i] * i; + {$IFDEF CHECK_ISMULTITHREAD} if (IsMultiThread) then + {$ENDIF} fCriticalSection.Leave; end; @@ -277,7 +303,9 @@ function TBoldMemoryManager.AllocateMemory(Size: integer): Pointer; INC(fBigBlockCount); {$ELSE} // Note, ordering and code repetition intentional, to give best operaion pairing. + {$IFDEF CHECK_ISMULTITHREAD} if (IsMultiThread) then + {$ENDIF} fCriticalSection.Acquire; if ((Size and BoldMemoryManagerMask) = 0) then begin @@ -289,11 +317,11 @@ function TBoldMemoryManager.AllocateMemory(Size: integer): Pointer; if assigned(result) then begin Inc(CurrentInUse[Size]); - FreePointers[Size] := Pointer(result^); + FreePointers[Size] := Pointer(result^); end else begin - AllocateNewPage(Size, Size); + AllocateNewPage(Size); result := FreePointers[Size]; Inc(CurrentInUse[Size]); FreePointers[Size] := Pointer(result^); @@ -302,11 +330,15 @@ function TBoldMemoryManager.AllocateMemory(Size: integer): Pointer; end else begin + {$IFDEF DEBUG_BOLDMEMORYMANAGER} BytesInBigBlocks := BytesInBigBlocks + size; INC(fBigBlockCount); + {$ENDIF} getMem(result, Size); end; + {$IFDEF CHECK_ISMULTITHREAD} if (IsMultiThread) then + {$ENDIF} fCriticalSection.Leave; {$ENDIF} end; @@ -319,7 +351,9 @@ procedure TBoldMemoryManager.DeAllocateMemory(Ptr: Pointer; Size: integer); if fBigBlockCount = 0 then FreeAndNil(G_BoldMemoryManager); {$ELSE} + {$IFDEF CHECK_ISMULTITHREAD} if (IsMultiThread) then + {$ENDIF} fCriticalSection.Acquire; if ((Size and BoldMemoryManagerMask) = 0) then begin @@ -335,11 +369,15 @@ procedure TBoldMemoryManager.DeAllocateMemory(Ptr: Pointer; Size: integer); end else begin + {$IFDEF DEBUG_BOLDMEMORYMANAGER} BytesInBigBlocks := BytesInBigBlocks - size; DEC(fBigBlockCount); + {$ENDIF} Freemem(Ptr, size); end; + {$IFDEF CHECK_ISMULTITHREAD} if (IsMultiThread) then + {$ENDIF} fCriticalSection.Leave {$ENDIF} end; @@ -351,7 +389,9 @@ procedure TBoldMemoryManager.GarbageCollect; {$ENDIF} begin {$IFNDEF BOLD_DISABLEMEMORYMANAGER} + {$IFDEF CHECK_ISMULTITHREAD} if (IsMultiThread) then + {$ENDIF} fCriticalSection.Acquire; for PageNum := Low(TotalAllocated) to High(TotalAllocated) do begin @@ -366,7 +406,9 @@ procedure TBoldMemoryManager.GarbageCollect; end; end; end; + {$IFDEF CHECK_ISMULTITHREAD} if (IsMultiThread) then + {$ENDIF} fCriticalSection.Leave; {$ENDIF} end; @@ -382,7 +424,9 @@ constructor TBoldMemoryManager.Create; destructor TBoldMemoryManager.Destroy; begin + {$IFDEF CHECK_ISMULTITHREAD} if (IsMultiThread) then + {$ENDIF} fCriticalSection.Acquire; while pages.Count > 0 do begin @@ -391,45 +435,73 @@ destructor TBoldMemoryManager.Destroy; end; FreeAndNil(fPages); FreeAndNil(fPageSizes); + {$IFDEF CHECK_ISMULTITHREAD} if (IsMultiThread) then + {$ENDIF} fCriticalSection.Leave; FreeAndNil(fCriticalSection); Log(sMemoryManagerDestroyed); inherited; end; -function TBoldMemoryManager.GetMemoryInfo: String; +function TBoldMemoryManager.GetMemoryInfo: string; {$IFNDEF BOLD_DISABLEMEMORYMANAGER} var - PageNum: integer; + PageNum: Integer; + AllocMemSize, AllocMemCount: Integer; + {$IFDEF BOLD_DELPHI10_OR_LATER} + MemMgrState: TMemoryManagerState; + I: Integer; + {$ENDIF} {$ENDIF} begin - result := ''; + Result := ''; {$IFDEF BOLD_DISABLEMEMORYMANAGER} - result := sMemMgrDisabled + BOLDCRLF + + Result := sMemMgrDisabled + BOLDCRLF + sMemMgrDisabledReason; {$ELSE} + {$IFDEF CHECK_ISMULTITHREAD} if (IsMultiThread) then + {$ENDIF} fCriticalSection.Acquire; - for PageNum := Low(TotalAllocated) to High(TotalAllocated) do - if TotalAllocated[PageNum] <> 0 then - begin - result := result + format(sMemMgrSize, [PageNum, CurrentInUse[PageNum], - (CurrentInUse[PageNum]*100.0*PageNum)/InUse, - TotalAllocated[PageNum] - CurrentInUse[PageNum]]) + BOLDCRLF; + try + for PageNum := Low(TotalAllocated) to High(TotalAllocated) do begin + if TotalAllocated[PageNum] <> 0 then begin + Result := Result + Format(sMemMgrSize, [PageNum, CurrentInUse[PageNum], + (CurrentInUse[PageNum]*100.0*PageNum)/InUse, + TotalAllocated[PageNum] - CurrentInUse[PageNum]]) + BOLDCRLF; + end; end; - result := result + format('%-15s: %7dkb (%10d bytes)', [sMemMgrAllocated, allocated DIV 1024, Allocated]) + BOLDCRLF; // do not localize - result := result + format('%-15s: %7dkb (%10d bytes)', [sMemMgrInUse, InUse DIV 1024, InUse]) + BOLDCRLF; // do not localize - result := result + format('%-15s: %7dkb (%10d bytes)', [sMemMgrOverHead, overhead DIV 1024, overhead]) + BOLDCRLF; // do not localize - if BigBlockCount > 0 then - begin - result := result + format('%-15s: %7dkb (%10d bytes)', [sMemMgrTotalBigBlocks, bytesinbigblocks DIV 1024, bytesinbigblocks]) + BOLDCRLF; // do not localize - result := result + format('%-15s: %7d (%10d bytes)', [sMemMgrBigBlockCount, BigBlockCount, bytesinbigblocks DIV BigBlockCount]) + BOLDCRLF; // do not localize - result := result + format('%-15s: %7dkb (%10d bytes)', [sMemMgrNonBold, (AllocMemSize - allocated-bytesinbigblocks)DIV 1024, (AllocMemSize - allocated-bytesinbigblocks)]) + BOLDCRLF; // do not localize - result := result + format('%-15s: %7d (%10d bytes)', [sMemMgrNonBoldCount, AllocMemCount-BigBlockCount-AllocatedPages, (AllocMemSize - allocated - bytesinbigblocks) DIV (AllocMemCount-BigBlockCount-AllocatedPages)]) + BOLDCRLF; // do not localize + Result := Result + Format('%-15s: %7dkb (%10d bytes)', [sMemMgrAllocated, allocated DIV 1024, Allocated]) + BOLDCRLF; // do not localize + Result := Result + Format('%-15s: %7dkb (%10d bytes)', [sMemMgrInUse, InUse DIV 1024, InUse]) + BOLDCRLF; // do not localize + Result := Result + Format('%-15s: %7dkb (%10d bytes)', [sMemMgrOverHead, overhead DIV 1024, overhead]) + BOLDCRLF; // do not localize + if BigBlockCount > 0 then begin + {$IFDEF BOLD_DELPHI10_OR_LATER} + GetMemoryManagerState(MemMgrState); + AllocMemSize := MemMgrState.TotalAllocatedMediumBlockSize + + MemMgrState.TotalAllocatedLargeBlockSize; + AllocMemCount := MemMgrState.AllocatedMediumBlockCount + + MemMgrState.AllocatedLargeBlockCount; + for I := 0 to High(MemMgrState.SmallBlockTypeStates) do begin + Inc(AllocMemSize, MemMgrState.SmallBlockTypeStates[I].InternalBlockSize + + MemMgrState.SmallBlockTypeStates[I].UseableBlockSize); + Inc(AllocMemCount, MemMgrState.SmallBlockTypeStates[I].AllocatedBlockCount); + end; + {$ELSE} + AllocMemSize := System.AllocMemSize; + AllocMemCount := System.AllocMemCount; + {$ENDIF} + Result := Result + Format('%-15s: %7dkb (%10d bytes)', [sMemMgrTotalBigBlocks, bytesinbigblocks DIV 1024, bytesinbigblocks]) + BOLDCRLF; // do not localize + Result := Result + Format('%-15s: %7d (%10d bytes)', [sMemMgrBigBlockCount, BigBlockCount, bytesinbigblocks DIV BigBlockCount]) + BOLDCRLF; // do not localize + Result := Result + Format('%-15s: %7dkb (%10d bytes)', [sMemMgrNonBold, (AllocMemSize - allocated-bytesinbigblocks)DIV 1024, (AllocMemSize - allocated-bytesinbigblocks)]) + BOLDCRLF; // do not localize + Result := Result + Format('%-15s: %7d (%10d bytes)', [sMemMgrNonBoldCount, AllocMemCount-BigBlockCount-AllocatedPages, (AllocMemSize - allocated - bytesinbigblocks) DIV (AllocMemCount-BigBlockCount-AllocatedPages)]) + BOLDCRLF; // do not localize + end; + finally + {$IFDEF CHECK_ISMULTITHREAD} + if (IsMultiThread) then + {$ENDIF} + fCriticalSection.Leave; end; - if (IsMultiThread) then - fCriticalSection.Leave; {$ENDIF} end; @@ -440,10 +512,14 @@ function TBoldMemoryManager.GetAllocated: integer; function TBoldMemoryManager.GetAllocatedPages: integer; begin + {$IFDEF CHECK_ISMULTITHREAD} if (IsMultiThread) then + {$ENDIF} fCriticalSection.Acquire; Result :=Pages.count; + {$IFDEF CHECK_ISMULTITHREAD} if (IsMultiThread) then + {$ENDIF} fCriticalSection.Leave; end; @@ -458,7 +534,7 @@ function TBoldMemoryManager.ReallocateMemoryZeroFill(Ptr: Pointer; OldSize: inte if NewSize > OldSize then begin Move(Ptr^, Result^, OldSize); - FillChar((Pchar(Result)+Oldsize)^, NewSize-OldSize, 0); + FillChar((PAnsiChar(Result)+Oldsize)^, NewSize-OldSize, 0); end else // NewSize < Oldize Move(Ptr^ , Result^, NewSize); @@ -476,6 +552,7 @@ initialization finalization Finalized := True; DestroyIfEmpty; +{$IFDEF DEBUG_BOLDMEMORYMANAGER} + FreeAndNil(strl); +{$ENDIF} end. - - diff --git a/Source/Common/Support/BoldNamedValueList.pas b/Source/Common/Support/BoldNamedValueList.pas index 54b24874..52b6cfe4 100644 --- a/Source/Common/Support/BoldNamedValueList.pas +++ b/Source/Common/Support/BoldNamedValueList.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldNamedValueList; interface @@ -6,7 +9,8 @@ interface Classes, BoldBase, BoldIndexableList, - BoldIndex; + BoldIndex, + BoldHashIndexes; type TBoldNamedValueListEntry = class(TBoldMemoryManagedObject) @@ -23,8 +27,9 @@ TBoldNamedValueListEntry = class(TBoldMemoryManagedObject) TBoldNamedValueList = class(TBoldIndexableList) private + class var IX_Name: integer; function GetItem(index: Integer): TBoldNamedValueListEntry; - function GetItemByName(const Name: string): TBoldNamedValueListEntry; + function GetItemByName(const Name: string): TBoldNamedValueListEntry; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetCommaText(const CommaText: string); function GetCommaText: string; function GetValueByname(const Name: string): string; @@ -35,7 +40,7 @@ TBoldNamedValueList = class(TBoldIndexableList) constructor Create; procedure AddFromStrings(strings: TStrings); procedure AddToStrings(strings: TStrings); - procedure AddEntry(Name, Value: string; aObject: TObject = nil); + function AddEntry(const Name, Value: string; aObject: TObject = nil): TBoldNamedValueListEntry; procedure RemoveName(const Name: String); property Items[index: Integer]: TBoldNamedValueListEntry read GetItem; default; property ItemByName[const Name: string]: TBoldNamedValueListEntry read GetItemByName; @@ -49,14 +54,8 @@ TBoldNamedValueList = class(TBoldIndexableList) implementation uses - SysUtils, - BoldUtils, - BoldHashIndexes; - -var - IX_Name: integer = -1; + BoldRev; - {---TNameIndex---} type TNameIndex = class(TBoldCaseSensitiveStringHashIndex) protected @@ -70,10 +69,10 @@ function TNameIndex.ItemAsKeyString(Item: TObject): string; { TBoldStringDictionary } -procedure TBoldNamedValueList.AddEntry(Name, Value: string; - aObject: TObject); +function TBoldNamedValueList.AddEntry(const Name, Value: string; aObject: TObject): TBoldNamedValueListEntry; begin - Add(TBoldNamedValueListEntry.Create(Name, Value, aObject)); + result := TBoldNamedValueListEntry.Create(Name, Value, aObject); + Add(result); end; procedure TBoldNamedValueList.AddFromStrings(strings: TStrings); @@ -109,7 +108,7 @@ function TBoldNamedValueList.GetCommaText: string; try AddToStrings(StringList); Result := StringList.CommaText; - finally + finally Stringlist.Free; end; end; @@ -123,7 +122,7 @@ function TBoldNamedValueList.GetItem( function TBoldNamedValueList.GetItemByName( const Name: string): TBoldNamedValueListEntry; begin - Result := TBoldNamedValueListEntry(TNameIndex(Indexes[IX_Name]).FindByString(Name)); + Result := TBoldNamedValueListEntry(TBoldCaseSensitiveStringHashIndex(Indexes[IX_Name]).FindByString(Name)); end; @@ -205,4 +204,7 @@ procedure TBoldNamedValueList.SetValueByname(const Name, NewValue: string); AddEntry(Name, NewValue); end; +initialization + TBoldNamedValueList.IX_Name := -1; + end. diff --git a/Source/Common/Support/BoldNavigatorDefs.pas b/Source/Common/Support/BoldNavigatorDefs.pas index dab6319d..0dfb96cd 100644 --- a/Source/Common/Support/BoldNavigatorDefs.pas +++ b/Source/Common/Support/BoldNavigatorDefs.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldNavigatorDefs; interface @@ -28,7 +31,8 @@ TBoldNavigateBtnImageIndexOwner = class(TCustomPanel) property FocusedButton: TBoldNavigateBtn read fFocusedButton write fFocusedButton; end; - { TBoldNavigateBtnImageIndex } + + { TBoldNavigateBtnImageIndex } TBoldNavigateBtnImageIndex = class(TPersistent) private FnbNext: integer; @@ -49,8 +53,8 @@ TBoldNavigateBtnImageIndex = class(TPersistent) procedure SetnbMoveUp(const Value: integer); procedure SetnbMoveDown(const Value: integer); public - constructor Create(Owner: TBoldNavigateBtnImageIndexOwner); - procedure Assign(Source: TPersistent); override; + constructor create(Owner: TBoldNavigateBtnImageIndexOwner); + procedure assign(Source: TPersistent); override; published property nbFirst: integer read FnbFirst write SetnbFirst; property nbPrior: integer read FnbPrior write SetnbPrior; @@ -84,7 +88,7 @@ implementation uses SysUtils, - BoldUtils; + BoldRev; const InitRepeatPause = 400; { pause before repeat timer (ms)} @@ -226,4 +230,6 @@ procedure TBoldNavButton.Paint; end; end; + + end. diff --git a/Source/Common/Support/BoldPerformanceCounter.pas b/Source/Common/Support/BoldPerformanceCounter.pas index 07c0e7cc..fb69dc68 100644 --- a/Source/Common/Support/BoldPerformanceCounter.pas +++ b/Source/Common/Support/BoldPerformanceCounter.pas @@ -1,13 +1,14 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPerformanceCounter; interface -// ------------------------------------ -// this unit was originally by OpenInfo, Hasse&Egil -// ------------------------------------ - uses + {$IFDEF MSWINDOWS} Windows, + {$ENDIF} Classes, BoldDefs; @@ -18,38 +19,100 @@ TBoldPerformanceCounter = class; TLargeInteger = longint; {$ENDIF} TBoldPerformanceCounterState = (bpcsStopped, bpcsStarted); + TBoldPerformanceCounterClass = class of TBoldPerformanceCounter; + + TBoldPerformanceData = record + private + fAccumulatedTime: TLargeInteger; + fLastCallTime: Int64; + fStart: TLargeInteger; + fCalls: Int64; + fKernelTime, fUserTime: TFileTime; + fAccumulatedCPUTime: TDateTime; + fLastCallCpuTime: TDateTime; + function GetLastCallSeconds: double; + function GetLastCallAsString: string; + function GetAccumulatedTime: TDateTime; + function GetSeconds: double; + public + procedure Clear; + property LastCallSeconds: double read GetLastCallSeconds; + property LastCallAsString: string read GetLastCallAsString; +// property Calls: Int64 read fCalls; + property AccumulatedTime: TDateTime read GetAccumulatedTime; + property LastCallCpuTime: TDateTime read fLastCallCpuTime; + property AccumulatedCpuTime: TDateTime read fAccumulatedCPUTime; + property Seconds: Double read GetSeconds; + end; { TBoldPerformanceCounter } TBoldPerformanceCounter = class private + fOwnData: TBoldPerformanceData; + fChildrenData: TBoldPerformanceData; fNumberOfChildrenRunning: integer; - fChildren: TStringList; + fChildren: TList; fOwner: TBoldPerformanceCounter; fName: String; - fAccumulatedTime: TLargeInteger; - fStart: TLargeInteger; - fCalls: integer; + fTag: integer; // for user convenience + fActive: boolean; function GetChildren(index: integer): TBoldPerformanceCounter; - function GetChildByName(Name: String): TBoldPerformanceCounter; + function GetChildByName(const AName: String): TBoldPerformanceCounter; + function GetAsDetailedString: String; function GetAsString: String; function GetChildCount: integer; function GetSeconds: double; function GetPercentOfOwner: double; procedure StartFromChild; procedure StopFromChild; + function GetActive: boolean; + procedure SetActive(const Value: boolean); + function GetSecondsWithoutChildren: Double; + function GetLastCallSeconds: double; + function GetLastCallAsString: string; + function GetAccumulatedTime: TDateTime; + function GetNamePath: string; + function GetPercentOfOwnerAsString: String; + protected + function NumberOfParents: integer; + procedure InternalStart; + procedure InternalStop; + function FileTime2DateTime(FileTime: TFileTime): TDateTime; + function HasRuningChildren: boolean; public - constructor Create(Owner: TBoldPerformanceCounter; Name: String); + constructor Create(Owner: TBoldPerformanceCounter; const Name: String); virtual; destructor Destroy; override; - function Reset: boolean; - function Start: boolean; - function Stop: boolean; + procedure Reset; + procedure Start; + procedure Restart; + procedure Stop; virtual; + procedure Clear; function WriteToFile(FileName: string): Boolean; + property Name: string read fName; + property NamePath: string read GetNamePath; property ChildCount: integer read GetChildCount; property Children[index: integer]: TBoldPerformanceCounter read GetChildren; - property ChildByName[name: String]: TBoldPerformanceCounter read GetChildByName; + property ChildByName[const name: String]: TBoldPerformanceCounter read GetChildByName; property AsString: String read GetAsString; + property AsDetailedString: string read GetAsDetailedString; + property Seconds: Double read GetSeconds; + property SecondsWithoutChildren: Double read GetSecondsWithoutChildren; + property LastCallSeconds: double read GetLastCallSeconds; + property LastCallAsString: string read GetLastCallAsString; property PercentOfOwner: Double read GetPercentOfOwner; + property PercentOfOwnerAsString: String read GetPercentOfOwnerAsString; + property Active: boolean read GetActive write SetActive; + property Owner: TBoldPerformanceCounter read fOwner; + property Calls: Int64 read fOwnData.fCalls; + property AccumulatedTime: TDateTime read GetAccumulatedTime; + property LastCallCpuTime: TDateTime read fOwnData.fLastCallCpuTime; + property AccumulatedCpuTime: TDateTime read fOwnData.fAccumulatedCPUTime; + + property Tag: integer read fTag write fTag; + + property OwnData: TBoldPerformanceData read fOwnData; + property ChildrenData: TBoldPerformanceData read fChildrenData; end; function BoldMainPerformanceCounter: TBoldPerformanceCounter; @@ -58,21 +121,22 @@ implementation uses SysUtils, - BoldUtils, - BoldCommonConst; + DateUtils, + + BoldUtils; var G_MainPerformanceCounter: TBoldPerformanceCounter; + Frequency: TLargeInteger; function BoldMainPerformanceCounter: TBoldPerformanceCounter; begin if not assigned(G_MainPerformanceCounter) then - G_MainPerformanceCounter := TBoldPerformanceCounter.Create(nil, 'BoldMainPerformanceCounter'); // do not localize + G_MainPerformanceCounter := TBoldPerformanceCounter.Create(nil, 'BoldMainPerformanceCounter'); result := G_MainPerformanceCounter; end; {$IFDEF LINUX} -{ TODO : Find performancecoutner for LINUX. } function QueryPerformanceCounter(var PerformanceCounter: TLargeInteger): boolean; begin PerformanceCounter := 0; @@ -86,15 +150,43 @@ function QueryPerformanceFrequency(var Frequency: TLargeInteger): boolean; end; {$ENDIF} -constructor TBoldPerformanceCounter.Create(Owner: TBoldPerformanceCounter; Name: String); +function TBoldPerformanceCounter.FileTime2DateTime(FileTime: TFileTime): TDateTime; //Convert then FileTime to TDatetime format +var + ft1: TFileTime; + st: TSystemTime; +begin + if FileTime.dwLowDateTime + FileTime.dwHighDateTime = 0 then + Result := 0 + else + begin + FileTimeToLocalFileTime(FileTime, ft1); + FileTimeToSystemTime(ft1, st); + Result := SystemTimeToDateTime(st); + end; +end; + +procedure TBoldPerformanceCounter.Clear; +var + i: integer; begin + for i := ChildCount - 1 downto 0 do + begin + Children[i].free; + end; + fChildren.Clear; + Reset; +end; + +constructor TBoldPerformanceCounter.Create(Owner: TBoldPerformanceCounter; const Name: String); +begin + Assert(Name <> ''); inherited create; fNUmberOfChildrenRunning := 0; - fChildren := TStringList.Create; + fChildren := TList.Create; fOwner := Owner; - fName := UpperCase(Name); + fName := Name; if Assigned(Owner) then - Owner.fChildren.AddObject(Name,self); + Owner.fChildren.Add(self); end; destructor TBoldPerformanceCounter.Destroy; @@ -103,18 +195,8 @@ destructor TBoldPerformanceCounter.Destroy; BoldPerformanceCounter: TBoldPerformanceCounter; begin if Assigned(fOwner) then - begin - for i := 0 to fOwner.ChildCount - 1 do - begin - if fOwner.Children[i] = self then - begin - fOwner.fChildren.Delete(i); - break; - end; - end; - end; - - for i := ChildCount - 1 downto 0 do + fOwner.fChildren.Remove(self); + for i := ChildCount-1 downto 0 do begin BoldPerformanceCounter := Children[i]; BoldPerformanceCounter.fOwner := nil; @@ -131,74 +213,232 @@ function TBoldPerformanceCounter.GetChildCount: integer; function TBoldPerformanceCounter.GetChildren(index: integer): TBoldPerformanceCounter; begin - result := fChildren.Objects[index] as TBoldPerformanceCounter; + result := TBoldPerformanceCounter(fChildren[index]); +end; + +function TBoldPerformanceCounter.GetLastCallAsString: string; +begin + result := Trim(format('%8.3f', [LastCallSeconds])); +end; + +function TBoldPerformanceCounter.GetLastCallSeconds: double; +begin + result := (fOwnData.fLastCallTime / 10000000); end; -function TBoldPerformanceCounter.GetChildByName(Name: String): TBoldPerformanceCounter; +function TBoldPerformanceCounter.GetNamePath: string; +begin + if Assigned(Owner) and (Owner.NamePath <> '') then + result := Owner.NamePath + '.' + name + else + result := name; +end; + +function TBoldPerformanceCounter.GetChildByName(const AName: String): TBoldPerformanceCounter; var i: integer; begin - i := fChildren.IndexOf(UpperCase(Name)); - if i = -1 then - result := TBoldPerformanceCounter.Create(self,name) - else - result := Children[i]; +// if there is a need consider using hash instead + for I := 0 to fChildren.Count - 1 do + if CompareText(AName, TBoldPerformanceCounter(fChildren[i]).Name) = 0 then + begin + result := Children[i]; + exit; + end; + result := TBoldPerformanceCounterClass(classType).Create(self,AName) end; -function TBoldPerformanceCounter.Reset: boolean; +procedure TBoldPerformanceCounter.Reset; var i: integer; begin - fAccumulatedTime := 0; - fCalls := 0; + fOwnData.Clear; for i := 0 to ChildCount-1 do Children[i].Reset; - result := true; end; -function TBoldPerformanceCounter.Start: boolean; +procedure TBoldPerformanceCounter.Restart; begin - inc(fCalls); - if assigned(fOwner) then - fOwner.StartFromChild; - QueryPerformanceCounter(fStart); - result := true; + Reset; + Start; +end; + +procedure TBoldPerformanceCounter.SetActive(const Value: boolean); +begin + if fActive <> Value then + begin + if Value then + Start + else + Stop; + end; end; -function TBoldPerformanceCounter.Stop: boolean; +procedure TBoldPerformanceCounter.InternalStart; +var + CreationTime, ExitTime: TFileTime; +begin + if HasRuningChildren then + QueryPerformanceCounter(fChildrenData.FStart) + else + QueryPerformanceCounter(fOwnData.FStart); + fActive := true; + if HasRuningChildren then + GetProcessTimes(GetCurrentProcess, CreationTime, ExitTime, fChildrenData.fKernelTime, fChildrenData.fUserTime) + else + GetProcessTimes(GetCurrentProcess, CreationTime, ExitTime, fOwnData.fKernelTime, fOwnData.fUserTime); +end; + +procedure TBoldPerformanceCounter.InternalStop; var CurrentTime: TLargeInteger; + CreationTime, ExitTime, KernelTime, UserTime: TFileTime; begin QueryPerformanceCounter(CurrentTime); + if HasRuningChildren then + begin + fChildrenData.fLastCallTime := CurrentTime - fChildrenData.fStart; + fChildrenData.fAccumulatedTime := fChildrenData.fAccumulatedTime + fChildrenData.fLastCallTime; + end + else + begin + fOwnData.fLastCallTime := CurrentTime - fOwnData.fStart; + fOwnData.fAccumulatedTime := fOwnData.fAccumulatedTime + fOwnData.fLastCallTime; + end; + GetProcessTimes(GetCurrentProcess, CreationTime, ExitTime, KernelTime, UserTime); + if HasRuningChildren then + begin + fChildrenData.fLastCallCpuTime := FileTime2DateTime(KernelTime) + FileTime2DateTime(UserTime) - FileTime2DateTime(fChildrenData.fKernelTime) - FileTime2DateTime(fChildrenData.fUserTime); + fChildrenData.fAccumulatedCpuTime := fChildrenData.fAccumulatedCpuTime + fChildrenData.fLastCallCpuTime; + end + else + begin + fOwnData.fLastCallCpuTime := FileTime2DateTime(KernelTime) + FileTime2DateTime(UserTime) - FileTime2DateTime(fOwnData.fKernelTime) - FileTime2DateTime(fOwnData.fUserTime); + fOwnData.fAccumulatedCpuTime := fOwnData.fAccumulatedCpuTime + fOwnData.fLastCallCpuTime; + end; + fActive := false; +end; + +procedure TBoldPerformanceCounter.Start; +begin + if active then + exit; + if HasRuningChildren then + inc(fChildrenData.fCalls) + else + inc(fOwnData.fCalls); + if assigned(fOwner) then + fOwner.StartFromChild; + if HasRuningChildren then + QueryPerformanceCounter(fChildrenData.fStart) + else + QueryPerformanceCounter(fOwnData.fStart); + InternalStart; +end; + +procedure TBoldPerformanceCounter.Stop; +begin + if not active then + exit; // or do we want to raise ? + InternalStop; if assigned(fOwner) then fOwner.StopFromChild; - fAccumulatedTime := fAccumulatedTime + CurrentTime - fStart; - result := true; end; function TBoldPerformanceCounter.GetSeconds: double; +begin + result := DateUtils.SecondSpan(AccumulatedTime, 0); +end; + +function TBoldPerformanceCounter.GetSecondsWithoutChildren: Double; var - Frequency: TLargeInteger; + i: integer; begin - QueryPerformanceFrequency(Frequency); - result := fAccumulatedTime / Frequency; + result := Seconds; + for I := 0 to GetChildCount - 1 do + begin + result := result - Children[i].Seconds; + end; +end; + +function TBoldPerformanceCounter.HasRuningChildren: boolean; +begin + result := fNumberOfChildrenRunning > 0; +end; + +function TBoldPerformanceCounter.NumberOfParents: integer; +var + lCounter: TBoldPerformanceCounter; +begin + result := 0; + lCounter := fOwner; + while Assigned(lCounter) do + begin + lCounter := lCounter.fOwner; + inc(result); + end; end; function TBoldPerformanceCounter.GetPercentOfOwner: double; begin - if Assigned(fOwner) and (fOwner.Seconds <> 0)then - result := 100*Seconds/fOwner.Seconds + if Assigned(fOwner) and (fOwner.ChildrenData.AccumulatedTime <> 0)then + result := 100 * AccumulatedTime/fOwner.ChildrenData.AccumulatedTime else result := 100; end; +function TBoldPerformanceCounter.GetPercentOfOwnerAsString: String; +begin + result := format('%4.2f', [PercentOfOwner])+'%'; +end; + +function TBoldPerformanceCounter.GetAccumulatedTime: TDateTime; +var + CurrentTime: TLargeInteger; +begin + // for consistency this returns ownData like all other places + if Active {and HasRuningChildren} then + begin + QueryPerformanceCounter(CurrentTime); + result := (fOwnData.fAccumulatedTime + CurrentTime - fOwnData.fStart) / Frequency / SecsPerDay; + end + else + result := (fOwnData.fAccumulatedTime) / Frequency / SecsPerDay; + +// ElapsedMilliseconds / MSecsPerSec / SecsPerDay; +end; + +function TBoldPerformanceCounter.GetActive: boolean; +begin + result := fActive; +end; + +function TBoldPerformanceCounter.GetAsDetailedString: String; +var + i: integer; + lIndent: string; +begin + result := ''; + if Calls > 0 then + begin + lIndent := StringOfChar(' ', NumberOfParents); + + result := format('%-50s %8.9fs calls: %5d ', [lIndent+fName, Seconds, Calls]); + if Assigned(fOwner) then + result := format('%s %4.2f %% of %s', [result, PercentOfOwner, fOwner.fName]); + result := result + BOLDCRLF; + end; + for i := 0 to ChildCount - 1 do + result := result + Children[i].AsDetailedString + BOLDCRLF; +end; + function TBoldPerformanceCounter.GetAsString: String; var i: integer; begin - result := format(sCallCount, [fName, Seconds, fCalls]); + result := format('%-35s seconds: %8.4f calls: %5d ', [NamePath, Seconds, Calls]); if Assigned(fOwner) then - result := format(sPercentCount, [result, PercentOfOwner, fOwner.fName]); + result := format('%s %4.1f percent of %s', [result, PercentOfOwner, fOwner.NamePath]); result := result+BOLDCRLF; @@ -208,16 +448,18 @@ function TBoldPerformanceCounter.GetAsString: String; procedure TBoldPerformanceCounter.StartFromChild; begin - if fNumberOfChildrenRunning = 0 then - start; + if Active and not HasRuningChildren then + stop; // stop with own data, start with childdata inc(fNumberOfChildrenRunning); + if fNumberOfChildrenRunning = 1 then + start; end; procedure TBoldPerformanceCounter.StopFromChild; begin - dec(fNumberOfChildrenRunning); - if fNumberOfChildrenRunning = 0 then + if fNumberOfChildrenRunning = 1 then stop; + dec(fNumberOfChildrenRunning); end; function TBoldPerformanceCounter.WriteToFile(FileName: string): Boolean; @@ -234,7 +476,50 @@ function TBoldPerformanceCounter.WriteToFile(FileName: string): Boolean; end; end; -initialization // empty +{ TBoldPerformanceData } + +procedure TBoldPerformanceData.Clear; +begin + fAccumulatedTime := 0; + fLastCallTime := 0; + fStart := 0; + fCalls := 0; + fKernelTime.dwLowDateTime := 0; + fKernelTime.dwHighDateTime := 0; + fUserTime.dwLowDateTime := 0; + fUserTime.dwHighDateTime := 0; + fAccumulatedCPUTime := 0; + fLastCallCpuTime := 0; +end; + +function TBoldPerformanceData.GetAccumulatedTime: TDateTime; +begin +{ if Active and HasRuningChildren? then + begin + QueryPerformanceCounter(CurrentTime); + result := (fOwnData.fAccumulatedTime + CurrentTime - fOwnData.fStart) / Frequency / SecsPerDay; + end + else} + result := (fAccumulatedTime) / Frequency / SecsPerDay; +end; + +function TBoldPerformanceData.GetLastCallAsString: string; +begin + result := Trim(format('%8.3f seconds', [LastCallSeconds])); +end; + +function TBoldPerformanceData.GetLastCallSeconds: double; +begin + result := (fLastCallTime / 10000000); +end; + +function TBoldPerformanceData.GetSeconds: double; +begin + result := DateUtils.SecondSpan(AccumulatedTime, 0); +end; + +initialization + QueryPerformanceFrequency(Frequency); finalization freeAndNil(G_MainPerformanceCounter); diff --git a/Source/Common/Support/BoldPriorityQueue.pas b/Source/Common/Support/BoldPriorityQueue.pas index 024416f7..819d6dfc 100644 --- a/Source/Common/Support/BoldPriorityQueue.pas +++ b/Source/Common/Support/BoldPriorityQueue.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPriorityQueue; interface @@ -11,20 +14,18 @@ interface TBoldPriorityQueueItem = class; TBoldPriorityQueue = class; - { TBoldPriorityQueueItem } TBoldPriorityQueueItem = class(TBoldMemoryManagedObject) public function HasHigherPriorityThan(Item: TBoldPriorityQueueItem): Boolean; virtual; abstract; end; - { TBoldPriorityQueue } TBoldPriorityQueue = class(TBoldMemoryManagedObject) private fHeap: TList; fOnHeadChanged: TNotifyEvent; fLocker: TBoldLoggableCriticalSection; - procedure SiftUp(pos: Integer); // internal use only, not thread safe - procedure SiftDown(pos: Integer); // internal use only, not thread safe + procedure SiftUp(pos: Integer); + procedure SiftDown(pos: Integer); function RightChild(pos: Integer): Integer; function LeftChild(pos: Integer): Integer; function Parent(pos: Integer): Integer; @@ -49,7 +50,8 @@ TBoldPriorityQueue = class(TBoldMemoryManagedObject) implementation uses - SysUtils; + SysUtils, + BoldRev; { TBoldPriorityQueue } @@ -78,7 +80,7 @@ function TBoldPriorityQueue.ChopHead: TBoldPriorityQueueItem; constructor TBoldPriorityQueue.Create; begin fHeap := TList.Create; - fLocker := TBoldLoggableCriticalSection.Create('PriQ'); // do not localize + fLocker := TBoldLoggableCriticalSection.Create('PriQ'); end; destructor TBoldPriorityQueue.Destroy; @@ -115,7 +117,7 @@ procedure TBoldPriorityQueue.InternalRemoveHead; OldHead := Head; fHeap.Exchange(0, fHeap.Count-1); fHeap.Delete(fHeap.Count-1); - SiftDown(1); // heap positions 1-based, even though fHeap is 0-based + SiftDown(1); if (Head <> OldHead) and assigned(fOnHeadChanged) then OnHeadChanged(self); end; @@ -168,7 +170,7 @@ procedure TBoldPriorityQueue.SetItems(pos: Integer; fHeap[pos] := Value; finally fLocker.Release; - end; + end; end; procedure TBoldPriorityQueue.SiftDown(pos: Integer); @@ -220,5 +222,6 @@ procedure TBoldPriorityQueue.swap(pos1, pos2: Integer); end; end; +initialization end. diff --git a/Source/Common/Support/BoldRegistry.pas b/Source/Common/Support/BoldRegistry.pas index 30958376..f3a128c5 100644 --- a/Source/Common/Support/BoldRegistry.pas +++ b/Source/Common/Support/BoldRegistry.pas @@ -1,9 +1,12 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldRegistry; interface uses - Windows, // HKEY_LOCAL_MACHINE + Windows, Registry; {** Usage (kala 990714) @@ -169,5 +172,6 @@ procedure TBoldRegistry.WriteString(const Name: String; Value: String); fRegistry.WriteString(Name, Value); end; +initialization end. diff --git a/Source/Common/Support/BoldRev.pas b/Source/Common/Support/BoldRev.pas index 951d71de..280abd6b 100644 --- a/Source/Common/Support/BoldRev.pas +++ b/Source/Common/Support/BoldRev.pas @@ -1,11 +1,10 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldRev; interface -implementation - -(* - uses Classes; @@ -19,8 +18,6 @@ procedure BoldRegisterModuleVersion(const Version: string); implementation -{.$R *.res} - uses SysUtils; @@ -60,20 +57,22 @@ function BoldProductVersion: string; function BoldModuleVersions: TStringList; begin if not Assigned(G_VersionList) then + begin G_VersionList := TStringList.Create; + G_VersionList.Sorted := true; + G_VersionList.Duplicates := dupError; + end; Result := G_VersionList; end; procedure BoldRegisterModuleVersion(const Version: string); begin - with BoldModuleVersions do - if IndexOf(Version) = -1 then - BoldModuleVersions.Add(Version); + BoldModuleVersions.Add(Version); end; initialization finalization FreeAndNil(G_VersionList); -*) -end. \ No newline at end of file + +end. diff --git a/Source/Common/Support/BoldSharedStrings.pas b/Source/Common/Support/BoldSharedStrings.pas index 7c23be5d..3ee84b3d 100644 --- a/Source/Common/Support/BoldSharedStrings.pas +++ b/Source/Common/Support/BoldSharedStrings.pas @@ -1,16 +1,25 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSharedStrings; interface +{$IFNDEF BOLD_DISABLESHAREDSTRINGS} uses +{$IFDEF UseCriticalSection} + SyncObjs, +{$ENDIF} BoldBase, BoldIndexableList; +{$ENDIF} type + {$IFNDEF BOLD_DISABLESHAREDSTRINGS} TBoldSharedStringHolder = class(TBoldMemoryManagedObject) private fValue: String; - function GetExternalRefCount: integer; + function GetExternalRefCount: integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} public constructor Create(const s: String); property ExternalRefCount: integer read GetExternalRefCount; @@ -19,51 +28,104 @@ TBoldSharedStringHolder = class(TBoldMemoryManagedObject) TBoldSharedStringCache = class(TBoldUnOrderedIndexableList) private - function GetHolderByValue(const s: String): TBoldSharedStringHolder; + class var IX_StringHolderValue: integer; + function GetHolderByValue(const s: String): TBoldSharedStringHolder; {$IFDEF BOLD_INLINE}inline;{$ENDIF} public constructor Create; property HolderByValue[const s: String]: TBoldSharedStringHolder read GetHolderByValue; end; + {$IFDEF BOLD_UNICODE} + TBoldSharedAnsiStringHolder = class(TBoldMemoryManagedObject) + private + fValue: AnsiString; + function GetExternalRefCount: integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + public + constructor Create(const s: AnsiString); + property ExternalRefCount: integer read GetExternalRefCount; + property Value: AnsiString read FValue; + end; + + TBoldSharedAnsiStringCache = class(TBoldUnOrderedIndexableList) + private + function GetHolderByValue(const s: AnsiString): TBoldSharedAnsiStringHolder; + public + constructor Create; + property HolderByValue[const s: AnsiString]: TBoldSharedAnsiStringHolder read GetHolderByValue; + end; + {$ENDIF} + {$ENDIF} + TBoldSharedStringManager = class private - fStringCache: TBoldSharedStringCache; + {$IFDEF UseCriticalSection} + fCriticalSection: TCriticalSection; + {$ENDIF} {$IFNDEF BOLD_DISABLESHAREDSTRINGS} + fAddsRemainingToGarbageCollect: integer; + fStringCache: TBoldSharedStringCache; + {$IFDEF BOLD_UNICODE} + fAnsiAddsRemainingToGarbageCollect: integer; + fAnsiStringCache: TBoldSharedAnsiStringCache; + {$ENDIF} fCachedHits: integer; + procedure DoGarbageCollect(KeepStringsWithOneReference: Boolean); overload; + {$IFDEF BOLD_UNICODE} + procedure DoAnsiGarbageCollect(KeepStringsWithOneReference: Boolean); overload; + {$ENDIF} {$ENDIF} - fAddsRemainingToGarbageCollect: integer; function GetSavedMemory: integer; function GetInfoString: String; public constructor Create; destructor Destroy; override; + procedure GarbageCollect; function GetSharedString(const s: String): String; - procedure GarbageCollect(KeepStringsWithOneReference: Boolean); + {$IFDEF BOLD_UNICODE} + function GetSharedAnsiString(const s: AnsiString): AnsiString; + {$ENDIF} property SavedMemory: integer read GetSavedMemory; property InfoString: String read GetInfoString; end; function BoldSharedStringManager: TBoldSharedStringManager; +{$IFNDEF BOLD_UNICODE} function StringRefCount(const s: String): integer; +{$ENDIF} implementation uses - SysUtils, + SysUtils + {$IFNDEF BOLD_DISABLESHAREDSTRINGS} + , BoldDefs, - BoldHashIndexes; + BoldIndex, + BoldHashIndexes + {$ENDIF}; var - IX_StringHolderValue: integer = -1; G_BoldSharedStringManager: TBoldSharedStringManager = nil; +{$IFNDEF BOLD_DISABLESHAREDSTRINGS} +const + MINIMUM_ADDS = 100; + type TBoldStringHolderValueIndex = class(TBoldCaseSensitiveStringHashIndex) protected function ItemAsKeyString(Item: TObject): string; override; end; + {$IFDEF BOLD_UNICODE} + TBoldAnsiStringHolderValueIndex = class(TBoldCaseSensitiveStringHashIndex) + protected + function ItemAsKeyString(Item: TObject): string; override; + end; + {$ENDIF} +{$ENDIF} + function BoldSharedStringManager: TBoldSharedStringManager; begin if not assigned(G_BoldSharedStringManager) then @@ -71,29 +133,119 @@ function BoldSharedStringManager: TBoldSharedStringManager; result := G_BoldSharedStringManager; end; +{$IFNDEF BOLD_UNICODE} function StringRefCount(const s: String): integer; begin result := Integer(Pointer(integer(Addr(s)^)-8)^); end; +{$ENDIF} + +{$IFNDEF BOLD_DISABLESHAREDSTRINGS} +{ TBoldSharedStringCache } + +constructor TBoldSharedStringCache.Create; +begin + inherited; + SetIndexVariable(IX_StringHolderValue, AddIndex(TBoldStringHolderValueIndex.Create)); +end; + +function TBoldSharedStringCache.GetHolderByValue( + const s: String): TBoldSharedStringHolder; +begin + Result := TBoldSharedStringHolder(TBoldCaseSensitiveStringHashIndex(Indexes[IX_StringHolderValue]).FindByString(s)); +end; + +{$IFDEF BOLD_UNICODE} +constructor TBoldSharedAnsiStringCache.Create; +begin + inherited; + SetIndexVariable(TBoldSharedStringCache.IX_StringHolderValue, AddIndex(TBoldAnsiStringHolderValueIndex.Create)); +end; + +function TBoldSharedAnsiStringCache.GetHolderByValue( + const s: AnsiString): TBoldSharedAnsiStringHolder; +begin + Result := TBoldSharedAnsiStringHolder(TBoldCaseSensitiveStringHashIndex(Indexes[TBoldSharedStringCache.IX_StringHolderValue]).FindByString(string(s))); +end; +{$ENDIF} + +{ TBoldStringHolderValueIndex } + +function TBoldStringHolderValueIndex.ItemAsKeyString(Item: TObject): string; +begin + Result := TBoldSharedStringHolder(item).Value; +end; + +{$IFDEF BOLD_UNICODE} +function TBoldAnsiStringHolderValueIndex.ItemAsKeyString(Item: TObject): string; +begin + Result := string(TBoldSharedAnsiStringHolder(item).Value); +end; +{$ENDIF} + +{ TBoldSharedStringHolder } + +constructor TBoldSharedStringHolder.Create(const s: String); +begin + inherited Create; + fValue := s; +end; + +function TBoldSharedStringHolder.GetExternalRefCount: integer; +begin + result := StringRefCount(fValue)-1; +end; + +{$IFDEF BOLD_UNICODE} +constructor TBoldSharedAnsiStringHolder.Create(const s: AnsiString); +begin + inherited Create; + fValue := s; +end; + +function TBoldSharedAnsiStringHolder.GetExternalRefCount: integer; +begin + result := StringRefCount(fValue)-1; +end; +{$ENDIF} +{$ENDIF} { TBoldSharedStringManager } constructor TBoldSharedStringManager.Create; begin inherited; + {$IFDEF UseCriticalSection} + fCriticalSection := TCriticalSection.Create; + {$ENDIF} + {$IFNDEF BOLD_DISABLESHAREDSTRINGS} fStringCache := TBoldSharedStringCache.Create; - fAddsRemainingToGarbageCollect := 100; + {$IFDEF BOLD_UNICODE} + fAnsiStringCache := TBoldSharedAnsiStringCache.Create; + {$ENDIF} + fAddsRemainingToGarbageCollect := MINIMUM_ADDS; + {$ENDIF} end; destructor TBoldSharedStringManager.Destroy; begin - inherited; + {$IFNDEF BOLD_DISABLESHAREDSTRINGS} FreeAndNil(fStringCache); + {$IFDEF BOLD_UNICODE} + FreeAndNil(fAnsiStringCache); + {$ENDIF} + {$ENDIF} + {$IFDEF UseCriticalSection} + FreeAndNil(fCriticalSection); + {$ENDIF} + inherited; end; -procedure TBoldSharedStringManager.GarbageCollect(KeepStringsWithOneReference: Boolean); +{$IFNDEF BOLD_DISABLESHAREDSTRINGS} +procedure TBoldSharedStringManager.DoGarbageCollect( + KeepStringsWithOneReference: Boolean); var - traverser: TBoldIndexableListTraverser; + Traverser: TBoldIndexableListTraverser; Holder: TBoldSharedStringHolder; MinimumReferencesToKeep: integer; begin @@ -101,109 +253,206 @@ procedure TBoldSharedStringManager.GarbageCollect(KeepStringsWithOneReference: B MinimumReferencesToKeep := 1 else MinimumReferencesToKeep := 2; + Traverser := fStringCache.CreateTraverser; - while not Traverser.EndOfList do + while Traverser.MoveNext do begin Holder := TBoldSharedStringHolder(Traverser.Item); if Holder.ExternalRefCount < MinimumReferencesToKeep then fStringCache.remove(Holder); - Traverser.Next; end; Traverser.Free; + fAddsRemainingToGarbageCollect := fStringCache.Count; + // Do not let fAddsRemainingToGarbageCollect get to small, + // because then GarbageCollect would be called very often and + // there is only a small chance, that Strings were added to the holder. + if fAddsRemainingToGarbageCollect < MINIMUM_ADDS then begin + fAddsRemainingToGarbageCollect := MINIMUM_ADDS; + end; +end; + +{$IFDEF BOLD_UNICODE} +procedure TBoldSharedStringManager.DoAnsiGarbageCollect( + KeepStringsWithOneReference: Boolean); +var + Traverser: TBoldIndexableListTraverser; + Holder: TBoldSharedAnsiStringHolder; + MinimumReferencesToKeep: integer; +begin + if KeepStringsWithOneReference then + MinimumReferencesToKeep := 1 + else + MinimumReferencesToKeep := 2; + + Traverser := fAnsiStringCache.CreateTraverser; + while Traverser.MoveNext do + begin + Holder := TBoldSharedAnsiStringHolder(Traverser.Item); + if Holder.ExternalRefCount < MinimumReferencesToKeep then + fAnsiStringCache.remove(Holder); + end; + Traverser.Free; + + fAnsiAddsRemainingToGarbageCollect := fAnsiStringCache.Count; + // Do not let fAnsiAddsRemainingToGarbageCollect get to small, + // because then GarbageCollect would be called very often and + // there is only a small chance, that Strings were added to the holder. + if fAnsiAddsRemainingToGarbageCollect < MINIMUM_ADDS then begin + fAnsiAddsRemainingToGarbageCollect := MINIMUM_ADDS; + end; +end; +{$ENDIF} +{$ENDIF} + +procedure TBoldSharedStringManager.GarbageCollect; +begin + {$IFNDEF BOLD_DISABLESHAREDSTRINGS} + {$IFDEF UseCriticalSection} + fCriticalSection.Enter; + try + {$ENDIF} + DoGarbageCollect(False); + {$IFDEF BOLD_UNICODE} + DoAnsiGarbageCollect(False); + {$ENDIF} + {$IFDEF UseCriticalSection} + finally + fCriticalSection.Leave; + end; + {$ENDIF} + {$ENDIF} end; function TBoldSharedStringManager.GetInfoString: String; +{$IFNDEF BOLD_DISABLESHAREDSTRINGS} +var + iSharedStrings: Integer; +{$ENDIF} begin - result := - format('Number of shared strings: %d', [FStringCache.Count])+BOLDCRLF+ {do not localize } - format('Saved memory %d', [SavedMemory]); {do not localize } +{$IFDEF BOLD_DISABLESHAREDSTRINGS} + Result := 'SharedStringManager disabled'; {do not localize } +{$ELSE} + {$IFDEF UseCriticalSection} + fCriticalSection.Enter; + try + {$ENDIF} + iSharedStrings := FStringCache.Count; + {$IFDEF BOLD_UNICODE} + Inc(iSharedStrings, fAnsiStringCache.Count); + {$ENDIF} + Result := + Format('Number of shared strings: %d', [iSharedStrings]) + BOLDCRLF + {do not localize } + Format('Saved memory %d', [SavedMemory]); {do not localize } +{$IFDEF UseCriticalSection} + finally + fCriticalSection.Leave; + end; +{$ENDIF} +{$ENDIF} end; function TBoldSharedStringManager.GetSavedMemory: integer; +{$IFNDEF BOLD_DISABLESHAREDSTRINGS} var - traverser: TBoldIndexableListTraverser; + Traverser: TBoldIndexableListTraverser; Holder: TBoldSharedStringHolder; + {$IFDEF BOLD_UNICODE} + AnsiHolder: TBoldSharedAnsiStringHolder; + {$ENDIF} +{$ENDIF} begin - result := 0; + Result := 0; +{$IFNDEF BOLD_DISABLESHAREDSTRINGS} Traverser := fStringCache.CreateTraverser; - while not Traverser.EndOfList do + while Traverser.MoveNext do begin Holder := TBoldSharedStringHolder(Traverser.Item); - result := result + (Holder.ExternalRefCount-1)*length(Holder.Value); - Traverser.Next; + Result := Result + (Holder.ExternalRefCount-1) * Length(Holder.Value) * SizeOf(Char); + end; + Traverser.Free; + {$IFDEF BOLD_UNICODE} + Traverser := fAnsiStringCache.CreateTraverser; + while Traverser.MoveNext do + begin + AnsiHolder := TBoldSharedAnsiStringHolder(Traverser.Item); + Result := Result + (AnsiHolder.ExternalRefCount-1) * Length(AnsiHolder.Value); end; Traverser.Free; + {$ENDIF} +{$ENDIF} end; function TBoldSharedStringManager.GetSharedString(const s: String): String; {$IFDEF BOLD_DISABLESHAREDSTRINGS} begin - result := s; -end; + Result := s; {$ELSE} var Holder: TBoldSharedStringHolder; begin - if s = '' then - result := s - else - begin + if s = '' then begin + Result := s; + end else begin + {$IFDEF UseCriticalSection} + fCriticalSection.Enter; + try + {$ENDIF} Holder := fStringCache.HolderByValue[s]; - if assigned(Holder) then - begin - result := Holder.Value; + if Assigned(Holder) then begin Inc(fCachedHits); - end - else - begin + end else begin Holder := TBoldSharedStringHolder.Create(s); fStringCache.Add(Holder); - result := s; end; + Result := Holder.Value; end; Dec(fAddsRemainingToGarbageCollect); if fAddsRemainingToGarbageCollect <= 0 then - GarbageCollect(true); -end; + DoGarbageCollect(true); +{$IFDEF UseCriticalSection} + finally + fCriticalSection.Leave; + end; +{$ENDIF} {$ENDIF} - -{ TBoldSharedStringCache } - -constructor TBoldSharedStringCache.Create; -begin - inherited; - SetIndexVariable(IX_StringHolderValue, AddIndex(TBoldStringHolderValueIndex.Create)); -end; - -function TBoldSharedStringCache.GetHolderByValue( - const s: String): TBoldSharedStringHolder; -begin - Result := TBoldSharedStringHolder(TBoldStringHolderValueIndex(Indexes[IX_StringHolderValue]).FindByString(s)); -end; - -{ TBoldStringHolderValueIndex } - -function TBoldStringHolderValueIndex.ItemASKeyString( - Item: TObject): string; -begin - result := TBoldSharedStringHolder(item).value; end; -{ TBoldSharedStringHolder } - -constructor TBoldSharedStringHolder.Create(const s: String); +{$IFDEF BOLD_UNICODE} +function TBoldSharedStringManager.GetSharedAnsiString(const s: AnsiString): + AnsiString; +{$IFDEF BOLD_DISABLESHAREDSTRINGS} begin - inherited Create; - fValue := s; -end; - -function TBoldSharedStringHolder.GetExternalRefCount: integer; + Result := s; +{$ELSE} +var + Holder: TBoldSharedAnsiStringHolder; begin - result := StringRefCount(fValue)-1; + if s = '' then begin + Result := s; + end else begin + Holder := fAnsiStringCache.HolderByValue[s]; + if Assigned(Holder) then begin + Inc(fCachedHits); + end else begin + Holder := TBoldSharedAnsiStringHolder.Create(s); + fAnsiStringCache.Add(Holder); + end; + Result := Holder.Value; + end; + Dec(fAnsiAddsRemainingToGarbageCollect); + if fAnsiAddsRemainingToGarbageCollect <= 0 then + DoAnsiGarbageCollect(true); +{$ENDIF} end; +{$ENDIF} initialization // empty +{$IFNDEF BOLD_DISABLESHAREDSTRINGS} + TBoldSharedStringCache.IX_StringHolderValue := -1; +{$ENDIF} + finalization FreeAndNil(G_BoldSharedStringManager); end. + diff --git a/Source/Common/Support/BoldSorter.pas b/Source/Common/Support/BoldSorter.pas index 48f49e5c..31884169 100644 --- a/Source/Common/Support/BoldSorter.pas +++ b/Source/Common/Support/BoldSorter.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSorter; interface @@ -11,6 +14,7 @@ procedure BoldSort(FirstIndex, LastIndex: Integer; Compare:TBoldSortCompare ; Ex implementation + procedure BoldSort(FirstIndex, LastIndex: Integer; Compare:TBoldSortCompare ; Exchange : TBoldSortExchange); var I, J, P: Integer; @@ -38,4 +42,6 @@ procedure BoldSort(FirstIndex, LastIndex: Integer; Compare:TBoldSortCompare ; Ex until I >= LastIndex; end; + + end. diff --git a/Source/Common/Support/BoldStringList.pas b/Source/Common/Support/BoldStringList.pas index 9c7473a2..a2e4ae98 100644 --- a/Source/Common/Support/BoldStringList.pas +++ b/Source/Common/Support/BoldStringList.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldStringList; interface @@ -34,7 +37,8 @@ implementation uses BoldSharedStrings, - SysUtils; + SysUtils, + BoldRev; { TBoldStringList } @@ -87,7 +91,7 @@ function TBoldStringList.GetIndexOfName(const Name: String; var Index: integer): result := GetIndexOfPrefix(name + '=', Index); end; -function BoldAnsiLCompareShortest(Const s1, s2: string): integer; // Don't inline, will invoke UniqueString +function BoldAnsiLCompareShortest(Const s1, s2: string): integer; var Len, Len1: integer; diff --git a/Source/Common/Support/BoldTemplateExpander.pas b/Source/Common/Support/BoldTemplateExpander.pas index 84b80538..64f129e4 100644 --- a/Source/Common/Support/BoldTemplateExpander.pas +++ b/Source/Common/Support/BoldTemplateExpander.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldTemplateExpander; interface @@ -30,7 +33,7 @@ TBoldTemplatevariable = class(TBoldMemoryManagedObject) fValue: String; fFlags: TBoldvariableFlags; public - constructor Create(const name, value: string; Flags: TBoldVariableFlags); + constructor create(const name, value: string; Flags: TBoldVariableFlags); property Name: string read fName; property Value: String read fValue write fValue; property Flags: TBoldVariableFlags read fFlags; @@ -57,6 +60,7 @@ TBoldTemplateVariables = class(TBoldUnOrderedIndexableList) end; { TBoldTemplateHolder } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldTemplateHolder = class(TComponent) private fTemplate: TStringList; @@ -71,9 +75,9 @@ TBoldTemplateHolder = class(TComponent) procedure SetFileName(const Value: String); procedure TemplateChanged(sender: TObject); public - constructor Create(aOwner: Tcomponent); override; + constructor create(aOwner: Tcomponent); override; procedure ExpandTemplate; - destructor Destroy; override; + destructor destroy; override; property Variables: TBoldTemplateVariables read fvariables; property ExpandedTemplate: TStringList read GetExpandedTemplate; property LastExpansion: TStringList read fExpandedTemplate; @@ -91,22 +95,21 @@ TBoldTemplateList = class(TList) property items[index: integer]: TBoldTemplateHolder read GetItems; default; end; + function BoldExpandTemplate(const Source: string; Variables: TBoldtemplateVariables; MacroNamePad: String = ''): string; implementation uses SysUtils, - BoldUtils, - BoldCommonConst; - + BoldUtils; var IX_TemplateVariables: integer = -1; type TBoldTemplatevariableIndex = class(TBoldStringHashIndex) protected - function ItemAsKeyString(Item: TObject): string; override; + function ItemASKeyString(Item: TObject): string; override; end; { TBoldTemplateHolder } @@ -150,9 +153,9 @@ function TBoldTemplateVariables.Exists(const Name: string): Boolean; function TBoldTemplateVariables.ExpandString(const Source: string): string; begin - Change('DATETIME', DateTimeToStr(now)); // do not localize - Change('DATE', DateToStr(now)); // do not localize - Change('TIME', TimeToStr(now)); // do not localize + Change('DATETIME', DateTimeToStr(now)); + Change('DATE', DateToStr(now)); + Change('TIME', TimeToStr(now)); result := BoldExpandTemplate(Source, Self); end; @@ -214,7 +217,6 @@ function BoldExpandTemplate(const Source: string; Variables: TBoldTemplateVariab result := Variables.Values[MacroName]; while (Result = '') and (pos('.', MacroName) <> 0) do begin - // variable Might to belong to an outer loop scope i := length(MacroName); While MacroName[i] <> '.' do dec(i); Delete(MacroName, i, maxint); @@ -234,16 +236,16 @@ function BoldExpandTemplate(const Source: string; Variables: TBoldTemplateVariab if Me > 0 then begin Result := Result + Copy(TempSource, 1, Mb - 1); - if not (temp[1] in ['?', ',']) then // temp cant be empty since MAcroEnd is inside temp + if not CharInSet(temp[1], ['?', ',']) then // temp cant be empty since MAcroEnd is inside temp MacroName := Copy(Temp, 1, Me - 1) + MacroNamePad else - MacroName := Copy(Temp, 1, Me - 1); // namepad has to be added later to ?-macros - if (Length(MacroName) > 0) and (MacroName[1] in MacroModifiers) then + MacroName := Copy(Temp, 1, Me - 1); + if (Length(MacroName) > 0) and CharInSet(MacroName[1], MacroModifiers) then begin Modifier := MacroName[1]; MacroName := Copy(MacroName, 2, MaxInt); case Modifier of - ',': // Separation + ',': begin Value := copy(MacroName, pos(':', MacroName) + 1, MaxInt); macroName := copy(MacroName, 1, pos(':', MacroName) - 1); @@ -251,14 +253,14 @@ function BoldExpandTemplate(const Source: string; Variables: TBoldTemplateVariab result := result + Value end; - '+': // uppercase + '+': Result := Result + AnsiUppercase(GetVarvalue(MacroName)); - '-': // lowercase + '-': Result := Result + AnsiLowercase(GetVarvalue(MacroName)); - '<','>': // justification + '<','>': begin Number := ''; - while MacroName[1] in MacroNumbers do + while CharInSet(MacroName[1], MacroNumbers) do begin Number := Number + MacroName[1]; MacroName := Copy(MacroName, 2, MaxInt); @@ -268,9 +270,9 @@ function BoldExpandTemplate(const Source: string; Variables: TBoldTemplateVariab if (J > 0) and (J > Length(MacroValue)) then begin case Modifier of - '<': // left justify + '<': Pad := MacroValue + StringOfChar(' ', J - Length(MacroValue)); - '>': // right justify + '>': Pad := StringOfChar(' ', J - Length(MacroValue)) + MacroValue; end; end @@ -278,7 +280,7 @@ function BoldExpandTemplate(const Source: string; Variables: TBoldTemplateVariab Pad := MacroValue; Result := Result + Pad; end; - '?': begin // IfStatement $(?varname:true,false) + '?': begin ColonPos := pos(':', MacroName); CommaPos:= pos(',', MacroName); if GetVarvalue(copy(MacroName, 1, ColonPos - 1) + MacroNamePad) = '1' then @@ -291,13 +293,13 @@ function BoldExpandTemplate(const Source: string; Variables: TBoldTemplateVariab else begin EndLoopPos := 0; - if Pos('LOOP', MacroName) = 1 then // do not localize + if Pos('LOOP', MacroName) = 1 then begin MacroName := Copy(MacroName, 5, maxint); MatchMacroName := MacroName; if pos('.', MatchMacroName) <> 0 then Delete(MatchMacroName, pos('.', MatchMacroName), MaxInt); - MatchMacroname := UpperCase(MacroBegin + 'ENDLOOP' + MatchMacroName + MacroEnd); // do not localize + MatchMacroname := UpperCase(MacroBegin + 'ENDLOOP' + MatchMacroName + MacroEnd); EndLoopPos := pos(MatchMacroName, UpperCase(temp)); if EndLoopPos <> 0 then @@ -313,16 +315,16 @@ function BoldExpandTemplate(const Source: string; Variables: TBoldTemplateVariab Variables.SetVariable(Macroname, IntToStr(OldLoopValue)); end else - raise Exception.CreateFmt(sUnterminatedLoop, [MacroName]); + raise Exception.Create('Unterminated loop in template: ' + MacroName); end - else if Pos('CASE', macroName) = 1 then // do not localize + else if Pos('CASE', macroName) = 1 then begin MacroName := Copy(MacroName, 5, maxint); MatchMacroName := MacroName; if pos('.', MatchMacroName) <> 0 then Delete(MatchMacroName, pos('.', MatchMacroName), MaxInt); - MatchMacroname := UpperCase(MacroBegin + 'ENDCASE' + MatchMacroName + MacroEnd); // do not localize + MatchMacroname := UpperCase(MacroBegin + 'ENDCASE' + MatchMacroName + MacroEnd); EndLoopPos := pos(MatchMacroName, UpperCase(temp)); if EndLoopPos <> 0 then @@ -339,7 +341,7 @@ function BoldExpandTemplate(const Source: string; Variables: TBoldTemplateVariab CurrentCaseTag := UpperCase(BoldExpandTemplate(uppercase(trim(copy(CaseText[i], 1, barpos - 1))), variables, MacroNamePad)); if currentCaseTag <> CaseValue then begin - if CurrentCasetag = 'ELSE' then // do not localize + if CurrentCasetag = 'ELSE' then ElseValue := copy(CaseText[i], BarPos + 1, maxint) + BOLDCRLF + ElseValue; CaseText.Delete(i); end @@ -362,15 +364,15 @@ function BoldExpandTemplate(const Source: string; Variables: TBoldTemplateVariab result := result + BoldExpandTemplate(CaseText.Text, Variables, MacroNamePad); CaseText.Free; end else - Raise Exception.CreateFmt(sUnterminatedCase, [MacroName]); + Raise Exception.Create('Unterminated case in template: ' + MacroName); end - else if Pos('MACROSTART', MacroName) = 1 then // do not localize + else if Pos('MACROSTART', MacroName) = 1 then begin MacroName := trim(Copy(MacroName, 11, maxint)); MatchMacroName := MacroName; if pos('.', MatchMacroName) <> 0 then Delete(MatchMacroName, pos('.', MatchMacroName), MaxInt); - MatchMacroname := UpperCase(MacroBegin + 'MACROEND ' + MatchMacroName + MacroEnd); // do not localize + MatchMacroname := UpperCase(MacroBegin + 'MACROEND ' + MatchMacroName + MacroEnd); EndLoopPos := pos(MatchMacroName, UpperCase(temp)); if EndLoopPos <> 0 then @@ -380,17 +382,16 @@ function BoldExpandTemplate(const Source: string; Variables: TBoldTemplateVariab Variables.SetVariable(Macroname, MacroText); end else - raise Exception.CreateFmt(sUnterminatedMacro, [MacroName]); + raise Exception.Create('Unterminated Macro in template: ' + MacroName); end; - if pos('CRLF', upperCase(MacroName)) = 1 then // in loops the CRLF becomes CRLF.0 // do not localize + if pos('CRLF', upperCase(MacroName)) = 1 then result := result + BOLDCRLF else if endLoopPos = 0 then begin value := Variables.Values[MacroName]; while (value = '') and (pos('.', MacroName) <> 0) do begin - // variable seems to belong to an outer loop scope i := length(MacroName); While MacroName[i] <> '.' do dec(i); Delete(MacroName, i, maxint); @@ -425,7 +426,7 @@ constructor TBoldTemplateHolder.create(aOwner: Tcomponent); fExpandedTemplate := TStringList.Create; end; -destructor TBoldTemplateHolder.Destroy; +destructor TBoldTemplateHolder.destroy; begin FreeAndNil(fVariables); FreeAndNil(fTemplate); @@ -485,9 +486,9 @@ procedure TBoldTemplateHolder.SetFileName(const Value: String); procedure TBoldTemplateVariables.InitializeDateTimeMacros; begin - SetVariable('DATETIME', DateTimeToStr(now)); // do not localize - SetVariable('DATE', DateToStr(now)); // do not localize - SetVariable('TIME', TimeToStr(now)); // do not localize + SetVariable('DATETIME', DateTimeToStr(now)); + SetVariable('DATE', DateToStr(now)); + SetVariable('TIME', TimeToStr(now)); end; procedure TBoldTemplateHolder.TemplateChanged(sender: TObject); @@ -512,6 +513,8 @@ function TBoldTemplatevariableIndex.ItemASKeyString(Item: TObject): string; result := TBoldTemplatevariable(Item).Name; end; + + { TBoldTemplateList } function TBoldTemplateList.GetItems(index: integer): TBoldTemplateHolder; @@ -519,4 +522,7 @@ function TBoldTemplateList.GetItems(index: integer): TBoldTemplateHolder; result := TBoldTemplateHolder(inherited items[index]); end; + +initialization + end. diff --git a/Source/Common/Support/BoldUtils.pas b/Source/Common/Support/BoldUtils.pas index 84bf60d0..c3e5aeaa 100644 --- a/Source/Common/Support/BoldUtils.pas +++ b/Source/Common/Support/BoldUtils.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUtils; interface @@ -7,7 +10,9 @@ interface SysUtils, Classes, TypInfo, - BoldDefs; + Windows, + BoldDefs, + WideStrings; type TBoldNotificationEvent = procedure(AComponent: TComponent; Operation: TOperation) of object; @@ -24,14 +29,14 @@ TBoldPassthroughNotifier = class(TComponent) function CharCount(c: char; const s: string): integer; function BoldNamesEqual(const name1, name2: string): Boolean; procedure BoldAppendToStrings(strings: TStrings; const aString: string; const ForceNewLine: Boolean); -function BoldSeparateStringList(strings: TStringList; const Separator, PreString, PostString: String): String; +function BoldSeparateStringList(strings: TStringList; const Separator, PreString, PostString: String; AIndex: integer = -1): String; function BoldSeparatedAppend(const S1, S2: string;const Separator: string = ','): string; function BoldTrim(const S: string): string; function BoldIsPrefix(const S, Prefix: string): Boolean; function BoldStrEqual(P1, P2: PChar; Len: integer): Boolean; -function BoldStrAnsiEqual(P1, P2: PChar; Len: integer): Boolean; -function BoldAnsiEqual(const S1, S2: string): Boolean; -function BoldStrStringEqual(const S1: string; P2: PChar; Len: integer): Boolean; +function BoldStrAnsiEqual(P1, P2: PChar; Len: integer): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} +function BoldAnsiEqual(const S1, S2: string): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} +function BoldStrStringEqual(const S1: string; P2: PChar; Len: integer): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function BoldCaseIndependentPos(const Substr, S: string): Integer; procedure EnumToStrings(aTypeInfo: pTypeInfo; Strings: TStrings); function CapitalisedToSpaced(Capitalised: String): String; @@ -48,7 +53,11 @@ function StrToDateFmt(const S: string; const DateFormat: string; const DateSepar function DateToStrFmt(const aDate: TDateTime; DateFormat: string; const DateSeparatorChar: char = '/'): String; function BoldParseFormattedDateList(const value: String; const formats: TStrings; var Date: TDateTime): Boolean; function BoldParseFormattedDate(const value: String; const formats: array of string; var Date: TDateTime): Boolean; - +{$IFDEF MSWINDOWS} +function FileTimeToDateTime(const FileTime: TFileTime): TDateTime; {$IFDEF BOLD_INLINE} inline; {$ENDIF} +{$ENDIF} +function UserTimeInTicks: Int64; +function TicksToDateTime(Ticks: Int64): TDateTime; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure EnsureTrailing(var Str: String; ch: char); { Taken from FileCtrl to remove unit dependency } function DirectoryExists(const Name: string): Boolean; @@ -60,24 +69,85 @@ function GetModuleFileNameAsString(IncludePath: Boolean): string; {variant support} function BoldVariantToStrings(V: OleVariant; Strings: TStrings): Integer; -const - BoldProductNameShort = 'BfD'; - BoldProductVersion = '4.0'; +{$IFNDEF BOLD_DELPHI13_OR_LATER} +function CharInSet(C: AnsiChar; const CharSet: TSysCharSet): Boolean; overload; {$IFDEF BOLD_INLINE}inline;{$ENDIF} +function CharInSet(C: WideChar; const CharSet: TSysCharSet): Boolean; overload; {$IFDEF BOLD_INLINE}inline;{$ENDIF} +{$ENDIF} -var - BoldRunningAsDesignTimePackage: boolean = false; +var BoldRunningAsDesignTimePackage: boolean = false; implementation uses - BoldCommonConst, - Windows; + BoldRev; {$IFDEF LINUX} const MAX_COMPUTERNAME_LENGTH = 128; {$ENDIF} +{$IFDEF MSWINDOWS} + +type + TFileTimeAligner = record + case integer of + 0: (asFileTime: TFileTime); + 1: (asInt64: Int64); + end; +var + CurrentProcess: THANDLE = 0; + +function FileTimeToDateTime(const FileTime: TFileTime): TDateTime; +const + Nr100nsPerDay = 3600.0*24*10000000; +var + FileTimeAsInt64: Int64; +begin + Move(FileTime, FileTimeAsInt64, 8); + Result := FileTimeAsInt64/Nr100nsPerDay; + +end; +{$ENDIF} + +function UserTimeInTicks: Int64; +var + UserTime, CreationTime, ExitTime, KernelTime: TFileTimeAligner; +begin +{$IFDEF MSWINDOWS} + if CurrentProcess <> 0 then + CloseHandle(CurrentProcess); + CurrentProcess := OpenProcess(PROCESS_QUERY_INFORMATION, False, GetCurrentProcessId); + if GetProcessTimes(CurrentProcess, CreationTime.asFileTime, ExitTime.asFileTime, KernelTime.asFileTime, UserTime.asFileTime) then + Result := UserTime.asInt64 + else + Result := 0; +{$ELSE} + FIXME +{$ENDIF} +end; +function TicksToDateTime(Ticks: Int64): TDateTime; +const + Nr100nsPerDay = 3600.0*24.0*10000000.0; +begin +{$IFDEF MSWINDOWS} + Result := Ticks/Nr100nsPerDay; +{$ELSE} + FIXME +{$ENDIF} +end; + +{$IFNDEF BOLD_DELPHI13_OR_LATER} +function CharInSet(C: AnsiChar; const CharSet: TSysCharSet): Boolean; +begin + Result := C in CharSet; +end; + +function CharInSet(C: WideChar; const CharSet: TSysCharSet): Boolean; +begin + Result := C in CharSet; +end; +{$ENDIF} + { Taken from FileCtrl to remove unit dependency } function DirectoryExists(const Name: string): Boolean; var @@ -91,33 +161,37 @@ function ForceDirectories(Dir: string): Boolean; begin Result := True; if Length(Dir) = 0 then - raise Exception.Create(sCannotCreateDirectory); + raise Exception.Create('Cannot create directory'); Dir := ExcludeTrailingPathDelimiter(Dir); if (Length(Dir) < 3) or DirectoryExists(Dir) - or (ExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem. + or (ExtractFilePath(Dir) = Dir) then Exit; Result := ForceDirectories(ExtractFilePath(Dir)) and CreateDir(Dir); end; function BoldIsPrefix(const S, Prefix: string): Boolean; +{ril - resusing length by variable } +var + PrefixLen: Integer; begin - Result := (Length(s) >= Length(Prefix)) and CompareMem(@s[1], @Prefix[1], Length(Prefix)); + PrefixLen := Length(Prefix); + Result := (Length(s) >= PrefixLen) and CompareMem(@s[1], @Prefix[1], PrefixLen * SizeOf(Char)); end; function BoldStrEqual(P1, P2: PChar; Len: integer): Boolean; begin - Result := CompareMem(P1, P2, Len); + Result := CompareMem(P1, P2, Len * SizeOf(Char)); end; function BoldStrAnsiEqual(P1, P2: PChar; Len: integer): Boolean; begin - Result := CompareMem(P1, P2, Len) or (AnsiStrLIComp(P1, P2, Len) = 0); + Result := CompareMem(P1, P2, Len * SizeOf(Char)) or (AnsiStrLIComp(P1, P2, Len) = 0); end; function BoldStrCaseIndpendentEqual(P1, P2: PChar; Len: integer): Boolean; var ch1, ch2: Char; begin - if not CompareMem(P1, P2, Len) then + if not CompareMem(P1, P2, Len * SizeOf(Char)) then while Len <> 0 do begin ch1 := P1^; @@ -158,7 +232,7 @@ function BoldStrStringEqual(const S1: string; P2: PChar; Len: integer): Boolean; if Len <> Length(S1) then Result := False else - Result := CompareMem(PChar(S1), P2, Len); + Result := CompareMem(PChar(S1), P2, Len * SizeOf(Char)); end; function BoldCaseIndependentPos(const Substr, S: string): Integer; @@ -172,7 +246,7 @@ function BoldCaseIndependentPos(const Substr, S: string): Integer; begin Result := Pos(Substr, S); if (Result = 0) or (Result > SubStrLen) then - Result := Pos(UpperCase(Substr), UpperCase(S)); + Result := Pos(AnsiUpperCase(Substr), AnsiUpperCase(S)); end; end; @@ -185,21 +259,20 @@ procedure EnsureTrailing(var Str: String; ch: char); function BooleanToString(BoolValue: Boolean): String; begin - if BoolValue then Result := 'True' else Result := 'False'; // do not localize + if BoolValue then Result := 'True' else Result := 'False'; end; function StringToBoolean(StrValue: String): Boolean; begin Result := False; - if (UpperCase(StrValue)= 'Y') or (UpperCase(StrValue) = 'T') or (UpperCase(StrValue) = 'TRUE') then // do not localize + if (UpperCase(StrValue)= 'Y') or (UpperCase(StrValue) = 'T') or (UpperCase(StrValue) = 'TRUE') then Result := True; end; function BoldRootRegistryKey: string; begin - // Returns something like this: Software\BoldSoft\BfD20D5Pro\2.0 - Result := Format('Software\BoldSoft\%s\%s', // do not localize - [BoldProductNameShort, BoldProductVersion]); + Result := Format('Software\BoldSoft\%s\%s', + [BoldProductNameShort,BoldProductVersion]); end; function GetModuleFileNameAsString(IncludePath: Boolean): string; @@ -212,7 +285,7 @@ function GetModuleFileNameAsString(IncludePath: Boolean): string; if IncludePath then Result := ModuleName else - Result := ExtractFileName(ModuleName); + Result := ExtractFileName(ModuleName); end; procedure EnumToStrings(aTypeInfo: pTypeInfo; Strings: TStrings); @@ -227,30 +300,119 @@ procedure EnumToStrings(aTypeInfo: pTypeInfo; Strings: TStrings); function BoldNamesEqual(const name1, name2: string): Boolean; begin - Result := (AnsiCompareText(name1, name2) = 0); + Result := (CompareText(name1, name2) = 0); end; -function BoldSeparateStringList(strings: TStringList; const Separator, PreString, PostString: String): String; +function BoldSeparateStringList(strings: TStringList; const Separator, PreString, PostString: String; AIndex: integer): String; +{$IFDEF RIL} +var + i, Cnt, Size: integer; + SB: TStringBuilder; +begin + Cnt := strings.Count; + case Cnt of + 0: Result := ''; + 1: Result := PreString + Strings[0] + PostString; + else + begin + Size := length(PreString) + length(PostString); + for I := 0 to Cnt - 1 do + Inc(Size, Length(Strings[I])); + Inc(Size, Length(Separator) * Cnt); + SB := TStringBuilder.Create(Size); + SB.Append(PreString); + for i := 0 to Cnt-2 do + begin + //result := result + Strings[i] + Separator; + SB.Append(Strings[i]); + if AIndex <> -1 then + SB.Append(IntToStr(AIndex)); + SB.Append(Separator); + end; + // result := result + Strings[Strings.Count - 1] + SB.Append(Strings[Cnt-1]); + if AIndex <> -1 then + SB.Append(IntToStr(AIndex)); + { no need to check Cnt again it IS > 0 so: } + // result := PreString + result +PostString; + SB.Append(PostString); + Result := SB.ToString; + FreeAndNil(SB); + end; + end; +{$ELSE} var i: integer; - begin result := ''; - if strings.Count > 0 then begin for i := 0 to strings.Count-2 do - result := result + Strings[i] + Separator; - result := result + Strings[Strings.Count - 1] + begin + result := result + Strings[i]; + if AIndex <> -1 then + result := result + IntToStr(AIndex); + result := result + Separator; + end; + result := result + Strings[Strings.Count - 1]; + if AIndex <> -1 then + result := result + IntToStr(AIndex); end else result := ''; - if strings.Count > 0 then result := PreString + result +PostString; +{$ENDIF} end; -procedure BoldAppendTostrings(Strings: TStrings; const aString: string; const ForceNewLine: Boolean); +procedure BoldAppendToStrings(Strings: TStrings; const aString: string; const ForceNewLine: Boolean); +{$IFDEF RIL} +var + StrCount, SplitterPos: Integer; + SB: TStringBuilder; + TempStr: string; +begin + + { replace all LFs and CRs in string with space chars. This is "Superfast" : } + if (Pos(BOLDLF, aString)>0) or (Pos(BOLDCR, aString)>0) then + begin + SB := TStringBuilder.Create(aString); + SB.Replace(BOLDCR, ' '); + SB.Replace(BOLDLF, ' '); + TempStr := SB.ToSTring; + FreeAndNil(SB); + end + else + TempStr := aString; + + Strings.BeginUpdate; + try + StrCount := Strings.Count-1; + if (StrCount = -1) or ForceNewLine then + begin + Strings.Add(TempStr); + Inc(StrCount); + end + else + Strings[StrCount] := Strings[StrCount] + TempStr; + + { break lines into max 80 chars per line } + while Length(Strings[StrCount]) > 80 do + begin + SplitterPos := 80; + + while (Pos(Strings[StrCount][SplitterPos],' ,=')=0) and (SplitterPos > 1) do + Dec(SplitterPos); + + Strings.Append(Copy(Strings[StrCount], SplitterPos + 1, 65536)); + Strings[StrCount] := Copy(Strings[StrCount], 1, SplitterPos); + + Inc(StrCount); + end; + finally + Strings.EndUpdate; + end; +{$ELSE} var StrCount: integer; i: integer; @@ -261,7 +423,7 @@ procedure BoldAppendTostrings(Strings: TStrings; const aString: string; const Fo try TempStr := aString; for i := 1 to length(TempStr) do - if TempStr[i] in [BOLDLF, BOLDCR] then + if CharInSet(TempStr[i], [BOLDLF, BOLDCR]) then TempStr[i] := ' '; StrCount := Pred(Strings.Count); if (StrCount = -1) or ForceNewLine then @@ -282,6 +444,7 @@ procedure BoldAppendTostrings(Strings: TStrings; const aString: string; const Fo finally Strings.EndUpdate; end; +{$ENDIF} end; function BoldSeparatedAppend(const S1, S2: string; const Separator: string = ','): string; @@ -337,7 +500,6 @@ function CapitalisedToSpaced(Capitalised: String): String; Start: Integer; begin Result := ''; - //if Pos('Neo',Capitalised)= 1 then Start := 4 else Start := 1; Start := 1; for I := Start to Length(Capitalised) do if (I>1) and (Capitalised[I] >= 'A') and (Capitalised[I] <= 'Z') @@ -371,7 +533,6 @@ function GetUpperLimitForMultiplicity(const Multiplicity: String): Integer; var p: Integer; begin - // unspecified multilicity is 0..1 if (Multiplicity = '') or (BoldTrim(Multiplicity) = '') then result := 1 @@ -411,7 +572,7 @@ function IsLocalMachine(const Machinename: WideString): Boolean; MachName:= BoldTrim(MachineName); Result := (MachName = '') or (AnsiCompareText(GetComputerNameStr, MachName) = 0); end; - +{$IFDEF MSWINDOWS} function GetComputerNameStr: string; var Size: DWORD; @@ -421,6 +582,14 @@ function GetComputerNameStr: string; GetComputerName(LocalMachine, Size); Result := LocalMachine; end; +{$ENDIF} + +{$IFDEF LINUX} +function GetComputerNameStr: string; +begin + Result := 'MyMachine'; +end; +{$ENDIF} function TimeStampComp(const Time1, Time2: TTimeStamp): Integer; var @@ -441,13 +610,13 @@ function StrToDateFmt(const S: string; const DateFormat: string; const DateSepar PreviousShortDateFormat: string; PreviousDateSeparator: char; begin - PreviousShortDateFormat := FormatSettings.ShortDateFormat; - FormatSettings.ShortDateFormat := DateFormat; - PreviousDateSeparator := FormatSettings.DateSeparator; - FormatSettings.DateSeparator := DateSeparatorChar; + PreviousShortDateFormat := {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}ShortDateFormat; + {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}ShortDateFormat := DateFormat; + PreviousDateSeparator := {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}DateSeparator; + {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}DateSeparator := DateSeparatorChar; Result := StrToDateTime(S); - FormatSettings.ShortDateFormat := PreviousShortDateFormat; - FormatSettings.DateSeparator := PreviousDateSeparator; + {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}ShortDateFormat := PreviousShortDateFormat; + {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}DateSeparator := PreviousDateSeparator; end; function DateToStrFmt(const aDate: TDateTime; DateFormat: string; const DateSeparatorChar: char = '/'): String; @@ -455,13 +624,13 @@ function DateToStrFmt(const aDate: TDateTime; DateFormat: string; const DateSepa PreviousShortDateFormat: string; PreviousDateSeparator: char; begin - PreviousShortDateFormat := FormatSettings.ShortDateFormat; - FormatSettings.ShortDateFormat := DateFormat; - PreviousDateSeparator := FormatSettings.DateSeparator; - FormatSettings.DateSeparator := DateSeparatorChar; + PreviousShortDateFormat := {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}ShortDateFormat; + {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}ShortDateFormat := DateFormat; + PreviousDateSeparator := {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}DateSeparator; + {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}DateSeparator := DateSeparatorChar; Result := DateToStr(aDate); - FormatSettings.ShortDateFormat := PreviousShortDateFormat; - FormatSettings.DateSeparator := PreviousDateSeparator; + {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}ShortDateFormat := PreviousShortDateFormat; + {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}DateSeparator := PreviousDateSeparator; end; function BoldVariantToStrings(V: OleVariant; Strings: TStrings): Integer; @@ -518,8 +687,11 @@ function BoldParseFormattedDateList(const Value: String; const formats: TStrings else if not (value[i] = format[i]) then exit; end; - if (format[i] in ['y', 'm', 'd']) and not (value[i] in ['0'..'9']) then + if CharInSet(format[i], ['y', 'm', 'd']) and + (not CharInSet(value[i], ['0'..'9'])) then + begin exit; + end; end; if length(y) = 0 then year := CurrentYear @@ -528,7 +700,7 @@ function BoldParseFormattedDateList(const Value: String; const formats: TStrings year := StrToInt(y); if length(y) = 2 then begin - if year < ((CurrentYear + FormatSettings.TwoDigitYearCenturyWindow) mod 100) then + if year < ((CurrentYear + {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}TwoDigitYearCenturyWindow) mod 100) then year := year + (CurrentYear div 100)*100 else year := year + ((CurrentYear div 100)+1)*100; diff --git a/Source/Common/Support/BoldXMLStreaming.pas b/Source/Common/Support/BoldXMLStreaming.pas index 6f9b3804..f73d7f5e 100644 --- a/Source/Common/Support/BoldXMLStreaming.pas +++ b/Source/Common/Support/BoldXMLStreaming.pas @@ -1,9 +1,13 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldXMLStreaming; interface uses - MSXML_TLB, + {$IFDEF OXML}OXmlPDOM{$ELSE}Bold_MSXML_TLB{$ENDIF}, + BoldDefs, BoldBase, BoldStreams, BoldIndexableList, @@ -41,23 +45,28 @@ TBoldXMLStreamStateManager = class(TBoldMemoryManagedObject) { TBoldXMLNode } TBoldXMLNode = class(TBoldMemoryManagedObject) private - fNode: IXMLDOMElement; + fNode: {$IFDEF OXML}PXMLNode{$ELSE}IXMLDOMElement{$ENDIF}; fManager: TBoldXMLStreamManager; fStateManager: TBoldXMLStreamStateManager; procedure EnsureType(const DynamicStreamName, StaticStreamName: string); function GetType(const StaticStreamName: string): string; + {$IFNDEF OXML} function GetDocument: IXMLDOMDocument; property Document: IXMLDOMDocument read GetDocument; + {$ENDIF} function GetAccessor: string; function GetIsNull: Boolean; public - constructor Create(Manager: TBoldXMLStreamManager; Node: IXMLDomElement; StreamStateManager: TBoldXMLStreamStateManager); + constructor Create(Manager: TBoldXMLStreamManager; Node: + {$IFDEF OXML}PXMLNode{$ELSE}IXMLDOMElement{$ENDIF}; StreamStateManager: + TBoldXMLStreamStateManager); function GetSubNode(const Accessor: string): TBoldXMLNode; function IsEmpty: Boolean; function NewSubNode(const Accessor: string): TBoldXMLNode; - function MakeNodeForElement(Element: IXMLDOMElement): TBoldXMLNode; + function MakeNodeForElement(Element: + {$IFDEF OXML}PXMLNode{$ELSE}IXMLDOMElement{$ENDIF}): TBoldXMLNode; function ReadBoolean: Boolean; - procedure ReadInterface(const StreamName: string; Item: IBoldStreamable); + procedure ReadInterface(const StreamName: string; const Item: IBoldStreamable); function ReadInteger: Integer; function ReadObject(const StreamName: string): TObject; function ReadString: string; @@ -65,19 +74,20 @@ TBoldXMLNode = class(TBoldMemoryManagedObject) function ReadCurrency: Currency; function ReadSubNodeBoolean(const Accessor: string): Boolean; function ReadSubNodeInteger(const Accessor: string): Integer; - function ReadSubNodeObject(const Accessor: string; const StreamName: string): TObject; - function ReadSubNodeString(const Accessor: string): String; //The caller of this function should take care of freeing the result object + function ReadSubNodeObject(const Accessor, StreamName: string): TObject; //The caller of this function should take care of freeing the result object + function ReadSubNodeString(const Accessor: string): String; function ReadSubNodeFloat(const Accessor: string): Double; procedure WriteBoolean(Value: Boolean); procedure WriteInteger(Value: Integer); - procedure WriteInterface(const StaticStreamName: string; Item: IBoldStreamable); + procedure WriteInterface(const StaticStreamName: string; const Item: IBoldStreamable); procedure WriteObject(const StaticStreamName: string; Obj: TBoldInterfacedObject); procedure WriteString(const Value: string); procedure WriteFloat(value: Double); procedure WriteCurrency(value: Currency); procedure WriteSubNodeBoolean(const Accessor: string; Value: Boolean); procedure WriteSubNodeInteger(const Accessor: string; Value: Integer); - procedure WriteSubNodeObject(const Accessor: string; const StaticStreamName: string; Obj: TBoldInterfacedObject); + procedure WriteSubNodeObject(const Accessor, StaticStreamName: string; Obj: + TBoldInterfacedObject); procedure WriteSubNodeString(const Accessor: string; const Value: String); procedure WriteSubNodeFloat(const Accessor: string; Value: Double); @@ -96,16 +106,17 @@ TBoldXMLNode = class(TBoldMemoryManagedObject) procedure WriteDateTime(Value: TDateTime); procedure WriteSubNodeDateTime(const Accessor: string; Value: TDateTime); - function ReadData: string; - function ReadSubNodeData(const Accessor: string): string; - procedure WriteData(Value: string); - procedure WriteSubNodeData(const Accessor: string; const Value: string); + function ReadData: TBoldAnsiString; + function ReadSubNodeData(const Accessor: string): TBoldAnsiString; + procedure WriteData(Value: TBoldAnsiString); + procedure WriteSubNodeData(const Accessor: string; const Value: TBoldAnsiString); procedure AddStateObject(const Name: string; StateObject: TObject); procedure RemoveStateObject(const Name: string); function GetStateObject(const Name: String): TObject; property Manager: TBoldXMLStreamManager read fManager; - property XMLDomElement: IXMLDOMElement read fNode; + property XMLDomElement: {$IFDEF OXML}PXMLNode{$ELSE}IXMLDOMElement{$ENDIF} + read fNode; property Accessor: string read GetAccessor; property IsNull: Boolean read GetIsNull; procedure SetToNull; @@ -132,10 +143,16 @@ TBoldXMLStreamManager = class(TBoldMemoryManagedObject) fRegistry: TBoldXMLStreamerRegistry; public constructor Create(Registry: TBoldXMLStreamerRegistry); - function GetRootNode(Document: TDomDocument; const Accessor: string): TBoldXMLNode; - function NewRootNode(Document: TDomDocument; const Accessor: string): TBoldXMLNode; - function GetSOAP(Document: TDomDocument): TBoldXMLNode; - function NewSOAP(Document: TDomDocument): TBoldXMLNode; + function GetRootNode(Document: + {$IFDEF OXML}TXMLDocument{$ELSE}TDomDocument{$ENDIF}; const Accessor: + string): TBoldXMLNode; + function NewRootNode(Document: + {$IFDEF OXML}TXMLDocument{$ELSE}TDomDocument{$ENDIF}; const Accessor: + string): TBoldXMLNode; + function GetSOAP(Document: + {$IFDEF OXML}TXMLDocument{$ELSE}TDomDocument{$ENDIF}): TBoldXMLNode; + function NewSOAP(Document: + {$IFDEF OXML}TXMLDocument{$ELSE}TDomDocument{$ENDIF}): TBoldXMLNode; property Registry: TBoldXMLStreamerRegistry read fRegistry; end; @@ -167,19 +184,18 @@ TBoldXMLObjectStreamer = class(TBoldXMLStreamer) { TBoldXMLInterfaceStreamer } TBoldXMLInterfaceStreamer = class(TBoldXMLStreamer) public - procedure WriteInterface(Item: IBoldStreamable; Node: TBoldXMLNode); virtual; - procedure ReadInterface(Item: IBoldStreamable; Node: TBoldXMLNode); virtual; + procedure WriteInterface(const Item: IBoldStreamable; Node: TBoldXMLNode); virtual; + procedure ReadInterface(const Item: IBoldStreamable; Node: TBoldXMLNode); virtual; end; implementation uses SysUtils, - BoldUtils, - BoldDefs, BoldHashIndexes, + {$IFDEF OXML}OXmlUtils,{$ENDIF} BoldBase64, - BoldCommonConst; + BoldUtils; const BoldNodeName_Year = 'Year'; @@ -207,20 +223,21 @@ TBoldXMLStreamerIndex = class(TBoldStringHashIndex) procedure PushFloatSettings; begin if FloatSettingsPushed then - raise EBold.Create(sCannotNestPushFloat); + raise EBold.Create('Nested calls to PushFloatSettings not allowed'); FloatSettingsPushed := true; - oldDecimalSeparator := FormatSettings.DecimalSeparator; - FormatSettings.DecimalSeparator := '.'; - oldThousandSeparator := FormatSettings.ThousandSeparator; - FormatSettings.ThousandSeparator := ','; + FloatSettingsPushed := true; + oldDecimalSeparator := {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}DecimalSeparator; + {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}DecimalSeparator := '.'; + oldThousandSeparator := {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}ThousandSeparator; + {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}ThousandSeparator := ','; end; procedure PopFloatSettings; begin if not FloatSettingsPushed then - raise EBold.Create(sPushNestMismatch); - FormatSettings.DecimalSeparator := oldDecimalSeparator; - FormatSettings.ThousandSeparator := oldThousandSeparator; + raise EBold.Create('Not allowed to call PopFloatSettins without previous call to PushFloatSettings'); + {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}DecimalSeparator := oldDecimalSeparator; + {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}ThousandSeparator := oldThousandSeparator; oldDecimalSeparator := '*'; oldThousandSeparator := '#'; FloatSettingsPushed := false; @@ -257,7 +274,7 @@ function TBoldXMLStreamerRegistry.GetStreamer(const Name: string): TBoldXMLStrea result := fParentRegistry.GetStreamer(Name); if not assigned(result) then - raise EBoldInternal.CreateFmt(sStreamerNotFound, [classname, name]); + raise EBoldInternal.CreateFmt('%s.GetStreamer: streamer for %s not found', [classname, name]); end; class function TBoldXMLStreamerRegistry.MainStreamerRegistry: TBoldXMLStreamerRegistry; @@ -280,7 +297,7 @@ procedure TBoldXMLObjectStreamer.ReadObject(Obj: TObject; Node: TBoldXMLNode); procedure TBoldXMLObjectStreamer.WriteObject(Obj: TBoldInterfacedObject; Node: TBoldXMLNode); begin -end; +end; { TBoldXMLNode } @@ -312,13 +329,24 @@ function TBoldXMLNode.ReadObject(const StreamName: string): TObject; end; function TBoldXMLNode.GetSubNode(const Accessor: string): TBoldXMLNode; +{$IFDEF OXML} +var + aNode: PXMLNode; +begin + Result := nil; + if FNode.ChildNodes.FindNode(Accessor, aNode) then begin + if aNode.NodeType = ntElement then begin + Result := TBoldXMLNode.Create(FManager, aNode, FStateManager); + end; + end; +end; +{$ELSE} var aList: IXMLDOMNodeList; aNode: IXMLDOMNode; anElement: IXMLDOMElement; begin - // this sucks. We shouldn't have to iterate our selves, but using - // GetElementsByTagName searches also lower levels than true child-nodes :-( + result := nil; aList := fNode.childNodes; aNode := aList.nextNode; @@ -336,56 +364,72 @@ function TBoldXMLNode.GetSubNode(const Accessor: string): TBoldXMLNode; aNode := aList.nextNode; end; end; +{$ENDIF} -constructor TBoldXMLNode.Create(Manager: TBoldXMLStreamManager; Node: IXMLDomElement; StreamStateManager: TBoldXMLStreamStateManager); +constructor TBoldXMLNode.Create(Manager: TBoldXMLStreamManager; Node: + {$IFDEF OXML}PXMLNode{$ELSE}IXMLDOMElement{$ENDIF}; StreamStateManager: + TBoldXMLStreamStateManager); begin fNode := Node; fManager := Manager; fStatemanager := StreamStateManager; end; +{$IFNDEF OXML} +function TBoldXMLNode.GetDocument: IXMLDOMDocument; +begin + result := fNode.ownerDocument; +end; +{$ENDIF} + function TBoldXMLNode.NewSubNode(const Accessor: string): TBoldXMLNode; var - aNode: IXMLDOMElement; + aNode: {$IFDEF OXML}PXMLNode{$ELSE}IXMLDOMElement{$ENDIF}; begin + {$IFDEF OXML} + aNode := fNode.AddChild(Accessor); + {$ELSE} aNode := Document.createElement(Accessor); fNode.appendChild(aNode); - result := TBoldXMLNode.Create(fManager, aNode, fStatemanager); + {$ENDIF} + result := TBoldXMLNode.Create(fManager, aNode, fStateManager); end; procedure TBoldXMLNode.WriteString(const Value: string); begin + {$IFDEF OXML} + fNode.AddText(Value); + {$ELSE} fNode.appendChild(Document.createTextNode(Value)); + {$ENDIF} end; function TBoldXMLNode.ReadString: string; var - aNode: IXMLDOMNode; + aNode: {$IFDEF OXML}PXMLNode{$ELSE}IXMLDOMNode{$ENDIF}; begin - aNode := fNode.childNodes.nextNode; - if assigned(aNode) and (aNode.nodeType = NODE_TEXT) then - result := aNode.Text - else + aNode := {$IFDEF OXML}fNode.ChildNodes.GetFirst + {$ELSE}fNode.childNodes.nextNode{$ENDIF}; + if assigned(aNode) and (aNode.nodeType = + {$IFDEF OXML}ntText{$ELSE}NODE_TEXT{$ENDIF}) then + begin + result := aNode.Text; + end else begin result := ''; + end; end; function TBoldXMLNode.ReadBoolean: Boolean; begin - result := (ReadString = '1'); //do not localize + result := ReadString = '1'; end; procedure TBoldXMLNode.WriteBoolean(Value: Boolean); begin if Value then - WriteString('1') //do not localize + WriteString('1') else - WriteString('0'); //do not localize -end; - -function TBoldXMLNode.GetDocument: IXMLDOMDocument; -begin - result := fNode.ownerDocument; -// result := fManager.fDocument; + WriteString('0'); end; function TBoldXMLNode.ReadInteger: Integer; @@ -398,7 +442,7 @@ procedure TBoldXMLNode.WriteInteger(Value: Integer); WriteString(IntToStr(Value)); end; -procedure TBoldXMLNode.WriteInterface(const StaticStreamName: string; Item: IBoldStreamable); +procedure TBoldXMLNode.WriteInterface(const StaticStreamName: string; const Item: IBoldStreamable); var DynamicStreamName: string; begin @@ -413,7 +457,7 @@ procedure TBoldXMLNode.EnsureType(const DynamicStreamName, StaticStreamName: str fNode.setAttribute(BoldSOAPTypeAttributeName, DynamicStreamName); end; -procedure TBoldXMLNode.ReadInterface(const StreamName: string; Item: IBoldStreamable); +procedure TBoldXMLNode.ReadInterface(const StreamName: string; const Item: IBoldStreamable); var aStreamer: TBoldXMLInterfaceStreamer; begin @@ -423,13 +467,14 @@ procedure TBoldXMLNode.ReadInterface(const StreamName: string; Item: IBoldStream function TBoldXMLNode.GetType(const StaticStreamName: string): string; var - anAttr: IXMLDOMAttribute; + anAttr: {$IFDEF OXML}PXMLNode{$ELSE}IXMLDOMAttribute{$ENDIF}; begin anAttr := fNode.getAttributeNode(BoldSOAPTypeAttributeName); - if assigned(anAttr) then - result := anAttr.Value - else + if assigned(anAttr) then begin + result := {$IFDEF OXML}anAttr.NodeValue{$ELSE}anAttr.Value{$ENDIF}; + end else begin result := StaticStreamName; + end; end; function TBoldXMLNode.GetAccessor: string; @@ -441,8 +486,6 @@ function TBoldXMLNode.IsEmpty: Boolean; begin result := not XMLDomElement.hasChildNodes; end; - -// The caller of this function should take care of freeing the returned object function TBoldXMLNode.ReadSubNodeObject(const Accessor, StreamName: string): TObject; var aSubNode: TBoldXMLNode; @@ -556,8 +599,11 @@ function TBoldXMLNode.ReadFloat: Double; procedure TBoldXMLNode.WriteFloat(value: Double); begin PushFloatSettings; - WriteString(FloatToStr(Value)); - PopFloatSettings; + try + WriteString(FloatToStr(Value)); + finally + PopFloatSettings; + end; end; function TBoldXMLNode.ReadSubNodeFloat(const Accessor: string): Double; @@ -609,7 +655,8 @@ procedure TBoldXMLNode.RemoveStateObject(const Name: string); end; end; -function TBoldXMLNode.MakeNodeForElement(Element: IXMLDOMElement): TBoldXMLNode; +function TBoldXMLNode.MakeNodeForElement(Element: + {$IFDEF OXML}PXMLNode{$ELSE}IXMLDOMElement{$ENDIF}): TBoldXMLNode; begin result := TBoldXMLNode.Create(Manager, Element, fStateManager); end; @@ -734,15 +781,15 @@ procedure TBoldXMLNode.WriteSubNodeDateTime(const Accessor: string; end; end; -procedure TBoldXMLNode.WriteData(Value: string); +procedure TBoldXMLNode.WriteData(Value: TBoldAnsiString); - function IncludesIllegalChar(Value: string): Boolean; + function IncludesIllegalChar(Value: TBoldAnsiString): Boolean; var i: Integer; begin result := true; for i := 1 to Length(Value) do - if not (Value[i] in [#9, BOLDLF, BOLDCR, #32..#255]) then + if not CharInSet(Value[i], [#9, BOLDLF, BOLDCR, #32..#255]) then exit; result := false; end; @@ -755,36 +802,38 @@ procedure TBoldXMLNode.WriteData(Value: string); begin Encoder := TBase64.Create; Encoder.EncodeData(Value, DataString); - XMLDomElement.setAttribute('dt', 'binary.base64'); // do not localize + XMLDomElement.setAttribute('dt', 'binary.base64'); Encoder.Free; end else - DataString := Value; + DataString := String(Value); WriteString(DataString); end; -function TBoldXMLNode.ReadData: string; +function TBoldXMLNode.ReadData: TBoldAnsiString; var - anAttr: IXMLDOMAttribute; + anAttr: {$IFDEF OXML}PXMLNode{$ELSE}IXMLDOMAttribute{$ENDIF}; DataString: string; Decoder: TBase64; begin DataString := ReadString; anAttr := fNode.getAttributeNode('dt'); // do not localize - if assigned(anAttr) and (anAttr.Value = 'binary.base64') then // do not localize + if assigned(anAttr) and ( + {$IFDEF OXML}anAttr.NodeValue{$ELSE}anAttr.Value{$ENDIF} = 'binary.base64') then // do not localize begin Decoder := TBase64.Create; - Decoder.DecodeData(DataString, result); + Decoder.DecodeData(DataString, Result); Decoder.Free; end else - result := DataString; + result := TBoldAnsiString(DataString); // without Base64 there are only AnsiChars end; function TBoldXMLNode.GetIsNull: Boolean; var - anAttr: IXMLDOMAttribute; + anAttr: {$IFDEF OXML}PXMLNode{$ELSE}IXMLDOMAttribute{$ENDIF}; begin anAttr := XMLDomElement.getAttributeNode(BoldSOAPNullAttributeName); - result := assigned(anAttr) and (anAttr.Value = '1'); + result := assigned(anAttr) and ( + {$IFDEF OXML}anAttr.NodeValue{$ELSE}anAttr.Value{$ENDIF} = '1'); end; procedure TBoldXMLNode.SetToNull; @@ -792,7 +841,7 @@ procedure TBoldXMLNode.SetToNull; XMLDomElement.setAttribute(BoldSOAPNullAttributeName, '1'); end; -function TBoldXMLNode.ReadSubNodeData(const Accessor: string): string; +function TBoldXMLNode.ReadSubNodeData(const Accessor: string): TBoldAnsiString; var aSubNode: TBoldXMLNode; begin @@ -804,7 +853,7 @@ function TBoldXMLNode.ReadSubNodeData(const Accessor: string): string; end; end; -procedure TBoldXMLNode.WriteSubNodeData(const Accessor, Value: string); +procedure TBoldXMLNode.WriteSubNodeData(const Accessor: string; const Value: TBoldAnsiString); var aSubNode: TBoldXMLNode; begin @@ -839,11 +888,11 @@ procedure TBoldXMLNode.WriteCurrency(value: Currency); { TBoldXMLInterfaceStreamer } -procedure TBoldXMLInterfaceStreamer.ReadInterface(Item: IBoldStreamable; Node: TBoldXMLNode); +procedure TBoldXMLInterfaceStreamer.ReadInterface(const Item: IBoldStreamable; Node: TBoldXMLNode); begin end; -procedure TBoldXMLInterfaceStreamer.WriteInterface(Item: IBoldStreamable; Node: TBoldXMLNode); +procedure TBoldXMLInterfaceStreamer.WriteInterface(const Item: IBoldStreamable; Node: TBoldXMLNode); begin end; @@ -854,20 +903,27 @@ constructor TBoldXMLStreamManager.Create(Registry: TBoldXMLStreamerRegistry); fRegistry := Registry; end; -function TBoldXMLStreamManager.GetRootNode(Document: TDomDocument; const Accessor: string): TBoldXMLNode; +function TBoldXMLStreamManager.GetRootNode(Document: + {$IFDEF OXML}TXMLDocument{$ELSE}TDomDocument{$ENDIF}; const Accessor: + string): TBoldXMLNode; +var + sTagName: string; begin if not assigned(Document) then - raise EBold.CreateFmt(sStreamerNotConnected, [classname, 'GetRootNode']); //do not localize + raise EBold.CreateFmt('%s.GetRootNode: Streamer is not connected to a Document', [classname]); if not assigned(Document.documentElement) then - raise EBold.CreateFmt(sDocumentHasNoRootNode, [classname]); - if (Accessor <> '') and (Document.documentElement.tagName <> Accessor) then - raise EBold.CreateFmt(sWrongTagName, - [classname, Document.documentElement.tagName, Accessor]); + raise EBold.CreateFmt('%s.GetRootNode: Document does not have root node', [classname]); + sTagName := {$IFDEF OXML}Document.documentElement.NodeName{$ELSE} + Document.documentElement.tagName{$ENDIF}; + if (Accessor <> '') and (sTagName <> Accessor) then + raise EBold.CreateFmt('%s.GetRootNode: Wrong tag name, is %s, should be %s', + [classname, sTagName, Accessor]); result := TBoldXMLNode.Create(self, Document.documentElement, nil); end; -function TBoldXMLStreamManager.GetSOAP(Document: TDomDocument): TBoldXMLNode; +function TBoldXMLStreamManager.GetSOAP(Document: + {$IFDEF OXML}TXMLDocument{$ELSE}TDomDocument{$ENDIF}): TBoldXMLNode; var aNode: TBoldXMLNode; begin @@ -876,27 +932,30 @@ function TBoldXMLStreamManager.GetSOAP(Document: TDomDocument): TBoldXMLNode; aNode.Free; end; -function TBoldXMLStreamManager.NewRootNode(Document: TDomDocument; const Accessor: string): TBoldXMLNode; +function TBoldXMLStreamManager.NewRootNode(Document: + {$IFDEF OXML}TXMLDocument{$ELSE}TDomDocument{$ENDIF}; const Accessor: + string): TBoldXMLNode; begin if not assigned(Document) then - raise EBold.CreateFmt(sStreamerNotConnected, [classname, 'NewRootNode']); // do not localize + raise EBold.CreateFmt('%s.NewRootNode: Streamer is not connected to a Document', [classname]); if assigned(Document.documentElement) then - raise EBold.CreateFmt(sDocumentHasRootNode, [classname]); + raise EBold.CreateFmt('%s.NewRootNode: Document already has root node', [classname]); Document.documentElement := Document.createElement(Accessor); result := TBoldXMLNode.Create(self, Document.documentElement, nil); - result.XMLDomElement.setAttribute('xmlns:xsi', 'http://www.w3.org/1999/XMLSchema-instance'); // do not localize - result.XMLDomElement.setAttribute('xml:space', 'preserve'); // do not localize + result.XMLDomElement.setAttribute('xmlns:xsi', 'http://www.w3.org/1999/XMLSchema-instance'); + result.XMLDomElement.setAttribute('xml:space', 'preserve'); end; -function TBoldXMLStreamManager.NewSOAP(Document: TDomDocument): TBoldXMLNode; +function TBoldXMLStreamManager.NewSOAP(Document: + {$IFDEF OXML}TXMLDocument{$ELSE}TDomDocument{$ENDIF}): TBoldXMLNode; var aNode: TBoldXMLNode; begin - aNode := NewRootNode(Document, 'SOAP-ENV:Envelope'); // do not localize - aNode.XMLDomElement.setAttribute('xmlns:SOAP-ENV', 'http://schemas.xmlsoap.org/soap/envelope/'); // do not localize - aNode.XMLDomElement.setAttribute('SOAP-ENV:encodingStyle', 'http://schemas.xmlsoap.org/soap/encoding/'); // do not localize - result := aNode.NewSubNode('SOAP-ENV:Body'); // do not localize + aNode := NewRootNode(Document, 'SOAP-ENV:Envelope'); + aNode.XMLDomElement.setAttribute('xmlns:SOAP-ENV', 'http://schemas.xmlsoap.org/soap/envelope/'); + aNode.XMLDomElement.setAttribute('SOAP-ENV:encodingStyle', 'http://schemas.xmlsoap.org/soap/encoding/'); + result := aNode.NewSubNode('SOAP-ENV:Body'); aNode.Free; end; @@ -914,10 +973,10 @@ constructor TBoldXMLStreamStateManager.create; fStateObjectList.Sorted := true; end; -destructor TBoldXMLStreamStateManager.Destroy; +destructor TBoldXMLStreamStateManager.destroy; begin freeAndNil(fStateObjectList); - inherited; + inherited; end; function TBoldXMLStreamStateManager.GetEmpty: Boolean; @@ -967,7 +1026,7 @@ function TBoldXMLStreamerIndex.ItemASKeyString(Item: TObject): string; result := TBoldXMLStreamer(Item).StreamName; end; -initialization // empty +initialization finalization FreeAndNil(G_MainRegistry); diff --git a/Source/Common/SupportWin/BoldThread.pas b/Source/Common/SupportWin/BoldThread.pas index 4f69f001..52fd239a 100644 --- a/Source/Common/SupportWin/BoldThread.pas +++ b/Source/Common/SupportWin/BoldThread.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldThread; interface @@ -44,9 +47,9 @@ implementation uses SysUtils, Messages, - BoldPropagatorConstants, { TODO : Move TIMEOUT to BoldDefs } - BoldThreadSafeLog, - BoldCommonConst; + BoldPropagatorConstants, + BoldThreadSafeLog, + BoldRev; function WaitForObject (iHandle : THandle; iTimeOut : dword) : TWaitResult; begin @@ -83,12 +86,14 @@ procedure TBoldNotifiableThread.EnsureMessageQueue; var rMsg:TMsg; begin - PeekMessage(rMsg, 0, 0, 0, PM_NOREMOVE); // force thread message queue! + PeekMessage(rMsg, 0, 0, 0, PM_NOREMOVE); end; +{$Assertions On} + procedure TBoldNotifiableThread.Notify(const Msg: Cardinal); begin - PostThreadMessage(ThreadID, Msg, 0, 0); + Assert(PostThreadMessage(ThreadID, Msg, 0, 0), SysErrorMessage(GetLastError)); end; function TBoldNotifiableThread.WaitUntilReady(dwMilliseconds: Cardinal): Boolean; @@ -112,7 +117,7 @@ function TBoldNotifiableThread.Quit(Wait: Boolean): Boolean; begin Resume; WaitUntilReady(TIMEOUT); - SwitchToThread; //REVIEW ME + SwitchToThread; end; if not (Terminated) then begin @@ -121,7 +126,7 @@ function TBoldNotifiableThread.Quit(Wait: Boolean): Boolean; Result := WaitForQuit else Result := (WaitForObject(Handle, Timeout*2) = wrSignaled); - end; + end; end; procedure TBoldNotifiableThread.Execute; @@ -134,11 +139,10 @@ procedure TBoldNotifiableThread.Execute; while not Terminated do begin res := Integer(GetMessage(rMsg, 0, 0, 0)); - if res = -1 then //error + if res = -1 then Terminate - else if res = 0 then // terminated + else if res = 0 then Terminate - //handle message else ProcessMessage(rMsg); end; @@ -161,26 +165,23 @@ function TBoldNotifiableThread.WaitForQuit: Boolean; Result := false; try Assert(ThreadId <> GetCurrentThreadId, - 'Message queue thread cannot be terminated from within its own thread!!!' // do not localize + 'Message queue thread cannot be terminated from within its own thread!!!' ); wr := WaitForObject(Handle, timeout*5); - - //if thread is not properly terminated, then force terminate it Result := (wr = wrSignaled); if (wr <> wrSignaled) then begin TerminateThread (Handle, 1); - BoldLogError(sThreadWasForcedTerminated, [ClassName]); + BoldLogError('%s.WaitForQuit: thread was force terminated', [ClassName]); end; except on E:Exception do - BoldLogError(sErrorWaitForQuit, [ClassName, E.Message]); + BoldLogError('%s.WaitForQuit: %s', [ClassName, E.Message]); end; end; class procedure TBoldNotifiableThread.CreateQueueWindow( var ServerWindow: HWnd); begin - //impelement in subsclasses that use queue windows end; procedure TBoldNotifiableThread.InitServerWindow(bInit: boolean); @@ -204,4 +205,6 @@ destructor TBoldNotifiableThread.Destroy; inherited; end; +initialization + end. diff --git a/Source/Common/SupportWin/BoldWinINet.pas b/Source/Common/SupportWin/BoldWinINet.pas index 1caebff3..1505ed2f 100644 --- a/Source/Common/SupportWin/BoldWinINet.pas +++ b/Source/Common/SupportWin/BoldWinINet.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWinINet; interface @@ -50,7 +53,7 @@ implementation SysUtils, BoldUtils; -{.$IFDEF BOLD_DELPHI} // marco +{$IFDEF BOLD_DELPHI} function BoldInternetOpen(Agent: String; AccessType: integer; Proxy: string; ProxyByPass: String; Flags: integer): pointer; begin result := InternetOpen(PChar(Agent), AccessType, PChar(Proxy), PChar(ProxyByPass), flags); @@ -111,85 +114,70 @@ function BoldInternetCrackUrl(Url: PChar; UrlLength, dwFlags: DWORD; var lpUrlCo begin result := InternetCrackURL(URL, UrlLength, dwFlags, lpUrlComponents); end; -{.$ENDIF} +{$ENDIF} {$IFDEF BOLD_BCB} - -function Unimplemented(const s: string); -begin - raise EBoldFeatureNotImplementedYet.CreateFmt('%s not yet implemented in Bold for C++', [s]); // do not localize -end; function BoldInternetOpen(Agent: String; AccessType: integer; Proxy: string; ProxyByPass: String; Flags: integer): pointer; begin - Unimplemented('BoldInternetOpen'); // do not localize -// result := InternetOpen(PChar(Agent), AccessType, PChar(Proxy), PChar(ProxyByPass), flags); + raise EBoldFeatureNotImplementedYet.Create('BoldInternetOpen now yet implemented in Bold for C++'); end; function BoldInternetOpenUrl(iNet: Pointer; URL: string; Headers: String; Flags, Context: cardinal): Pointer; begin - Unimplemented('BoldInternetOpenUrl'); // do not localize -// result := InternetOpenURL(iNet, pChar(Url), PChar(Headers), length(Headers), Flags, Context); + raise EBoldFeatureNotImplementedYet.Create('BoldInternetOpenUrl now yet implemented in Bold for C++'); end; function BoldInternetReadFile(hFile: Pointer; Buffer: Pointer; NumberOfBytesToRead: Cardinal; var NumberOfBytesRead: Cardinal): LongBool; begin - Unimplemented('BoldInternetReadFile'); // do not localize -// result := InternetReadFile(hFile, Buffer, NumberOfBytesToRead, NumberOfBytesRead); + raise EBoldFeatureNotImplementedYet.Create('BoldInternetReadFile now yet implemented in Bold for C++'); end; function BoldInternetCloseHandle(HINet: Pointer): LongBool; begin - Unimplemented('BoldInternetCloseHandle'); // do not localize -// result := InternetCloseHandle(hInet); + raise EBoldFeatureNotImplementedYet.Create('BoldInternetCloseHandle now yet implemented in Bold for C++'); end; function BoldHttpQueryInfo(hRequest: Pointer; InfoLevel: Cardinal; Buffer: Pointer; BufferLength: Cardinal; Reserved: Cardinal): LongBool; begin - Unimplemented('BoldHttpQueryInfo'); // do not localize -// result := HTTPQueryInfo(hRequest, InfoLevel, Buffer, BufferLength, Reserved); + raise EBoldFeatureNotImplementedYet.Create('BoldHttpQueryInfo now yet implemented in Bold for C++'); end; function BoldInternetQueryDataAvailable(hFile: Pointer; var NumberOfBytesAvailable: Cardinal; flags: Cardinal; Context: Cardinal): LongBool; begin - Unimplemented('BoldInternetQueryDataAvailable'); // do not localize -// result := InternetQueryDataAvailable(hFile, NumberOfBytesAvailable, flags, Context) + raise EBoldFeatureNotImplementedYet.Create('BoldInternetQueryDataAvailable now yet implemented in Bold for C++'); end; function BoldHttpOpenRequest(hConnect: Pointer; Verb, ObjectName, Version, Referrer: String; AcceptTypes: PCharArr; Flags, Context: Cardinal): Pointer; begin - Unimplemented('BoldHttpOpenRequest'); // do not localize -// result := httpOpenRequest(hConnect, PChar(Verb), PChar(ObjectName), PChar(Version), PChar(Referrer), Pointer(AcceptTypes), Flags, Context) + raise EBoldFeatureNotImplementedYet.Create('BoldHttpOpenRequest now yet implemented in Bold for C++'); end; function BoldHttpSendRequest(hRequest: Pointer; Headers: string; Optional: Pointer; OptionalLength: Cardinal): LongBool; begin - Unimplemented('BoldHttpSendRequest'); // do not localize -// HttpSendRequest(hRequest, PChar(Headers), length(Headers), Optional, OptionalLength); + raise EBoldFeatureNotImplementedYet.Create('BoldHttpSendRequest now yet implemented in Bold for C++'); end; function BoldInternetErrorDlg(hWnd: HWND; hRequest: HINTERNET; dwError, dwFlags: DWORD; var lppvData: Pointer): DWORD; begin - Unimplemented('BoldInternetErrorDlg'); // do not localize -// result := InternetErrorDlg(hWnd, hRequest, dwError, dwFlags, lppvData); + raise EBoldFeatureNotImplementedYet.Create('BoldInternetErrorDlg now yet implemented in Bold for C++'); end; function BoldInternetAttemptConnect(dwReserved: DWORD): DWORD; begin - Unimplemented('BoldInternetAttemptConnect'); // do not localize -// result := InternetAttemptConnect(dwReserved); + raise EBoldFeatureNotImplementedYet.Create('BoldInternetAttemptConnect now yet implemented in Bold for C++'); end; function BoldInternetConnect(hInet: HINTERNET; ServerName: string; nServerPort: INTERNET_PORT; Username: string; Password: string; dwService: DWORD; dwFlags: DWORD; dwContext: DWORD): HINTERNET; begin - Unimplemented('BoldInternetConnect'); // do not localize -// result := InternetConnect(hINet, PChar(ServerName), nServerPort, PChar(UserName), PChar(Password), dwService, dwFlags, dwContext); + raise EBoldFeatureNotImplementedYet.Create('BoldInternetConnect now yet implemented in Bold for C++'); end; function BoldInternetCrackUrl(Url: PChar; UrlLength, dwFlags: DWORD; var lpUrlComponents: TURLComponents): BOOL; begin - Unimplemented('BoldInternetCrackUrl'); // do not localize -// result := InternetCrackURL(URL, UrlLength, dwFlags, lpUrlComponents); + raise EBoldFeatureNotImplementedYet.Create('BoldInternetCrackUrl now yet implemented in Bold for C++'); end; {$ENDIF} +initialization + end. diff --git a/Source/Common/SupportWin/BoldWinUtils.pas b/Source/Common/SupportWin/BoldWinUtils.pas index 4b6df26f..16955421 100644 --- a/Source/Common/SupportWin/BoldWinUtils.pas +++ b/Source/Common/SupportWin/BoldWinUtils.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWinUtils; interface @@ -17,11 +20,13 @@ function GetTaskBarHeigth: Integer; var Parent, Child: HWND; ChildRect, ParentRect: TRect; begin - Parent := FindWindow('Progman', 'Program Manager'); // do not localize + Parent := FindWindow('Progman', 'Program Manager'); Child := FindWindowEx(Parent, 0, nil, nil); GetWindowRect(Parent, ParentRect); GetWindowRect(Child, ChildRect); Result := ParentRect.Bottom - ChildRect.Bottom; end; +initialization + end. diff --git a/Source/Common/TaggedValues/BoldDefaultTaggedValues.pas b/Source/Common/TaggedValues/BoldDefaultTaggedValues.pas index a18d9da9..12fb56b3 100644 --- a/Source/Common/TaggedValues/BoldDefaultTaggedValues.pas +++ b/Source/Common/TaggedValues/BoldDefaultTaggedValues.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDefaultTaggedValues; interface @@ -7,11 +10,9 @@ interface BoldTaggedValueList; const - BOLDTVREV_MAJOR = '6'; // Increase when changing the default of Tagged values - BOLDTVREV_MINOR = '4'; // Increase when adding or removing Tagged values - BOLDTVREV = BOLDTVREV_MAJOR + '.' + BOLDTVREV_MINOR; - { TODO 1 : is changeability bold or stdvalue } - { TODO 1 : Should the common UML-TV:s be broken out? } + BOLDTVREV_MAJOR = '6'; + BOLDTVREV_MINOR = '4'; + BOLDTVREV = BOLDTVREV_MAJOR + '.' + BOLDTVREV_MINOR; {Genernal constants} @@ -21,74 +22,49 @@ interface TV_NAME_UPPERCASE: string = ''; TV_NAME_Length = 6; -const - DEFAULTVALUE = 'default'; - - // Tagged values of enum type - - // AttributeKind - TAG_ATTRIBUTEKIND: String = 'AttributeKind'; // used to be stereotype + TAG_ATTRIBUTEKIND: String = 'AttributeKind'; TV_ATTRIBUTEKIND_BOLD: String = 'Bold'; TV_ATTRIBUTEKIND_DELPHI: String = 'Delphi'; - - - // DeleteAction TAG_DELETEACTION: String = 'DeleteAction'; TV_DELETEACTION_DEFAULT: String = DEFAULTNAMELITERAL; TV_DELETEACTION_ALLOW: String = 'Allow'; TV_DELETEACTION_PROHIBIT: String = 'Prohibit'; TV_DELETEACTION_CASCADE: String = 'Cascade'; - - // DelphiPropertyRead/DelphiPropertyWrite TAG_DPREAD: String = 'DelphiPropertyRead'; TAG_DPWRITE: String = 'DelphiPropertyWrite'; - TV_DPNONE: String = 'None'; // FIXME, add underscore + TV_DPNONE: String = 'None'; TV_DPFIELD: String = 'Field'; TV_DPPRIVATEMETHOD: String = 'PrivateMethod'; TV_DPPROTECTEDVIRTUALMETHOD: String = 'ProtectedVirtualMethod'; - - // EvolutionState TAG_EVOLUTIONSTATE: String = 'EvolutionState'; TV_EVOLUTIONSTATE_NORMAL: String = 'Normal'; TV_EVOLUTIONSTATE_TOBEREMOVED: String = 'ToBeRemoved'; TV_EVOLUTIONSTATE_REMOVED: String = 'Removed'; - - // NatinalCharConversion TAG_NATIONALCHARCONVERSION: String = 'NationalCharConversion'; TV_NATIONALCHARCONVERSION_DEFAULT: String = DEFAULTNAMELITERAL; TV_NATIONALCHARCONVERSION_TRUE: String = 'True'; TV_NATIONALCHARCONVERSION_FALSE: String = 'False'; - - // OperationKind TAG_DELPHIOPERATIONKIND: String = 'OperationKind'; - TV_DELPHIOPERATIONKIND_NORMAL: String = 'Common'; // not 'Normal' for backwards compatibility reasons + TV_DELPHIOPERATIONKIND_NORMAL: String = 'Common'; TV_DELPHIOPERATIONKIND_VIRTUAL: String = 'Virtual'; TV_DELPHIOPERATIONKIND_OVERRIDE: String = 'Override'; TV_DELPHIOPERATIONKIND_DYNAMIC: String = 'Dynamic'; TV_DELPHIOPERATIONKIND_ABSTRACTVIRTUAL: String = 'Abstract'; - - // OptimisticLocking TAG_OPTIMISTICLOCKING: String = 'OptimisticLocking'; TV_OPTIMISTICLOCKING_DEFAULT: String = DEFAULTNAMELITERAL; TV_OPTIMISTICLOCKING_OFF: String = 'Off'; TV_OPTIMISTICLOCKING_MODIFIEDMEMBERS: String = 'ModifiedMembers'; TV_OPTIMISTICLOCKING_ALLMEMBERS: String = 'AllMembers'; TV_OPTIMISTICLOCKING_TIMESTAMP: String = 'TimeStamp'; - - // deprecated names for Optimistic Locking tagged values TV_OPTIMISTICLOCKING_MODIFIEDMEMBERS_OLDNAME: String = 'Member'; TV_OPTIMISTICLOCKING_ALLMEMBERS_OLDNAME: String = 'Class'; - - - // TableMapping TAG_TABLEMAPPING: String = 'TableMapping'; TV_TABLEMAPPING_OWN: String = 'Own'; TV_TABLEMAPPING_PARENT: String = 'Parent'; TV_TABLEMAPPING_CHILDREN: String = 'Children'; TV_TABLEMAPPING_IMPORTED: String = 'Imported'; - DEFAULTTABLEMAPPINGSTRING = 'Own'; //FIXME!! + DEFAULTTABLEMAPPINGSTRING = 'Own'; - // Storage TAG_STORAGE: String = 'Storage'; ENUM_TAG_CLASS_STORAGE: string = 'ClassStorageEnum'; ENUM_TAG_ATTRIBUTE_STORAGE: string = 'AttributeStorageEnum'; @@ -99,9 +75,7 @@ interface TV_STORAGE_EXTERNALKEY: String = 'ExternalKey'; - TV_PERSISTENT_OLD: String = 'Persistent'; - - // Tagged values of basic type + TV_PERSISTENT_OLD: String = 'Persistent'; TAG_ALLOWNULL: String = 'AllowNULL'; @@ -178,11 +152,9 @@ interface BOLDINTERALTVPREFIX = '_BoldInternal.'; TV_MODELERRORS = 'ModelErrors'; - - // Tags for boldification BOLDBOLDIFYPREFIX = '_Boldify.'; TAG_BOLDIFIED = 'boldified'; - TAG_AUTOCREATED = 'autoCreated'; // object + TAG_AUTOCREATED = 'autoCreated'; TAG_DEFAULTMULTIPLICITY = 'defaultMultiplicity'; TAG_NONAME = 'noName'; TAG_WASEMBEDED = 'wasEmbeded'; @@ -191,154 +163,143 @@ interface function BoldDefaultTaggedValueList: TBoldTaggedValuePerClassList; -function TVIsTrue(value: string): Boolean; -function TVIsFalse(value: string): Boolean; +function TVIsTrue(value: string): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} +function TVIsFalse(value: string): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} implementation uses - SysUtils, - BoldUtils; + SysUtils; var G_BoldDefaultTaggedValues: TBoldTaggedValuePerClassList = nil; procedure AddDefaultTaggedValues; begin -// Tagged values for Model - with G_BoldDefaultTaggedValues.ListForClassName['Model'] do // do not localize + with G_BoldDefaultTaggedValues.ListForClassName['Model'] do begin - Add('Boolean', TAG_GENERATEMULTIPLICITYCONSTRAINTS, TV_TRUE); // do not localize - Add('Text', TAG_INTERFACEUSES, ''); // do not localize - Add('Text', TAG_IMPLEMENTATIONUSES, ''); // do not localize - Add('Text', TAG_COPYRIGHTNOTICE, ''); // do not localize - Add('String', TAG_DEFAULTSUPERCLASS, ''); // do not localize - Add('String', TAG_DEFAULTLINKCLASSSUPERCLASS, ''); // do not localize - Add('String', TAG_UNITNAME, 'BusinessClasses'); // do not localize - Add('String', TAG_ROOTCLASS, ''); // do not localize - Add('String', TAG_PMAPPERNAME, DEFAULTNAMELITERAL); // do not localize - Add('Boolean', TAG_USEXFILES, TV_TRUE); // do not localize - Add('Boolean', TAG_USETIMESTAMP, TV_TRUE); // do not localize - Add('Boolean', TAG_USEGLOBALID, TV_TRUE); // do not localize - Add('Boolean', TAG_USEREADONLY, TV_TRUE); // do not localize - Add('Boolean', TAG_USEMODELVERSION, TV_FALSE); // do not localize - Add('Integer', TAG_MODELVERSION, '0'); // do not localize - Add('Boolean', TAG_USECLOCKLOG, TV_TRUE); // do not localize - Add('Boolean', TAG_UPDATEWHOLEOBJECTS, TV_FALSE); // do not localize - Add('OptimisticLockingSet', // do not localize + Add('Boolean', TAG_GENERATEMULTIPLICITYCONSTRAINTS, TV_TRUE); + Add('Text', TAG_INTERFACEUSES, ''); + Add('Text', TAG_IMPLEMENTATIONUSES, ''); + Add('Text', TAG_COPYRIGHTNOTICE, ''); + Add('String', TAG_DEFAULTSUPERCLASS, ''); + Add('String', TAG_DEFAULTLINKCLASSSUPERCLASS, ''); + Add('String', TAG_UNITNAME, 'BusinessClasses'); + Add('String', TAG_ROOTCLASS, ''); + Add('String', TAG_PMAPPERNAME, DEFAULTNAMELITERAL); + Add('Boolean', TAG_USEXFILES, TV_TRUE); + Add('Boolean', TAG_USETIMESTAMP, TV_TRUE); + Add('Boolean', TAG_USEGLOBALID, TV_TRUE); + Add('Boolean', TAG_USEREADONLY, TV_TRUE); + Add('Boolean', TAG_USEMODELVERSION, TV_FALSE); + Add('Integer', TAG_MODELVERSION, '0'); + Add('Boolean', TAG_USECLOCKLOG, TV_TRUE); + Add('Boolean', TAG_UPDATEWHOLEOBJECTS, TV_FALSE); + Add('OptimisticLockingSet', TAG_OPTIMISTICLOCKING, TV_OPTIMISTICLOCKING_OFF); - Add('NationalCharConversionEnum', // do not localize + Add('NationalCharConversionEnum', TAG_NATIONALCHARCONVERSION, TV_NATIONALCHARCONVERSION_DEFAULT); - Add('String', TAG_GUID, ''); // do not localize - Add('String', TAG_TYPELIBVERSION, '1.0'); // do not localize - Add('Text', TAG_REGIONDEFINITIONS, ''); // do not localize - Add('Boolean', TAG_GENERATEDEFAULTREGIONS, TV_FALSE); // do not localize + Add('String', TAG_GUID, ''); + Add('String', TAG_TYPELIBVERSION, '1.0'); + Add('Text', TAG_REGIONDEFINITIONS, ''); + Add('Boolean', TAG_GENERATEDEFAULTREGIONS, TV_FALSE); end; - -// Tagged values for Class - with G_BoldDefaultTaggedValues.ListForClassName['Class'] do // do not localize + with G_BoldDefaultTaggedValues.ListForClassName['Class'] do begin - Add('String', TAG_INCFILENAME, ''); // do not localize - Add('String', TAG_UNITNAME, ''); // do not localize - Add('Boolean', TAG_IMPORTED, TV_FALSE); // do not localize - Add('TableMappingSet', // do not localize + Add('String', TAG_INCFILENAME, ''); + Add('String', TAG_UNITNAME, ''); + Add('Boolean', TAG_IMPORTED, TV_FALSE); + Add('TableMappingSet', TAG_TABLEMAPPING, TV_TABLEMAPPING_OWN); - Add('String', TAG_DELPHINAME, 'T'); // do not localize - Add('String', TAG_CPPNAME, TV_NAME); // do not localize - Add('String', TAG_EXPRESSIONNAME, TV_NAME); // do not localize - Add('String', TAG_TABLENAME, TV_NAME); // do not localize - Add('EvolutionStateEnum', // do not localize + Add('String', TAG_DELPHINAME, 'T'); + Add('String', TAG_CPPNAME, TV_NAME); + Add('String', TAG_EXPRESSIONNAME, TV_NAME); + Add('String', TAG_TABLENAME, TV_NAME); + Add('EvolutionStateEnum', TAG_EVOLUTIONSTATE, TV_EVOLUTIONSTATE_NORMAL); - Add('String', TAG_PMAPPERNAME, DEFAULTNAMELITERAL); // do not localize - Add('String', TAG_DEFAULTSTRINGREPRESENTATION, ''); // do not localize - Add('Text', TAG_DERIVATIONEXPRESSIONS, ''); // do not localize - Add('Boolean', TAG_VERSIONED, TV_FALSE); // do not localize - Add('OptimisticLockingSet', // do not localize + Add('String', TAG_PMAPPERNAME, DEFAULTNAMELITERAL); + Add('String', TAG_DEFAULTSTRINGREPRESENTATION, ''); + Add('Text', TAG_DERIVATIONEXPRESSIONS, ''); + Add('Boolean', TAG_VERSIONED, TV_FALSE); + Add('OptimisticLockingSet', TAG_OPTIMISTICLOCKING, TV_OPTIMISTICLOCKING_DEFAULT); - Add('Text', TAG_FORMERNAMES, ''); // do not localize - Add('String', TAG_INTERFACENAME, 'I'); // do not localize - Add('String', TAG_GUID, ''); // do not localize - Add('Boolean', // do not localize + Add('Text', TAG_FORMERNAMES, ''); + Add('String', TAG_INTERFACENAME, 'I'); + Add('String', TAG_GUID, ''); + Add('Boolean', TAG_GENERATEDEFAULTREGION_CLASS, TV_TRUE); Add(ENUM_TAG_CLASS_STORAGE, TAG_STORAGE, TV_STORAGE_INTERNAL); end; - -// Tagged values for Association - with G_BoldDefaultTaggedValues.ListForClassName['Association'] do // do not localize + with G_BoldDefaultTaggedValues.ListForClassName['Association'] do begin - Add('String', TAG_LINKCLASSNAME, TV_NAME); // do not localize - Add('Text', TAG_FORMERNAMES, ''); // do not localize - Add('EvolutionStateEnum', // do not localize + Add('String', TAG_LINKCLASSNAME, TV_NAME); + Add('Text', TAG_FORMERNAMES, ''); + Add('EvolutionStateEnum', TAG_EVOLUTIONSTATE, TV_EVOLUTIONSTATE_NORMAL); Add(ENUM_TAG_ASSOCIATION_STORAGE, TAG_STORAGE, TV_STORAGE_INTERNAL); end; - -// Tagged values for Attribute - with G_BoldDefaultTaggedValues.ListForClassName['Attribute'] do // do not localize + with G_BoldDefaultTaggedValues.ListForClassName['Attribute'] do begin - Add('Integer', TAG_LENGTH, '255'); // do not localize - Add('Boolean', TAG_ALLOWNULL, TV_FALSE); // do not localize - Add('Boolean', TAG_DELAYEDFETCH, TV_FALSE); // do not localize - Add('String', TAG_COLUMNNAME, TV_NAME); // do not localize - Add('String', TAG_EXPRESSIONNAME, TV_NAME); // do not localize - Add('String', TAG_DELPHINAME, TV_NAME); // do not localize - Add('String', TAG_CPPNAME, TV_NAME); // do not localize - Add('String', TAG_PMAPPERNAME, DEFAULTNAMELITERAL); // do not localize - - Add('Text', TAG_DERIVATIONOCL, ''); // do not localize - Add('Boolean', TAG_VIRTUALDERIVE, TV_TRUE); // do not localize - Add('Boolean', TAG_REVERSEDERIVE, TV_FALSE); // do not localize - Add('AttributeKindSet', // do not localize + Add('Integer', TAG_LENGTH, '255'); + Add('Boolean', TAG_ALLOWNULL, TV_FALSE); + Add('Boolean', TAG_DELAYEDFETCH, TV_FALSE); + Add('String', TAG_COLUMNNAME, TV_NAME); + Add('String', TAG_EXPRESSIONNAME, TV_NAME); + Add('String', TAG_DELPHINAME, TV_NAME); + Add('String', TAG_CPPNAME, TV_NAME); + Add('String', TAG_PMAPPERNAME, DEFAULTNAMELITERAL); + + Add('Text', TAG_DERIVATIONOCL, ''); + Add('Boolean', TAG_VIRTUALDERIVE, TV_TRUE); + Add('Boolean', TAG_REVERSEDERIVE, TV_FALSE); + Add('AttributeKindSet', TAG_ATTRIBUTEKIND, TV_ATTRIBUTEKIND_BOLD); - Add('Boolean', TAG_DELPHIFIELD, TV_FALSE); // do not localize - Add('DelphiPropertySet', // do not localize + Add('Boolean', TAG_DELPHIFIELD, TV_FALSE); + Add('DelphiPropertySet', TAG_DPREAD, TV_DPNONE); - Add('DelphiPropertySet', // do not localize + Add('DelphiPropertySet', TAG_DPWRITE, TV_DPNONE); - Add('EvolutionStateEnum', // do not localize + Add('EvolutionStateEnum', TAG_EVOLUTIONSTATE, TV_EVOLUTIONSTATE_NORMAL); - Add('Text', TAG_FORMERNAMES, ''); // do not localize - Add('String', TAG_DEFAULTDBVALUE, ''); // do not localize + Add('Text', TAG_FORMERNAMES, ''); + Add('String', TAG_DEFAULTDBVALUE, ''); Add(ENUM_TAG_ATTRIBUTE_STORAGE, TAG_STORAGE, TV_STORAGE_INTERNAL); - end; -// Tagged values for AssociationEnd - with G_BoldDefaultTaggedValues.ListForClassName['AssociationEnd'] do // do not localize + end; + with G_BoldDefaultTaggedValues.ListForClassName['AssociationEnd'] do begin - Add('Boolean', TAG_ORDERED, TV_FALSE); // do not localize - Add('String', TAG_COLUMNNAME, TV_NAME); // do not localize - Add('String', TAG_EXPRESSIONNAME, TV_NAME); // do not localize - Add('String', TAG_DELPHINAME, TV_NAME); // do not localize - Add('String', TAG_CPPNAME, TV_NAME); // do not localize - Add('Boolean', TAG_EMBED, TV_TRUE); // do not localize - Add('Text', TAG_DERIVATIONOCL, ''); // do not localize - Add('Boolean', TAG_VIRTUALDERIVE, TV_TRUE); // do not localize - Add('DeleteActions', // do not localize + Add('Boolean', TAG_ORDERED, TV_FALSE); + Add('String', TAG_COLUMNNAME, TV_NAME); + Add('String', TAG_EXPRESSIONNAME, TV_NAME); + Add('String', TAG_DELPHINAME, TV_NAME); + Add('String', TAG_CPPNAME, TV_NAME); + Add('Boolean', TAG_EMBED, TV_TRUE); + Add('Text', TAG_DERIVATIONOCL, ''); + Add('Boolean', TAG_VIRTUALDERIVE, TV_TRUE); + Add('DeleteActions', TAG_DELETEACTION, TV_DELETEACTION_DEFAULT); - Add('Text', TAG_FORMERNAMES, ''); // do not localize - Add('DefaultRegionModeAssociationEnum', // do not localize + Add('Text', TAG_FORMERNAMES, ''); + Add('DefaultRegionModeAssociationEnum', TAG_DEFAULTREGIONMODE_ASSOCIATIONEND, TV_DEFAULTREGIONMODE_ASSOCIATIONEND_DEFAULT); end; - -// Tagged values for Operation - with G_BoldDefaultTaggedValues.ListForClassName['Operation'] do // do not localize + with G_BoldDefaultTaggedValues.ListForClassName['Operation'] do begin - Add('String', TAG_DELPHINAME, TV_NAME); // do not localize - Add('String', TAG_CPPNAME, TV_NAME); // do not localize - Add('String', TAG_EXPRESSIONNAME, TV_NAME); // do not localize - Add('BoldOperationKindSet', // do not localize + Add('String', TAG_DELPHINAME, TV_NAME); + Add('String', TAG_CPPNAME, TV_NAME); + Add('String', TAG_EXPRESSIONNAME, TV_NAME); + Add('BoldOperationKindSet', TAG_DELPHIOPERATIONKIND, TV_DELPHIOPERATIONKIND_NORMAL); - Add('Boolean', TAG_OVERRIDEINALLSUBCLASSES, TV_FALSE); // do not localize + Add('Boolean', TAG_OVERRIDEINALLSUBCLASSES, TV_FALSE); end; - with G_BoldDefaultTaggedValues.ListForClassName['Parameter'] do // do not localize + with G_BoldDefaultTaggedValues.ListForClassName['Parameter'] do begin - Add('Boolean', TAG_ISCONST, TV_FALSE); // do not localize + Add('Boolean', TAG_ISCONST, TV_FALSE); end; end; diff --git a/Source/Common/TaggedValues/BoldTaggedValueList.pas b/Source/Common/TaggedValues/BoldTaggedValueList.pas index c5576140..4c199ec9 100644 --- a/Source/Common/TaggedValues/BoldTaggedValueList.pas +++ b/Source/Common/TaggedValues/BoldTaggedValueList.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldTaggedValueList; interface @@ -70,7 +73,6 @@ implementation uses SysUtils, - BoldUtils, BoldSharedStrings; { TBoldTaggedValueDefinition } @@ -175,4 +177,6 @@ function TBoldTaggedValueDefinitionIndex.ItemAsKeyString(Item: TObject): string; result := TBoldTaggedValueDefinition(item).Tag; end; +initialization + end. diff --git a/Source/Common/TaggedValues/BoldTaggedValueSupport.pas b/Source/Common/TaggedValues/BoldTaggedValueSupport.pas index 5341a227..96ec46e0 100644 --- a/Source/Common/TaggedValues/BoldTaggedValueSupport.pas +++ b/Source/Common/TaggedValues/BoldTaggedValueSupport.pas @@ -1,11 +1,13 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldTaggedValueSupport; interface uses - Classes, // TStrings + Classes, BoldDefaultTaggedValues, - BoldUMLTypes, BoldDefs; type @@ -27,8 +29,6 @@ TBoldTaggedValueSupport = class; { TBoldTaggedValueSupport } TBoldTaggedValueSupport = class - private - class procedure UnknownValue(const Invoker: string); public class procedure AddEvolutionStates(Strings: TStrings); class procedure AddNationalCharConversions(Strings: TStrings); @@ -65,8 +65,7 @@ implementation uses SysUtils, - BoldUtils, - BoldCommonConst; + BoldRev; class procedure TBoldTaggedValueSupport.AddTableMappings( Strings: TStrings); @@ -149,13 +148,14 @@ class procedure TBoldTaggedValueSupport.AddDefaultRegionModes( Strings.Add(DefaultRegionModeToString(i)); end; + class function TBoldTaggedValueSupport.AttributeKindToString(Value: TBoldAttributeKind): String; begin case Value of bastBold: Result := TV_ATTRIBUTEKIND_BOLD; bastDelphi: Result := TV_ATTRIBUTEKIND_DELPHI; else - UnknownValue('AttributeKindToString'); // do not localize + raise EBold.CreateFmt('%s.AttributeKindToString: Unknown TBoldAttributeKind', [ClassName]); end; end; @@ -167,7 +167,7 @@ class function TBoldTaggedValueSupport.DeleteActionToString(Value: TDeleteAction daProhibit: Result := TV_DELETEACTION_PROHIBIT; daCascade: Result := TV_DELETEACTION_CASCADE; else - UnknownValue('DeleteActionToString'); // do not localize + raise EBold.CreateFmt('%s.DeleteActionToString: Unknown TDeleteAction', [ClassName]); end; end; @@ -180,7 +180,7 @@ class function TBoldTaggedValueSupport.DelphiFunctionTypeToString(Value: TDelphi dfDynamic: Result := TV_DELPHIOPERATIONKIND_DYNAMIC; dfAbstractVirtual: Result := TV_DELPHIOPERATIONKIND_ABSTRACTVIRTUAL; else - UnknownValue('DelphiFunctionTypeToString'); // do not localize + raise EBold.CreateFmt('%s.DelphiFunctionTypeToString: Unknown TDelphiFunctionType', [ClassName]); end; end; @@ -192,7 +192,7 @@ class function TBoldTaggedValueSupport.DelphiPropertyAccessKindToString(Value: T pkPrivateMethod: Result := TV_DPPRIVATEMETHOD; pkProtectedVirtualMethod: Result := TV_DPPROTECTEDVIRTUALMETHOD; else - UnknownValue('DelphiPropertyAccessKindToString'); // do not localize + raise EBold.CreateFmt('%s.DelphiPropertyAccessKindToString: Unknown TDelphiPropertyAccessKind', [ClassName]); end; end; @@ -208,13 +208,12 @@ class function TBoldTaggedValueSupport.StringToAttributeKind(const Value: String class function TBoldTaggedValueSupport.StringToBoolean(const Value: String): Boolean; begin - Result := False; if SameText(Value, TV_TRUE) then Result := True else if SameText(Value, TV_FALSE) then Result := False else - UnknownValue('StringToBoolean'); // do not localize + raise EBold.CreateFmt('%s is not a valid string for a Boolean', [Value]); end; class function TBoldTaggedValueSupport.StringToDefaultRegionMode(const value: String): TBoldAssociationEndDefaultRegionMode; @@ -259,7 +258,7 @@ class function TBoldTaggedValueSupport.StringToDelphiFunctionType(const Value: S Result := dfDynamic else if Value = TV_DELPHIOPERATIONKIND_ABSTRACTVIRTUAL then Result := dfAbstractVirtual - else if Value = 'AbstractVirtual' then // legacy // do not localize + else if Value = 'AbstractVirtual' then Result := dfAbstractVirtual else result := dfNormal; @@ -349,7 +348,7 @@ class function TBoldTaggedValueSupport.TableMappingToString(Value: TTableMapping tmChildren: Result := TV_TABLEMAPPING_CHILDREN; tmImported: Result := TV_TABLEMAPPING_IMPORTED; else - UnknownValue('TableMappingToString'); // do not localize + raise EBold.CreateFmt('%s.TableMappingToString: Unknown TTableMapping', [ClassName]); end; end; @@ -363,7 +362,7 @@ class function TBoldTaggedValueSupport.OptimisticLockingModeToString( bolmAllMembers: Result := TV_OPTIMISTICLOCKING_ALLMEMBERS; bolmTimeStamp: Result := TV_OPTIMISTICLOCKING_TIMESTAMP; else - UnknownValue('OptimisticLockingModeToString'); // do not localize + raise EBold.CreateFmt('%s.OptimisticLockingModeToString: Unknown TBoldOptimisticLockingMode', [ClassName]); end; end; @@ -375,7 +374,7 @@ class function TBoldTaggedValueSupport.EvolutionStateToString( esToBeRemoved: Result := TV_EVOLUTIONSTATE_TOBEREMOVED; esRemoved: Result := TV_EVOLUTIONSTATE_REMOVED; else - UnknownValue('EvolutionStateToString'); // do not localize + raise EBold.CreateFmt('%s.EvolutionStateToString: Unknown TBoldEvolutionState', [ClassName]); end; end; @@ -400,28 +399,24 @@ class function TBoldTaggedValueSupport.NationalCharConversionToString( nccTrue: Result := TV_TRUE; nccFalse: Result := TV_FALSE; else - UnknownValue('NationalCharConversionToString'); // do not localize + raise EBold.CreateFmt('%s.NationalCharConversionoString: Unknown TBoldNationalCharConversion', [ClassName]); end; end; class function TBoldTaggedValueSupport.DefaultRegionModeToString( Value: TBoldAssociationEndDefaultRegionMode): String; begin - case Value of +case Value of aedrmDefault: Result := TV_DEFAULTREGIONMODE_ASSOCIATIONEND_DEFAULT; aedrmNone: Result := TV_DEFAULTREGIONMODE_ASSOCIATIONEND_NONE; aedrmExistence: Result := TV_DEFAULTREGIONMODE_ASSOCIATIONEND_EXISTENCE; aedrmIndependentCascade: Result := TV_DEFAULTREGIONMODE_ASSOCIATIONEND_INDEPENDENTCASCADE; aedrmCascade: Result := TV_DEFAULTREGIONMODE_ASSOCIATIONEND_CASCADE; else - UnknownValue('DefaultRegionModeToString'); // do not localize + raise EBold.CreateFmt('%s.DefaultRegionModeToString: Unknown TBoldAssociationEndDefaultRegionMode', [ClassName]); end; end; -class procedure TBoldTaggedValueSupport.UnknownValue( - const Invoker: string); -begin - raise EBold.CreateFmt(sUnknownValue, [ClassName, Invoker]); -end; +initialization end. diff --git a/Source/Common/TaggedValues/BoldUMLTaggedValues.pas b/Source/Common/TaggedValues/BoldUMLTaggedValues.pas index 53a1ed1a..c416ec9c 100644 --- a/Source/Common/TaggedValues/BoldUMLTaggedValues.pas +++ b/Source/Common/TaggedValues/BoldUMLTaggedValues.pas @@ -1,11 +1,12 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLTaggedValues; interface uses - BoldDefs, - BoldTaggedValueList, - BoldDefaultTaggedValues; + BoldTaggedValueList; const TAG_DOCUMENTATION: String ='documentation'; @@ -13,8 +14,9 @@ interface ENUM_TAG_PERSISTENCE: String = 'PersistenceEnum'; TAG_PERSISTENCE: String = 'persistence'; - TV_PERSISTENCE_PERSISTENT: String = 'persistent'; - TV_PERSISTENCE_TRANSIENT: String = 'transient'; + TV_PERSISTENCE_PERSISTENT: String = 'persistent'; + TV_PERSISTENCE_TRANSIENT: String = 'transient'; + function UMLTaggedValueList: TBoldTaggedValuePerClassList; @@ -22,30 +24,25 @@ implementation uses SysUtils, - BoldUtils; + BoldDefaultTaggedValues; var G_UMLTaggedValues: TBoldTaggedValuePerClassList = nil; procedure AddDefaultTaggedValues; begin -// Tagged values for Class - with G_UMLTaggedValues.ListForClassName['Class'] do // do not localize + with G_UMLTaggedValues.ListForClassName['Class'] do begin Add(ENUM_TAG_PERSISTENCE, TAG_PERSISTENCE, TV_PERSISTENCE_PERSISTENT); end; - -// Tagged values for Association - with G_UMLTaggedValues.ListForClassName['Association'] do // do not localize - begin // do not localize - Add('Boolean', TAG_DERIVED, TV_FALSE); // do not localize + with G_UMLTaggedValues.ListForClassName['Association'] do + begin + Add('Boolean', TAG_DERIVED, TV_FALSE); Add(ENUM_TAG_PERSISTENCE, TAG_PERSISTENCE, TV_PERSISTENCE_PERSISTENT); end; - -// Tagged values for Attribute - with G_UMLTaggedValues.ListForClassName['Attribute'] do // do not localize + with G_UMLTaggedValues.ListForClassName['Attribute'] do begin - Add('Boolean', TAG_DERIVED, TV_FALSE); // do not localize + Add('Boolean', TAG_DERIVED, TV_FALSE); Add(ENUM_TAG_PERSISTENCE, TAG_PERSISTENCE, TV_PERSISTENCE_PERSISTENT); end; end; diff --git a/Source/Common/Template/BoldTemplate.pas b/Source/Common/Template/BoldTemplate.pas index 8d52dd09..a1aadb6b 100644 --- a/Source/Common/Template/BoldTemplate.pas +++ b/Source/Common/Template/BoldTemplate.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldTemplate; interface @@ -14,4 +17,9 @@ TBoldTemplate = class implementation +uses + SysUtils, + BoldUtils; + + end. diff --git a/Source/Common/UML/BoldUMLDelphiSupport.pas b/Source/Common/UML/BoldUMLDelphiSupport.pas index e122a6c4..b33ec4a3 100644 --- a/Source/Common/UML/BoldUMLDelphiSupport.pas +++ b/Source/Common/UML/BoldUMLDelphiSupport.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLDelphiSupport; interface @@ -19,7 +22,8 @@ implementation uses SysUtils, - BoldUtils; + BoldUtils, + BoldRev; { TBoldUMLDelphiSupport } @@ -32,8 +36,8 @@ class function TBoldUMLDelphiSupport.ExtractType( if ColonPos > 0 then begin Result := BoldTrim(Copy(ParameterName, ColonPos+1, MaxInt)); - Delete(ParameterName, ColonPos, Maxint); - end; + Delete(ParameterName, ColonPos, Maxint); + end; end; class function TBoldUMLDelphiSupport.ExtractIsConst( @@ -41,10 +45,10 @@ class function TBoldUMLDelphiSupport.ExtractIsConst( var Index: integer; begin - Index := Pos('const ', LowerCase(ParameterName)); // do not localize + Index := Pos('const ', LowerCase(ParameterName)); Result := Index > 0; if Result then - Delete(ParameterName, Index, 6); // 6 = length('const '); + Delete(ParameterName, Index, 6); end; class function TBoldUMLDelphiSupport.ExtractKind( @@ -52,19 +56,19 @@ class function TBoldUMLDelphiSupport.ExtractKind( var Index: integer; begin - Index := Pos('var ', LowerCase(ParameterName)); // do not localize + Index := Pos('var ', LowerCase(ParameterName)); if Index > 0 then begin Result := pdInOut; - Delete(ParameterName, Index, 4); // 4 = length('var '); + Delete(ParameterName, Index, 4); end else begin - Index := Pos('out ', LowerCase(ParameterName)); // do not localize + Index := Pos('out ', LowerCase(ParameterName)); if Index > 0 then begin Result := pdOut; - Delete(ParameterName, Index, 4); // 4 = length('out '); + Delete(ParameterName, Index, 4); end else Result := pdIn; @@ -75,11 +79,11 @@ class function TBoldUMLDelphiSupport.ParameterModifier( Kind: TBoldParameterDirectionKind; IsConst: Boolean): string; begin if IsConst then - Result := 'const ' // do not localize + Result := 'const ' else if Kind = pdInOut then - Result := 'var ' // do not localize + Result := 'var ' else if Kind = pdOut then - Result := 'out ' // do not localize + Result := 'out ' else Result := ''; end; diff --git a/Source/Common/UML/BoldUMLTypes.pas b/Source/Common/UML/BoldUMLTypes.pas index 325cbd2b..8aac0cdd 100644 --- a/Source/Common/UML/BoldUMLTypes.pas +++ b/Source/Common/UML/BoldUMLTypes.pas @@ -1,19 +1,18 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLTypes; interface uses - Classes, BoldBase, - BoldSharedStrings, BoldContainers; type { forward declarations } TBoldUMLRange = class; - TBoldUMLMultiplicity = class; - - { TODO : Normalize names to form TBoldUMLXX } + TBoldUMLMultiplicity = class; TBoldParameterDirectionKind = (pdIn, pdOut, pdInout, pdReturn); TAggregationKind = (akNone, akAggregate, akComposite); TVisibilityKind = (vkPrivate, vkProtected, vkPublic); @@ -61,7 +60,7 @@ implementation uses SysUtils, - BoldUtils; + BoldRev; { TBoldUMLRange } @@ -157,7 +156,7 @@ function TBoldUMLMultiplicity.FormatAsString( if length(Result) > 0 then Result := Result + ','; Result := result + Range[i].FormatAsString(UnlimitedString); - end; + end; end; function TBoldUMLMultiplicity.GetAsString: string; diff --git a/Source/Common/UtilsGUI/BoldCursorGuard.pas b/Source/Common/UtilsGUI/BoldCursorGuard.pas index 9dd700e5..60c3394d 100644 --- a/Source/Common/UtilsGUI/BoldCursorGuard.pas +++ b/Source/Common/UtilsGUI/BoldCursorGuard.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldCursorGuard; interface @@ -37,4 +40,6 @@ destructor TBoldCursorGuard.Destroy; inherited; end; +initialization + end. diff --git a/Source/ConcurrencyControl/COM/BoldLockManagerAdminHandleCom.pas b/Source/ConcurrencyControl/COM/BoldLockManagerAdminHandleCom.pas index 160c08ee..8472277c 100644 --- a/Source/ConcurrencyControl/COM/BoldLockManagerAdminHandleCom.pas +++ b/Source/ConcurrencyControl/COM/BoldLockManagerAdminHandleCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLockManagerAdminHandleCom; interface @@ -13,6 +16,7 @@ interface {forward declarations} TBoldLockManagerAdminHandleCom = class; + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldLockManagerAdminHandleCom = class(TBoldAbstractLockManagerAdminHandle) private FComObject: IUnknown; @@ -184,4 +188,6 @@ procedure TBoldLockManagerAdminHandleCom._Receive(Originator: TObject; end; end; +initialization + end. diff --git a/Source/ConcurrencyControl/COM/BoldLockManagerHandleCom.pas b/Source/ConcurrencyControl/COM/BoldLockManagerHandleCom.pas index 69e537ce..f6ea0c5c 100644 --- a/Source/ConcurrencyControl/COM/BoldLockManagerHandleCom.pas +++ b/Source/ConcurrencyControl/COM/BoldLockManagerHandleCom.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLockManagerHandleCom; interface @@ -14,6 +17,7 @@ interface {forward declarations} TBoldLockManagerHandleCom = class; + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldLockManagerHandleCom = class(TBoldAbstractLockManagerHandle) private FComObject: IUnknown; @@ -49,7 +53,8 @@ implementation BoldUtils, BoldLockingDefs, BoldComClient, - BoldDefs; + BoldDefs + ; { TBoldLockManagerHandleCom } @@ -171,4 +176,6 @@ procedure TBoldLockManagerHandleCom._Receive(Originator: TObject; end; end; +initialization + end. diff --git a/Source/ConcurrencyControl/Common/BoldAbstractLockManagerAdminHandle.pas b/Source/ConcurrencyControl/Common/BoldAbstractLockManagerAdminHandle.pas index bd26dfef..f4e446ee 100644 --- a/Source/ConcurrencyControl/Common/BoldAbstractLockManagerAdminHandle.pas +++ b/Source/ConcurrencyControl/Common/BoldAbstractLockManagerAdminHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAbstractLockManagerAdminHandle; interface @@ -20,5 +23,10 @@ TBoldAbstractLockManagerAdminHandle = class(TBoldSubscribableComponent) implementation -end. +uses + BoldRev + ; +initialization + +end. diff --git a/Source/ConcurrencyControl/Common/BoldAbstractLockManagerHandle.pas b/Source/ConcurrencyControl/Common/BoldAbstractLockManagerHandle.pas index 0db68a23..63abb7cb 100644 --- a/Source/ConcurrencyControl/Common/BoldAbstractLockManagerHandle.pas +++ b/Source/ConcurrencyControl/Common/BoldAbstractLockManagerHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAbstractLockManagerHandle; interface @@ -19,4 +22,7 @@ TBoldAbstractLockManagerHandle = class(TBoldSubscribableComponent) implementation + +initialization + end. diff --git a/Source/ConcurrencyControl/Common/BoldLockingDefs.pas b/Source/ConcurrencyControl/Common/BoldLockingDefs.pas index da84c46b..2aa9bf87 100644 --- a/Source/ConcurrencyControl/Common/BoldLockingDefs.pas +++ b/Source/ConcurrencyControl/Common/BoldLockingDefs.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLockingDefs; interface @@ -10,5 +13,6 @@ interface implementation -end. +initialization +end. diff --git a/Source/ConcurrencyControl/IDECOM/BoldConcurrencyControlReg.pas b/Source/ConcurrencyControl/IDECOM/BoldConcurrencyControlReg.pas index 0eacbf01..c12c6d4e 100644 --- a/Source/ConcurrencyControl/IDECOM/BoldConcurrencyControlReg.pas +++ b/Source/ConcurrencyControl/IDECOM/BoldConcurrencyControlReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldConcurrencyControlReg; interface @@ -7,15 +10,11 @@ procedure Register; implementation uses - SysUtils, BoldLockManagerAdminHandleCom, BoldLockManagerHandleCom, BoldIDEConsts, Classes; -{$R *.res} - - procedure RegisterComponentsOnPalette; begin RegisterComponents(BOLDPAGENAME_OSS_CMS, [ @@ -24,7 +23,6 @@ procedure RegisterComponentsOnPalette; ]); end; - procedure Register; begin RegisterComponentsOnPalette; diff --git a/Source/Extensions/OLLE/Core/BoldOLLEController.pas b/Source/Extensions/OLLE/Core/BoldOLLEController.pas index c65d5675..c72e0629 100644 --- a/Source/Extensions/OLLE/Core/BoldOLLEController.pas +++ b/Source/Extensions/OLLE/Core/BoldOLLEController.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOLLEController; interface @@ -9,6 +12,7 @@ interface BoldSystem, BoldDBInterfaces, BoldSQLDatabaseConfig, + BoldIndexCollection, BoldAbstractPersistenceHandleDB; type @@ -16,9 +20,11 @@ TBoldPHandleMimic = class(TBoldAbstractPersistenceHandleDB) private fPHandle: TBoldAbstractPersistenceHandleDB; fSQLDatabaseConfig: TBoldSQLDatabaseConfig; + fCustomIndexes: TBoldIndexCollection; protected function GetDataBaseInterface: IBoldDatabase; override; function GetSQLDatabaseConfig: TBoldSQLDatabaseConfig; override; + function GetCustomIndexes: TBoldIndexCollection; override; public destructor Destroy; override; end; @@ -41,8 +47,8 @@ implementation uses SysUtils, - BoldUtils, - OLLEConsts; + BoldUtils; + { TBoldOLLEController } @@ -53,7 +59,7 @@ constructor TBoldOLLEController.Create(PersistenceHandle: TBoldAbstractPersisten fMimicPHandle.fPHandle := PersistenceHandle; fMimicPHandle.BoldModel := fOlleDM.BoldModel1; fMimicPHandle.SQLDatabaseConfig.AssignConfig(PersistenceHandle.SQLDatabaseConfig); - fMimicPHandle.SQLDataBaseConfig.SystemTablePrefix := 'OLLE'; // do not localize + fMimicPHandle.SQLDataBaseConfig.SystemTablePrefix := 'OLLE'; fOlleDM.BoldObjectInfoSystem.PersistenceHandle := fMimicPHandle; end; @@ -78,7 +84,7 @@ procedure TBoldOLLEController.SetPersistent(const Value: Boolean); if value <> Persistent then begin if fOlleDm.BoldObjectInfoSystem.Active then - raise Exception.CreateFmt(sCannotChangePersistenceWhenActive, [ClassName]); + raise Exception.Create( 'TBoldOLLEController: Can not change Persistent-property when the OLLE system is active' ); if Value then fOlleDM.BoldObjectInfoSystem.PersistenceHandle := fMimicPHandle else @@ -88,12 +94,20 @@ procedure TBoldOLLEController.SetPersistent(const Value: Boolean); { TBoldPHandleMimic } -destructor TBoldPHandleMimic.destroy; +destructor TBoldPHandleMimic.Destroy; begin FreeAndNil(fSQLDatabaseConfig); + FreeAndNil(fCustomIndexes); inherited; end; +function TBoldPHandleMimic.GetCustomIndexes: TBoldIndexCollection; +begin + if not assigned(fCustomIndexes) then + fCustomIndexes := TBoldIndexCollection.Create(nil); + result := fCustomIndexes; +end; + function TBoldPHandleMimic.GetDataBaseInterface: IBoldDatabase; begin result := fPHandle.DataBaseInterface; @@ -106,4 +120,6 @@ function TBoldPHandleMimic.GetSQLDatabaseConfig: TBoldSQLDatabaseConfig; result := fSQLDatabaseConfig; end; +initialization + end. diff --git a/Source/Extensions/OLLE/Core/BoldOLLEDistributableObjectHandlers.pas b/Source/Extensions/OLLE/Core/BoldOLLEDistributableObjectHandlers.pas index 002187fc..8be032ae 100644 --- a/Source/Extensions/OLLE/Core/BoldOLLEDistributableObjectHandlers.pas +++ b/Source/Extensions/OLLE/Core/BoldOLLEDistributableObjectHandlers.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOLLEDistributableObjectHandlers; interface @@ -22,11 +25,13 @@ interface BoldDbInterfaces, BoldOLLEdmmain; + + const BOLD_OLL_IDATTRIBUTECOLUMN_NAME = 'LOCALID'; BOLD_OLL_PSIDATTRIBUTECOLUMN_NAME = 'GLOBALID'; BOLD_OLL_NAMEOFCLASSATTRIBUTECOLUMN_NAME = 'NAMEOFCLASS'; - + type TBoldPSId = string; TBoldDistributableObjectHandler = class; @@ -53,13 +58,11 @@ TBoldDistributableObjectHandler = class fBrokenLinkResolver: TBoldBrokenLinkResolver; fMyTransaction: Boolean; fTheMapping: TMapping; -// function GetDatabase: IBoldDatabase; function TheMapping: TMapping; function LookupInfoByLocalId(LocalId: TBoldDefaultId): TDistributableObjectInfo; procedure AddToMapping(anObj: TDistributableObjectInfo); procedure GetLocalIdsFor(InfoObjects: TDistributableObjectInfoList; IdList: TBoldObjectIdList); function GetForeignPSInfo(PSId: TBoldPSId): TForeignPSInfo; -// function NewLocalClassIdFor(ClassId: TBoldClassIdWithExpressionName): TBoldClassId; procedure ExtractAllIds(IdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; OutIdList: TBoldObjectIdList); procedure Fetch(IdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace); procedure GetInfoObjectsFor(IdList: TBoldObjectIdList; InfoObjectList: TDistributableObjectInfoList; RemainingIdList: TBoldObjectIdList); @@ -68,7 +71,7 @@ TBoldDistributableObjectHandler = class procedure MakeGlobalTranslationListFor(ValueSpace: IBoldValueSpace; IdList: TBoldObjectIdList; GlobalTranslationList: TBoldIdTranslationList); procedure MakeLocalizingTranslationList(ValueSpace: IBoldValueSpace; GlobalIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); procedure SearchByOcl(OclExpr: string; IdList: TBoldObjectIdList); - procedure Update(ValueSpace: IBoldValueSpace; IdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; var TimeStamp: Integer); + procedure Update(ValueSpace: IBoldValueSpace; IdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType); procedure LockAndFreeObjects(IdList, FreeList: TBoldObjectIdList); procedure VerifyAssociations(ValueSpace: IBoldValueSpace; IdList, HoldList: TBoldObjectIdList); procedure StartTransaction; @@ -117,7 +120,6 @@ implementation uses SysUtils, BoldUtils, - OlleConsts, BoldDomainElement; procedure AddObjectToIdList(aDistributableInfo: TDistributableObjectInfo; anIdList: TBoldObjectIdList); @@ -155,10 +157,10 @@ procedure TBoldForeignObjectHandler.PutObjects( begin anObject := InfoObjects[i]; if not (anObject is TForeignObjectInfo) then - raise EBold.CreateFmt(sObjectNotForeign, [Classname]); + raise EBold.CreateFmt('%s.EnsureForeignInfo: Object is not a foreign object', [Classname]); aForeignObjectInfo := anObject as TForeignObjectInfo; if not (aForeignObjectInfo.Owner = Owner) then - raise EBold.CreateFmt(sWrongOwner, [Classname]); + raise EBold.CreateFmt('%s.EnsureForeignInfo: Wrong owner', [Classname]); anObjectId.AsInteger := aForeignObjectInfo.LocalId; aForeignObjectInfo.Put(ValueSpace, HoldList.IdInList[anObjectId], NewLocalTimeStamp); end; @@ -198,8 +200,6 @@ procedure TBoldForeignObjectHandler.Put(ValueSpace: IBoldValueSpace; IdList: TBo VerifyAssociations(ValueSpace, IdList2, HoldList2); Update(ValueSpace, IdList2, TranslationList2, NewLocalTimeStamp); - -// FVS.ApplyTranslationList(TranslationList2); Done by Update IdList2.ApplyTranslationList(TranslationList2); HoldList2.ApplyTranslationList(TranslationList2); @@ -238,7 +238,7 @@ procedure TBoldForeignObjectHandler.StartCheckIn(IdList, try OwnerForeignPSInfo := GetForeignPSInfo(Owner); if OwnerForeignPSInfo.IsCheckingIn then - raise EBold.CreateFmt(sObjectsAlreadyBeingCheckedIn, [Classname]); + raise EBold.CreateFmt('%s.StartCheckIn: Already checking in objects for this persistent storage', [Classname]); Fetch(Idlist, ValueSpace); StartCheckInObjects(ValueSpace, IdList, ReleaseList, OwnerForeignPSInfo); ReleaseObjects(ValueSpace, ReleaseList); @@ -347,7 +347,6 @@ procedure TBoldForeignObjectHandler.ModifiedObjectsFrom(Owner: TBoldPSId; aValueSpace: TBoldFreeStandingValueSpace; function DifferentTimeStamp: Boolean; - // This function exists to remove a weird bug that probably has to do with releasing interfaces. var anObjectContents: IBOldObjectContents; begin @@ -361,7 +360,7 @@ procedure TBoldForeignObjectHandler.ModifiedObjectsFrom(Owner: TBoldPSId; anObjectIdList := TBoldObjectIdList.Create; aValueSpace := TBoldFreeStandingValueSpace.Create; try - GetForeignPSInfo(Owner).EvaluateExpression('ownedObjectInfos.heldObjectInfo', anElement); // do not localize + GetForeignPSInfo(Owner).EvaluateExpression('ownedObjectInfos.heldObjectInfo', anElement); anObjectList := anElement.Value as TBoldObjectList; anObjectList.EnsureObjects; for i := 0 to anObjectList.Count-1 do @@ -390,6 +389,7 @@ procedure TBoldForeignObjectHandler.ObjectsFrom(Owner: TBoldPSId; AddObjectToIdList(anObjectList[i], Objects); end; + { TOwnObjectHandler } procedure TBoldOwnObjectHandler.AcknowledgeSynch(ForeignPS: TBoldPSId); @@ -424,8 +424,6 @@ procedure TBoldOwnObjectHandler.CheckIn(ValueSpace: IBoldValueSpace; IdList, VerifyAssociations(ValueSpace, IdList2, IdList2); Update(ValueSpace, IdList2, TranslationList2, NewTimeStamp); - -// FVS.ApplyTranslationList(TranslationList2); Done by Update IdList2.ApplyTranslationList(TranslationList2); ReleaseList2.ApplyTranslationList(TranslationList2); @@ -465,7 +463,7 @@ procedure TBoldOwnObjectHandler.CheckInObjects(ValueSpace: IBoldValueSpace; begin anObject := InfoObjects[i]; if not (anObject is TOwnObjectInfo) then - raise EBold.CreateFmt(sObjectNotOwned, [Classname, 'CheckInObjects']); // do not localize + raise EBold.CreateFmt('%s.CheckInObjects: Object is not an owned object', [Classname]); anOwnObjectInfo := anObject as TOwnObjectInfo; anObjectId.AsInteger := anOwnObjectInfo.LocalId; anOwnObjectInfo.CheckIn(ValueSpace, ReleaseList.IdInList[anObjectId], Holder); @@ -476,7 +474,7 @@ procedure TBoldOwnObjectHandler.CheckInObjects(ValueSpace: IBoldValueSpace; anOwnObjectInfo.LocalId := (NewInfoIds[i] as TBoldDefaultId).AsInteger; AddToMapping(anOwnObjectInfo); anOwnObjectInfo.CheckedOutObjectInfo := TCheckedOutObjectInfo.Create(OllSystem); - anOwnObjectInfo.CheckedOutObjectInfo.Holder := Holder; // Needed for those objects that aren't released + anOwnObjectInfo.CheckedOutObjectInfo.Holder := Holder; anOwnObjectInfo.CheckIn(ValueSpace, ReleaseList.IdInList[NewInfoIds[i]], Holder); end; finally @@ -552,7 +550,7 @@ procedure TBoldOwnObjectHandler.GetSynch(ForeignPS: TBoldPSId; try aForeignPS := GetForeignPSInfo(ForeignPS); if aForeignPS.IsSynching then - raise EBold.CreateFmt(sSynchInProgress, [classname]); + raise EBold.CreateFmt('%s.GetSynch: There is already an ongoing synch that must either be acknowledged or failed.', [classname]); ChangedObjects := TBoldObjectIdList.Create; HoldList := TBoldObjectIdList.Create; @@ -583,7 +581,6 @@ procedure TBoldOwnObjectHandler.GetSynch(ForeignPS: TBoldPSId; HoldList.Free; aCond.Free; InfoObjects.Free; - MissingIds.Free; end; OllSystem.UpdateDatabase; @@ -665,7 +662,7 @@ procedure TBoldOwnObjectHandler.UnCheckOutObjects(IdList: TBoldObjectIdList; for i := 0 to InfoObjects.Count - 1 do begin if not (InfoObjects[i] is TOwnObjectInfo) then - raise EBold.CreateFmt(sObjectNotOwned, [Classname, 'UnCheckOutObjects']); // do not localize + raise EBold.CreateFmt('%s.UnCheckOutObjects: Object is not an owned object', [Classname]); anOwnObjectInfo := InfoObjects[i] as TOwnObjectInfo; anOwnObjectInfo.UnCheckOut(Holder); end; @@ -693,7 +690,7 @@ function TBoldDistributableObjectHandler.GetForeignPSInfo( aCondition.WhereFragment := BOLD_OLL_PSIDATTRIBUTECOLUMN_NAME + ' = ''' + PSId + ''''; OllSystem.PersistenceController.PMFetchIDListWithCondition(PSInfoObjectIdList, OllSystem.AsIBoldvalueSpace[bdepPMIn], fmNormal, aCondition, 0); end else} - SearchByOcl('ForeignPSInfo.allInstances->select(globalId = ''' + PSId + ''')', PSInfoObjectIdList); // do not localize + SearchByOcl('ForeignPSInfo.allInstances->select(globalId = ''' + PSId + ''')', PSInfoObjectIdList); if PSInfoObjectIdList.Count = 0 then begin result := TForeignPSInfo.Create(OllSystem); @@ -809,8 +806,8 @@ procedure TBoldDistributableObjectHandler.GetInfoObjectsFor(IdList: TBoldObjectI aCondition := TBoldSQLCondition.Create; FoundIds := TBoldObjectIdList.Create; try - aCondition.TopSortedIndex := OllSystem.BoldSystemTypeInfo.ClassTypeInfoByModelName['DistributableObjectInfo'].TopSortedIndex; // do not localize - aCondition.WhereFragment := BOLD_OLL_IDATTRIBUTECOLUMN_NAME + ' IN (' + IdListToSQL(RemainingIds) + ')'; // do not localize + aCondition.TopSortedIndex := OllSystem.BoldSystemTypeInfo.ClassTypeInfoByModelName['DistributableObjectInfo'].TopSortedIndex; + aCondition.WhereFragment := BOLD_OLL_IDATTRIBUTECOLUMN_NAME + ' IN (' + IdListToSQL(RemainingIds) + ')'; OllSystem.GetAllWithCondition(FetchedInfoObjs, aCondition); FetchedInfoObjs.EnsureObjects; for i := 0 to FetchedInfoObjs.Count-1 do @@ -851,17 +848,17 @@ procedure TBoldDistributableObjectHandler.MakeLocalizingTranslationList( procedure TBoldDistributableObjectHandler.Update(ValueSpace: IBoldValueSpace; IdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; - var TimeStamp: Integer); + var TimeStamp: TBoldTimeStampType); var anObject: IBoldObjectContents; - i, j: Integer; + ClientId, i, j: Integer; + TimeOfLatestUpdate: TDateTime; begin for i := IdList.Count-1 downto 0 do begin anObject := ValueSpace.ObjectContentsByObjectId[IdList[i]]; for j := 0 to anObject.MemberCount-1 do - if assigned(anObject.ValueByIndex[j]) then - anObject.ValueByIndex[j].BoldPersistenceState := bvpsModified; + anObject.ValueByIndex[j].BoldPersistenceState := bvpsModified; if IdList[i] is TBoldGlobalId then begin if anObject.BoldExistenceState = besDeleted then @@ -876,7 +873,9 @@ procedure TBoldDistributableObjectHandler.Update(ValueSpace: IBoldValueSpace; anObject.BoldPersistenceState := bvpsModified; end; end; - PController.PMUpdate(IdList, ValueSpace, nil, nil, TranslationList, TimeStamp, 0); + ClientId := 0; + TimeOfLatestUpdate:= now; + PController.PMUpdate(IdList, ValueSpace, nil, nil, TranslationList, TimeStamp, TimeOfLatestUpdate, ClientId); end; procedure TBoldDistributableObjectHandler.LockAndFreeObjects(IdList, @@ -958,11 +957,9 @@ procedure TBoldDistributableObjectHandler.VerifyAssociations( VerifyObjectRoles(ValueSpace.ObjectContentsByObjectId[anIdRefPair.Id2]); end else if aMember.QueryInterface(IBoldObjectIdListRef, anIdListRef) = S_OK then begin -// VerifyAllInList(anIdListRef.IdList); end else if aMember.QueryInterface(IBoldObjectIdListRefPair, anIdListRefPair) = S_OK then begin -// VerifyAllInList(anIdListRefPair.anIdListRefPair.IdList1); -// VerifyAllInList(anIdListRefPair.anIdListRefPair.IdList2); + end; end; end; @@ -979,7 +976,6 @@ procedure TBoldDistributableObjectHandler.VerifyAssociations( aMember := ObjectContents.ValueByIndex[j]; if assigned(aMember) then begin - // FIXME: Doesn't work for non-embedded singlelinks, but that requires access to the model if ((aMember.QueryInterface(IBoldObjectIdRef, anIdRef) = S_OK) and (anIdRef.Id is TBoldGlobalId) and (not ValueSpace.HasContentsForId[anIdRef.Id])) or @@ -990,12 +986,11 @@ procedure TBoldDistributableObjectHandler.VerifyAssociations( begin if not BrokenLinkResolver.ResolveBrokenLink(ObjectContents, j, HoldList.IdInList[IdList[i]]) then begin - raise EBoldFeatureNotImplementedYet.CreateFmt(sCannotFailIndividualObjects, [classname]); -// CascadeToNeighbours; -// ValueSpace.deleteobject + raise EBoldFeatureNotImplementedYet.CreateFmt('%s.VerifyAssociations: Failing inidividual objects not implemented', [classname]); + end; end else - raise EBold.Create(sUnresolvedLink); + raise EBold.Create('Operation failed: Unresolved link'); end; end; end; @@ -1072,11 +1067,11 @@ function TBoldBrokenLinkResolver.ResolveBrokenLink( begin aMember := ObjectContents.ValueByIndex[MemberIndex]; if (aMember.QueryInterface(IBoldObjectIdRef, anIdRef) = S_OK) then - anIdRef.SetFromId(nil) + anIdRef.SetFromId(nil, false) else if (aMember.QueryInterface(IBoldObjectIdRefPair, anIdRefPair) = S_OK) then anIdRefPair.SetFromIds(nil, nil) else - raise EBoldInternal.CreateFmt(sMemberNotSingleLink, [Classname]); + raise EBoldInternal.CreateFmt('%.ResolveBrokenLink: Member is not a singlelink', [Classname]); end; begin @@ -1088,10 +1083,10 @@ function TBoldBrokenLinkResolver.ResolveBrokenLink( case ResolveAction of blraCut: Cut; - blraAbort: raise EBold.Create(sUnresolvedLink); + blraAbort: raise EBold.Create('Operation failed: Unresolved link'); blraFailObject: result := False; blraIgnore:; - blraMissing: raise EBoldFeatureNotImplementedYet.Create(sMissingObjectsNotImplemented); + blraMissing: raise EBoldFeatureNotImplementedYet.Create('Missing Objects not implemented'); end; end; @@ -1110,7 +1105,7 @@ procedure TBoldDistributableObjectHandler.GetLocalIdsFor( end; finally TempId.Free; - end; + end; end; procedure TBoldDistributableObjectHandler.NewOwnInfoObjectsFor( @@ -1161,7 +1156,7 @@ function TBoldDistributableObjectHandler.TheMapping: TMapping; begin if not assigned(fTheMapping) then begin - Mappings := fOllSystem.ClassByExpressionName['Mapping']; // do not localize + Mappings := fOllSystem.ClassByExpressionName['Mapping']; if Mappings.Count = 0 then fTheMapping := TMapping.Create(fOllSystem) else diff --git a/Source/Extensions/OLLE/Core/BoldOLLEHandles.pas b/Source/Extensions/OLLE/Core/BoldOLLEHandles.pas index 9d64f232..9b303433 100644 --- a/Source/Extensions/OLLE/Core/BoldOLLEHandles.pas +++ b/Source/Extensions/OLLE/Core/BoldOLLEHandles.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOLLEHandles; interface @@ -12,6 +15,7 @@ interface type TBoldOLLEHandle = class; + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldOLLEHandle = class(TBoldHandle) private fOLLEController: TBoldOLLEController; @@ -36,6 +40,8 @@ TBoldOLLEHandle = class(TBoldHandle) property ApplicationPersistenceHandle: TBoldAbstractPersistenceHandleDB read fAppPHandle write fAppPHandle; end; + + implementation uses @@ -99,4 +105,5 @@ procedure TBoldOLLEHandle.SetPersistent(const Value: Boolean); GetOLLEController.Persistent := Value; end; + end. diff --git a/Source/Extensions/OLLE/Core/BoldOLLEdmmain.pas b/Source/Extensions/OLLE/Core/BoldOLLEdmmain.pas index 524d0037..31a4c873 100644 --- a/Source/Extensions/OLLE/Core/BoldOLLEdmmain.pas +++ b/Source/Extensions/OLLE/Core/BoldOLLEdmmain.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOLLEDmmain; interface @@ -27,10 +30,8 @@ implementation uses SysUtils, - BoldRev, BoldUtils; {$R *.DFM} -initialization end. diff --git a/Source/Extensions/OLLE/Core/DistributableInfo.pas b/Source/Extensions/OLLE/Core/DistributableInfo.pas index a6330bdb..3ccd0bf7 100644 --- a/Source/Extensions/OLLE/Core/DistributableInfo.pas +++ b/Source/Extensions/OLLE/Core/DistributableInfo.pas @@ -1,27 +1,14 @@ -(*****************************************) -(* This file is autogenerated *) -(* Any manual changes will be LOST! *) -(*****************************************) -(* Generated 2002-04-04 15:49:35 *) -(*****************************************) -(* This file should be stored in the *) -(* same directory as the form/datamodule *) -(* with the corresponding model *) -(*****************************************) -(* Copyright notice: *) -(* *) -(*****************************************) +{ Global compiler directives } +{$include bold.inc} unit DistributableInfo; {$DEFINE DistributableInfo_unitheader} {$INCLUDE DistributableInfo_Interface.inc} uses - // implementation uses BoldDefaultId, - // implementation dependencies - // other + BoldGeneratedCodeDictionary; { Includefile for methodimplementations } @@ -759,46 +746,44 @@ procedure TOwnPSInfoList.SetBoldObject(index: Integer; NewObject: TOwnPSInfo); function GeneratedCodeCRC: String; begin - result := '287685748'; // do not localize + result := '287685748'; end; procedure InstallObjectListClasses(BoldObjectListClasses: TBoldGeneratedClassList); begin - BoldObjectListClasses.AddObjectEntry('BusinessClassesRoot', TBusinessClassesRootList); // do not localize - BoldObjectListClasses.AddObjectEntry('CheckedOutObjectInfo', TCheckedOutObjectInfoList); // do not localize - BoldObjectListClasses.AddObjectEntry('CheckingInObjectInfo', TCheckingInObjectInfoList); // do not localize - BoldObjectListClasses.AddObjectEntry('DistributableObjectInfo', TDistributableObjectInfoList); // do not localize - BoldObjectListClasses.AddObjectEntry('HeldObjectInfo', THeldObjectInfoList); // do not localize - BoldObjectListClasses.AddObjectEntry('Mapping', TMappingList); // do not localize - BoldObjectListClasses.AddObjectEntry('PSInfo', TPSInfoList); // do not localize - BoldObjectListClasses.AddObjectEntry('ForeignObjectInfo', TForeignObjectInfoList); // do not localize - BoldObjectListClasses.AddObjectEntry('OwnObjectInfo', TOwnObjectInfoList); // do not localize - BoldObjectListClasses.AddObjectEntry('ForeignPSInfo', TForeignPSInfoList); // do not localize - BoldObjectListClasses.AddObjectEntry('OwnPSInfo', TOwnPSInfoList); // do not localize + BoldObjectListClasses.AddObjectEntry('BusinessClassesRoot', TBusinessClassesRootList); + BoldObjectListClasses.AddObjectEntry('CheckedOutObjectInfo', TCheckedOutObjectInfoList); + BoldObjectListClasses.AddObjectEntry('CheckingInObjectInfo', TCheckingInObjectInfoList); + BoldObjectListClasses.AddObjectEntry('DistributableObjectInfo', TDistributableObjectInfoList); + BoldObjectListClasses.AddObjectEntry('HeldObjectInfo', THeldObjectInfoList); + BoldObjectListClasses.AddObjectEntry('Mapping', TMappingList); + BoldObjectListClasses.AddObjectEntry('PSInfo', TPSInfoList); + BoldObjectListClasses.AddObjectEntry('ForeignObjectInfo', TForeignObjectInfoList); + BoldObjectListClasses.AddObjectEntry('OwnObjectInfo', TOwnObjectInfoList); + BoldObjectListClasses.AddObjectEntry('ForeignPSInfo', TForeignPSInfoList); + BoldObjectListClasses.AddObjectEntry('OwnPSInfo', TOwnPSInfoList); end; procedure InstallBusinessClasses(BoldObjectClasses: TBoldGeneratedClassList); begin - BoldObjectClasses.AddObjectEntry('BusinessClassesRoot', TBusinessClassesRoot); // do not localize - BoldObjectClasses.AddObjectEntry('CheckedOutObjectInfo', TCheckedOutObjectInfo); // do not localize - BoldObjectClasses.AddObjectEntry('CheckingInObjectInfo', TCheckingInObjectInfo); // do not localize - BoldObjectClasses.AddObjectEntry('DistributableObjectInfo', TDistributableObjectInfo); // do not localize - BoldObjectClasses.AddObjectEntry('HeldObjectInfo', THeldObjectInfo); // do not localize - BoldObjectClasses.AddObjectEntry('Mapping', TMapping); // do not localize - BoldObjectClasses.AddObjectEntry('PSInfo', TPSInfo); // do not localize - BoldObjectClasses.AddObjectEntry('ForeignObjectInfo', TForeignObjectInfo); // do not localize - BoldObjectClasses.AddObjectEntry('OwnObjectInfo', TOwnObjectInfo); // do not localize - BoldObjectClasses.AddObjectEntry('ForeignPSInfo', TForeignPSInfo); // do not localize - BoldObjectClasses.AddObjectEntry('OwnPSInfo', TOwnPSInfo); // do not localize + BoldObjectClasses.AddObjectEntry('BusinessClassesRoot', TBusinessClassesRoot); + BoldObjectClasses.AddObjectEntry('CheckedOutObjectInfo', TCheckedOutObjectInfo); + BoldObjectClasses.AddObjectEntry('CheckingInObjectInfo', TCheckingInObjectInfo); + BoldObjectClasses.AddObjectEntry('DistributableObjectInfo', TDistributableObjectInfo); + BoldObjectClasses.AddObjectEntry('HeldObjectInfo', THeldObjectInfo); + BoldObjectClasses.AddObjectEntry('Mapping', TMapping); + BoldObjectClasses.AddObjectEntry('PSInfo', TPSInfo); + BoldObjectClasses.AddObjectEntry('ForeignObjectInfo', TForeignObjectInfo); + BoldObjectClasses.AddObjectEntry('OwnObjectInfo', TOwnObjectInfo); + BoldObjectClasses.AddObjectEntry('ForeignPSInfo', TForeignPSInfo); + BoldObjectClasses.AddObjectEntry('OwnPSInfo', TOwnPSInfo); end; var CodeDescriptor: TBoldGeneratedCodeDescriptor; initialization - CodeDescriptor := GeneratedCodes.AddGeneratedCodeDescriptorWithFunc('DistributableInfo', InstallBusinessClasses, InstallObjectListClasses, GeneratedCodeCRC); // do not localize + CodeDescriptor := GeneratedCodes.AddGeneratedCodeDescriptorWithFunc('DistributableInfo', InstallBusinessClasses, InstallObjectListClasses, GeneratedCodeCRC); finalization GeneratedCodes.Remove(CodeDescriptor); end. - - diff --git a/Source/Extensions/OLLE/Core/OlleConsts.pas b/Source/Extensions/OLLE/Core/OlleConsts.pas index dde68fec..6ef27614 100644 --- a/Source/Extensions/OLLE/Core/OlleConsts.pas +++ b/Source/Extensions/OLLE/Core/OlleConsts.pas @@ -23,4 +23,4 @@ interface implementation -end. \ No newline at end of file +end. diff --git a/Source/Extensions/OLLE/IDE/BoldOLLEHandles.rc b/Source/Extensions/OLLE/IDE/BoldOLLEHandles.rc index c6490b96..8e3ebe96 100644 --- a/Source/Extensions/OLLE/IDE/BoldOLLEHandles.rc +++ b/Source/Extensions/OLLE/IDE/BoldOLLEHandles.rc @@ -1 +1 @@ -TBOLDOLLEHANDLE BITMAP LOADONCALL TBoldOLLEHandle.bmp \ No newline at end of file +TBOLDOLLEHANDLE BITMAP LOADONCALL ..\..\..\Images\Components\TBoldOLLEHandle.bmp diff --git a/Source/Extensions/OLLE/IDE/BoldOLLEHandlesComponentEditor.pas b/Source/Extensions/OLLE/IDE/BoldOLLEHandlesComponentEditor.pas index 95b35133..5f1d8d74 100644 --- a/Source/Extensions/OLLE/IDE/BoldOLLEHandlesComponentEditor.pas +++ b/Source/Extensions/OLLE/IDE/BoldOLLEHandlesComponentEditor.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOLLEHandlesComponentEditor; interface @@ -19,8 +22,7 @@ implementation uses SysUtils, - BoldUtils, - OLLEConsts; + BoldUtils; { TBoldOLLEHandleComponentEditor } @@ -36,9 +38,9 @@ procedure TBoldOLLEHandleComponentEditor.ExecuteVerb(index: Integer); function TBoldOLLEHandleComponentEditor.GetVerb(index: Integer): string; begin case index of - 0: result := sGenerateOLLEDB; + 0: result := 'Generate OLLE database'; else - result := sNonexistingAction; + result := 'Nonexisting action'; end; end; @@ -48,4 +50,3 @@ function TBoldOLLEHandleComponentEditor.GetVerbCount: Integer; end; end. - diff --git a/Source/Extensions/OLLE/IDE/BoldOLLEHandlesReg.pas b/Source/Extensions/OLLE/IDE/BoldOLLEHandlesReg.pas index dfd3acb1..46816264 100644 --- a/Source/Extensions/OLLE/IDE/BoldOLLEHandlesReg.pas +++ b/Source/Extensions/OLLE/IDE/BoldOLLEHandlesReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOLLEHandlesReg; interface @@ -31,7 +34,6 @@ procedure RegisterComponentEditors; procedure Register; begin - RemovePackageFromDisabledPackagesRegistry(Format('BoldOLLE%s', [LIBSUFFIX])); // do not localize RegisterComponentsOnPalette; RegisterComponentEditors; end; diff --git a/Source/FreestandingValueSpace/Core/BoldFreeStandingValueFactories.pas b/Source/FreestandingValueSpace/Core/BoldFreeStandingValueFactories.pas index 814854bf..738c54d4 100644 --- a/Source/FreestandingValueSpace/Core/BoldFreeStandingValueFactories.pas +++ b/Source/FreestandingValueSpace/Core/BoldFreeStandingValueFactories.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldFreeStandingValueFactories; interface @@ -29,7 +32,6 @@ implementation uses SysUtils, - FreeStandingValuesConst, BoldDefs, BoldDefaultStreamNames; {--- TBoldFreeStandingObjectContentsFactory ---} @@ -40,7 +42,7 @@ constructor TBoldFreeStandingElementFactory.create; fClasses := TBoldNamedValueList.Create; end; -destructor TBoldFreeStandingElementFactory.Destroy; +destructor TBoldFreeStandingElementFactory.destroy; begin FreeAndNil(fClasses); inherited; @@ -48,7 +50,7 @@ destructor TBoldFreeStandingElementFactory.Destroy; procedure TBoldFreeStandingElementFactory.RegisterFreeStandingClass(const ContentName: String; FreeStandingClass: TBoldFreeStandingElementClass); begin - fClasses.AddEntry(ContentName, '', TObject(FreeStandingClass)); + fClasses.AddEntry(ContentName, '', TObject(FreeStandingClass)); end; function TBoldFreeStandingElementFactory.CreateInstance(const ContentName: string): TBoldInterfacedObject; @@ -58,8 +60,8 @@ function TBoldFreeStandingElementFactory.CreateInstance(const ContentName: strin ElementClass := TBoldFreeStandingElementClass(fClasses.ObjectByName[ContentName]); if Assigned(ElementClass) then result := ElementClass.Create - else - raise EBold.createFmt(sNoClassregisteredForName, [classname, ContentName]); + else + raise EBold.createFmt('%s.CreateInstance: No freestanding class registered for name %s', [classname, ContentName]); end; initialization @@ -87,4 +89,3 @@ finalization FreeAndNil(FreeStandingValueFactory); end. - diff --git a/Source/FreestandingValueSpace/Core/BoldFreeStandingValues.pas b/Source/FreestandingValueSpace/Core/BoldFreeStandingValues.pas index 4b45072d..b0fdebc2 100644 --- a/Source/FreestandingValueSpace/Core/BoldFreeStandingValues.pas +++ b/Source/FreestandingValueSpace/Core/BoldFreeStandingValues.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldFreeStandingValues; interface @@ -48,49 +51,56 @@ TBFSObjectIdListRefPair = class; end; TBoldFreeStandingElementClass = class of TBoldFreeStandingElement; + TBoldFreeStandingObjectContentsClass = class of TBoldFreeStandingObjectContents; { TBoldFreeStandingElement } TBoldFreeStandingElement = class(TBoldNonRefCountedObject) public + class function ContentType: TBoldValueContentType; virtual; abstract; + function GetContentType: TBoldValueContentType; constructor Create; virtual; end; { TBoldFreeStandingValueSpace } TBoldFreeStandingValueSpace = class(TBoldFreeStandingElement, IBoldValueSpace) - private - fIdLIst: TBoldObjectIdlist; + strict private + fIdList: TBoldObjectIdlist; fObjectContentsList: TBoldFSObjectContentList; fTranslationList: TBoldIdTranslationList; - function GetIdList: TBoldObjectIdList; - function GetObjectContentsByObjectId(ObjectId: TBoldObjectId): IBoldObjectContents; + private + function GetIdList: TBoldObjectIdList; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetObjectContentsByObjectId(ObjectId: TBoldObjectId): IBoldObjectContents; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure ApplyTranslationList(IdTranslationList: TBoldIdTranslationList); - procedure EnsureObjectId(ObjectId: TBoldObjectId); + procedure EnsureObjectId(ObjectId: TBoldObjectId); {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure ExactifyIDs(TranslationList: TBoldIdTranslationList); protected property IdList: TBoldObjectIdList read GetIdList; public constructor Create; override; destructor Destroy; override; + class function ContentType: TBoldValueContentType; override; procedure RemoveDeletedObjects; procedure MarkAllObjectsAndMembersCurrent; - function GetFSObjectContentsByObjectId(ObjectId: TBoldObjectId): TBoldFreeStandingObjectContents; - procedure RemoveFSObjectContentsByObjectId(ObjectId: TBoldObjectId); - procedure ApplyValueSpace(ValueSpace: IBoldValueSpace; IgnorePersistenceState: Boolean); + function GetFSObjectContentsByObjectId(ObjectId: TBoldObjectId): TBoldFreeStandingObjectContents; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure RemoveFSObjectContentsByObjectId(ObjectId: TBoldObjectId); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure RemoveFSObjectContents(ObjectContents: TBoldFreeStandingObjectContents); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure ApplyValueSpace(const ValueSpace: IBoldValueSpace; IgnorePersistenceState: Boolean); procedure AllObjectIds(resultList: TBoldObjectIdList; OnlyLoaded: Boolean); - procedure UpdateOwnValuesFrom(ValueSpace: IBoldValueSpace); + procedure ClearWhenObjectContentsEmpty; + procedure UpdateOwnValuesFrom(const ValueSpace: IBoldValueSpace); procedure RemoveAllObjectContents; - function GetHasContentsForId(ObjectId: TBoldObjectId): boolean; - procedure EnsureObjectContents(ObjectId: TBoldObjectId); - function GetEnsuredObjectContentsByObjectId(ObjectId: TBoldObjectId): IBoldObjectContents; - function GetEnsuredFSObjectContentsByObjectId(ObjectId: TBoldObjectId): TBoldFreeStandingObjectContents; + function GetHasContentsForId(ObjectId: TBoldObjectId): boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure EnsureObjectContents(ObjectId: TBoldObjectId); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetEnsuredObjectContentsByObjectIdAndCheckIfCreated(ObjectId: TBoldObjectId; out aBoldObjectContents: IBoldObjectContents): boolean; + function GetEnsuredObjectContentsByObjectId(ObjectId: TBoldObjectId): IBoldObjectContents; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetEnsuredFSObjectContentsByObjectId(ObjectId: TBoldObjectId): TBoldFreeStandingObjectContents; overload; + function GetEnsuredFSObjectContentsByObjectId(ObjectId: TBoldObjectId; out aCreated: boolean): TBoldFreeStandingObjectContents; overload; function GetValueForIdAndMemberIndex(Id: TBoldObjectId; MemberIndex: integer): IBoldValue; + function IdCount: integer; + function IsEmpty: boolean; + procedure Clear; end; - PMemberList = ^TMemberList; - TMemberList = array[0..MaxListSize - 1] of TBoldFreeStandingValue; - - - { TBoldFreeStandingObjectContents } TBoldFreeStandingObjectContents = class(TBoldFreeStandingElement, IBoldObjectContents, IBoldStreamable) private @@ -98,42 +108,47 @@ TBoldFreeStandingObjectContents = class(TBoldFreeStandingElement, IBoldObjectC fBoldPersistenceState: TBoldValuePersistenceState; fGlobalId: string; fIsReadOnly: Boolean; - fMemberList: PMemberList; - fMemberCount: integer; fObjectId: TBoldObjectId; fTimeStamp: TBoldTimeStampType; - function GetObjectId: TBoldObjectId; - function GetStreamName: string; + function GetObjectId: TBoldObjectId; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetStreamName: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure ApplyTranslationList(TranslationList: TBoldIdTranslationList); - function GetBoldExistenceState: TBoldExistenceState; - function GetBoldMemberCount: Integer; - function GetBoldPersistenceState: TBoldValuePersistenceState; - function GetGlobalId: string; - function GetIsModified: Boolean; - function GetIsReadOnly: Boolean; - function GetValueByIndex(I: Integer): IBoldValue; - function GetFSValueByIndex(i: integer): TBoldFreeStandingValue; - function GetValueByMemberId(MemberId: TBoldMemberID):IBoldValue; - function GetTimeStamp: TBoldTimeStampType; - procedure SetBoldExistenceState(Value: TBoldExistenceState); - procedure SetBoldPersistenceState(Value: TBoldValuePersistenceState); - procedure SetGlobalId(const NewValue: string); - procedure SetIsReadOnly(NewValue: Boolean); - procedure SetTimeStamp(NewValue: TBoldTimeStampType); + function GetBoldExistenceState: TBoldExistenceState; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetBoldMemberCount: Integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetBoldPersistenceState: TBoldValuePersistenceState; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetGlobalId: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetIsModified: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetIsReadOnly: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetValueByIndex(I: Integer): IBoldValue; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetFSValueByIndex(i: integer): TBoldFreeStandingValue; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetValueByMemberId(MemberId: TBoldMemberID):IBoldValue; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetTimeStamp: TBoldTimeStampType; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetBoldExistenceState(Value: TBoldExistenceState); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetBoldPersistenceState(Value: TBoldValuePersistenceState); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetGlobalId(const NewValue: string); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetIsReadOnly(NewValue: Boolean); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetTimeStamp(NewValue: TBoldTimeStampType); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + protected + fMemberList: array of TBoldFreeStandingValue; + procedure EnsureMemberListLength(index: integer); // {$IFDEF BOLD_INLINE} inline; {$ENDIF} public constructor Create; override; destructor Destroy; override; + class function ContentType: TBoldValueContentType; override; procedure MarkAllMembersCurrent; - procedure RemoveMemberByIndex(Index: integer); + procedure RemoveMemberByIndex(Index: integer); {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure EnsureMember(MemberId: TBoldMemberId; const StreamName: string); - procedure EnsureMemberByIndex(Index: integer; const StreamName: string); - procedure ApplyObjectContents(ObjectContents: IBoldObjectContents; const ApplyValues: Boolean; const IgnorePersistenceState: Boolean); - procedure UpdateObjectContentsFrom(ObjectContents: IBoldObjectContents); + function EnsureMemberAndGetValueByIndex(Index: integer; const StreamName: string): IBoldValue; + procedure ApplyObjectContents(const ObjectContents: IBoldObjectContents; ApplyValues: Boolean; IgnorePersistenceState: Boolean); + procedure UpdateObjectContentsFrom(const ObjectContents: IBoldObjectContents); + function IsEmpty: boolean; property ValueByIndex[I: integer]: IBoldValue read GetValueByIndex; property FSValueByIndex[I: integer]: TBoldFreeStandingValue read GetFSValueByIndex; property BoldExistenceState: TBoldExistenceState read GetBoldExistenceState write SetBoldExistenceState; property BoldPersistenceState: TBoldValuePersistenceState read GetBoldPersistenceState write SetBoldPersistenceState; - property MemberCount: integer read fMemberCount; + property TimeStamp: TBoldTimeStampType read GetTimeStamp write SetTimeStamp; + property MemberCount: integer read GetBoldMemberCount; + property ObjectId: TBoldObjectId read GetObjectId; end; { TBoldFreeStandingValue } @@ -141,39 +156,49 @@ TBoldFreeStandingValue = class(TBoldFreeStandingElement, IBoldValue, IBoldStre private fBoldPersistenceState: TBoldValuePersistenceState; protected - function GetContentName: String; - function GetBoldPersistenceState: TBoldValuePersistenceState; - procedure SetBoldPersistenceState(Value: TBoldValuePersistenceState); + function GetContentName: String; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetBoldPersistenceState: TBoldValuePersistenceState; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetBoldPersistenceState(Value: TBoldValuePersistenceState); {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetStreamName: string; virtual; abstract; procedure ApplyTranslationList(TranslationList: TBoldIdTranslationList); virtual; - procedure AssignContentValue(Source: IBoldValue); virtual; + procedure AssignContentValue(const Source: IBoldValue); virtual; public constructor Create; override; - procedure AssignContent(Source: IBoldValue); + procedure AssignContent(const Source: IBoldValue); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function IsEqualToValue(const Value: IBoldValue): Boolean; virtual; property ContentName: string read GetContentName; property BoldPersistenceState: TBoldValuePersistenceState read fBoldPersistenceState write fBoldPersistenceState; end; { TBoldFreeStandingNullableValue } - TBoldFreeStandingNullableValue = class(TBoldFreeStandingValue, IBoldNullableValue) + TBoldFreeStandingNullableValue = class(TBoldFreeStandingValue, IBoldNullableValue, IBoldVariantReadable, IBoldStringRepresentable) private fIsNull: Boolean; + function GetAsVariant: Variant; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected - procedure SetToNonNull; - function GetContentIsNull: Boolean; - procedure SetContentToNull; + procedure SetToNonNull; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetContentIsNull: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetContentToNull; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetValueAsVariant: Variant; virtual; abstract; + function GetStringRepresentation(representation:integer): String; virtual; + function GetContentAsString: String; virtual; + public + function IsEqualToValue(const Value: IBoldValue): Boolean; override; end; { TBFSInteger } TBFSInteger = class(TBoldFreeStandingNullableValue, IBoldIntegerContent) private fDataValue: Integer; - function GetContentAsInteger: Integer; - procedure SetContentAsInteger(NewValue: Integer); + function GetContentAsInteger: Integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetContentAsInteger(NewValue: Integer); {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected function GetStreamName: string; override; - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; + function GetValueAsVariant: Variant; override; public + class function ContentType: TBoldValueContentType; override; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; property AsInteger: Integer read GetContentAsInteger write SetContentAsInteger; end; @@ -181,12 +206,15 @@ TBFSInteger = class(TBoldFreeStandingNullableValue, IBoldIntegerContent) TBFSString = class(TBoldFreeStandingNullableValue, IBoldStringContent) private fDataValue: String; - function GetContentAsString: String; - procedure SetContentAsString(const NewValue: String); + function GetContentAsString: String; override; + procedure SetContentAsString(const NewValue: String); {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected function GetStreamName: string; override; - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; + function GetValueAsVariant: Variant; override; public + class function ContentType: TBoldValueContentType; override; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; property AsString: String read GetContentAsString write SetContentAsString; end; @@ -194,12 +222,15 @@ TBFSString = class(TBoldFreeStandingNullableValue, IBoldStringContent) TBFSCurrency = class(TBoldFreeStandingNullableValue, IBoldCurrencyContent) private fDataValue: Currency; - function GetContentAsCurrency: Currency; - procedure SetContentAsCurrency(NewValue: Currency); + function GetContentAsCurrency: Currency; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetContentAsCurrency(NewValue: Currency); {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected function GetStreamName: String; override; - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; + function GetValueAsVariant: Variant; override; public + class function ContentType: TBoldValueContentType; override; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; property AsCurrency: Currency read GetContentAsCurrency write SetContentAsCurrency; end; @@ -207,12 +238,15 @@ TBFSCurrency = class(TBoldFreeStandingNullableValue, IBoldCurrencyContent) TBFSFloat = class(TBoldFreeStandingNullableValue, IBoldFloatContent) private fDataValue: Double; - function GetContentAsFloat: Double; - procedure SetContentAsFloat(NewValue: Double); + function GetContentAsFloat: Double; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetContentAsFloat(NewValue: Double); {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected function GetStreamName: String; override; - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; + function GetValueAsVariant: Variant; override; public + class function ContentType: TBoldValueContentType; override; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; property AsFloat: Double read GetContentAsFloat write SetContentAsFloat; end; @@ -220,12 +254,15 @@ TBFSFloat = class(TBoldFreeStandingNullableValue, IBoldFloatContent) TBFSBoolean = class(TBoldFreeStandingNullableValue, IBoldBooleanContent) private fDataValue: Boolean; - function GetContentAsBoolean: Boolean; - procedure SetContentAsBoolean(NewValue: Boolean); + function GetContentAsBoolean: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetContentAsBoolean(NewValue: Boolean); {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected function GetStreamName: String; override; - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; + function GetValueAsVariant: Variant; override; public + class function ContentType: TBoldValueContentType; override; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; property AsBoolean: Boolean read GetContentAsBoolean write SetContentAsBoolean; end; @@ -234,20 +271,23 @@ TBFSDateTimeAbstract = class(TBoldFreeStandingNullableValue) private fDataValue: TDateTime; protected - function GetContentAsDateTime: TDateTime; - procedure SetContentAsDateTime(NewValue: TDateTime); - function GetContentAsTime: TDateTime; - procedure SetContentAsTime(NewValue: TDateTime); - function GetContentAsDate: TDateTime; - procedure SetContentAsDate(NewValue: TDateTime); + function GetContentAsDateTime: TDateTime; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetContentAsDateTime(NewValue: TDateTime); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetContentAsTime: TDateTime; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetContentAsTime(NewValue: TDateTime); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetContentAsDate: TDateTime; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetContentAsDate(NewValue: TDateTime); {$IFDEF BOLD_INLINE} inline; {$ENDIF} end; { TBFSDateTime } TBFSDateTime = class(TBFSDateTimeAbstract, IBoldDateTimeContent) protected function GetStreamName: String; override; - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; + function GetValueAsVariant: Variant; override; public + class function ContentType: TBoldValueContentType; override; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; property AsDateTime: TDateTime read GetContentAsDateTime write SetContentAsDateTime; end; @@ -255,8 +295,11 @@ TBFSDateTime = class(TBFSDateTimeAbstract, IBoldDateTimeContent) TBFSDate = class(TBFSDateTimeAbstract, IBoldDateContent) protected function GetStreamName: String; override; - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; + function GetValueAsVariant: Variant; override; public + class function ContentType: TBoldValueContentType; override; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; property AsDate: TDateTime read GetContentAsDate write SetContentAsDate; end; @@ -264,39 +307,48 @@ TBFSDate = class(TBFSDateTimeAbstract, IBoldDateContent) TBFSTime = class(TBFSDateTimeAbstract, IBoldTimeContent) protected function GetStreamName: String; override; - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; + function GetValueAsVariant: Variant; override; public + class function ContentType: TBoldValueContentType; override; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; property AsTime: TDateTime read GetContentAsTime write SetContentAsTime; end; { TBFSBlobAbstract } TBFSBlobAbstract = class(TBoldFreeStandingNullableValue) private - fDataValue: String; - function GetContentAsBlob: String; - procedure SetContentAsBlob(const NewValue: String); + fDataValue: AnsiString; + function GetContentAsBlob: TBoldAnsiString; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetContentAsBlob(const NewValue: TBoldAnsiString); {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected function GetStreamName: String; override; + function GetValueAsVariant: Variant; override; public - property AsBlob: String read GetContentAsBlob write SetContentAsBlob; + property AsBlob: TBoldAnsiString read GetContentAsBlob write SetContentAsBlob; end; { TBFSBlob } TBFSBlob = class(TBFSBlobAbstract, IBoldBlobContent) protected - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; + public + class function ContentType: TBoldValueContentType; override; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; end; { TBFSTypedBlob } TBFSTypedBlob = class(TBFSBlobAbstract, IBoldTypedBlob, IBoldBlobContent) private fContent: String; - function GetContentTypeContent: String; - procedure SetContentTypeContent(const NewValue: String); + function GetContentTypeContent: String; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetContentTypeContent(const NewValue: String); {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected - function GetStreamName: String; override; - procedure AssignContentValue(Source: IBoldValue); override; + function GetStreamName: String; override; + procedure AssignContentValue(const Source: IBoldValue); override; public + class function ContentType: TBoldValueContentType; override; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; property ContentTypeContent: String read GetContentTypeContent write SetContentTypeContent; end; @@ -306,8 +358,8 @@ TBFSTypedBlob = class(TBFSBlobAbstract, IBoldTypedBlob, IBoldBlobContent) TBFSObjectIDRefAbstract = class(TBoldFreeStandingValue) private fOrderNo: Integer; - function GetOrderNo: integer; - procedure SetOrderNo(NewOrder: Integer); + function GetOrderNo: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetOrderNo(NewOrder: Integer); {$IFDEF BOLD_INLINE} inline; {$ENDIF} public property OrderNo: integer read GetOrderNo write SetOrderNo; end; @@ -316,14 +368,16 @@ TBFSObjectIDRefAbstract = class(TBoldFreeStandingValue) TBFSObjectIDRef = class(TBFSObjectIDRefAbstract, IBoldObjectIdRef) private fObjectId: TBoldObjectId; - function GetId: TBoldObjectID; + function GetId: TBoldObjectID; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; function GetStreamName: String; override; procedure ApplyTranslationList(TranslationList: TBoldIdTranslationList); override; public destructor Destroy; override; - procedure SetFromId(Id: TBoldObjectId); + class function ContentType: TBoldValueContentType; override; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; + procedure SetFromId(Id: TBoldObjectId; Adopt: Boolean); property Id: TBoldObjectId read GetId; end; @@ -331,15 +385,16 @@ TBFSObjectIDRef = class(TBFSObjectIDRefAbstract, IBoldObjectIdRef) TBFSObjectIDRefPair = class(TBFSObjectIDRefAbstract, IBoldObjectIdRefPair) private fObjectIds: TBoldObjectIdList; - procedure EnsureIdList; - function GetId1: TBoldObjectID; - function GetId2: TBoldObjectID; + procedure EnsureIdList; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetId1: TBoldObjectID; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetId2: TBoldObjectID; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; function GetStreamName: String; override; procedure ApplyTranslationList(TranslationList: TBoldIdTranslationList); override; public destructor Destroy; override; + class function ContentType: TBoldValueContentType; override; procedure SetFromIds(Id1, Id2: TBoldObjectId); property Id1: TBoldObjectId read GetId1; property Id2: TBoldObjectId read GetId2; @@ -352,15 +407,17 @@ TBFSObjectIdListref = class(TBoldFreeStandingValue, IBoldObjectIdListRef, IBol function GetIdList(Index: Integer): TBoldObjectID; procedure RemoveId(Id: TBoldObjectId); procedure AddId(Id: TBoldObjectId); - procedure EnsureList; + procedure EnsureList; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; function GetStreamName: String; override; procedure ApplyTranslationList(TranslationList: TBoldIdTranslationList); override; - function GetCount: integer; + function GetCount: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public destructor Destroy; override; + class function ContentType: TBoldValueContentType; override; procedure SetFromIdList(IdList: TBoldObjectIdList); + procedure SetList(IdList: TBoldObjectIdList); property IdList[Index: integer]: TBoldObjectID read GetIdList; property Count: integer read GetCount; end; @@ -369,18 +426,19 @@ TBFSObjectIdListref = class(TBoldFreeStandingValue, IBoldObjectIdListRef, IBol TBFSObjectIdListrefPair = class(TBoldFreeStandingValue, IBoldObjectIdListRefPair, IBoldFreeStandingIdListPair) private fIdLIst1, fIdList2: TBoldObjectidLIst; - function GetIdList1(Index: Integer): TBoldObjectID; - function GetIdList2(Index: Integer): TBoldObjectID; - procedure EnsureLists; + function GetIdList1(Index: Integer): TBoldObjectID; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetIdList2(Index: Integer): TBoldObjectID; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure EnsureLists; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure AddIds(Id1, Id2: TBoldObjectId); procedure RemoveId(Id: TBoldObjectId); protected - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; function GetStreamName: String; override; procedure ApplyTranslationList(TranslationList: TBoldIdTranslationList); override; - function GetCount: integer; + function GetCount: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public destructor Destroy; override; + class function ContentType: TBoldValueContentType; override; procedure SetFromIdLists(IdList1, IdList2: TBoldObjectIdList); property IdList1[Index: integer]: TBoldObjectID read GetIdList1; property IdList2[Index: integer]: TBoldObjectID read GetIdList2; @@ -388,30 +446,32 @@ TBFSObjectIdListrefPair = class(TBoldFreeStandingValue, IBoldObjectIdListRefPa end; { TBoldFSObjectContentList } - - // this list should be an unordered indexable list for performace reasons, but FSValueSpace.ApplyTranslationList is a bit tricky to rewrite... TBoldFSObjectContentList = class(TBoldIndexableList) private - function GetItems(index: integer): TBoldFreeStandingObjectContents; + class var IX_FSObjectContent: integer; + function GetItems(index: integer): TBoldFreeStandingObjectContents; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetItems(index: integer; const Value: TBoldFreeStandingObjectContents); public constructor Create; - function FindObjectContentById(Id: TBoldObjectId): TBoldFreeStandingObjectContents; + function FindObjectContentById(Id: TBoldObjectId): TBoldFreeStandingObjectContents; {$IFDEF BOLD_INLINE} inline; {$ENDIF} property Items[index: integer]: TBoldFreeStandingObjectContents read GetItems write SetItems; default; end; + +var + BoldFreeStandingObjectContentsClass: TBoldFreeStandingObjectContentsClass = TBoldFreeStandingObjectContents; + implementation uses SysUtils, - FreeStandingValuesConst, BoldUtils, BoldIndex, BoldHashIndexes, BoldFreeStandingValueFactories, BoldDefaultStreamNames, - BoldMemoryManager, - BoldGuard; + BoldGuard, + Variants; type {---TBoldObjectIdHashIndex---} @@ -421,29 +481,30 @@ TBoldFSObjectContentHashIndex = class(TBoldHashIndex) function HashItem(Item: TObject): Cardinal; override; function Match(const Key; Item:TObject):Boolean; override; function Hash(const Key): Cardinal; override; - function FindById(boldObjectId:TboldObjectId): TObject; + function FindById(BoldObjectId: TBoldObjectId): TObject; {$IFDEF BOLD_INLINE} inline; {$ENDIF} end; -var - IX_FSObjectContent: integer = -1; - {---TBoldFreeStandingElement---} constructor TBoldFreeStandingElement.Create; begin - // this is empty, but allows other freestanding values to initialize values - // in their overridden constructors + inherited; end; +function TBoldFreeStandingElement.GetContentType: TBoldValueContentType; +begin + result := ContentType; +end; + {---TBoldFreeStandingvalueSpace---} constructor TBoldFreeStandingvalueSpace.Create; begin inherited; fObjectContentsList := TBoldFSObjectContentList.create; - fIdLIst := tBoldObjectIdList.Create; + fIdLIst := TBoldObjectIdList.Create; end; destructor TBoldFreeStandingvalueSpace.Destroy; @@ -467,25 +528,30 @@ function TBoldFreeStandingvalueSpace.GetIdList: TBoldObjectIdList; result := fIdList; end; +function TBoldFSObjectContentList.FindObjectContentById(Id: TBoldObjectId): TBoldFreeStandingObjectContents; +begin + Result := TBoldFreeStandingObjectContents(TBoldHashIndex(indexes[IX_FSObjectContent]).Find(ID)); +end; + function TBoldFreeStandingvalueSpace.GetFSObjectContentsByObjectId(ObjectId: TBoldObjectId): TBoldFreeStandingObjectContents; begin result := fObjectContentsList.FindObjectContentById(ObjectId); end; +procedure TBoldFreeStandingValueSpace.RemoveFSObjectContents( + ObjectContents: TBoldFreeStandingObjectContents); +begin + fObjectContentsList.Remove(ObjectContents); +end; + procedure TBoldFreeStandingvalueSpace.RemoveFSObjectContentsByObjectId(ObjectId: TBoldObjectId); begin fObjectContentsList.Remove(GetFSObjectContentsByObjectId(ObjectId)); end; function TBoldFreeStandingvalueSpace.GetObjectContentsByObjectId(ObjectId: TBoldObjectId): IBoldObjectContents; -var - temp: TBoldFreeStandingObjectContents; begin - temp := GetFSObjectContentsByObjectId(ObjectId); - if assigned(temp) then - result := temp - else - result := nil; + result := GetFSObjectContentsByObjectId(ObjectId); end; function TBoldFreeStandingvalueSpace.GetEnsuredObjectContentsByObjectId(ObjectId: TBoldObjectId): IBoldObjectContents; @@ -493,6 +559,13 @@ function TBoldFreeStandingvalueSpace.GetEnsuredObjectContentsByObjectId(ObjectId Result := GetEnsuredFSObjectContentsByObjectId(ObjectId); end; +function TBoldFreeStandingValueSpace.GetEnsuredObjectContentsByObjectIdAndCheckIfCreated( + ObjectId: TBoldObjectId; + out aBoldObjectContents: IBoldObjectContents): boolean; +begin + aBoldObjectContents := GetEnsuredFSObjectContentsByObjectId(ObjectId, result); +end; + function TBoldFreeStandingvalueSpace.GetHasContentsForId(ObjectId: TBoldObjectId): boolean; begin result := assigned(GetObjectContentsByObjectId(Objectid)); @@ -534,12 +607,13 @@ procedure TBoldFreeStandingvalueSpace.ApplytranslationList(IdTranslationList: TB if not assigned(fTranslationList) then fTranslationList := TBoldIDTranslationList.Create; For i := 0 to IdTranslationList.Count - 1 do + if IdTranslationList.OldIds[i] <> nil then fTranslationList.AddTranslation(IdTranslationList.OldIds[i], IdTranslationList.NewIds[i]); for i := 0 to fObjectContentsList.Count - 1 do DoOneObject(i, TBoldFreeStandingObjectContents(fObjectContentsList[i])); end; -procedure TBoldFreeStandingvalueSpace.ApplyValueSpace(ValueSpace: IBoldValueSpace; IgnorePersistenceState: Boolean); +procedure TBoldFreeStandingvalueSpace.ApplyValueSpace(const ValueSpace: IBoldValueSpace; IgnorePersistenceState: Boolean); var i: Integer; anIdList: TBoldObjectIdList; @@ -580,12 +654,8 @@ destructor TBoldFreeStandingObjectContents.Destroy; var i: integer; begin - if Assigned(fMemberList) then - begin - for i := 0 to fMemberCount - 1 do - fMemberList^[i].Free; - BoldMemoryManager_.DeAllocateMemory(fMemberList, fMemberCount*sizeof(Pointer)); - end; + for i := 0 to Length(fMemberList) - 1 do + FreeAndNil(fMemberList[i]); inherited; end; @@ -595,6 +665,19 @@ function TBoldFreeStandingObjectContents.GetValueByMemberId(MemberId: TBoldMembe result := GetValueByIndex(MemberId.MemberIndex); end; +function TBoldFreeStandingObjectContents.IsEmpty: boolean; +var + i: integer; +begin + result := true; + for i := Length(fMemberList) - 1 downto 0 do + if Assigned(fMemberList[i]) then + begin + result := false; + exit; + end; +end; + function TBoldFreeStandingObjectContents.GetStreamName: string; begin result := BOLDOBJECTCONTENTSNAME; @@ -602,13 +685,13 @@ function TBoldFreeStandingObjectContents.GetStreamName: string; procedure TBoldFreeStandingObjectContents.EnsureMember(MemberId: TBoldMemberId; const StreamName: string); begin - EnsurememberByIndex( MemberId.MemberIndex, StreamName ); + EnsureMemberAndGetValueByIndex( MemberId.MemberIndex, StreamName ); end; function TBoldFreeStandingObjectContents.GetValueByIndex(I: Integer): IBoldValue; begin - if i < MemberCount then - result := fMemberList^[i] + if i < Length(fMemberList) then + result := fMemberList[i] else result := nil; end; @@ -616,12 +699,11 @@ function TBoldFreeStandingObjectContents.GetValueByIndex(I: Integer): IBoldValue function TBoldFreeStandingObjectContents.GetFSValueByIndex(i: integer): TBoldFreeStandingValue; begin if i < MemberCount then - result := fMemberList^[i] + result := fMemberList[i] else result := nil; end; - function TBoldFreeStandingObjectContents.GetIsModified: Boolean; begin result := True; @@ -636,7 +718,6 @@ function TBoldFreeStandingValue.GetBoldPersistenceState: TBoldValuePersistenceSt procedure TBoldFreeStandingValue.ApplyTranslationList(TranslationList: TBoldIdTranslationList); begin - // do nothing end; {---TBoldFreeStandingNullableValue---} @@ -646,16 +727,48 @@ procedure TBoldFreeStandingNullableValue.SetContentToNull; fIsNull := true; end; +function TBoldFreeStandingNullableValue.GetContentAsString: String; +begin + result := GetStringRepresentation(brDefault); +end; + function TBoldFreeStandingNullableValue.GetContentIsNull: Boolean; begin result := fIsNull; end; +function TBoldFreeStandingNullableValue.IsEqualToValue(const Value: IBoldValue): + Boolean; +var + aNullableValue: IBoldNullableValue; +begin + Result := Assigned(Value) and + (Value.QueryInterface(IBoldNullableValue, aNullableValue) = S_OK) and + (fIsNull = aNullableValue.IsNull); +end; + +function TBoldFreeStandingNullableValue.GetStringRepresentation( + representation: integer): String; +begin + if GetContentIsNull then + result := '' + else + result := VarToStr(GetValueAsVariant); +end; + procedure TBoldFreeStandingNullableValue.SetToNonNull; begin fIsNull := false; end; +function TBoldFreeStandingNullableValue.GetAsVariant; +begin + if GetContentIsNull then + result := Null + else + result := GetValueAsVariant; +end; + {---TBFSInteger---} function TBFSInteger.GetStreamName: string; @@ -663,11 +776,21 @@ function TBFSInteger.GetStreamName: string; result := BoldContentName_Integer; end; +function TBFSInteger.GetValueAsVariant: Variant; +begin + result := AsInteger; +end; + function TBFSInteger.GetContentAsInteger: Integer; begin result := fDataValue; end; +class function TBFSInteger.ContentType: TBoldValueContentType; +begin + result := bctInteger; +end; + procedure TBFSInteger.SetContentAsInteger(NewValue: Integer); begin fDataValue := NewValue; @@ -681,14 +804,24 @@ function TBFSString.GetStreamName: string; result := BoldContentName_String; end; +function TBFSString.GetValueAsVariant: Variant; +begin + result := AsString; +end; + function TBFSString.GetContentAsString: String; begin result := fDataValue; end; +class function TBFSString.ContentType: TBoldValueContentType; +begin + result := bctString; +end; + procedure TBFSString.SetContentAsString(const NewValue: String); begin - fDataValue := NewValue; + fDataValue := NewValue; // Use BoldSharedStringManager ? SetToNonNull; end; @@ -699,11 +832,21 @@ function TBFSCurrency.GetStreamName: String; result := BoldContentName_Currency; end; +function TBFSCurrency.GetValueAsVariant: Variant; +begin + result := AsCurrency; +end; + function TBFSCurrency.GetContentAsCurrency: Currency; begin result := fDataValue; end; +class function TBFSCurrency.ContentType: TBoldValueContentType; +begin + result := bctCurrency; +end; + procedure TBFSCurrency.SetContentAsCurrency(NewValue: Currency); begin fDataValue := NewValue; @@ -717,11 +860,21 @@ function TBFSFloat.GetStreamName: String; result := BoldContentName_Float; end; +function TBFSFloat.GetValueAsVariant: Variant; +begin + result := AsFloat; +end; + function TBFSFloat.GetContentAsFloat: double; begin result := fDataValue; end; +class function TBFSFloat.ContentType: TBoldValueContentType; +begin + result := bctFloat; +end; + procedure TBFSFloat.SetContentAsFloat(NewValue: Double); begin fDataValue := NewValue; @@ -735,11 +888,21 @@ function TBFSBoolean.GetStreamName: String; Result := BoldContentName_Boolean; end; +function TBFSBoolean.GetValueAsVariant: Variant; +begin + result := AsBoolean; +end; + function TBFSBoolean.GetContentAsBoolean: Boolean; begin Result := fDataValue; end; +class function TBFSBoolean.ContentType: TBoldValueContentType; +begin + result := bctBoolean; +end; + procedure TBFSBoolean.SetContentAsBoolean(NewValue: Boolean); begin fDataValue := NewValue; @@ -788,12 +951,17 @@ function TBFSBlobAbstract.GetStreamName: String; Result := BoldContentName_Blob; end; -function TBFSBlobAbstract.GetContentAsBlob: String; +function TBFSBlobAbstract.GetValueAsVariant: Variant; +begin + result := AsBlob; +end; + +function TBFSBlobAbstract.GetContentAsBlob: TBoldAnsiString; begin Result := fDataValue; end; -procedure TBFSBlobAbstract.SetContentAsBlob(const NewValue: String); +procedure TBFSBlobAbstract.SetContentAsBlob(const NewValue: TBoldAnsiString); begin fDataValue := NewValue; SetToNonNull; @@ -806,6 +974,11 @@ function TBFSTypedBlob.GetStreamName: String; Result := BoldContentName_TypedBlob; end; +class function TBFSTypedBlob.ContentType: TBoldValueContentType; +begin + result := bctTypedBlob; +end; + function TBFSTypedBlob.GetContentTypeContent: String; begin Result := fContent; @@ -836,18 +1009,36 @@ function TBFSObjectIdRef.GetStreamName: String; Result := BoldContentName_ObjectIdRef; end; -procedure TBFSObjectIdRef.SetFromId(Id: TBoldObjectId); +procedure TBFSObjectIdRef.SetFromId(Id: TBoldObjectId; Adopt: Boolean); +var + Assign: Boolean; begin + Assign := false; if assigned(Id) then begin if (not Assigned(fObjectId)) or (not Id.IsEqual[fObjectId]) then begin FreeAndNil(fObjectId); - fObjectId := Id.Clone; + Assign := True; end - end + end else FreeAndNil(fObjectId); + if Adopt then + begin + if Assign then + fObjectId := Id + else + FreeAndNil(Id); + end + else + if Assign then + fObjectId := Id.Clone; +end; + +class function TBFSObjectIDRef.ContentType: TBoldValueContentType; +begin + result := bctObjectIdRef; end; function TBFSObjectIdRef.GetId: TBoldObjectID; @@ -875,6 +1066,11 @@ procedure TBFSObjectIdRefPair.SetFromIds(Id1, Id2: TBoldObjectId); end; end; +class function TBFSObjectIDRefPair.ContentType: TBoldValueContentType; +begin + result := bctObjectIdRefPair; +end; + function TBFSObjectIdRefPair.GetId1: TBoldObjectID; begin EnsureIdList; @@ -905,6 +1101,16 @@ procedure TBFSObjectIdListref.SetFromIdList(IdList: TBoldObjectIdList); fIdList := IdList.Clone; end; +procedure TBFSObjectIdListref.SetList(IdList: TBoldObjectIdList); +var + i: integer; +begin + IdList.Clear; + IdList.Capacity := fIdList.Count; + for i := 0 to fIdList.Count - 1 do + IdList.Add(fIdList[i]); +end; + function TBFSObjectIdListref.GetIdList(Index: Integer): TBoldObjectID; begin result := fIdList[Index]; @@ -969,11 +1175,12 @@ procedure TBoldFreeStandingObjectContents.ApplyTranslationList( var i: Integer; begin - for i := 0 to MemberCount - 1 do - if Assigned(fMemberList^[i]) then - fMemberList^[i].ApplyTranslationList(TranslationList); + for i := 0 to Length(fMemberList)- 1 do + if Assigned(fMemberList[i]) then + fMemberList[i].ApplyTranslationList(TranslationList); end; + procedure TBFSObjectIdListref.ApplyTranslationList( TranslationList: TBoldIdTranslationList); begin @@ -986,7 +1193,6 @@ procedure TBFSObjectIdListrefPair.ApplyTranslationList( begin if assigned(fIdlist1) then begin - // the two lists are either assigned or not assigned, there can never be one assigned and one not assigned fIdLIst1.ApplyTranslationList(TranslationList); fIdList2.ApplyTranslationList(TranslationList); end; @@ -1036,9 +1242,13 @@ procedure TBFSObjectIDRefPair.EnsureIdList; procedure TBoldFreeStandingValueSpace.AllObjectIds( resultList: TBoldObjectIdList; OnlyLoaded: Boolean); var - i: integer; + i,j: integer; begin - for i := 0 to fIdList.Count - 1 do + j := fIdList.Count; + if j = 0 then + exit; + resultList.Capacity := j; + for i := 0 to j - 1 do if OnlyLoaded then begin if Assigned(GetObjectContentsByObjectId(fIdList[i])) then @@ -1066,6 +1276,11 @@ procedure TBoldFreeStandingValueSpace.RemoveDeletedObjects; end; end; +class function TBFSObjectIdListref.ContentType: TBoldValueContentType; +begin + result := bctObjectIdListRef; +end; + function TBFSObjectIdListref.GetCount: integer; begin if assigned(fIdList) then @@ -1074,6 +1289,11 @@ function TBFSObjectIdListref.GetCount: integer; result := 0; end; +class function TBFSObjectIdListrefPair.ContentType: TBoldValueContentType; +begin + result := bctObjectIdListRefPair; +end; + function TBFSObjectIdListrefPair.GetCount: integer; begin if assigned(fIdList1) then @@ -1098,6 +1318,11 @@ function TBoldFreeStandingObjectContents.GetBoldPersistenceState: TBoldValuePers result := fBoldPersistenceState; end; +class function TBoldFreeStandingObjectContents.ContentType: TBoldValueContentType; +begin + result := bctObject; +end; + procedure TBoldFreeStandingObjectContents.SetBoldExistenceState( Value: TBoldExistenceState); begin @@ -1110,13 +1335,13 @@ procedure TBoldFreeStandingObjectContents.SetBoldPersistenceState( fBoldPersistenceState := Value; end; -procedure TBoldFreeStandingValue.AssignContent(Source: IBoldValue); +procedure TBoldFreeStandingValue.AssignContent(const Source: IBoldValue); begin AssignContentValue(Source); BoldPersistenceState := Source.BoldPersistenceState; end; -procedure TBFSInteger.AssignContentValue(Source: IBoldValue); +procedure TBFSInteger.AssignContentValue(const Source: IBoldValue); var s: IBoldIntegerContent; begin @@ -1126,10 +1351,19 @@ procedure TBFSInteger.AssignContentValue(Source: IBoldValue); else SetContentAsInteger(s.AsInteger) else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); +end; + +function TBFSInteger.IsEqualToValue(const Value: IBoldValue): Boolean; +var + aIntegerValue: IBoldIntegerContent; +begin + Result := inherited IsEqualToValue(Value) and + (Value.QueryInterface(IBoldIntegerContent, aIntegerValue) = S_OK) and + (AsInteger = aIntegerValue.asInteger); end; -procedure TBFSString.AssignContentValue(Source: IBoldValue); +procedure TBFSString.AssignContentValue(const Source: IBoldValue); var s: IBoldStringContent; begin @@ -1139,10 +1373,19 @@ procedure TBFSString.AssignContentValue(Source: IBoldValue); else SetContentAsString(s.AsString) else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); +end; + +function TBFSString.IsEqualToValue(const Value: IBoldValue): Boolean; +var + aStringValue: IBoldStringContent; +begin + Result := inherited IsEqualToValue(Value) and + (Value.QueryInterface(IBoldStringContent, aStringValue) = S_OK) and + (AsString = aStringValue.asString); end; -procedure TBFSCurrency.AssignContentValue(Source: IBoldValue); +procedure TBFSCurrency.AssignContentValue(const Source: IBoldValue); var s: IBoldCurrencyContent; begin @@ -1152,10 +1395,19 @@ procedure TBFSCurrency.AssignContentValue(Source: IBoldValue); else SetContentAsCurrency(s.AsCurrency) else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); end; -procedure TBFSFloat.AssignContentValue(Source: IBoldValue); +function TBFSCurrency.IsEqualToValue(const Value: IBoldValue): Boolean; +var + aCurrencyValue: IBoldCurrencyContent; +begin + Result := inherited IsEqualToValue(Value) and + (Value.QueryInterface(IBoldCurrencyContent, aCurrencyValue) = S_OK) and + (AsCurrency = aCurrencyValue.asCurrency); +end; + +procedure TBFSFloat.AssignContentValue(const Source: IBoldValue); var s: IBoldFloatContent; begin @@ -1165,10 +1417,19 @@ procedure TBFSFloat.AssignContentValue(Source: IBoldValue); else SetContentAsFloat(s.AsFloat) else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); +end; + +function TBFSFloat.IsEqualToValue(const Value: IBoldValue): Boolean; +var + aFloatValue: IBoldFloatContent; +begin + Result := inherited IsEqualToValue(Value) and + (Value.QueryInterface(IBoldFloatContent, aFloatValue) = S_OK) and + (AsFloat = aFloatValue.asFloat); end; -procedure TBFSBoolean.AssignContentValue(Source: IBoldValue); +procedure TBFSBoolean.AssignContentValue(const Source: IBoldValue); var s: IBoldBooleanContent; begin @@ -1178,12 +1439,21 @@ procedure TBFSBoolean.AssignContentValue(Source: IBoldValue); else SetContentAsBoolean(s.AsBoolean) else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); +end; + +function TBFSBoolean.IsEqualToValue(const Value: IBoldValue): Boolean; +var + aBooleanValue: IBoldBooleanContent; +begin + Result := inherited IsEqualToValue(Value) and + (Value.QueryInterface(IBoldBooleanContent, aBooleanValue) = S_OK) and + (AsBoolean = aBooleanValue.asBoolean); end; { TBFSDateTime } -procedure TBFSDateTime.AssignContentValue(Source: IBoldValue); +procedure TBFSDateTime.AssignContentValue(const Source: IBoldValue); var s: IBoldDateTimeContent; begin @@ -1193,7 +1463,17 @@ procedure TBFSDateTime.AssignContentValue(Source: IBoldValue); else SetContentAsDateTime(s.AsDateTime) else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); +end; + +function TBFSDateTime.GetValueAsVariant: Variant; +begin + result := AsDateTime; +end; + +class function TBFSDateTime.ContentType: TBoldValueContentType; +begin + result := bctDateTime; end; function TBFSDateTime.GetStreamName: String; @@ -1201,9 +1481,18 @@ function TBFSDateTime.GetStreamName: String; result := BoldContentName_DateTime; end; +function TBFSDateTime.IsEqualToValue(const Value: IBoldValue): Boolean; +var + aDateTimeValue: IBoldDateTimeContent; +begin + Result := inherited IsEqualToValue(Value) and + (Value.QueryInterface(IBoldDateTimeContent, aDateTimeValue) = S_OK) and + (AsDateTime = aDateTimeValue.asDateTime); +end; + { TBFSDate } -procedure TBFSDate.AssignContentValue(Source: IBoldValue); +procedure TBFSDate.AssignContentValue(const Source: IBoldValue); var s: IBoldDateContent; begin @@ -1213,7 +1502,17 @@ procedure TBFSDate.AssignContentValue(Source: IBoldValue); else SetContentAsDate(s.AsDate) else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); +end; + +function TBFSDate.GetValueAsVariant: Variant; +begin + result := AsDate; +end; + +class function TBFSDate.ContentType: TBoldValueContentType; +begin + result := bctDate; end; function TBFSDate.GetStreamName: String; @@ -1221,9 +1520,18 @@ function TBFSDate.GetStreamName: String; result := BoldContentName_Date; end; +function TBFSDate.IsEqualToValue(const Value: IBoldValue): Boolean; +var + aDateValue: IBoldDateContent; +begin + Result := inherited IsEqualToValue(Value) and + (Value.QueryInterface(IBoldDateContent, aDateValue) = S_OK) and + (AsDate = aDateValue.asDate); +end; + { TBFSTime } -procedure TBFSTime.AssignContentValue(Source: IBoldValue); +procedure TBFSTime.AssignContentValue(const Source: IBoldValue); var s: IBoldTimeContent; begin @@ -1233,7 +1541,17 @@ procedure TBFSTime.AssignContentValue(Source: IBoldValue); else SetContentAsTime(s.AsTime) else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); +end; + +function TBFSTime.GetValueAsVariant: Variant; +begin + result := AsTime; +end; + +class function TBFSTime.ContentType: TBoldValueContentType; +begin + result := bctTime; end; function TBFSTime.GetStreamName: String; @@ -1241,9 +1559,18 @@ function TBFSTime.GetStreamName: String; result := BoldContentName_Time; end; +function TBFSTime.IsEqualToValue(const Value: IBoldValue): Boolean; +var + aTimeValue: IBoldTimeContent; +begin + Result := inherited IsEqualToValue(Value) and + (Value.QueryInterface(IBoldTimeContent, aTimeValue) = S_OK) and + (AsTime = aTimeValue.asTime); +end; + { TBFSBlob } -procedure TBFSBlob.AssignContentValue(Source: IBoldValue); +procedure TBFSBlob.AssignContentValue(const Source: IBoldValue); var s: IBoldBlobContent; begin @@ -1253,10 +1580,24 @@ procedure TBFSBlob.AssignContentValue(Source: IBoldValue); else SetContentAsBlob(s.AsBlob) else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); +end; + +class function TBFSBlob.ContentType: TBoldValueContentType; +begin + result := bctBlob; +end; + +function TBFSBlob.IsEqualToValue(const Value: IBoldValue): Boolean; +var + aBlobValue: IBoldBlobContent; +begin + Result := inherited IsEqualToValue(Value) and + (Value.QueryInterface(IBoldBlobContent, aBlobValue) = S_OK) and + (AsBlob = aBlobValue.asBlob); end; -procedure TBFSTypedBlob.AssignContentValue(Source: IBoldValue); +procedure TBFSTypedBlob.AssignContentValue(const Source: IBoldValue); var s: IBoldBlobContent; t: IBoldTypedBlob; @@ -1271,23 +1612,44 @@ procedure TBFSTypedBlob.AssignContentValue(Source: IBoldValue); SetContentTypeContent(t.ContentTypeContent); end else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); end; -procedure TBFSObjectIDRef.AssignContentValue(Source: IBoldValue); +function TBFSTypedBlob.IsEqualToValue(const Value: IBoldValue): Boolean; +var + aBlobValue: IBoldBlobContent; + aTypedBlob: IBoldTypedBlob; +begin + Result := inherited IsEqualToValue(Value) and + (Value.QueryInterface(IBoldBlobContent, aBlobValue) = S_OK) and + (Value.QueryInterface(IBoldTypedBlob, aTypedBlob) = S_OK) and + (AsBlob = aBlobValue.asBlob) and + (ContentTypeContent = aTypedBlob.ContentTypeContent); +end; + +procedure TBFSObjectIDRef.AssignContentValue(const Source: IBoldValue); var s: IBoldObjectIdRef; begin if source.QueryInterface(IBoldObjectIDRef, S) = S_OK then begin - SetFromId(s.Id); + SetFromId(s.Id, false); OrderNo := s.OrderNo; end else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); end; -procedure TBFSObjectIDRefPair.AssignContentValue(Source: IBoldValue); +function TBFSObjectIDRef.IsEqualToValue(const Value: IBoldValue): Boolean; +var + aObjectIDRef: IBoldObjectIdRef; +begin + Result := Assigned(Value) and + (Value.QueryInterface(IBoldObjectIdRef, aObjectIDRef) = S_OK) and + ((Assigned(ID) and Assigned(aObjectIDRef.Id) and Id.IsEqual[aObjectIDRef.Id]) or + ((ID = nil) and (aObjectIDRef.Id = nil))); +end; +procedure TBFSObjectIDRefPair.AssignContentValue(const Source: IBoldValue); var s: IBoldObjectIdRefPair; begin @@ -1297,10 +1659,26 @@ procedure TBFSObjectIDRefPair.AssignContentValue(Source: IBoldValue); OrderNo := s.OrderNo; end else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); end; -procedure TBFSObjectIdListref.AssignContentValue(Source: IBoldValue); +procedure TBFSObjectIdListref.EnsureList; +begin + if not assigned(fIdList) then + fIdList := TBoldObjectIdList.Create + else + Assert(fIdList is TBoldObjectIdList); +end; + +procedure TBFSObjectIdListrefPair.EnsureLists; +begin + if not assigned(fIdList1) then + fIdList1 := TBoldObjectIdList.Create; + if not assigned(fIdList2) then + fIdList2 := TBoldObjectIdList.Create; +end; + +procedure TBFSObjectIdListref.AssignContentValue(const Source: IBoldValue); var s: IBoldObjectIdListRef; i: Integer; @@ -1308,15 +1686,13 @@ procedure TBFSObjectIdListref.AssignContentValue(Source: IBoldValue); if source.QueryInterface(IBoldObjectIDListRef, S) = S_OK then begin EnsureList; - fIdList.Clear; - for i := 0 to s.Count - 1 do - fIdList.Add(s.IdList[i]); + s.SetList(fIdList); end else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); end; -procedure TBFSObjectIdListrefPair.AssignContentValue(Source: IBoldValue); +procedure TBFSObjectIdListrefPair.AssignContentValue(const Source: IBoldValue); var s: IBoldObjectIdListRefPair; i: Integer; @@ -1326,6 +1702,8 @@ procedure TBFSObjectIdListrefPair.AssignContentValue(Source: IBoldValue); EnsureLists; fIdList1.Clear; fIdList2.Clear; + fIdList1.Capacity := s.Count; + fIdList2.Capacity := s.Count; for i := 0 to s.Count - 1 do begin fIdList1.Add(s.IdList1[i]); @@ -1333,7 +1711,7 @@ procedure TBFSObjectIdListrefPair.AssignContentValue(Source: IBoldValue); end; end else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); end; destructor TBFSObjectIdListrefPair.Destroy; @@ -1353,37 +1731,11 @@ procedure TBoldFreeStandingObjectContents.RemoveMemberByIndex(Index: integer); begin if MemberCount > Index then begin - fMemberList^[Index].Free; - fMemberList^[Index] := nil; + fMemberList[Index].Free; + fMemberList[Index] := nil; end; end; -{ TBoldFSObjectContentList } - -constructor TBoldFSObjectContentList.Create; -begin - inherited Create; - SetIndexCapacity(1); - OwnsEntries := true; - SetIndexVariable(IX_FSObjectContent, AddIndex(TBoldFSObjectContentHashIndex.Create)); -end; - -function TBoldFSObjectContentList.FindObjectContentById(Id: TBoldObjectId): TBoldFreeStandingObjectContents; -begin - Result := TBoldFreeStandingObjectContents(TBoldFSObjectContentHashIndex(indexes[IX_FSObjectContent]).FindByID(ID)); -end; - -function TBoldFSObjectContentList.GetItems(index: integer): TBoldFreeStandingObjectContents; -begin - result := TBoldFreeStandingObjectContents(inherited items[index]); -end; - -procedure TBoldFSObjectContentList.SetItems(index: integer; - const Value: TBoldFreeStandingObjectContents); -begin - inherited items[index] := Value; -end; - { TBoldFSObjectContentHashIndex } function TBoldFSObjectContentHashIndex.FindById(BoldObjectId: TBoldObjectId): TObject; @@ -1412,6 +1764,28 @@ function TBoldFSObjectContentHashIndex.Match(const Key; Item: TObject): Boolean; Result := TBoldObjectId(Key).IsEqual[ItemAsBoldObjectId(Item)]; end; +{ TBoldFSObjectContentList } + +constructor TBoldFSObjectContentList.Create; +begin + inherited Create; + SetIndexCapacity(1); + OwnsEntries := true; + IX_FSObjectContent := -1; + SetIndexVariable(IX_FSObjectContent, AddIndex(TBoldFSObjectContentHashIndex.Create)); +end; + +function TBoldFSObjectContentList.GetItems(index: integer): TBoldFreeStandingObjectContents; +begin + result := TBoldFreeStandingObjectContents(inherited items[index]); +end; + +procedure TBoldFSObjectContentList.SetItems(index: integer; + const Value: TBoldFreeStandingObjectContents); +begin + inherited items[index] := Value; +end; + function TBoldFreeStandingValue.GetContentName: String; begin result := GetStreamName; @@ -1423,9 +1797,14 @@ constructor TBoldFreeStandingValue.create; BoldPersistenceState := bvpsInvalid; end; -procedure TBoldFreeStandingValue.AssignContentValue(Source: IBoldValue); +procedure TBoldFreeStandingValue.AssignContentValue(const Source: IBoldValue); begin - raise EBold.CreateFmt(sAbstractError, [classname]); + raise EBold.CreateFmt('%s.AssignContentValue: Abstract error', [classname]); +end; + +function TBoldFreeStandingValue.IsEqualToValue(const Value: IBoldValue): Boolean; +begin + raise EBold.CreateFmt('%s.IsEqualToValue: Abstract error', [classname]); end; function TBoldFreeStandingObjectContents.GetObjectId: TBoldObjectId; @@ -1434,36 +1813,30 @@ function TBoldFreeStandingObjectContents.GetObjectId: TBoldObjectId; end; procedure TBoldFreeStandingObjectContents.ApplyObjectContents( - ObjectContents: IBoldObjectContents; const ApplyValues: Boolean; const IgnorePersistenceState: Boolean); + const ObjectContents: IBoldObjectContents; ApplyValues: Boolean; IgnorePersistenceState: Boolean); var i: Integer; aValue: IBoldValue; - MemberId: TBoldMemberId; begin SetBoldExistenceState(ObjectContents.BoldExistenceState); SetBoldPersistenceState(ObjectContents.BoldPersistenceState); if ApplyValues then - for i := 0 to ObjectContents.MemberCount - 1 do + for i := ObjectContents.MemberCount - 1 downto 0 do begin aValue := ObjectContents.valueByIndex[i]; if assigned(aValue) then begin - MemberId := TBoldMemberId.Create(i); - try - EnsureMember(MemberId, aValue.ContentName); - if IgnorePersistenceState then - fMemberList^[i].AssignContentValue(aValue) - else - fMemberList^[i].AssignContent(aValue); - finally - FreeAndNil(MemberId); - end; + EnsureMemberAndGetValueByIndex(i, aValue.ContentName); + if IgnorePersistenceState then + fMemberList[i].AssignContentValue(aValue) + else + fMemberList[i].AssignContent(aValue); end; end; end; procedure TBoldFreeStandingValueSpace.UpdateOwnValuesFrom( - ValueSpace: IBoldValueSpace); + const ValueSpace: IBoldValueSpace); var i: Integer; anIdList: TBoldObjectIdList; @@ -1488,27 +1861,32 @@ procedure TBoldFreeStandingValueSpace.UpdateOwnValuesFrom( end; procedure TBoldFreeStandingObjectContents.UpdateObjectContentsFrom( - ObjectContents: IBoldObjectContents); + const ObjectContents: IBoldObjectContents); var i: Integer; OwnValue, aValue: IBoldValue; begin SetBoldExistenceState(ObjectContents.BoldExistenceState); SetBoldPersistenceState(ObjectContents.BoldPersistenceState); - for i := 0 to MemberCount - 1 do + for i := MemberCount - 1 downto 0 do begin OwnValue := GetValueByIndex(i); - aValue := ObjectContents.ValueByIndex[i]; - if assigned(OwnValue) and assigned(aValue) then - OwnValue.AssignContent(aValue); + if Assigned(OwnValue) then begin + aValue := ObjectContents.ValueByIndex[i]; + if Assigned(aValue) then begin + OwnValue.AssignContent(aValue); + end; + end; end; end; procedure TBoldFreeStandingValueSpace.RemoveAllObjectContents; -var +{var i: integer; - ObjectIds: TBoldObjectIdlist; + ObjectIds: TBoldObjectIdlist;} begin + fObjectContentsList.Clear; +{ ObjectIds := TBoldObjectIdList.Create; try AllObjectIds(ObjectIds, True); @@ -1517,6 +1895,7 @@ procedure TBoldFreeStandingValueSpace.RemoveAllObjectContents; finally FreeAndNil(Objectids); end; +} end; procedure TBoldFreeStandingValueSpace.MarkAllObjectsAndMembersCurrent; @@ -1537,31 +1916,44 @@ procedure TBoldFreeStandingObjectContents.MarkAllMembersCurrent; M: integer; begin for M := 0 to MemberCount - 1 do - if Assigned(fMemberList^[M]) then - GetValueByIndex(M).BoldPersistenceState := bvpsCurrent; + if Assigned(fMemberList[M]) then + fMemberList[M].BoldPersistenceState := bvpsCurrent; end; +procedure TBoldFreeStandingObjectContents.EnsureMemberListLength( + index: integer); +begin + if (Index >= Length(fMemberList)) then + SetLength(fMemberList, Index+1); +end; +procedure TBoldFreeStandingValueSpace.Clear; +begin + fIdLIst.Clear; + fObjectContentsList.Clear; + FreeAndNil(fTranslationList); +end; -procedure TBoldFreeStandingObjectContents.EnsureMemberByIndex( - Index: integer; const StreamName: string); +procedure TBoldFreeStandingValueSpace.ClearWhenObjectContentsEmpty; begin - if not Assigned(fMemberlist) then - begin - fMemberlist := BoldMemoryManager_.AllocateMemoryZeroFill((Index+1)*sizeof(Pointer)); - fMemberCount := Index+1; - end; - if (Index >= MemberCount) then - begin - fMemberlist := BoldMemoryManager_.ReallocateMemoryZeroFill(fMemberlist, MemberCount*sizeof(Pointer), - (Index+1)*sizeof(Pointer)); - fMemberCount := Index+1; + if fObjectContentsList.Count = 0 then begin + if Assigned(fIdLIst) then begin + fIdLIst.Clear; + end; + if Assigned(fTranslationList) then begin + FreeAndNil(fTranslationList); + end; end; - - if not assigned(fMemberlist^[Index]) then - fMemberlist^[Index] := TBoldFreeStandingValue(FreeStandingValueFactory.CreateInstance(StreamName)); end; +function TBoldFreeStandingObjectContents.EnsureMemberAndGetValueByIndex( + Index: integer; const StreamName: string): IBoldValue; +begin + EnsureMemberListLength(Index); + if not assigned(fMemberlist[Index]) then + fMemberlist[Index] := TBoldFreeStandingValue(FreeStandingValueFactory.CreateInstance(StreamName)); + Result := fMemberlist[Index]; +end; function TBoldFreeStandingValueSpace.GetValueForIdAndMemberIndex( Id: TBoldObjectId; MemberIndex: integer): IBoldValue; @@ -1571,33 +1963,66 @@ function TBoldFreeStandingValueSpace.GetValueForIdAndMemberIndex( ObjectContents := GetFSObjectContentsByObjectId(Id); if Assigned(ObjectContents) then Result := ObjectContents.ValueByIndex[MemberIndex] + else + result := nil; +end; + +class function TBoldFreeStandingValueSpace.ContentType: TBoldValueContentType; +begin + result := bctValueSpace; end; function TBoldFreeStandingValueSpace.GetEnsuredFSObjectContentsByObjectId( - ObjectId: TBoldObjectId): TBoldFreeStandingObjectContents; + ObjectId: TBoldObjectId; + out aCreated: boolean): TBoldFreeStandingObjectContents; var LocalId: TBoldObjectId; begin Result := GetFSObjectContentsByObjectId(ObjectId); - if not Assigned(Result) then + aCreated := not Assigned(Result); + if aCreated then begin LocalId := IdLIst.IdById[ObjectId]; if not assigned(LocalId) then begin - IdList.Add(ObjectId); - LocalId :=IdLIst.IdById[ObjectId]; + LocalId := IdList.AddAndGetID(ObjectId); end; - Result := TBoldFreeStandingObjectContents.Create; + Result := BoldFreeStandingObjectContentsClass.Create; Result.fObjectId := LocalId; fObjectContentsList.Add(Result); end; end; -function TBoldFreeStandingObjectContents.GetBoldMemberCount: Integer; +function TBoldFreeStandingValueSpace.GetEnsuredFSObjectContentsByObjectId( + ObjectId: TBoldObjectId): TBoldFreeStandingObjectContents; +var + lCreated: boolean; begin - Result := fMemberCount; + result := GetEnsuredFSObjectContentsByObjectId(ObjectId, lCreated); end; +function TBoldFreeStandingValueSpace.IdCount: integer; +begin + result := fIdLIst.Count; +end; + +function TBoldFreeStandingValueSpace.IsEmpty: boolean; +var + i: integer; +begin + for i := 0 to fIdList.Count - 1 do + if Assigned(GetObjectContentsByObjectId(fIdList[i])) then + begin + result := false; + exit; + end; + result := true; +end; + +function TBoldFreeStandingObjectContents.GetBoldMemberCount: Integer; +begin + Result := Length(fMemberList); +end; procedure TBFSObjectIdListrefPair.RemoveId(Id: TBoldObjectId); var @@ -1615,13 +2040,14 @@ procedure TBFSObjectIdListref.RemoveId(Id: TBoldObjectId); var p: integer; begin - p := fIdList.IndexByID[id]; + p := fIdList.IndexByID[Id]; if p <> -1 then fIdLIst.RemoveByIndex(p); end; procedure TBFSObjectIdListrefPair.AddIds(Id1, Id2: TBoldObjectId); begin + EnsureLists; fIdList1.Add(Id1); fIdLIst2.Add(Id2); end; @@ -1632,18 +2058,5 @@ procedure TBFSObjectIdListref.AddId(Id: TBoldObjectId); fIdList.Add(Id); end; -procedure TBFSObjectIdListref.EnsureList; -begin - if not assigned(fIdList) then - fIdList := TBoldObjectIdList.Create; -end; - -procedure TBFSObjectIdListrefPair.EnsureLists; -begin - if not assigned(fIdList1) then - fIdList1 := TBoldObjectIdList.Create; - if not assigned(fIdList2) then - fIdList2 := TBoldObjectIdList.Create; -end; - end. + diff --git a/Source/FreestandingValueSpace/Core/FreeStandingValuesConst.pas b/Source/FreestandingValueSpace/Core/FreeStandingValuesConst.pas index 92e3e1b9..5dc0937e 100644 --- a/Source/FreestandingValueSpace/Core/FreeStandingValuesConst.pas +++ b/Source/FreestandingValueSpace/Core/FreeStandingValuesConst.pas @@ -10,4 +10,4 @@ interface implementation -end. \ No newline at end of file +end. diff --git a/Source/Handles/Actions/BoldActionDefs.pas b/Source/Handles/Actions/BoldActionDefs.pas index 2f4dc7d5..8de10fce 100644 --- a/Source/Handles/Actions/BoldActionDefs.pas +++ b/Source/Handles/Actions/BoldActionDefs.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldActionDefs; interface @@ -12,4 +15,3 @@ interface implementation end. - diff --git a/Source/Handles/Actions/BoldActions.pas b/Source/Handles/Actions/BoldActions.pas index dcfbb674..b1b33fe0 100644 --- a/Source/Handles/Actions/BoldActions.pas +++ b/Source/Handles/Actions/BoldActions.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldActions; interface @@ -15,7 +18,9 @@ TBoldSystemHandleAction = class; TBoldActivateSystemAction = class; TBoldUpdateDBAction = class; TBoldFailureDetectionAction = class; - + TBoldCreateDatabaseAction = class; + TBoldDiscardChangesAction = class; + TBoldSaveAction = (saAsk, saYes, saNo, saFail); { TBoldSystemHandleAction } @@ -44,6 +49,15 @@ TBoldUpdateDBAction = class(TBoldSystemHandleAction) procedure ExecuteTarget(Target: TObject); override; end; + { TBoldDiscardChangesAction } + TBoldDiscardChangesAction = class(TBoldSystemHandleAction) + protected + procedure CheckAllowEnable(var EnableAction: boolean); override; + public + constructor Create(AOwner: TComponent); override; + procedure ExecuteTarget(Target: TObject); override; + end; + { TBoldActivateSystemAction } TBoldActivateSystemAction = class(TBoldSystemHandleAction) private @@ -77,15 +91,34 @@ TBoldActivateSystemAction = class(TBoldSystemHandleAction) property SaveOnClose: TBoldSaveAction read FSaveOnClose write fSaveOnClose; end; + TBoldCreateDatabaseAction = class(TBoldSystemHandleAction) + private + fOnSchemaGenerated: TNotifyEvent; + fIgnoreUnknownTables: boolean; + fDropExisting: boolean; + procedure SchemaGenerated; + protected + procedure GenerateSchema; + procedure CheckAllowEnable(var EnableAction: boolean); override; + public + constructor Create(AOwner: TComponent); override; + procedure ExecuteTarget(Target: TObject); override; + published + property OnSchemaGenerated: TNotifyEvent read fOnSchemaGenerated write fOnSchemaGenerated; + property IgnoreUnknownTables: boolean read fIgnoreUnknownTables write fIgnoreUnknownTables default false; + property DropExisting: boolean read fDropExisting write fDropExisting default false; + end; + implementation uses SysUtils, - HandlesConst, BoldDefs, + Forms, Controls, Dialogs, ComCtrls, + Menus, // for TextToShortCut BoldSystem; const @@ -104,7 +137,8 @@ procedure TBoldUpdateDBAction.CheckAllowEnable(var EnableAction: boolean); constructor TBoldUpdateDBAction.Create(AOwner: TComponent); begin inherited; - Caption := sUpdateDB; + Caption := 'Update DB'; + ShortCut := TextToShortCut('Ctrl+S'); end; procedure TBoldUpdateDBAction.ExecuteTarget(Target: TObject); @@ -120,9 +154,9 @@ constructor TBoldActivateSystemAction.Create(AOwner: TComponent); begin inherited; fHandleIdentitySubscriber := TBoldPassthroughSubscriber.Create(_Receive); - fOpenCaption := sOpenSystem; - fCloseCaption := sCloseSystem; - fSaveQuestion := sThereAreDirtyObjects; + fOpenCaption := 'Open system'; + fCloseCaption := 'Close system'; + fSaveQuestion := 'There are dirty objects. Save them before closing system?'; UpdateCaption; end; @@ -151,7 +185,7 @@ procedure TBoldActivateSystemAction.ExecuteTarget(Target: TObject); saYes: BoldSystemHandle.UpdateDatabase; saNo: BoldSystemHandle.System.Discard; saFail: if BoldSystemHandle.System.DirtyObjects.Count > 0 then - raise EBold.Create(sClosingWithDirtyObjects); + raise EBold.Create('Closing system with dirty objects!!'); end; if Update then BoldSystemHandle.Active := not BoldSystemHandle.Active; @@ -245,6 +279,8 @@ function TBoldFailureDetectionAction.HandlesTarget( ((Target as TControl).Action = self); end; +type TControlAccess = class(TControl); + procedure TBoldFailureDetectionAction.UpdateTarget(Target: TObject); var failure: TBoldFailureReason; @@ -255,12 +291,11 @@ procedure TBoldFailureDetectionAction.UpdateTarget(Target: TObject); Caption := failure.Reason else Caption := ''; - - // The statusbar seems to have a bug, it does not correctly update its caption... - // even this does not make it work fully... Bug in VCL - if Target is TStatusBar then - (Target as TStatusBar).SimpleText := Caption; + (Target as TStatusBar).SimpleText := Caption + else + if Target is TControl then + (Target as TControlAccess).Caption := Caption end; { TBoldSystemHandleAction } @@ -276,4 +311,66 @@ procedure TBoldSystemHandleAction.SetBoldSystemHandle( BoldElementHandle := Value; end; +{ TBoldCreateDatabaseAction } + +procedure TBoldCreateDatabaseAction.CheckAllowEnable(var EnableAction: boolean); +begin + EnableAction := Assigned(BoldSystemHandle) and Assigned(BoldSystemHandle.PersistenceHandleDB) and not BoldSystemHandle.Active; +end; + +constructor TBoldCreateDatabaseAction.Create(AOwner: TComponent); +begin + inherited; + Caption := 'Create DB'; +end; + +procedure TBoldCreateDatabaseAction.ExecuteTarget(Target: TObject); +begin + GenerateSchema; +end; + +procedure TBoldCreateDatabaseAction.GenerateSchema; +begin + if Assigned(BoldSystemHandle) and Assigned(BoldSystemHandle.PersistenceHandleDB) then + begin + Screen.Cursor := crHourGlass; + try + BoldSystemHandle.PersistenceHandleDB.CreateDataBase(DropExisting); + BoldSystemHandle.PersistenceHandleDB.CreateDataBaseSchema(IgnoreUnknownTables); + finally + Screen.Cursor := crDefault; + end; + SchemaGenerated; + end; +end; + +procedure TBoldCreateDatabaseAction.SchemaGenerated; +begin + if Assigned(fOnSchemaGenerated) then + fOnSchemaGenerated(Self); +end; + +{ TBoldDiscardChangesAction } + +procedure TBoldDiscardChangesAction.CheckAllowEnable(var EnableAction: boolean); +begin + inherited; + if EnableAction then + EnableAction := BoldSystemHandle.Active and + (BoldSystemHandle.System.DirtyObjects.Count > 0); +end; + +constructor TBoldDiscardChangesAction.Create(AOwner: TComponent); +begin + inherited; + Caption := 'Discard changes'; +end; + +procedure TBoldDiscardChangesAction.ExecuteTarget(Target: TObject); +begin + inherited; + if Assigned(BoldSystemHandle) then + BoldSystemHandle.Discard; +end; + end. diff --git a/Source/Handles/Actions/BoldHandleAction.pas b/Source/Handles/Actions/BoldHandleAction.pas index 9a74586a..40bd5ed1 100644 --- a/Source/Handles/Actions/BoldHandleAction.pas +++ b/Source/Handles/Actions/BoldHandleAction.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldHandleAction; interface @@ -35,7 +38,8 @@ implementation uses SysUtils, - BoldUtils; + BoldUtils, + BoldRev; const breFreeHandle = 44; @@ -98,5 +102,6 @@ procedure TBoldHandleAction.CheckAllowEnable(var EnableAction: boolean); EnableAction := Assigned(BoldElementHandle); end; -end. +initialization +end. diff --git a/Source/Handles/Actions/BoldListActions.pas b/Source/Handles/Actions/BoldListActions.pas index 9715b554..3322a7ac 100644 --- a/Source/Handles/Actions/BoldListActions.pas +++ b/Source/Handles/Actions/BoldListActions.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldListActions; interface @@ -5,12 +8,12 @@ interface uses Classes, Controls, - BoldDefs, // Defines EBold (Move it to BoldExceptions?) + BoldDefs, BoldSubscription, BoldSystem, BoldAbstractListHandle, BoldHandleAction, - BoldNavigatorDefs; // Defines TBoldDeleteMode (should move to BoldDefs) + BoldNavigatorDefs; type TBoldListHandleAction = class; @@ -23,7 +26,6 @@ TBoldListHandleAddNewAction = class; TBoldListHandleMoveUpAction = class; TBoldListHandleMoveDownAction = class; - { TBoldListHandleAction } TBoldListHandleAction = class(TBoldHandleAction) private function GetBoldHandle: TBoldAbstractListHandle; @@ -34,7 +36,6 @@ TBoldListHandleAction = class(TBoldHandleAction) property BoldHandle: TBoldAbstractListHandle read GetBoldHandle write SetBoldHandle; end; - { TBoldListHandleNextAction } TBoldListHandleNextAction = class(TBoldListHandleAction) protected procedure CheckAllowEnable(var EnableAction: boolean); override; @@ -43,7 +44,6 @@ TBoldListHandleNextAction = class(TBoldListHandleAction) procedure ExecuteTarget(Target: TObject); override; end; - { TBoldListHandlePrevAction } TBoldListHandlePrevAction = class(TBoldListHandleAction) protected procedure CheckAllowEnable(var EnableAction: boolean); override; @@ -52,7 +52,6 @@ TBoldListHandlePrevAction = class(TBoldListHandleAction) procedure ExecuteTarget(Target: TObject); override; end; - { TBoldListHandleFirstAction } TBoldListHandleFirstAction = class(TBoldListHandleAction) protected procedure CheckAllowEnable(var EnableAction: boolean); override; @@ -111,7 +110,7 @@ implementation uses SysUtils, BoldUtils, - HandlesConst; + BoldRev; { TBoldListHandleAction } @@ -148,7 +147,7 @@ procedure TBoldListHandleNextAction.CheckAllowEnable( constructor TBoldListHandleNextAction.Create(AOwner: TComponent); begin inherited; - Caption := sNext; + Caption := 'Next'; end; procedure TBoldListHandleNextAction.ExecuteTarget(Target: TObject); @@ -170,7 +169,7 @@ procedure TBoldListHandlePrevAction.CheckAllowEnable( constructor TBoldListHandlePrevAction.Create(AOwner: TComponent); begin inherited; - Caption := sPrev; + Caption := 'Prev'; end; procedure TBoldListHandlePrevAction.ExecuteTarget(Target: TObject); @@ -192,7 +191,7 @@ procedure TBoldListHandleFirstAction.CheckAllowEnable( constructor TBoldListHandleFirstAction.Create(AOwner: TComponent); begin inherited; - Caption := sFirst; + Caption := 'First'; end; procedure TBoldListHandleFirstAction.ExecuteTarget(Target: TObject); @@ -214,7 +213,7 @@ procedure TBoldListHandleLastAction.CheckAllowEnable( constructor TBoldListHandleLastAction.Create(AOwner: TComponent); begin inherited; - Caption := sLast; + Caption := 'Last'; end; procedure TBoldListHandleLastAction.ExecuteTarget(Target: TObject); @@ -236,7 +235,7 @@ function TBoldListHandleDeleteAction.AllowDelete( dmUnlinkAllAndDelete: Result := True; else - raise EBold.CreateFmt(sUnknownDeleteMode, [ClassName]); + raise EBold.CreateFmt('%s.AllowDelete: Unknown deletemode', [ClassName]); end; end; @@ -257,7 +256,7 @@ procedure TBoldListHandleDeleteAction.CheckAllowEnable( constructor TBoldListHandleDeleteAction.Create(AOwner: TComponent); begin inherited; - Caption := sDelete; + Caption := 'Delete'; end; procedure TBoldListHandleDeleteAction.ExecuteTarget(Target: TObject); @@ -290,7 +289,7 @@ procedure TBoldListHandleAddNewAction.CheckAllowEnable( constructor TBoldListHandleAddNewAction.Create(AOwner: TComponent); begin inherited; - Caption := sAddNew; + Caption := 'Add New'; end; procedure TBoldListHandleAddNewAction.ExecuteTarget(Target: TObject); @@ -315,7 +314,7 @@ procedure TBoldListHandleMoveUpAction.CheckAllowEnable( constructor TBoldListHandleMoveUpAction.Create(AOwner: TComponent); begin inherited; - Caption := sMoveUp; + Caption := 'Move up'; end; procedure TBoldListHandleMoveUpAction.ExecuteTarget(Target: TObject); @@ -337,7 +336,7 @@ procedure TBoldListHandleMoveDownAction.CheckAllowEnable( constructor TBoldListHandleMoveDownAction.Create(AOwner: TComponent); begin inherited; - Caption := sMoveDown; + Caption := 'Move down'; end; procedure TBoldListHandleMoveDownAction.ExecuteTarget(Target: TObject); @@ -346,4 +345,6 @@ procedure TBoldListHandleMoveDownAction.ExecuteTarget(Target: TObject); BoldHandle.List.Move(BoldHandle.CurrentIndex, BoldHandle.CurrentIndex+1); end; +initialization + end. diff --git a/Source/Handles/Actions/BoldUndoActions.pas b/Source/Handles/Actions/BoldUndoActions.pas index 6acd626d..79394f77 100644 --- a/Source/Handles/Actions/BoldUndoActions.pas +++ b/Source/Handles/Actions/BoldUndoActions.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUndoActions; interface @@ -38,11 +41,12 @@ TBoldRedoAction = class(TBoldSystemHandleAction) implementation uses - HandlesConst, BoldSystem, ActnList, + Menus, // for TextToShortCut BoldUndoInterfaces; + { TBoldSetCheckPointAction } procedure TBoldSetCheckPointAction.CheckAllowEnable( @@ -50,13 +54,14 @@ procedure TBoldSetCheckPointAction.CheckAllowEnable( begin inherited; if EnableAction then - EnableAction := BoldSystemHandle.Active; + EnableAction := BoldSystemHandle.Active and BoldSystemHandle.System.UndoHandlerInterface.Enabled + and not ((BoldSystemHandle.System.UndoHandlerInterface.UndoList.Count > 0) and not BoldSystemHandle.System.UndoHandlerInterface.CurrentUndoBlockHasChanges); end; constructor TBoldSetCheckPointAction.Create(AOwner: TComponent); begin inherited; - Caption := sSetCheckPoint; + Caption := 'Set check point'; end; procedure TBoldSetCheckPointAction.ExecuteTarget(Target: TObject); @@ -80,7 +85,8 @@ procedure TBoldUndoAction.CheckAllowEnable(var EnableAction: boolean); constructor TBoldUndoAction.Create(AOwner: TComponent); begin inherited; - Caption := sUndo; + Caption := 'Undo'; + ShortCut := TextToShortCut('Ctrl+Z'); end; procedure TBoldUndoAction.ExecuteTarget(Target: TObject); @@ -102,7 +108,8 @@ procedure TBoldRedoAction.CheckAllowEnable(var EnableAction: boolean); constructor TBoldRedoAction.Create(AOwner: TComponent); begin inherited; - Caption := sRedo; + Caption := 'Redo'; + ShortCut := TextToShortCut('Shift+Ctrl+Z'); end; procedure TBoldRedoAction.ExecuteTarget(Target: TObject); diff --git a/Source/Handles/COM/BoldComClientElementHandles.pas b/Source/Handles/COM/BoldComClientElementHandles.pas index 484d8407..e3529b44 100644 --- a/Source/Handles/COM/BoldComClientElementHandles.pas +++ b/Source/Handles/COM/BoldComClientElementHandles.pas @@ -1,7 +1,13 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComClientElementHandles; interface implementation + +initialization + end. diff --git a/Source/Handles/COM/BoldComServerElementHandleFactory.pas b/Source/Handles/COM/BoldComServerElementHandleFactory.pas index d445d755..284920d8 100644 --- a/Source/Handles/COM/BoldComServerElementHandleFactory.pas +++ b/Source/Handles/COM/BoldComServerElementHandleFactory.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComServerElementHandleFactory; interface @@ -30,7 +33,6 @@ implementation uses SysUtils, BoldComAdapter, - // Handles BoldCursorHandle, BoldDerivedHandle, BoldExpressionHandle, @@ -99,7 +101,6 @@ function TBoldComServerElementHandleFactory.GetObject(const ClassId: TGUID; procedure TBoldComServerElementHandleFactory.GetObjectInfo( const ClassId: TGUID; ObjectNames, ClassNames: TStrings); begin - // Using Class.ClassName to get compiler errors if classes change names ClassNames.Add(TBoldCursorHandle.ClassName); ClassNames.Add(TBoldDerivedHandle.ClassName); ClassNames.Add(TBoldExpressionHandle.ClassName); @@ -113,6 +114,6 @@ initialization G_ServerElementHandleFactory := TBoldComServerElementHandleFactory.Create; finalization - FreeAndNil(G_ServerElementHandleFactory); + FreeAndNil(G_ServerElementHandleFactory); end. diff --git a/Source/Handles/COM/BoldComServerElementHandles.pas b/Source/Handles/COM/BoldComServerElementHandles.pas index eebe6a30..c821838c 100644 --- a/Source/Handles/COM/BoldComServerElementHandles.pas +++ b/Source/Handles/COM/BoldComServerElementHandles.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComServerElementHandles; interface @@ -14,6 +17,7 @@ interface TBoldComServerElementHandle = class; {-- TBoldComServerElementHandle --} + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldComServerElementHandle = class(TBoldComExportHandle) private FBoldHandle: TBoldElementHandle; @@ -33,8 +37,7 @@ implementation uses BoldComAdapter, - // These two are not used here, this is just to make - // sure they get linked into the executable + BoldComObjectSpaceAdapters, BoldComServerElementHandleFactory; @@ -88,4 +91,6 @@ procedure TBoldComServerElementHandle.SetExportMode(Value: TBoldComServerElement end; end; +initialization + end. diff --git a/Source/Handles/Core/BoldAbstractListHandle.pas b/Source/Handles/Core/BoldAbstractListHandle.pas index 47f2c9b4..82d79712 100644 --- a/Source/Handles/Core/BoldAbstractListHandle.pas +++ b/Source/Handles/Core/BoldAbstractListHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAbstractListHandle; interface @@ -24,6 +27,8 @@ TBoldAbstractListHandle = class(TBoldRootedHandle) function GetStaticListType: TBoldListTypeInfo; function GetObjectList: TBoldObjectList; function GetMutableObjectList: TBoldObjectList; + procedure SetCurrentBoldObject(const Value: TBoldObject); + procedure SetCurrentElement(const Value: TBoldElement); protected function GetCurrentElement: TBoldElement; virtual; abstract; function GetCurrentIndex: Integer; virtual; abstract; @@ -37,8 +42,8 @@ TBoldAbstractListHandle = class(TBoldRootedHandle) procedure Prior; procedure RemoveCurrentElement; property Count: Integer read GetCount; - property CurrentBoldObject: TBoldObject read GetCurrentBoldObject; - property CurrentElement: TBoldElement read GetCurrentElement; + property CurrentBoldObject: TBoldObject read GetCurrentBoldObject write SetCurrentBoldObject; + property CurrentElement: TBoldElement read GetCurrentElement write SetCurrentElement; property CurrentIndex: Integer read GetCurrentIndex write SetCurrentIndex; property List: TBoldList read GetList; property ObjectList: TBoldObjectList read GetObjectList; @@ -55,15 +60,17 @@ implementation uses SysUtils, - HandlesConst, BoldDefs; { TBoldAbstractListHandle } function TBoldAbstractListHandle.GetCount: Integer; +var + BoldList: TBoldList; begin - if Assigned(List) then - Result := List.Count + BoldList := List; + if Assigned(BoldList) then + Result := BoldList.Count else Result := 0; end; @@ -73,7 +80,7 @@ procedure TBoldAbstractListHandle.Prior; if GetHasPrior then CurrentIndex := CurrentIndex - 1 else - raise EBold.CreateFmt(sNoPreviousElement, [ClassName]); + raise EBold.CreateFmt('%s: No previous element', [ClassName]); end; procedure TBoldAbstractListHandle.Next; @@ -81,7 +88,7 @@ procedure TBoldAbstractListHandle.Next; if GetHasNext then CurrentIndex := CurrentIndex + 1 else - raise EBold.CreateFmt(sNoNextElement, [ClassName]); + raise EBold.CreateFmt('%s: No next element', [ClassName]); end; procedure TBoldAbstractListHandle.First; @@ -96,34 +103,57 @@ procedure TBoldAbstractListHandle.Last; end; procedure TBoldAbstractListHandle.RemoveCurrentElement; +var + BoldList: TBoldList; begin - if CurrentIndex = -1 then - raise EBold.CreateFmt(sNoCurrentElement, [ClassName]) - else - begin - if list.mutable then - List.RemoveByIndex(CurrentIndex) - else if assigned(MutableLIst) then - mutableList.remove(CurrentElement) - else - raise EBold.CreateFmt(sCannotRemoveCurrentFromImmutable, [classname, name]); - end; + if CurrentIndex = -1 then begin + raise EBold.CreateFmt('%s.RemoveCurrentElement: No current element', [ClassName]) + end else begin + BoldList := List; + if Assigned(BoldList) and BoldList.Mutable then begin + BoldList.RemoveByIndex(CurrentIndex); + end else begin + BoldList := MutableList; + if Assigned(BoldList) then begin + BoldList.Remove(CurrentElement); + end else begin + raise EBold.CreateFmt('%s: Can not remove current Element from an immutable list (in %s)', [classname, name]); + end; + end;; + end; +end; + +procedure TBoldAbstractListHandle.SetCurrentBoldObject( + const Value: TBoldObject); +begin + SetCurrentElement(Value); +end; + +procedure TBoldAbstractListHandle.SetCurrentElement(const Value: TBoldElement); +begin + CurrentIndex := List.IndexOf(Value); end; function TBoldAbstractListHandle.GetCurrentBoldObject: TBoldObject; +var + aCurrentElement: TBoldElement; begin - if CurrentElement is TBoldObject then - Result := TBoldObject(CurrentElement) - else if not Assigned(CurrentElement) then + aCurrentElement := CurrentElement; + if aCurrentElement is TBoldObject then + Result := TBoldObject(aCurrentElement) + else if aCurrentElement = nil then Result := nil else - raise EBold.CreateFmt(sCurrentElementNotBoldObject, [ClassName]); + raise EBold.CreateFmt('%s.CurrentBoldObject: Current element is not a TBoldObject', [ClassName]); end; function TBoldAbstractListHandle.GetListElementType: TBoldElementTypeInfo; +var + BoldList: TBoldList; begin - if Assigned(List) then - Result := TBoldListTypeInfo(List.BoldType).ListElementTypeInfo + BoldList := List; + if Assigned(BoldList) and Assigned(BoldList.BoldType) then + Result := TBoldListTypeInfo(BoldList.BoldType).ListElementTypeInfo else Result := StaticBoldType; end; @@ -139,9 +169,12 @@ function TBoldAbstractListHandle.GetHasPrior: Boolean; end; function TBoldAbstractListHandle.GetListType: TBoldListTypeInfo; +var + BoldList: TBoldList; begin - if Assigned(List) then - Result := TBoldListTypeInfo(List.BoldType) + BoldList := List; + if Assigned(BoldList) then + Result := TBoldListTypeInfo(BoldList.BoldType) else result := StaticListType; end; @@ -166,19 +199,27 @@ function TBoldAbstractListHandle.GetMutableList: TBoldList; end; function TBoldAbstractListHandle.GetObjectList: TBoldObjectList; +var + BoldList: TBoldList; begin - if list is TBoldObjectList then - result := list as TBoldObjectList + BoldList := List; + if BoldList is TBoldObjectList then + result := TBoldObjectList(BoldList) else result := nil; end; function TBoldAbstractListHandle.GetMutableObjectList: TBoldObjectList; +var + BoldList: TBoldList; begin - if MutableList is TBoldObjectList then - result := MutableList as TBoldObjectList + BoldList := MutableList; + if BoldList is TBoldObjectList then + result := TBoldObjectList(BoldList) else result := nil; end; +initialization + end. diff --git a/Source/Handles/Core/BoldCursorHandle.pas b/Source/Handles/Core/BoldCursorHandle.pas index 74081974..20ddd88b 100644 --- a/Source/Handles/Core/BoldCursorHandle.pas +++ b/Source/Handles/Core/BoldCursorHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldCursorHandle; interface @@ -14,14 +17,14 @@ interface TBoldCursorHandle = class; { TBoldCursorHandle } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldCursorHandle = class(TBoldAbstractListHandle) private fAutoFirst: Boolean; - fListElement: TBoldIndirectElement; + fListElement: TBoldIndirectElement; fCurrentIndex: Integer; fListSubscriber: TBoldPassThroughSubscriber; procedure SetAutoFirst(Value: Boolean); -// function GetListSubscriber: TBoldPassThroughSubscriber; procedure _ReceiveFromList(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); protected procedure DeriveAndSubscribe(DerivedObject: TObject; Subscriber: TBoldSubscriber); override; @@ -30,7 +33,7 @@ TBoldCursorHandle = class(TBoldAbstractListHandle) function GetList: TBoldList; override; procedure SetCurrentIndex(NewIndex: Integer); override; function GetStaticBoldType: TBoldElementTypeInfo; override; -// property ListSubscriber: TBoldPassThroughSubscriber read GetListSubscriber; + property ListElement: TBoldIndirectElement read fListElement; public constructor Create(Owner: TComponent); override; destructor Destroy; override; @@ -42,7 +45,6 @@ implementation uses SysUtils, - HandlesConst, BoldDefs, BoldSystemRT; @@ -51,7 +53,7 @@ implementation constructor TBoldCursorhandle.Create(Owner: TComponent); begin inherited; - fListElement := TBOldIndirectElement.Create; + fListElement := TBoldIndirectElement.Create; fListSubscriber := TBoldPassThroughSubscriber.Create(_ReceiveFromList); fCurrentIndex := -1; AutoFirst := True; @@ -66,6 +68,8 @@ procedure TBoldCursorhandle.DeriveAndSubscribe(DerivedObject: TObject; TheList: TBoldList; NewValue: TBoldElement; begin + if csDestroying in ComponentState then + raise EBold.CreateFmt('%s.DeriveAndSubscribe: %s Handle is in csDestroying state, can not DeriveAndSubscribe.', [classname, name]); fListSubscriber.CancelAllSubscriptions; if EffectiveRootValue = nil then @@ -80,7 +84,7 @@ procedure TBoldCursorhandle.DeriveAndSubscribe(DerivedObject: TObject; if Assigned(TheList) then begin ListCount := TheList.Count; - IndexOfOldCurrent := TheList.IndexOf(ResultElement.Value) // Don't ensure current! + IndexOfOldCurrent := TheList.IndexOf(ResultElement.Value) end else begin @@ -190,8 +194,8 @@ procedure TBoldCursorhandle.SetCurrentIndex(NewIndex: Integer); var NewValue: TBoldElement; begin - if (NewIndex < -1) or (NewIndex >= Count) then // -1 accepted as "no current element" - raise EBold.CreateFmt(sIndexOutOfBounds, [ClassName, Count-1, NewIndex]); + if (NewIndex < -1) or (NewIndex >= Count) then + raise EBold.CreateFmt('%s.SetCurrentIndex: Index out of bounds. Valid range from -1 to %d. Attempted to set %d', [ClassName, Count-1, NewIndex]); if (NewIndex = -1) then NewValue := nil else @@ -202,8 +206,10 @@ procedure TBoldCursorhandle.SetCurrentIndex(NewIndex: Integer); fCurrentIndex := NewIndex; ResultElement.SetReferenceValue(NewValue); SubscribeToValue; - ValueIdentityChanged; // changing index is an identitychange + ValueIdentityChanged; end; end; +initialization + end. diff --git a/Source/Handles/Core/BoldDerivedHandle.pas b/Source/Handles/Core/BoldDerivedHandle.pas index d151425d..b9ab4f80 100644 --- a/Source/Handles/Core/BoldDerivedHandle.pas +++ b/Source/Handles/Core/BoldDerivedHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDerivedHandle; interface @@ -16,6 +19,7 @@ interface TBoldDerivedHandle = class; {---TBoldDerviedHandle---} + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldDerivedHandle = class(TBoldRootedHandle) private fOnDeriveAndSubscribe: TBoldHandleDeriveAndSubscribe; @@ -23,6 +27,7 @@ TBoldDerivedHandle = class(TBoldRootedHandle) procedure SetOnDeriveAndSubscribe(Value: TBoldHandleDeriveAndSubscribe); procedure SetValueTypeName(Value: string); protected + procedure DoAssign(Source: TPersistent); override; procedure DeriveAndSubscribe(DerivedObject: TObject; Subscriber: TBoldSubscriber); override; function GetStaticBoldType: TBoldElementTypeInfo; override; published @@ -34,16 +39,27 @@ implementation uses SysUtils, - HandlesConst, BoldSystemRT, BoldDefs; + { TBoldDerviedHandle } -procedure TBoldDerivedHandle.DeriveAndSubscribe(DerivedObject: TObject; - Subscriber: TBoldSubscriber); +procedure TBoldDerivedHandle.DoAssign(Source: TPersistent); +begin + inherited; + if Source is TBoldDerivedHandle then with TBoldDerivedHandle(Source) do + begin + self.ValueTypeName := ValueTypeName; + self.OnDeriveAndSubscribe := OnDeriveAndSubscribe; + end; +end; + +procedure TBoldDerivedHandle.DeriveAndSubscribe(DerivedObject: TObject;Subscriber: TBoldSubscriber); begin - Assert (DerivedObject is TBoldIndirectElement); + if csDestroying in ComponentState then + raise EBold.CreateFmt('%s.DeriveAndSubscribe: %s Handle is in csDestroying state, can not DeriveAndSubscribe.', [classname, name]); + Assert(DerivedObject is TBoldIndirectElement); if Assigned(fOnDeriveAndSubscribe) then fOnDeriveAndSubscribe(Self, EffectiveRootValue, TBoldIndirectElement(DerivedObject), Subscriber); end; @@ -63,7 +79,7 @@ function TBoldDerivedHandle.GetStaticBoldType: TBoldElementTypeInfo; begin result := SystemTypeInfo.ElementTypeInfoByExpressionName[ValueTypeName]; if assigned(result) and not (result.BoldValueType in [bvtAttr, bvtList]) then - raise EBold.CreateFmt(sIllegalTypeSelected, [ClassName, ValueTypeName]); + raise EBold.CreateFmt('%s.GetStaticBoldType: Only lists and attributes are allowed as types (expr: %s)', [ClassName, ValueTypeName]); end else result := nil; diff --git a/Source/Handles/Core/BoldExpressionHandle.pas b/Source/Handles/Core/BoldExpressionHandle.pas index 1a85ff3f..26e1db9a 100644 --- a/Source/Handles/Core/BoldExpressionHandle.pas +++ b/Source/Handles/Core/BoldExpressionHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldExpressionHandle; interface @@ -14,7 +17,10 @@ interface { forward declaration of classes } TBoldExpressionHandle = class; + TBoldExpressionHandleClass = class of TBoldExpressionHandle; + {---TBoldExpressionHandle---} + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldExpressionHandle = class(TBoldRootedHandle, IBoldOCLComponent) function IBoldOCLComponent.GetContextType = GetStaticRootType; private @@ -22,33 +28,42 @@ TBoldExpressionHandle = class(TBoldRootedHandle, IBoldOCLComponent) FVariables: TBoldOclVariables; fVariablesSubscriber: TBoldPassThroughSubscriber; fEvaluateInPS: Boolean; + fUsePrefetch: Boolean; procedure _VariablesReceive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); - procedure SetExpression(Value: string); - function GetExpression: String; + procedure SetExpression(const Value: TBoldExpression); + function GetExpression: TBoldExpression; procedure SetVariables(const Value: TBoldOclVariables); - function GetVariableList: TBoldExternalVariableList; procedure SetEvaluateInPS(const Value: Boolean); protected function GetStaticBoldType: TBoldElementTypeInfo; override; procedure DeriveAndSubscribe(DerivedObject: TObject; Subscriber: TBoldSubscriber); override; + procedure DoAssign(Source: TPersistent); override; + procedure DoExpressionChanged; virtual; + function GetVariables: TBoldOclVariables; virtual; + function GetVariableList: TBoldExternalVariableList; virtual; + property VariableList: TBoldExternalVariableList read GetVariableList; public constructor Create(owner: TComponent); override; destructor Destroy; override; function RefersToComponent(Component: TBoldSubscribableComponent): Boolean; override; published - property Expression: TBoldExpression read fExpression write SetExpression; - property Variables: TBoldOclVariables read FVariables write SetVariables; + property Expression: TBoldExpression read GetExpression write SetExpression; + property Variables: TBoldOclVariables read GetVariables write SetVariables; property EvaluateInPS: Boolean read fEvaluateInPS write SetEvaluateInPS default false; {$IFNDEF T2H} property Subscribe; {$ENDIF} + property UsePrefetch: Boolean read fUsePrefetch write fUsePrefetch default true; end; implementation uses SysUtils, - HandlesConst; + {$IFDEF SpanFetch} + AttracsSpanFetchManager, + {$ENDIF} + BoldRev; const breVariablesDestroyed = 200; @@ -56,50 +71,64 @@ implementation {---TBoldExpressionHandle---} function TBoldExpressionHandle.GetStaticBoldType: TBoldElementTypeInfo; +var + vStaticRootType: TBoldElementTypeInfo; begin - if Assigned(StaticRootType) then - begin - if assigned(Variables) then - Result := StaticRootType.Evaluator.ExpressionType(Expression, StaticRootType, False, Variables.VariableList) - else - Result := StaticRootType.Evaluator.ExpressionType(Expression, StaticRootType, False); - end + vStaticRootType := StaticRootType; + if Assigned(vStaticRootType) then + Result := vStaticRootType.Evaluator.ExpressionType(Expression, vStaticRootType, True, VariableList) else Result := nil; end; -procedure TBoldExpressionHandle.SetExpression(Value: string); +procedure TBoldExpressionHandle.SetExpression(const Value: TBoldExpression); begin if Value <> fExpression then begin fExpression := Value; MarkSubscriptionOutOfdate; + DoExpressionChanged; end; end; procedure TBoldExpressionHandle.DeriveAndSubscribe(DerivedObject: TObject; Subscriber: TBoldSubscriber); + + function GetFullName(AComponent: TComponent): string; + begin + result := AComponent.GetNamePath; + if result = '' then + result := '('+AComponent.ClassName+')'; + if (AComponent is TComponent) and Assigned(TComponent(AComponent).Owner) then + result := GetFullName(TComponent(AComponent).Owner) + '.' + result; + end; + var RootValue: TBoldElement; vars: TBoldExternalVariableList; begin + if csDestroying in ComponentState then + raise EBold.CreateFmt('%s.DeriveAndSubscribe: %s Handle is in csDestroying state, can not DeriveAndSubscribe.', [classname, name]); RootValue := EffectiveRootValue; if Assigned(RootValue) then begin if assigned(Variables) then - begin - Vars := variables.VariableList; - variables.SubscribeToHandles(Subscriber); - end - else - vars := nil; + variables.SubscribeToHandles(Subscriber, Expression); + Vars := VariableList; try - RootValue.EvaluateAndSubscribeToExpression(Expression, Subscriber, ResultElement, False, EvaluateInPS, vars) + begin +{$IFDEF SpanFetch} + if UsePrefetch and not EvaluateInps then + FetchOclSpan(RootValue, Expression, vars); +{$ENDIF} + if Assigned(RootValue.BoldType) then // ValueSetValue has no BoldType + RootValue.EvaluateAndSubscribeToExpression(Expression, Subscriber, ResultElement, False, EvaluateInPS, vars) + end; except on e: Exception do begin - e.message := format(sDeriveAndSubscribeFailed, - [ClassName, Name, e.Message]); + e.message := format('%s.DeriveAndSubscribe (%s): Failed with message: %s', + [ClassName, GetFullName(self), e.Message]); raise end; end; @@ -118,7 +147,7 @@ procedure TBoldExpressionHandle.SetVariables(const Value: TBoldOclVariables); if Value <> Variables then begin if assigned(value) and value.LinksToHandle(self) then - raise EBold.CreateFmt(sCircularReference, [classname, name, value.name]); + raise EBold.CreateFmt('%s.SetVariables: %s can not be linked to %s. Circular reference', [classname, name, value.name]); FVariables := Value; StaticBoldTypeChanged; fVariablesSubscriber.CancelAllSubscriptions; @@ -143,10 +172,26 @@ procedure TBoldExpressionHandle._VariablesReceive(Originator: TObject; FVariables := nil; end; -constructor TBoldExpressionHandle.create(owner: TComponent); +procedure TBoldExpressionHandle.DoAssign(Source: TPersistent); +begin + inherited; + if Source is TBoldExpressionHandle then with TBoldExpressionHandle(Source) do + begin + self.Expression := Expression; + self.Variables := Variables; + self.EvaluateInPS := EvaluateInPS; + end; +end; + +procedure TBoldExpressionHandle.DoExpressionChanged; +begin +end; + +constructor TBoldExpressionHandle.Create(owner: TComponent); begin inherited; fVariablesSubscriber := TBoldPassthroughSubscriber.create(_VariablesReceive); + fUsePrefetch := true; end; destructor TBoldExpressionHandle.Destroy; @@ -163,6 +208,11 @@ function TBoldExpressionHandle.GetVariableList: TBoldExternalVariableList; result := nil; end; +function TBoldExpressionHandle.GetVariables: TBoldOclVariables; +begin + result := fVariables; +end; + function TBoldExpressionHandle.RefersToComponent(Component: TBoldSubscribableComponent): Boolean; begin result := inherited RefersToComponent(Component); @@ -171,3 +221,4 @@ function TBoldExpressionHandle.RefersToComponent(Component: TBoldSubscribableCom end; end. + diff --git a/Source/Handles/Core/BoldFilteredHandle.pas b/Source/Handles/Core/BoldFilteredHandle.pas index 9ba12df4..294b6f3b 100644 --- a/Source/Handles/Core/BoldFilteredHandle.pas +++ b/Source/Handles/Core/BoldFilteredHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldFilteredHandle; interface @@ -18,6 +21,7 @@ TBoldFilteredHandle = class; TBoldElementFilter = function (Element: TBoldElement): Boolean of object; { TBoldFilter } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldFilter = class(TBoldSubscribableComponentViaBoldElem) private FOnFilter: TBoldElementFilter; @@ -27,8 +31,8 @@ TBoldFilter = class(TBoldSubscribableComponentViaBoldElem) procedure SetPreFetchRoles(const Value: TStrings); function StorePreFetchRoles: Boolean; public - constructor Create(owner: TComponent); override; - destructor Destroy; override; + constructor create(owner: TComponent); override; + destructor destroy; override; procedure Subscribe(boldElement: TBoldElement; Subscriber: TBoldSubscriber); virtual; function Filter(Element: TBoldElement): Boolean; virtual; procedure FilterList(List: TBoldList); @@ -54,8 +58,10 @@ implementation uses SysUtils, + BoldDefs, BoldSystemRT; + {---TBoldFilter---} constructor TBoldFilter.create(owner: TComponent); @@ -64,10 +70,10 @@ constructor TBoldFilter.create(owner: TComponent); fPreFetchRoles := TStringList.Create; end; -destructor TBoldFilter.Destroy; +destructor TBoldFilter.destroy; begin FreeAndNil(fPreFetchRoles); - inherited; + inherited; end; function TBoldFilter.Filter(Element: TBoldElement): Boolean; @@ -100,7 +106,7 @@ procedure TBoldFilter.SetPreFetchRoles(const Value: TStrings); function TBoldFilter.StorePreFetchRoles: Boolean; begin - result := PreFetchRoles.Count <> 0; + result := PreFetchRoles.Count <> 0; end; procedure TBoldFilter.Subscribe(boldElement: TBoldElement; Subscriber: TBoldSubscriber); @@ -121,7 +127,10 @@ procedure TBoldFilteredHandle.DeriveAndSubscribe(DerivedObject: TObject; ListTypeInfo: TBoldListTypeInfo; ClassTypeInfo: TBoldClassTypeInfo; MemberRTInfo: TBoldMemberRTInfo; + begin + if csDestroying in ComponentState then + raise EBold.CreateFmt('%s.DeriveAndSubscribe: %s Handle is in csDestroying state, can not DeriveAndSubscribe.', [classname, name]); if EffectiveRootValue = nil then ResultElement.SetOwnedValue(nil) else if not Assigned(BoldFilter) then @@ -186,4 +195,6 @@ procedure TBoldFilteredHandle.SetBoldFilter(NewValue: TBoldFilter); end; end; +initialization + end. diff --git a/Source/Handles/Core/BoldHandles.pas b/Source/Handles/Core/BoldHandles.pas index b1fb5cb3..c315c53a 100644 --- a/Source/Handles/Core/BoldHandles.pas +++ b/Source/Handles/Core/BoldHandles.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldHandles; interface @@ -9,7 +12,8 @@ interface BoldSubscription, BoldElements, BoldSystem, - BoldSystemRT; + BoldSystemRT, + BoldComponentValidator; // maybe move IBoldValidateableComponent here instead ? type { forward declaration of classes } @@ -18,29 +22,42 @@ TBoldElementHandle = class; TBoldSystemTypeInfoHandle = class; TBoldNonSystemHandle = class; + TBoldElementHandleClass = class of TBoldElementHandle; + TBoldNonSystemHandleClass = class of TBoldNonSystemHandle; + {---TBoldElementHandle---} - TBoldElementHandle = class(TBoldSubscribableComponent) + TBoldElementHandle = class(TBoldSubscribableComponent, IBoldValidateableComponent) private fStrictType: Boolean; function GetDynamicBoldType: TBoldElementTypeInfo; function GetBoldType: TBoldElementTypeInfo; + function GetValueAsString: String; + function GetValueAsVariant: variant; protected function GetValue: TBoldElement; virtual; abstract; function GetStaticSystemTypeInfo: TBoldSystemTypeInfo; virtual; abstract; function GetStaticBoldType: TBoldElementTypeInfo; virtual; abstract; procedure StaticBoldTypeChanged; virtual; + function GetCanSetValue: boolean; virtual; + procedure SetValue(NewValue: TBoldElement); virtual; public destructor Destroy; override; function RefersToComponent(Component: TBoldSubscribableComponent): Boolean; virtual; + { IBoldValidateableComponent} + function ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: String): Boolean; virtual; property StaticSystemTypeInfo: TBoldSystemTypeInfo read GetStaticSystemTypeInfo; property BoldType: TBoldElementTypeInfo read GetBoldType; property DynamicBoldType: TBoldElementTypeInfo read GetDynamicBoldType; property StaticBoldType: TBoldElementTypeInfo read GetStaticBoldType; property Value: TBoldElement read GetValue; property StrictType: Boolean read fStrictType write fStrictType; + property AsString: String read GetValueAsString; + property AsVariant: Variant read GetValueAsVariant; + property CanSetValue: boolean read GetCanSetValue; end; { TBoldSystemTypeInfoHandle } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldSystemTypeInfoHandle = class(TBoldElementHandle) private fBoldModel: TBoldAbstractModel; @@ -54,6 +71,7 @@ TBoldSystemTypeInfoHandle = class(TBoldElementHandle) procedure SetBoldModel(Value: TBoldAbstractModel); procedure ModelChanged; function GetRegionDefinitions: TBoldRegionDefinitions; + function GetIsSystemTypeInfoAvailable: boolean; protected function GetStaticBoldType: TBoldElementTypeInfo; override; function GetStaticSystemTypeInfo: TBoldSystemTypeInfo; override; @@ -64,6 +82,7 @@ TBoldSystemTypeInfoHandle = class(TBoldElementHandle) procedure InstallOclDefinitionLookUp(const Value: TBoldLookUpOclDefinition); function RefersToComponent(Component: TBoldSubscribableComponent): Boolean; override; property RegionDefinitions: TBoldRegionDefinitions read GetRegionDefinitions; + property IsSystemTypeInfoAvailable: boolean read GetIsSystemTypeInfoAvailable; published property BoldModel: TBoldAbstractModel read fBoldModel write SetBoldModel; property UseGeneratedCode: Boolean read fUseGeneratedCode write fUseGeneratedCode default True; @@ -78,8 +97,7 @@ TBoldAbstractSystemHandle = class(TBoldElementHandle) fSystemTypeInfoHandle: TBoldSystemTypeInfoHandle; procedure SetSystemTypeInfoHandle(Value: TBoldSystemTypeInfoHandle); procedure _Recieve(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); - procedure setIsDefault(Value: Boolean); - function GetIsDefault: Boolean; + procedure SetIsDefault(Value: Boolean); protected function GetActive: Boolean; virtual; abstract; procedure SetActive(Value: Boolean); virtual; abstract; @@ -96,8 +114,9 @@ TBoldAbstractSystemHandle = class(TBoldElementHandle) property SystemTypeInfoHandle: TBoldSystemTypeInfoHandle read fSystemTypeInfoHandle write SetSystemTypeInfoHandle; class function DefaultBoldSystemTypeInfo: TBoldSystemTypeInfo; class function DefaultBoldSystemHandle: TBoldAbstractSystemHandle; + class function FindSystemHandleForSystem(ABoldSystem: TBoldSystem): TBoldAbstractSystemHandle; published - property IsDefault: Boolean read GetIsDefault write setIsDefault nodefault; {Always save} + property IsDefault: Boolean read fIsDefault write SetIsDefault nodefault; {Always save} end; { TBoldNonSystemHandle } @@ -106,23 +125,31 @@ TBoldNonSystemHandle = class(TBoldElementHandle) fStaticSystemHandle: TBoldAbstractSystemHandle; fStaticSystemHandleSubscriber: TBoldPassthroughSubscriber; procedure _Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); + function GetBoldSystem: TBoldSystem; protected + function GetStaticSystemHandle: TBoldAbstractSystemHandle; virtual; procedure SetStaticSystemHandle(Value: TBoldAbstractSystemHandle); virtual; function GetStaticSystemTypeInfo: TBoldSystemTypeInfo; override; + procedure DoAssign(Source: TPersistent); virtual; + function IsStaticSystemHandleStored: boolean; virtual; public constructor Create(Owner: TComponent); override; + procedure AfterConstruction; override; destructor Destroy; override; + procedure Assign(Source: TPersistent); override; + property BoldSystem: TBoldSystem read GetBoldSystem; published - property StaticSystemHandle: TBoldAbstractSystemHandle read fStaticSystemHandle write SetStaticSystemHandle; + property StaticSystemHandle: TBoldAbstractSystemHandle read GetStaticSystemHandle write SetStaticSystemHandle stored IsStaticSystemHandleStored; end; implementation uses SysUtils, - HandlesConst, BoldDefs, - BoldregionDefinitionParser; + BoldregionDefinitionParser, + BoldContainers, + Variants; const breModelDestroyed = 42; @@ -132,6 +159,7 @@ implementation var G_DefaultBoldSystemHandle: TBoldAbstractSystemHandle = nil; + G_BoldSystemHandleList: TBoldObjectArray; {---TBoldElementHandle---} @@ -144,10 +172,15 @@ destructor TBoldElementHandle.Destroy; function TBoldElementHandle.GetBoldType: TBoldElementTypeInfo; begin Result := DynamicBoldType; - if not Assigned(DynamicBoldType) then + if not Assigned(Result) then Result := StaticBoldType; end; +function TBoldElementHandle.GetCanSetValue: boolean; +begin + result := false; +end; + function TBoldElementHandle.GetDynamicBoldType: TBoldElementTypeInfo; begin if Assigned(Value) then @@ -156,23 +189,53 @@ function TBoldElementHandle.GetDynamicBoldType: TBoldElementTypeInfo; Result := nil; end; +function TBoldElementHandle.GetValueAsString: String; +begin + if Assigned(Value) then + result := Value.AsString + else + result := ''; +end; + +function TBoldElementHandle.GetValueAsVariant: variant; +begin + if Assigned(Value) then + result := Value.AsVariant + else + result := null; +end; + function TBoldElementHandle.RefersToComponent(Component: TBoldSubscribableComponent): Boolean; begin result := false; end; +procedure TBoldElementHandle.SetValue(NewValue: TBoldElement); +begin + raise EBold.CreateFmt('%s: SetValue Not supported', [ClassName]); +end; + procedure TBoldElementHandle.StaticBoldTypeChanged; begin SendEvent(self, beValueIdentityChanged); end; +function TBoldElementHandle.ValidateComponent( + ComponentValidator: TBoldComponentValidator; NamePrefix: String): Boolean; +var + vBoldOCLComponent: IBoldOCLComponent; +begin + result := Assigned(BoldType); + if result and Supports(self, IBoldOCLComponent, vBoldOCLComponent) then + result := ComponentValidator.ValidateOCLComponent(vBoldOCLComponent, NamePrefix+Name); +end; + { TBoldNonSystemHandle } procedure TBoldNonSystemHandle._Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); begin - Assert(Originator=StaticSystemHandle); - Assert(RequestedEvent in [breFreeHandle, breValueIdentityChanged]); + Assert(RequestedEvent in [breFreeHandle, breValueIdentityChanged], IntToStr(OriginalEvent) + ',' + IntToStr(RequestedEvent)); case RequestedEvent of breFreeHandle: StaticSystemHandle := nil; breValueIdentityChanged: StaticBoldTypeChanged; @@ -185,23 +248,78 @@ procedure TBoldNonSystemHandle.SetStaticSystemHandle(Value: TBoldAbstractSystemH begin fStaticSystemHandleSubscriber.CancelAllSubscriptions; fStaticSystemHandle := Value; - if Assigned(StaticSystemHandle) then + if Assigned(fStaticSystemHandle) then begin - StaticSystemHandle.AddSmallSubscription(fStaticSystemHandleSubscriber, [beDestroying], breFreeHandle); - StaticSystemHandle.AddSmallSubscription(fStaticSystemHandleSubscriber, [beValueIDentityChanged], breValueIdentityChanged); + fStaticSystemHandle.AddSmallSubscription(fStaticSystemHandleSubscriber, [beDestroying], breFreeHandle); + fStaticSystemHandle.AddSmallSubscription(fStaticSystemHandleSubscriber, [beValueIDentityChanged], breValueIdentityChanged); end; StaticBoldTypeChanged; end; end; +function TBoldNonSystemHandle.GetBoldSystem: TBoldSystem; +begin + if Assigned(fStaticSystemHandle) then + result := fStaticSystemHandle.System + else + result := nil; +end; + +function TBoldNonSystemHandle.GetStaticSystemHandle: TBoldAbstractSystemHandle; +begin + if Assigned(fStaticSystemHandle) then + result := fStaticSystemHandle + else + begin + result := nil; +{ if BoldSystemCount = 1 then + begin + result := TBoldAbstractSystemHandle.DefaultBoldSystemHandle; + if Assigned(result) and (fStaticSystemHandleSubscriber.SubscriptionCount = 0) then + begin + result.AddSmallSubscription(fStaticSystemHandleSubscriber, [beDestroying], breFreeHandle); + result.AddSmallSubscription(fStaticSystemHandleSubscriber, [beValueIDentityChanged], breValueIdentityChanged); + end; + end; +} + end; +end; + function TBoldNonSystemHandle.GetStaticSystemTypeInfo: TBoldSystemTypeInfo; begin if Assigned(StaticSystemHandle) then Result := StaticSystemHandle.StaticSystemTypeInfo - else if TBoldAbstractSystemHandle.DefaultBoldSystemHandle <> nil then + else Result := TBoldAbstractSystemHandle.DefaultBoldSystemTypeInfo +end; + +function TBoldNonSystemHandle.IsStaticSystemHandleStored: boolean; +begin + result := Assigned(fStaticSystemHandle); +end; + +procedure TBoldNonSystemHandle.AfterConstruction; +begin + inherited; + if Assigned(G_DefaultBoldSystemHandle) and not (csLoading in ComponentState) and (csDesigning in ComponentState) then + {connect to default system at design time} + StaticSystemHandle := G_DefaultBoldSystemHandle; +end; + +procedure TBoldNonSystemHandle.Assign(Source: TPersistent); +begin + if Source is TBoldNonSystemHandle then + DoAssign(Source) else - Result := nil; + inherited Assign(Source); +end; + +procedure TBoldNonSystemHandle.DoAssign(Source: TPersistent); +begin + if (Source is TBoldNonSystemHandle) then + begin + StaticSystemHandle := TBoldNonSystemHandle(Source).StaticSystemHandle; + end end; constructor TBoldNonSystemHandle.Create(Owner: TComponent); @@ -225,6 +343,7 @@ constructor TBoldAbstractSystemHandle.create(owner: TComponent); fSystemTypeInfoHandleSubscriber := TBoldPassThroughSubscriber.Create(_Recieve); if not Assigned(G_DefaultBoldSystemHandle) and (csdesigning in ComponentState) then {only make first default at design time} IsDefault := True; + G_BoldSystemHandleList.Add(self); end; class function TBoldAbstractSystemHandle.DefaultBoldSystemHandle: TBoldAbstractSystemHandle; @@ -243,6 +362,7 @@ class function TBoldAbstractSystemHandle.DefaultBoldSystemTypeInfo: TBoldSystemT destructor TBoldAbstractSystemHandle.Destroy; begin FreePublisher; + G_BoldSystemHandleList.Remove(self); if G_DefaultBoldSystemHandle = self then G_DefaultBoldSystemHandle := nil; IsDefault := False; @@ -250,9 +370,17 @@ destructor TBoldAbstractSystemHandle.Destroy; inherited; end; -function TBoldAbstractSystemHandle.GetIsDefault: Boolean; +class function TBoldAbstractSystemHandle.FindSystemHandleForSystem(ABoldSystem: TBoldSystem): TBoldAbstractSystemHandle; +var + i: integer; begin - result := fIsDefault; + for I := 0 to G_BoldSystemHandleList.Count - 1 do + begin + result := TBoldAbstractSystemHandle(G_BoldSystemHandleList[i]); + if ABoldSystem = result.System then + exit; + end; + result := nil; end; function TBoldAbstractSystemHandle.GetStaticBoldType: TBoldElementTypeInfo; @@ -275,17 +403,18 @@ function TBoldAbstractSystemHandle.RefersToComponent(Component: TBoldSubscribabl result := Component = SystemTypeInfoHandle; end; -procedure TBoldAbstractSystemHandle.setIsDefault(Value: Boolean); +procedure TBoldAbstractSystemHandle.SetIsDefault(Value: Boolean); begin if (Value <> IsDefault) then begin fIsDefault := Value; if Value then G_DefaultBoldSystemHandle := Self - else if Isdefault then + else + if G_DefaultBoldSystemHandle = Self then G_DefaultBoldSystemHandle := nil; if Active then - System.IsDefault := Value; + System.IsDefault := G_DefaultBoldSystemHandle = Self; end; end; @@ -294,7 +423,7 @@ procedure TBoldAbstractSystemHandle.SetSystemTypeInfoHandle(Value: TBoldSystemTy if Value <> fSystemTypeInfoHandle then begin if Active then - raise EBold.CreateFmt(sNotAllowedOnActiveHandle, [Name]); + raise EBold.CreateFmt('%s: Not allowed to change the systemTypeInfoHandle on an active system', [Name]); fSystemTypeInfoHandleSubscriber.CancelAllSubscriptions; if Assigned(Value) then begin @@ -336,7 +465,7 @@ procedure TBoldSystemTypeInfoHandle._Recieve(Originator: TObject; function TBoldSystemTypeInfoHandle.GetStaticBoldType: TBoldElementTypeInfo; begin - result := GetStaticSystemTypeInfo; + result := GetStaticSystemTypeInfo; end; function TBoldSystemTypeInfoHandle.GetStaticSystemTypeInfo: TBoldSystemTypeInfo; @@ -358,10 +487,16 @@ function TBoldSystemTypeInfoHandle.GetStaticSystemTypeInfo: TBoldSystemTypeInfo; end; procedure TBoldSystemTypeInfoHandle.ModelChanged; +var + WasActive: boolean; begin + WasActive := Assigned(fSystemTypeInfo); + if WasActive then + SendEvent(self, beValueIdentityChanged); FreeAndNil(fSystemTypeInfo); FreeAndNil(fRegionDefinitions); - SendEvent(self, beValueIdentityChanged); // type change regarded as idenitychange + if not WasActive then + SendEvent(self, beValueIdentityChanged); end; procedure TBoldSystemTypeInfoHandle.SetBoldModel(Value: TBoldAbstractModel); @@ -387,7 +522,7 @@ constructor TBoldSystemTypeInfoHandle.Create(owner: TComponent); fModelSubscriber := TBoldPassThroughSubscriber.Create(_Recieve); end; -destructor TBoldSystemTypeInfoHandle.Destroy; +destructor TBoldSystemTypeInfoHandle.destroy; begin FreePublisher; FreeAndNil(fModelSubscriber); @@ -415,6 +550,11 @@ function TBoldSystemTypeInfoHandle.RefersToComponent(Component: TBoldSubscribabl result := Component = BoldModel; end; +function TBoldSystemTypeInfoHandle.GetIsSystemTypeInfoAvailable: boolean; +begin + result := Assigned(fSystemTypeInfo); +end; + function TBoldSystemTypeInfoHandle.GetRegionDefinitions: TBoldRegionDefinitions; var Parser: TBoldRegionParser; @@ -437,4 +577,10 @@ function TBoldSystemTypeInfoHandle.GetRegionDefinitions: TBoldRegionDefinitions; result := fRegionDefinitions; end; +initialization + G_BoldSystemHandleList := TBoldObjectArray.Create(10, []); + +finalization + FreeAndNil(G_BoldSystemHandleList); + end. diff --git a/Source/Handles/Core/BoldListHandle.pas b/Source/Handles/Core/BoldListHandle.pas index 703b6941..5487aacf 100644 --- a/Source/Handles/Core/BoldListHandle.pas +++ b/Source/Handles/Core/BoldListHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldListHandle; interface @@ -17,29 +20,32 @@ interface type {---Forward declarations---} - TBoldListHandle = class; + TBoldListHandle = class; {---TBoldListHandle---} + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldListHandle = class(TBoldCursorHandle, IBoldOCLComponent) private fExpressionHandle: TBoldExpressionHandle; fFilterHandle: TBoldFilteredHandle; fSorterHandle: TBoldSortedHandle; + FInternalRootHandle: TBoldSortedHandle; fMutableListExpression: TBoldExpression; + fUsePrefetch: boolean; function GetContextType: TBoldElementTypeInfo; function GetComparer: TBoldComparer; function GetExpression: TBoldExpression; function GetFilter: TBoldFilter; procedure SetComparer(Value: TBoldComparer); - procedure SetExpression(Value: string); + procedure SetExpression(const Value: TBoldExpression); procedure SetFilter(Value: TBoldFilter); - function GetVariableList: TBoldExternalVariableList; - function GetVariables: TBoldOclVariables; procedure SetVariables(Value: TBoldOclVariables); function GetEvaluateInPS: Boolean; procedure SetEvaluateInPS(const Value: Boolean); procedure SetMutableListExpression(const Value: TBoldExpression); procedure FixupRoots; + function GetUsePrefetch: Boolean; + procedure SetUsePrefetch(const Value: Boolean); protected procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure SetSubscribe(Value: Boolean); override; @@ -47,12 +53,18 @@ TBoldListHandle = class(TBoldCursorHandle, IBoldOCLComponent) procedure Loaded; override; function GetRootHandle: TBoldElementHandle; override; procedure SetRootHandle(const Value: TBoldElementHandle); override; + procedure SetRootTypeName(Value: string); override; function GetMutableList: TBoldList; override; + procedure DoAssign(Source: TPersistent); override; + function GetVariables: TBoldOclVariables; virtual; + function GetVariableList: TBoldExternalVariableList; virtual; + function GetExpressionHandleClass: TBoldExpressionHandleClass; virtual; public constructor Create(Owner: TComponent); override; destructor Destroy; override; procedure MarkOutOfDate; override; function RefersToComponent(Component: TBoldSubscribableComponent): Boolean; override; + property VariableList: TBoldExternalVariableList read GetVariableList; published property BoldComparer: TBoldComparer read GetComparer write SetComparer; property BoldFilter: TBoldFilter read GetFilter write SetFilter; @@ -60,21 +72,26 @@ TBoldListHandle = class(TBoldCursorHandle, IBoldOCLComponent) property Variables: TBoldOclVariables read GetVariables write SetVariables; property EvaluateInPS: Boolean read GetEvaluateInPS write SetEvaluateInPS default false; property MutableListExpression: TBoldExpression read fMutableListExpression write SetMutableListExpression; + property UsePrefetch: Boolean read GetUsePrefetch write SetUsePrefetch default true; end; implementation uses SysUtils, - HandlesConst, BoldRootedHandles; +type + THackSortedHandle = class(TBoldSortedHandle); + {---TBoldListHandle---} constructor TBoldListHandle.Create(Owner: TComponent); begin inherited; - fExpressionHandle := TBoldExpressionHandle.Create(nil); + fExpressionHandle := GetExpressionHandleClass.Create(self); + FInternalRootHandle := TBoldSortedHandle.Create(nil); FixupRoots; + UsePrefetch := true; end; destructor TBoldListHandle.Destroy; @@ -83,9 +100,24 @@ destructor TBoldListHandle.Destroy; FreeAndNil(fSorterHandle); FreeAndNil(fFilterHandle); FreeAndNil(fExpressionHandle); + FreeAndNil(FInternalRootHandle); inherited; end; +procedure TBoldListHandle.DoAssign(Source: TPersistent); +begin + inherited; + if Source is TBoldListHandle then with TBoldListHandle(Source) do + begin + self.BoldComparer := BoldComparer; + self.BoldFilter := BoldFilter; + self.Expression := Expression; + self.Variables := Variables; + self.EvaluateInPS := EvaluateInPS; + self.MutableListExpression := MutableListExpression; + end; +end; + procedure TBoldListHandle.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); @@ -102,6 +134,7 @@ procedure TBoldListHandle.SetSubscribe(Value: Boolean); fFilterHandle.Subscribe := Value; if Assigned(fSorterHandle) then fSorterHandle.Subscribe := Value; + FInternalRootHandle.Subscribe := Value; inherited; end; @@ -112,6 +145,7 @@ procedure TBoldListHandle.MarkOutOfDate; fFilterHandle.MarkOutOfDate; if Assigned(fSorterHandle) then fSorterHandle.MarkOutOfDate; + FInternalRootHandle.MarkOutOfDate; inherited; end; @@ -120,25 +154,29 @@ procedure TBoldListHandle.FixupRoots; NextHandle: TBoldElementHandle; begin NextHandle := fExpressionHandle; - fExpressionHandle.Name := Name + '_expr'; // do not localize + fExpressionHandle.Name := Name + '_expr'; if Assigned(fFilterHandle) then begin fFilterHandle.RootHandle := NextHandle; - fFilterHandle.Name := Name + '_filt'; // do not localize + fFilterHandle.Name := Name + '_filt'; NextHandle := fFilterHandle; end; if Assigned(fSorterHandle) then begin FSorterHandle.RootHandle := NextHandle; - fSorterHandle.Name := Name + '_sort'; // do not localize + fSorterHandle.Name := Name + '_sort'; NextHandle := FSorterHandle; end; + FInternalRootHandle.RootHandle := NextHandle; + FInternalRootHandle.Name := Name + '_root'; // do not localize + NextHandle := FInternalRootHandle; + InternalRootHandle := NextHandle; end; -procedure TBoldListHandle.SetExpression(Value: string); +procedure TBoldListHandle.SetExpression(const Value: TBoldExpression); begin if value <> fExpressionHandle.Expression then begin @@ -152,6 +190,11 @@ function TBoldListHandle.GetExpression: TBoldExpression; Result := fExpressionHandle.Expression; end; +function TBoldListHandle.GetExpressionHandleClass: TBoldExpressionHandleClass; +begin + result := TBoldExpressionHandle; +end; + procedure TBoldListHandle.SetFilter(Value: TBoldFilter); begin if Value = BoldFilter then @@ -160,6 +203,11 @@ procedure TBoldListHandle.SetFilter(Value: TBoldFilter); begin if Assigned(fFilterHandle) then begin + if Assigned(FSorterHandle) then begin + FSorterHandle.RootHandle := FExpressionHandle; + end else begin + FInternalRootHandle.RootHandle := FExpressionHandle; + end; FreeAndNil(fFilterHandle); end end @@ -183,12 +231,21 @@ function TBoldListHandle.GetFilter: TBoldFilter; procedure TBoldListHandle.SetComparer(Value: TBoldComparer); begin - if Value = BoldComparer then + if Value = BoldComparer then begin + if Assigned(FSorterHandle) then begin + THackSortedHandle(FSorterHandle).MarkSubscriptionOutOfdate; + end; Exit; + end; if Value = nil then begin if Assigned(FSorterHandle) then begin + if Assigned(FFilterHandle) then begin + FInternalRootHandle.RootHandle := FFilterHandle; + end else begin + FInternalRootHandle.RootHandle := FExpressionHandle; + end; FreeAndNil(fSorterHandle); end end @@ -222,11 +279,30 @@ function TBoldListHandle.GetRootHandle: TBoldElementHandle; Result := fExpressionHandle.RootHandle; end; +procedure TBoldListHandle.SetUsePrefetch(const Value: Boolean); +begin + fUsePrefetch := Value; + fExpressionHandle.UsePrefetch := Value; +end; + +function TBoldListHandle.GetUsePrefetch: Boolean; +begin + result := fUsePrefetch; +end; + procedure TBoldListHandle.SetRootHandle(const Value: TBoldElementHandle); begin fExpressionHandle.RootHandle := Value; end; +procedure TBoldListHandle.SetRootTypeName(Value: string); +begin + inherited; + fExpressionHandle.RootTypeName := Value; + fInternalROotHandle.RootTypeName := Value; + StaticBoldTypeChanged; +end; + procedure TBoldListHandle.SetStaticSystemHandle( Value: TBoldAbstractSystemHandle); begin @@ -253,7 +329,7 @@ function TBoldListHandle.GetVariables: TBoldOclVariables; procedure TBoldListHandle.SetVariables(Value: TBoldOclVariables); begin if assigned(value) and value.LinksToHandle(self) then - raise EBold.CreateFmt(sCircularReference, [classname, name, value.name]); + raise EBold.CreateFmt('%s.SetVariables: %s can not be linked to %s. Circular reference', [classname, name, value.name]); fExpressionHandle.Variables := Value; end; diff --git a/Source/Handles/Core/BoldOclRepository.pas b/Source/Handles/Core/BoldOclRepository.pas index 0c04a659..0ccd2cd9 100644 --- a/Source/Handles/Core/BoldOclRepository.pas +++ b/Source/Handles/Core/BoldOclRepository.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOclRepository; interface @@ -8,22 +11,29 @@ interface BoldSystemRT, BoldSystemHandle, BoldSubscription, - BoldComponentvalidator; + BoldHandles, + BoldComponentvalidator, + BoldDefs; type TBoldOclDefinitions = class; TBoldOclDefinition = class; TBoldOclRepository = class; + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldOclRepository = class(TBoldSubscribableComponent, IBoldValidateableComponent) private + fSystemHandle: TBoldSystemHandle; FOclDefinitions: TBoldOclDefinitions; - FSystemHandle: TBoldSystemHandle; procedure SetOclDefinitions(const Value: TBoldOclDefinitions); - procedure SetSystemHandle(const Value: TBoldSystemHandle); + procedure SetSystemHandle(Value: TBoldSystemHandle); + protected + procedure Notification(AComponent: TComponent; Operation: TOperation); override; function ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: String): Boolean; public + procedure AfterConstruction; override; constructor Create(owner: TComponent); override; + destructor Destroy; override; function LookUpOclDefinition(Name: string): string; published property OclDefinitions: TBoldOclDefinitions read FOclDefinitions write SetOclDefinitions; @@ -39,7 +49,7 @@ TBoldOclDefinitions = class(TCollection) property OwningRepository: TBoldOclRepository read fOwningRepository; function NameIsUnique(Name: String): Boolean; public - constructor Create(OwningRepository: TBoldOclRepository); + constructor create(OwningRepository: TBoldOclRepository); function GetUniqueName: String; function LookUpOclDefinition(Name: string): string; property Items[Index: integer]: TBoldOclDefinition read GetItems; default; @@ -50,8 +60,8 @@ TBoldOclDefinition = class(TCollectionItem, IBoldOclComponent) fName: String; fExpression: String; fContext: String; - procedure SetExpression(Expression: String); - function GetExpression: String; + procedure SetExpression(const Value: TBoldExpression); + function GetExpression: TBoldExpression; function GetVariableList: TBoldExternalVariableList; function GetDefinitions: TBoldOclDefinitions; function QueryInterface(const IId: TGUID; out Obj): HResult; virtual; stdcall; @@ -63,7 +73,7 @@ TBoldOclDefinition = class(TCollectionItem, IBoldOclComponent) function GetDisplayName: string; override; public constructor Create(Collection: TCollection); override; - destructor Destroy; override; + destructor destroy; override; function GetContextType: TBoldElementTypeInfo; property Definitions: TBoldOclDefinitions read GetDefinitions; property SystemTypeInfo: TBoldSystemTypeInfo read GetSystemTypeInfo; @@ -73,42 +83,69 @@ TBoldOclDefinition = class(TCollectionItem, IBoldOclComponent) property Context: String read FContext write fContext; end; + implementation uses SysUtils, - BoldDefs, - BoldHandles, - BoldLogHandler, - HandlesConst; + BoldLogHandler; { TBoldOclRepository } -constructor TBoldOclRepository.create(owner: TComponent); +procedure TBoldOclRepository.AfterConstruction; +begin + inherited; + if (TBoldSystemHandle.DefaultBoldSystemHandle <> nil) and not (csLoading in ComponentState) and (csDesigning in ComponentState) then + {connect to default system at design time} + SystemHandle := TBoldSystemHandle.DefaultBoldSystemHandle as TBoldSystemHandle; +end; + +constructor TBoldOclRepository.Create(owner: TComponent); begin inherited; FOclDefinitions := TBoldOclDefinitions.Create(self); end; +destructor TBoldOclRepository.Destroy; +begin + FreeAndNil(FOclDefinitions); + inherited; +end; + function TBoldOclRepository.LookUpOclDefinition(Name: string): string; begin result := OclDefinitions.LookUpOclDefinition(Name); end; +procedure TBoldOclRepository.Notification(AComponent: TComponent; + Operation: TOperation); +begin + inherited Notification(AComponent, Operation); + if (Operation = opRemove) and (AComponent = SystemHandle) then + SystemHandle := nil; +end; + procedure TBoldOclRepository.SetOclDefinitions( const Value: TBoldOclDefinitions); begin FOclDefinitions := Value; end; -procedure TBoldOclRepository.SetSystemHandle(const Value: TBoldSystemHandle); +procedure TBoldOclRepository.SetSystemHandle(Value: TBoldSystemHandle); begin - if assigned(SystemHandle) then - SystemHandle.InstallOclDefinitionLookUp(nil); - - FSystemHandle := Value; - if assigned(SystemHandle) then - SystemHandle.InstallOclDefinitionLookUp(LookUpOclDefinition); + if fSystemHandle = Value then + exit; + if assigned(Value) and Assigned(fSystemHandle) then + begin + fSystemHandle.InstallOclDefinitionLookUp(nil); + fSystemHandle.RemoveFreeNotification(self); + end; + fSystemHandle := Value; + if assigned(Value) then + begin + Value.InstallOclDefinitionLookUp(LookUpOclDefinition); + Value.FreeNotification(Self); + end; end; function TBoldOclRepository.ValidateComponent( @@ -118,20 +155,18 @@ function TBoldOclRepository.ValidateComponent( i: integer; Context: TBoldElementTypeInfo; begin - result := true; if not assigned(SystemHandle) then - BoldLog.LogFmt(sRepositoryHasNoSystemHandle, [NamePrefix, Name]) + BoldLog.LogFmt('*** OclRepository %s%s has no SystemHandle', [NamePrefix, Name]) else if not assigned(SystemHandle.StaticSystemTypeInfo) then - BoldLog.LogFmt(sSystemHandleHasNoTypeInfo, [NamePrefix, Name]) + BoldLog.LogFmt('*** SystemHandle of OclRepository %s%s has no TypeInfo', [NamePrefix, Name]) else begin - for i := 0 to OclDefinitions.count - 1 do - begin + for i := 0 to OclDefinitions.count-1 do begin Context := SystemHandle.StaticSystemTypeInfo.ElementTypeInfoByExpressionName[OclDefinitions[i].Context]; result := ComponentValidator.ValidateExpressionInContext( OclDefinitions[i].Expression, Context, - NamePrefix + Name + '.' + OclDefinitions[i].Name) and result; + NamePrefix+Name+ '.'+OclDefinitions[i].Name) and result; end; end; end; @@ -144,9 +179,10 @@ constructor TBoldOclDefinition.Create(Collection: TCollection); Name := (Collection as TBoldOclDefinitions).GetUniqueName; end; -destructor TBoldOclDefinition.Destroy; +destructor TBoldOclDefinition.destroy; begin inherited; + end; function TBoldOclDefinition.GetContextType: TBoldElementTypeInfo; @@ -164,11 +200,11 @@ function TBoldOclDefinition.GetDefinitions: TBoldOclDefinitions; function TBoldOclDefinition.GetDisplayName: string; begin - result:= '%' + name + ': ' + Expression; + result:= '%' + name + ': '+Expression; end; -function TBoldOclDefinition.GetExpression: String; +function TBoldOclDefinition.GetExpression: TBoldExpression; begin result := fExpression; end; @@ -195,9 +231,9 @@ function TBoldOclDefinition.QueryInterface(const IId: TGUID; Result := E_NOINTERFACE; end; -procedure TBoldOclDefinition.SetExpression(Expression: String); +procedure TBoldOclDefinition.SetExpression(const Value: TBoldExpression); begin - fExpression := Expression; + fExpression := Value; end; procedure TBoldOclDefinition.SetName(const Value: String); @@ -207,7 +243,7 @@ procedure TBoldOclDefinition.SetName(const Value: String); if TBoldOclDefinitions(Collection).NameIsUnique(Value) then FName := Value else - raise EBold.CreateFmt(sNameNotUnique, [Value]); + raise EBold.CreateFmt('Invalid Name: %s Not Unique', [Value]); end; end; @@ -245,7 +281,7 @@ function TBoldOclDefinitions.GetUniqueName: String; begin i := 1; repeat - result := 'Ocl' + IntToStr(i); // do not translate + result := 'Ocl'+IntToStr(i); Inc(i); until NameIsUnique(result); end; @@ -255,7 +291,7 @@ function TBoldOclDefinitions.LookUpOclDefinition(Name: string): string; i: integer; begin result := ''; - for i := 0 to Count - 1 do + for i := 0 to Count -1 do if Items[i].Name = Name then begin result := items[i].Expression; @@ -269,7 +305,7 @@ function TBoldOclDefinitions.NameIsUnique(Name: String): Boolean; begin result := true; for i := 0 to Count-1 do - if AnsiCompareStr(Name, Items[i].Name) = 0 then + if CompareStr(Name, Items[i].Name) = 0 then begin result := false; exit; @@ -277,4 +313,3 @@ function TBoldOclDefinitions.NameIsUnique(Name: String): Boolean; end; end. - diff --git a/Source/Handles/Core/BoldOclVariables.pas b/Source/Handles/Core/BoldOclVariables.pas index ff56baf4..7c3baa53 100644 --- a/Source/Handles/Core/BoldOclVariables.pas +++ b/Source/Handles/Core/BoldOclVariables.pas @@ -1,9 +1,16 @@ + +{ Global compiler directives } +{$include bold.inc} + unit BoldOclVariables; interface uses Classes, +{$IFNDEF BOLD_DELPHI16_OR_LATER} + Controls, // TDate = type TDateTime; +{$ENDIF} BoldSubscription, BoldHandles, BoldElements; @@ -20,48 +27,77 @@ TBoldHandleBasedExternalVariable = class(TBoldExternalVariable) private fHandle: TBoldElementHandle; fUseListElement: Boolean; - fhandleSubscriber: TBoldPassThroughSubscriber; + fHandleSubscriber: TBoldPassThroughSubscriber; procedure _ReceiveHandleEvent(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); + procedure SetHandle(const Value: TBoldElementHandle); protected function GetValue: TBoldElement; override; function GetValueType: TBoldElementTypeInfo; override; + property Handle: TBoldElementHandle read fHandle write SetHandle; public constructor Create(Name: String; Handle: TBoldElementHandle; UseListElement: Boolean); destructor Destroy; override; end; { TBoldOclVariables } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldOclVariables = class(TBoldSubscribableComponent) private fVariableTupleList: TBoldVariableTupleList; fVariableList: TBoldExternalVariableList; + fGlobalSystemHandle: TBoldAbstractSystemhandle; + fSubscriber: TBoldPassthroughSubscriber; procedure SetVariableTupleList(const Value: TBoldVariableTupleList); procedure VariablesChanged; function GetVariableList: TBoldExternalVariableList; + procedure SetGlobalSystemHandle(aSystemHandle: TBoldAbstractSystemhandle); + procedure _Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); + procedure PlaceSubscriptions; + procedure SubscribeToHandle(AHandle: TBoldElementHandle); + function GetGlobalSystemHandle: TBoldAbstractSystemhandle; + function GetVariableFromHandle(AHandle: TBoldElementHandle): TBoldExternalVariable; + protected + procedure Loaded; override; + procedure RegisterVariables; public constructor Create(Owner: TComponent); override; destructor Destroy; override; - procedure SubscribeToHandles(Subscriber: TBoldSubscriber); + procedure SubscribeToHandles(Subscriber: TBoldSubscriber); overload; + procedure SubscribeToHandles(Subscriber: TBoldSubscriber; Expression: string); overload; + function AddVariable(aVariableName: string; aBoldHandle: TBoldElementHandle; aUseListElement: boolean = false): TBoldVariableTuple; + procedure AddVariables(aBoldOclVariables: TBoldOclVariables); + function FindVariableByName(const aVariableName: string): TBoldExternalVariable; + function GetVariableValue(const aVariableName: string): TBoldElement; function LinksToHandle(Handle: TBoldElementHandle): Boolean; property VariableList: TBoldExternalVariableList read GetVariableList; published + property GlobalSystemHandle: TBoldAbstractSystemhandle read GetGlobalSystemHandle write SetGlobalSystemHandle; property Variables: TBoldVariableTupleList read fVariableTupleList write SetVariableTupleList; end; + TBoldVariableTupleListEnumerator = class(TCollectionEnumerator) + public + function GetCurrent: TBoldVariableTuple; + property Current: TBoldVariableTuple read GetCurrent; + end; + { TBoldVariableTupleList } TBoldVariableTupleList = class(TCollection) private fOwningDefinition: TBoldOclVariables; function GetItems(Index: integer): TBoldVariableTuple; + function GetVariableByName(const aName: string): TBoldVariableTuple; protected function GetOwner: TPersistent; override; property OwningDefinition: TBoldOclVariables read fOwningDefinition; public constructor Create(aOwningDefinition: TBoldOclVariables); + function GetEnumerator: TBoldVariableTupleListEnumerator; function NameIsUnique(Name: String): Boolean; function NameIsValid(Name: String): Boolean; function GetUniqueName: String; property Items[Index: integer]: TBoldVariableTuple read GetItems; default; + property VariableByName[const aName: string]: TBoldVariableTuple read GetVariableByName; end; { TBoldVariableTuple } @@ -82,7 +118,7 @@ TBoldVariableTuple = class(TCollectionItem) function GetDisplayName: string; override; public constructor Create(Collection: TCollection); override; - destructor Destroy; override; + destructor destroy; override; procedure Assign(Source: TPersistent); override; function LinksToHandle(Handle: TBoldElementHandle): Boolean; property TupleList: TBoldVariableTupleList read GetTupleList; @@ -90,7 +126,27 @@ TBoldVariableTuple = class(TCollectionItem) published property BoldHandle: TBoldElementHandle read FBoldHandle write SetBoldHandle; property VariableName: String read FVariableName write SetVariableName; - property UseListElement: Boolean read fUseListElement write SetUseListElement; + property UseListElement: Boolean read fUseListElement write SetUseListElement default false; + end; + + + TBoldOclVariable = class(TBoldExternalVariable) + private + fBoldIndirectElement: TBoldIndirectElement; + fBoldElementTypeInfo: TBoldElementTypeInfo; + function GetBoldIndirectElement: TBoldIndirectElement; + protected + function GetValue: TBoldElement; override; + function GetValueType: TBoldElementTypeInfo; override; + public + constructor Create(const aName: string; aValue: TBoldElement{; aOwnsValue: boolean = false}); overload; + constructor CreateWithTypeInfo(const aName: string; AValue: TBoldElement; aBoldElementTypeInfo: TBoldElementTypeInfo); + constructor CreateFromIndirectElement(const aName: string; aBoldIndirectElement: TBoldIndirectElement); + constructor CreateStringVariable(const aName: string; const aValue: string); + constructor CreateDateVariable(const aName: string; const aValue: TDate); + constructor CreateDateTimeVariable(const aName: string; const aValue: TDateTime); + destructor Destroy; override; + property BoldIndirectElement: TBoldIndirectElement read GetBoldIndirectElement; end; implementation @@ -98,27 +154,99 @@ implementation uses SysUtils, BoldDefs, + BoldSystem, BoldRootedHandles, - HandlesConst, - BoldAbstractListHandle; + BoldAbstractListHandle, + BoldAttributes, + BoldUtils; { TBoldOclVariables } +function TBoldOclVariables.AddVariable(aVariableName: string; + aBoldHandle: TBoldElementHandle; aUseListElement: boolean): TBoldVariableTuple; +begin + result := Variables.VariableByName[aVariableName]; + if not Assigned(result) then + begin + result := Variables.Add as TBoldVariableTuple; + result.VariableName := aVariableName; + end; + result.BoldHandle := aBoldHandle; + result.UseListElement := aUseListElement; +end; + +procedure TBoldOclVariables.AddVariables(aBoldOclVariables: TBoldOclVariables); +var + i: integer; + lBoldVariableTuple: TBoldVariableTuple; +begin + for I := 0 to aBoldOclVariables.Variables.Count - 1 do + begin + lBoldVariableTuple := Variables.VariableByName[aBoldOclVariables.Variables[i].VariableName]; + if Assigned(lBoldVariableTuple) then + lBoldVariableTuple.Assign(aBoldOclVariables.Variables[i]) + else + Variables.Add.Assign(aBoldOclVariables.Variables[i]); + end; +end; + constructor TBoldOclVariables.create(Owner: TComponent); begin inherited; fVariableList := nil; fVariableTupleList := TBoldVariableTupleList.Create(self); + fSubscriber := TBoldPassthroughSubscriber.Create(_Receive); + PlaceSubscriptions; end; -destructor TBoldOclVariables.Destroy; +destructor TBoldOclVariables.destroy; begin FreePublisher; FreeAndNil(fVariableList); FreeAndNil(fVariableTupleList); + FreeAndNil(fSubscriber); inherited; end; +function TBoldOclVariables.FindVariableByName( + const aVariableName: string): TBoldExternalVariable; +var + i: integer; +begin + for I := 0 to VariableList.Count - 1 do + begin + if CompareText(VariableList.Variables[i].Name, aVariableName) = 0 then + begin + result := VariableList.Variables[i]; + exit; + end; + end; + result := nil; +end; + +function TBoldOclVariables.GetGlobalSystemHandle: TBoldAbstractSystemhandle; +begin + result := fGlobalSystemHandle +end; + +function TBoldOclVariables.GetVariableFromHandle( + AHandle: TBoldElementHandle): TBoldExternalVariable; +var + i: integer; + vTuple: TBoldVariableTuple; +begin + for i := 0 to Variables.count - 1 do + begin + vTuple := Variables[i]; + if vTuple.BoldHandle = AHandle then + begin + result := VariableList[i]; + exit; + end; + end; + result := nil; +end; + function TBoldOclVariables.GetVariableList: TBoldExternalVariableList; var i: integer; @@ -145,6 +273,18 @@ function TBoldOclVariables.GetVariableList: TBoldExternalVariableList; result := fVariableList; end; +function TBoldOclVariables.GetVariableValue( + const aVariableName: string): TBoldElement; +var + lVariable: TBoldExternalVariable; +begin + lVariable := FindVariableByName(aVariableName); + if Assigned(lVariable) then + result := lVariable.Value + else + result := nil; +end; + function TBoldOclVariables.LinksToHandle(Handle: TBoldElementHandle): Boolean; var i: integer; @@ -154,6 +294,73 @@ function TBoldOclVariables.LinksToHandle(Handle: TBoldElementHandle): Boolean; result := result or Variables[i].linksToHandle(Handle); end; +procedure TBoldOclVariables.Loaded; +begin + inherited Loaded; + PlaceSubscriptions; +end; + +procedure TBoldOclVariables.PlaceSubscriptions; +begin + fSubscriber.CancelAllSubscriptions; + RegisterVariables; + SubscribeToHandles(fSubscriber); +end; + +procedure TBoldOclVariables.RegisterVariables; +var + vEvaluator: TBoldEvaluator; + vVariable: TBoldExternalVariable; + vTuple: TBoldVariableTuple; + vTypeInfo: TBoldElementTypeInfo; +begin + if (VariableList.Count > 0) and Assigned(GlobalSystemHandle) and Assigned(GlobalSystemHandle.SystemTypeInfoHandle) and GlobalSystemHandle.SystemTypeInfoHandle.IsSystemTypeInfoAvailable then + begin + if not (csDesigning in ComponentState) then + begin + if GlobalSystemHandle.Active then + begin + vEvaluator := GlobalSystemHandle.System.Evaluator; + if Assigned(vEvaluator) then + for vVariable in VariableList do + begin + Assert(not Assigned(vVariable.Evaluator) or (vVariable.Evaluator = vEvaluator)); + vEvaluator.DefineVariable(vVariable.Name, vVariable); + end; + end + else + begin + for vVariable in VariableList do + begin + if Assigned(vVariable.Evaluator) then + vVariable.Evaluator := nil; + end; + end; + end; + // register into type/meta evaluator + vEvaluator := GlobalSystemHandle.BoldType.Evaluator; + for vTuple in Variables do + if Assigned(vTuple.BoldHandle) then + begin + if vTuple.EffectiveUseListElement then + vTypeInfo := TBoldAbstractListHandle(vTuple.BoldHandle).StaticListType + else + vTypeInfo := vTuple.BoldHandle.StaticBoldType; + vEvaluator.DefineVariable(vTuple.VariableName, nil, vTypeInfo, false, false); + end; + end; +end; + +procedure TBoldOclVariables.SetGlobalSystemHandle( + aSystemHandle: TBoldAbstractSystemhandle); +begin + if aSystemHandle <> fGlobalSystemHandle then + begin + fGlobalSystemHandle := aSystemHandle; + PlaceSubscriptions; + end; +end; + procedure TBoldOclVariables.SetVariableTupleList( const Value: TBoldVariableTupleList); begin @@ -163,12 +370,57 @@ procedure TBoldOclVariables.SetVariableTupleList( procedure TBoldOclVariables.SubscribeToHandles( Subscriber: TBoldSubscriber); var - i: integer; + vTuple: TBoldVariableTuple; begin - if assigned(Subscriber) then - for i := 0 to Variables.Count-1 do - if assigned(Variables[i].boldHandle) then - Variables[i].BoldHandle.AddSubscription(Subscriber, beValueIdentityChanged, breResubscribe); + if self.fSubscriber <> Subscriber then + self.AddSubscription(Subscriber, beDestroying, breReSubscribe); + if Assigned(GlobalSystemHandle) then + begin + GlobalSystemHandle.AddSmallSubscription(Subscriber, [beValueIdentityChanged, beDestroying], beValueIdentityChanged); + if GlobalSystemHandle.Active then + GlobalSystemHandle.System.AddSmallSubscription(Subscriber, [beDestroying], beDestroying); + end; + for vTuple in Variables do + if assigned(vTuple.boldHandle) then + vTuple.BoldHandle.AddSubscription(Subscriber, beValueIdentityChanged, breResubscribe); +end; + +procedure TBoldOclVariables.SubscribeToHandle(AHandle: TBoldElementHandle); +var + vVariable: TBoldExternalVariable; +begin + if (not (csDestroying in ComponentState) and ((Owner = nil) or not (csDestroying in TComponent(Owner).ComponentState))) + and (VariableList.Count > 0) and Assigned(GlobalSystemHandle) and GlobalSystemHandle.Active then // Assigned(GlobalSystemHandle.SystemTypeInfoHandle) and GlobalSystemHandle.SystemTypeInfoHandle.IsSystemTypeInfoAvailable then + begin + GlobalSystemHandle.System.AddSmallSubscription(fSubscriber, [beDestroying], beDestroying); + vVariable := GetVariableFromHandle(AHandle); + if Assigned(vVariable) then + begin + AHandle.AddSubscription(fSubscriber, beDestroying, breReSubscribe); + AHandle.AddSubscription(fSubscriber, beValueIdentityChanged, breResubscribe); + GlobalSystemHandle.System.Evaluator.DefineVariable(vVariable.Name, vVariable); + end; + end; +end; + +procedure TBoldOclVariables.SubscribeToHandles(Subscriber: TBoldSubscriber; + Expression: string); +var + vVariable: TBoldVariableTuple; +begin + if self.fSubscriber <> Subscriber then + self.AddSubscription(Subscriber, beDestroying, breReSubscribe); + if Assigned(GlobalSystemHandle) then + begin + GlobalSystemHandle.AddSmallSubscription(Subscriber, [beValueIdentityChanged, beDestroying], beValueIdentityChanged); + if GlobalSystemHandle.Active then + GlobalSystemHandle.System.AddSmallSubscription(Subscriber, [beDestroying], beDestroying); + end; + if Assigned(Subscriber) then + for vVariable in Variables do + if Assigned(vVariable.BoldHandle) then + if BoldCaseIndependentPos(vVariable.VariableName, Expression) > 0 then + vVariable.BoldHandle.AddSubscription(Subscriber, beValueIdentityChanged, breResubscribe); end; procedure TBoldOclVariables.VariablesChanged; @@ -177,6 +429,44 @@ procedure TBoldOclVariables.VariablesChanged; SendEvent(Self, beValueChanged); end; +procedure TBoldOclVariables._Receive(Originator: TObject; + OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); +var + vVariable: TBoldExternalVariable; + i: integer; +begin + if (Originator = fGlobalSystemHandle) then + begin + case OriginalEvent of + beDestroying: + begin + GlobalSystemHandle := nil; + fSubscriber.CancelAllSubscriptions; + end; + beValueIdentityChanged: + begin + RegisterVariables; + end; + end; + end + else + if (Originator is TBoldSystem)then + begin + if OriginalEvent = beDestroying then + begin + FreeAndNil(fVariableList); + SendEvent(Self, beValueChanged); + end + else + RegisterVariables; + end + else + if Originator is TBoldElementHandle then + begin + SubscribeToHandle(TBoldElementHandle(Originator)); + end; +end; + { TBoldVariableTupleList } constructor TBoldVariableTupleList.create(aOwningDefinition: TBoldOclVariables); @@ -185,6 +475,11 @@ constructor TBoldVariableTupleList.create(aOwningDefinition: TBoldOclVariables); fOwningDefinition := aOwningDefinition; end; +function TBoldVariableTupleList.GetEnumerator: TBoldVariableTupleListEnumerator; +begin + result := TBoldVariableTupleListEnumerator.Create(self); +end; + function TBoldVariableTupleList.GetItems( Index: integer): TBoldVariableTuple; begin @@ -202,18 +497,32 @@ function TBoldVariableTupleList.GetUniqueName: String; begin i := 1; repeat - result := 'Variable' + IntToStr(i); // do not localize + result := 'Variable'+IntToStr(i); Inc(i); until NameIsUnique(result); end; +function TBoldVariableTupleList.GetVariableByName( + const aName: string): TBoldVariableTuple; +var + i: integer; +begin + for I := 0 to Count - 1 do + if Items[i].VariableName = aName then + begin + result := Items[i]; + exit; + end; + result := nil; +end; + function TBoldVariableTupleList.NameIsUnique(Name: String): Boolean; var i: integer; begin result := true; for i := 0 to Count-1 do - if AnsiCompareStr(Name, Items[i].VariableName) = 0 then + if CompareText(Name, Items[i].VariableName) = 0 then begin result := false; exit; @@ -226,7 +535,7 @@ function TBoldVariableTupleList.NameIsValid(Name: String): Boolean; begin result := true; for i := 1 to length(name) do - if not (name[i] in ['A'..'Z', 'a'..'z', '_', '0'..'9']) then + if not CharInSet(name[i], ['A'..'Z', 'a'..'z', '_', '0'..'9']) then begin result := false; exit; @@ -263,7 +572,7 @@ constructor TBoldVariableTuple.Create(Collection: TCollection); fBoldHandleSubscriber := TBoldPassthroughSubscriber.Create(_ReceiveHandleEvent); end; -destructor TBoldVariableTuple.Destroy; +destructor TBoldVariableTuple.destroy; begin FreeAndNil(fBoldHandleSubscriber); inherited; @@ -275,9 +584,9 @@ function TBoldVariableTuple.GetDisplayName: string; if assigned(BoldHandle) then Result := result + ': ' + BoldHandle.Name else - result := result + ': Not Connected'; // do not localize + result := result + ': Not Connected'; if EffectiveUseListElement then - result := result + ' (list)'; // do not localize + result := result + ' (list)'; end; function TBoldVariableTuple.GetEffectiveUseListElement: Boolean; @@ -302,7 +611,7 @@ procedure TBoldVariableTuple.SetBoldHandle(const Value: TBoldElementHandle); if value <> fBoldHandle then begin if assigned(value) and Value.RefersToComponent(TupleList.OwningDefinition) then - raise EBold.CreateFmt(sCircularReference, [classname, TupleList.OwningDefinition.name, value.name]); + raise EBold.CreateFmt('%s.SetBoldHandle: %s can not be linked to %s. Circular reference', [classname, TupleList.OwningDefinition.name, value.name]); FBoldHandle := Value; fBoldHandleSubscriber.CancelAllSubscriptions; if assigned(value) then @@ -321,14 +630,17 @@ procedure TBoldVariableTuple.SetUseListElement(const Value: Boolean); end; procedure TBoldVariableTuple.SetVariableName(const Value: String); +var + vNewName: string; begin - if FVariableName <> Value then + if CompareText(FVariableName, Value) <> 0 then begin - if not (Collection as TBoldVariableTupleList).NameIsUnique(Value) then - raise EBold.CreateFmt(sNameNotUnique, [Value]); - if not (Collection as TBoldVariableTupleList).NameIsValid(Value) then - raise EBold.Create(sIllegalCharsInName); - FVariableName := Value; + vNewName := LowerCase(Copy(Value,1,1)) + Copy(Value,2,MaxInt); + if not (Collection as TBoldVariableTupleList).NameIsUnique(vNewName) then + raise EBold.CreateFmt('Can''t rename variable to "%s", name already exists', [vNewName]); + if not (Collection as TBoldVariableTupleList).NameIsValid(vNewName) then + raise EBold.Create('Invalid variable name, only alphanum characters and underscore valid'); + FVariableName := vNewName; Changed; end; end; @@ -364,7 +676,7 @@ constructor TBoldHandleBasedExternalVariable.Create(Name: String; destructor TBoldHandleBasedExternalVariable.Destroy; begin FreeAndNil(fHandleSubscriber); - inherited; + inherited; end; function TBoldHandleBasedExternalVariable.GetValue: TBoldElement; @@ -393,4 +705,112 @@ function TBoldHandleBasedExternalVariable.GetValueType: TBoldElementTypeInfo; result := nil; end; +procedure TBoldHandleBasedExternalVariable.SetHandle( + const Value: TBoldElementHandle); +begin + if fHandle = Value then + exit; + fHandleSubscriber.CancelAllSubscriptions; + fHandle := Value; + if assigned(fHandle) then + fHandle.AddSmallSubscription(fHandleSubscriber, [beDestroying], beDestroying); +end; + +{ TBoldOclVariable } + +constructor TBoldOclVariable.Create(const aName: string; + aValue: TBoldElement{; aOwnsValue: boolean = false}); +begin + inherited Create(aName); +{ if aOwnsValue then + BoldIndirectElement.SetOwnedValue(aValue) + else +} + BoldIndirectElement.SetReferenceValue(aValue); +end; + +constructor TBoldOclVariable.CreateFromIndirectElement(const aName: string; + aBoldIndirectElement: TBoldIndirectElement); +begin + inherited Create(aName); + aBoldIndirectElement.TransferValue(BoldIndirectElement); +end; + +constructor TBoldOclVariable.CreateWithTypeInfo(const aName: string; AValue: TBoldElement; + aBoldElementTypeInfo: TBoldElementTypeInfo); +begin + inherited Create(aName); + BoldIndirectElement.SetOwnedValue(AValue); + fBoldElementTypeInfo := aBoldElementTypeInfo; +end; + +constructor TBoldOclVariable.CreateStringVariable(const aName, aValue: string); +var + vString: TBAString; +begin + inherited Create(aName); + vString := TBAString.Create; + vString.AsString := aValue; + BoldIndirectElement.SetOwnedValue(vString); +end; + +constructor TBoldOclVariable.CreateDateTimeVariable(const aName: string; + const aValue: TDateTime); +var + vDateTime: TBADateTime; +begin + inherited Create(aName); + vDateTime := TBADateTime.Create; + vDateTime.AsDateTime := aValue; + BoldIndirectElement.SetOwnedValue(vDateTime); +end; + +constructor TBoldOclVariable.CreateDateVariable(const aName: string; + const aValue: TDate); +var + vDate: TBADate; +begin + inherited Create(aName); + vDate := TBADate.Create; + vDate.AsDate := aValue; + BoldIndirectElement.SetOwnedValue(vDate); +end; + +destructor TBoldOclVariable.Destroy; +begin + FreeAndNil(fBoldIndirectElement); + inherited; +end; + +function TBoldOclVariable.GetBoldIndirectElement: TBoldIndirectElement; +begin + if not Assigned(fBoldIndirectElement) then + begin + fBoldIndirectElement := TBoldIndirectElement.Create; + end; + result := fBoldIndirectElement; +end; + +function TBoldOclVariable.GetValue: TBoldElement; +begin + result:= BoldIndirectElement.Value; +end; + +function TBoldOclVariable.GetValueType: TBoldElementTypeInfo; +begin + if GetValue <> nil then + result:= GetValue.BoldType + else + result := fBoldElementTypeInfo; +end; + +{ TBoldVariableTupleListEnumerator } + +function TBoldVariableTupleListEnumerator.GetCurrent: TBoldVariableTuple; +begin + result := inherited GetCurrent as TBoldVariableTuple; +end; + +initialization + end. diff --git a/Source/Handles/Core/BoldPlaceableSubscriber.pas b/Source/Handles/Core/BoldPlaceableSubscriber.pas index ef1eebe5..552a5476 100644 --- a/Source/Handles/Core/BoldPlaceableSubscriber.pas +++ b/Source/Handles/Core/BoldPlaceableSubscriber.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPlaceableSubscriber; interface @@ -18,13 +21,14 @@ TBoldPlaceableSubscriber = class; RequestedEvent: TBoldRequestedEvent) of object; {---TBoldPlaceableSubscriber---} + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldPlaceableSubscriber = class(TBoldSubscribableComponentViaBoldElem) private FBoldHandle: TBoldElementHandle; FOnReceive: TBoldPlaceableSubcriberReceive; FOnSubscribeToElement: TBoldSubscribeToElementEvent; FHandleSubscriber: TBoldPassthroughSubscriber; - FValueSubscriber: TBoldPassthroughSubscriber; + FValueSubscriber: TBoldExtendedPassthroughSubscriber; FDelayEventsUntilPostNotify: Boolean; procedure SetBoldHandle(Value: TBoldElementHandle); procedure HandleSubscriberReceive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); @@ -43,18 +47,21 @@ TBoldPlaceableSubscriber = class(TBoldSubscribableComponentViaBoldElem) property BoldHandle: TBoldElementHandle read FBoldHandle write SetBoldHandle; property OnReceive: TBoldPlaceableSubcriberReceive read FOnReceive write fOnReceive; property OnSubscribeToElement: TBoldSubscribeToElementEvent read FOnSubscribeToElement write FOnSubscribeToElement; - property DelayEventsUntilPostNotify: Boolean read FDelayEventsUntilPostNotify write SetDelayEventsUntilPostNotify; + property DelayEventsUntilPostNotify: Boolean read FDelayEventsUntilPostNotify write SetDelayEventsUntilPostNotify default false; end; implementation +uses + BoldRev; + {---TBoldPlaceableSubscriber---} constructor TBoldPlaceableSubscriber.Create(Owner: TComponent); begin inherited; FHandleSubscriber := TBoldPassthroughSubscriber.Create(HandleSubscriberReceive); - FValueSubscriber := TBoldPassthroughSubscriber.CreateWithExtendedReceive(ValueSubscriberReceive); + FValueSubscriber := TBoldExtendedPassthroughSubscriber.CreateWithExtendedReceive(ValueSubscriberReceive); end; destructor TBoldPlaceableSubscriber.Destroy; @@ -80,7 +87,7 @@ procedure TBoldPlaceableSubscriber.SetBoldHandle(Value: TBoldElementHandle); if Assigned(Value) then begin Value.FreeNotification(Self); - BoldHandle.AddSmallSubscription(fHandleSubscriber, [beDestroying, beValueIdentityChanged], breReEvaluate); // CHECKME + BoldHandle.AddSmallSubscription(fHandleSubscriber, [beDestroying, beValueIdentityChanged], breReEvaluate); end; HandleValueChanged; end; @@ -88,6 +95,8 @@ procedure TBoldPlaceableSubscriber.SetBoldHandle(Value: TBoldElementHandle); procedure TBoldPlaceableSubscriber.HandleSubscriberReceive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); begin + if (csDestroying in ComponentState) or (Assigned(BoldHandle) and (csDestroying in BoldHandle.ComponentState)) then + exit; Receive(Originator, OriginalEvent, RequestedEvent, []); HandleValueChanged; end; @@ -114,7 +123,9 @@ procedure TBoldPlaceableSubscriber.HandleValueChanged; procedure TBoldPlaceableSubscriber.SubscribeToElement(Element: TBoldElement; Subscriber: TBoldSubscriber); begin if Assigned(FOnSubscribeToElement) then - FOnSubscribeToElement(Element, Subscriber); + FOnSubscribeToElement(Element, Subscriber) + else if Assigned(Element) then + Element.DefaultSubscribe(Subscriber); end; procedure TBoldPlaceableSubscriber.Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const); @@ -126,8 +137,9 @@ procedure TBoldPlaceableSubscriber.Receive(Originator: TObject; OriginalEvent: T procedure TBoldPlaceableSubscriber.ActOnHandleValueChanged(Sender: TObject); begin fValueSubscriber.CancelAllSubscriptions; - if assigned(BoldHandle) and assigned(BoldHandle.Value) then - SubscribeToElement(BoldHandle.Value, fValueSubscriber); + if Assigned(BoldHandle) and not (csDesigning in BoldHandle.ComponentState) then + if not (csDestroying in ComponentState) and not (csDestroying in BoldHandle.ComponentState) and assigned(BoldHandle.Value) then + SubscribeToElement(BoldHandle.Value, fValueSubscriber); end; procedure TBoldPlaceableSubscriber.SetDelayEventsUntilPostNotify(const Value: Boolean); diff --git a/Source/Handles/Core/BoldRawSQLHandle.pas b/Source/Handles/Core/BoldRawSQLHandle.pas new file mode 100644 index 00000000..2a5c7fcd --- /dev/null +++ b/Source/Handles/Core/BoldRawSQLHandle.pas @@ -0,0 +1,176 @@ + +///////////////////////////////////////////////////////// +// // +// Bold for Delphi // +// Copyright (c) 2002 BoldSoft AB, Sweden // +// // +///////////////////////////////////////////////////////// + +{ Global compiler directives } +{$include bold.inc} +unit BoldRawSQLHandle; + +interface + +uses + Classes, + Db, + BoldElements, + BoldHandles, + BoldSystem; + +type + { forward declarations } + TBoldRawSQLHandle = class; + + { TBoldRawSQLHandle } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] + TBoldRawSQLHandle = class(TBoldNonSystemHandle) + private + fBoldObjectClass: TBoldObjectClass; + fSQL: string; + fClassExpressionName: string; + fObjectList: TBoldObjectlist; + fListMode: TBoldListDupMode; + fClearBeforeExecute: Boolean; + fParams: TParams; + fMaxAnswers: integer; + fOffset: integer; + procedure SetClassExpressionName(const Value: string); + procedure SetListMode(const Value: TBoldListDupMode); + procedure SetParams(const Value: TParams); + protected + { Protected declarations } + function GetStaticBoldType: TBoldElementTypeInfo; override; + function GetValue: TBoldElement; override; + procedure EnsureList(RaiseException: Boolean); + public + { Public declarations } + constructor Create(Owner: TComponent); override; + destructor Destroy; override; + procedure ExecuteSQL; + procedure ClearList; + published + { Published declarations } + property SQL: string read fSQL write fSQL; + property ListMode: TBoldListDupMode read FListMode write SetListMode default bldmMerge; + property ClassExpressionName: string read fClassExpressionName write SetClassExpressionName; + property ClearBeforeExecute: Boolean read fClearBeforeExecute write fClearBeforeExecute default true; + property MaxAnswers: integer read fMaxAnswers write fMaxAnswers default -1; + property Offset: integer read fOffset write fOffset default -1; + property Params: TParams read fParams write SetParams; + end; + +implementation + +uses + SysUtils, + BoldDefs, + BoldSubscription, + BoldSystemRT; + +constructor TBoldRawSQLHandle.Create(Owner: TComponent); +begin + inherited; + fClearBeforeExecute := true; + fListMode := bldmMerge; + fParams := TParams.Create(self); + fMaxAnswers := -1; + fOffset := -1; +end; + +destructor TBoldRawSQLHandle.Destroy; +begin + FreePublisher; + FreeAndNil(fObjectList); + FreeAndNil(fParams); + inherited; +end; + +function TBoldRawSQLHandle.GetStaticBoldType: TBoldElementTypeInfo; +begin + if assigned(StaticSystemTypeInfo) then + Result := StaticSystemTypeInfo.ClassTypeInfoByExpressionName[fClassExpressionName] + else + result := nil; +end; + +procedure TBoldRawSQLHandle.ExecuteSQL; +begin + if not assigned(StaticSystemHandle) then + raise EBold.CreateFmt('%s.ExecuteSQL: %s has no SystemHandle', [classname, name]); + if not StaticSystemHandle.Active then + raise EBold.CreateFmt('%s.ExecuteSQL: Systemhandle is not active', [classname]); + + if ClearBeforeExecute then + ClearList; + EnsureList(true); + StaticSystemHandle.System.GetAllInClassWithRawSQL(fObjectList, fBoldObjectClass, SQL, Params, MaxAnswers, Offset); +end; + +procedure TBoldRawSQLHandle.ClearList; +begin + if assigned(fObjectList) then + fObjectlist.Clear; +end; + +function TBoldRawSQLHandle.GetValue: TBoldElement; +begin + EnsureList(false); + result := fObjectList; +end; + +procedure TBoldRawSQLHandle.SetClassExpressionName(const Value: string); +begin + if fClassExpressionName <> Value then + begin + fClassExpressionName := Value; + FreeAndNil(fObjectList); + SendEvent(Self, beValueIdentityChanged); + end; +end; + +procedure TBoldRawSQLHandle.EnsureList(RaiseException: Boolean); +var + ElementTypeInfo: TBoldElementTypeInfo; + ClassTypeInfo: TBoldClassTypeInfo; + ListTypeInfo: TBoldListTypeInfo; +begin + if not assigned(fObjectList) then + begin + + if not assigned(StaticSystemHandle) and RaiseException then + raise EBold.CreateFmt('%s.EnsureList: %s not connected to a SystemHandle', [ClassName, name]); + + ElementTypeInfo := StaticBoldType; + + if ElementTypeInfo is TBoldClassTypeInfo then + begin + ClassTypeInfo := ElementTypeInfo as TBoldClassTypeInfo; + fBoldObjectClass := TBoldObjectClass(ClassTypeInfo.ObjectClass); + ListTypeInfo := StaticSystemTypeInfo.ListTypeInfoByElement[ClassTypeInfo]; + fObjectList := TBoldMemberFactory.CreateMemberFromBoldType(ListTypeInfo) as TBoldObjectList; + fObjectList.DuplicateMode := ListMode; + end + else + if raiseException then + raise EBold.CreateFmt('%s.EnsureList: Unable to create list (%s), cant find valid type', [ClassName, Name]); + end; +end; + +procedure TBoldRawSQLHandle.SetListMode(const Value: TBoldListDupMode); +begin + if FListMode <> value then + begin + FListMode := Value; + if assigned(fObjectList) then + fObjectList.DuplicateMode := value; + end; +end; + +procedure TBoldRawSQLHandle.SetParams(const Value: TParams); +begin + Params.Assign(Value); +end; + +end. diff --git a/Source/Handles/Core/BoldReferenceHandle.pas b/Source/Handles/Core/BoldReferenceHandle.pas index eda6eef5..6d40030c 100644 --- a/Source/Handles/Core/BoldReferenceHandle.pas +++ b/Source/Handles/Core/BoldReferenceHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldReferenceHandle; interface @@ -13,6 +16,7 @@ interface TBoldReferenceHandle = class; { TBoldReferenceHandle } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldReferenceHandle = class(TBoldNonSystemHandle) private fStaticValueTypeName: String; @@ -20,12 +24,15 @@ TBoldReferenceHandle = class(TBoldNonSystemHandle) fValueSubscriber: TBoldPassthroughSubscriber; FOnValueDestroyed: TNotifyEvent; FOnObjectDeleted: TNotifyEvent; - procedure SetValue(NewValue: TBoldElement); procedure SetStaticValueTypeName(Value: string); procedure _Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); protected function GetValue: TBoldElement; override; function GetStaticBoldType: TBoldElementTypeInfo; override; + function GetStaticSystemHandle: TBoldAbstractSystemHandle; override; + procedure SetValue(NewValue: TBoldElement); override; + function GetCanSetValue: boolean; override; + procedure DoAssign(Source: TPersistent); override; public constructor Create(Owner: TComponent); override; destructor Destroy; override; @@ -40,7 +47,9 @@ implementation uses SysUtils, - BoldSystemRT; + BoldSystemRT, + BoldSystem, + BoldRev; const breValueDestroyed = 42; @@ -61,6 +70,23 @@ destructor TBoldReferenceHandle.Destroy; inherited; end; +procedure TBoldReferenceHandle.DoAssign(Source: TPersistent); +begin + inherited; + if Source is TBoldReferenceHandle then with TBoldReferenceHandle(Source) do + begin + self.StaticValueTypeName := StaticValueTypeName; + // do we want to assign these events ? + self.OnObjectDeleted := OnObjectDeleted; + self.OnValueDestroyed := OnValueDestroyed; + end; +end; + +function TBoldReferenceHandle.GetCanSetValue: boolean; +begin + result := true; +end; + function TBoldReferenceHandle.GetStaticBoldType: TBoldElementTypeInfo; begin if Assigned(StaticSystemTypeInfo) then @@ -69,6 +95,25 @@ function TBoldReferenceHandle.GetStaticBoldType: TBoldElementTypeInfo; Result := nil; end; +function TBoldReferenceHandle.GetStaticSystemHandle: TBoldAbstractSystemHandle; +var + System: TBoldSystem; +begin + result := inherited GetStaticSystemHandle; + if Assigned(result) or not Assigned(fValue) then + exit; + System := nil; + if fValue is TBoldSystem then + System := TBoldSystem(fValue) + else + if fValue is TBoldObject then + System := TBoldObject(fValue).BoldSystem + else + if fValue is TBoldMember then + System := TBoldMember(fValue).BoldSystem; + result := TBoldAbstractSystemHandle.FindSystemHandleForSystem(System); +end; + function TBoldReferenceHandle.GetValue: TBoldElement; begin result := fValue; @@ -89,10 +134,11 @@ procedure TBoldReferenceHandle.SetValue(NewValue: TBoldElement); begin fValue := NewValue; fValueSubscriber.CancelAllSubscriptions; - if Assigned(fValue) then + if Assigned(fValue) and (not (fValue is TBoldSystem)) then begin fValue.AddSmallSubscription(fValueSubscriber, [beDestroying], breValueDestroyed); - fValue.AddSmallSubscription(fValueSubscriber, [beObjectDeleted], breObjectDeleted); + if (fValue is TBoldObject) then + fValue.AddSmallSubscription(fValueSubscriber, [beObjectDeleted], breObjectDeleted) end; SendEvent(Self, beValueIdentityChanged); end; @@ -117,4 +163,6 @@ procedure TBoldReferenceHandle._Receive(Originator: TObject; end; end; +initialization + end. diff --git a/Source/Handles/Core/BoldRootedHandles.pas b/Source/Handles/Core/BoldRootedHandles.pas index c93c11c3..8296b598 100644 --- a/Source/Handles/Core/BoldRootedHandles.pas +++ b/Source/Handles/Core/BoldRootedHandles.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldRootedHandles; interface @@ -23,11 +26,12 @@ TBoldRootedHandle = class(TBoldNonSystemHandle) fInternalRootHandleSubscriber: TBoldPassthroughSubscriber; fValueSubscriber: TBoldPassthroughSubscriber; fDeriver: TBoldDeriver; + FOnBeginValueIdentityChanged: TNotifyEvent; + FOnEndValueIdentityChanged: TNotifyEvent; fResultElement: TBoldIndirectElement; fRootTypeName: String; - procedure SetRootTypeName(Value: string); - procedure ReadDesignTimeContext(Reader: TReader); // compatibility - procedure ReadDesignTimeHandle(Reader: TReader); // compatibility + procedure ReadDesignTimeContext(Reader: TReader); + procedure ReadDesignTimeHandle(Reader: TReader); procedure _ReceiveFromRoot(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); procedure _ReceiveFromValue(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); procedure SetInternalRootHandle(Value: TBoldElementHandle); @@ -35,11 +39,16 @@ TBoldRootedHandle = class(TBoldNonSystemHandle) procedure _NotifyOutOfDate; function GetSubscribe: Boolean; function GetIsDeriving: Boolean; + function IsRootTypeNameStored: Boolean; + function GetRootTypeName: string; + function GetIsCurrent: boolean; protected procedure SubscribeToValue; procedure EffectiveRootValueChanged; virtual; function EffectiveRootValue: TBoldElement; + function GetStaticSystemHandle: TBoldAbstractSystemHandle; override; function GetStaticSystemTypeInfo: TBoldSystemTypeInfo; override; + procedure SetRootTypeName(Value: string); virtual; procedure Loaded; override; procedure SetEnabled(Value: Boolean); virtual; procedure SetSubscribe(Value: Boolean); virtual; @@ -52,7 +61,9 @@ TBoldRootedHandle = class(TBoldNonSystemHandle) function GetStaticRootType: TBoldElementTypeInfo; procedure ValueIdentityChanged; function GetRootHandle: TBoldElementHandle; virtual; + procedure InternalValueIdentityChanged; virtual; procedure SetRootHandle(const Value: TBoldElementHandle); virtual; + procedure DoAssign(Source: TPersistent); override; property InternalRootHandle: TBoldElementHandle read fInternalRootHandle write SetInternalRootHandle; property IsDeriving: Boolean read GetIsDeriving; public @@ -63,18 +74,24 @@ TBoldRootedHandle = class(TBoldNonSystemHandle) function IsRootLinkedTo(Handle: TBoldElementHandle): Boolean; function RefersToComponent(Component: TBoldSubscribableComponent): Boolean; override; property StaticRootType: TBoldElementTypeInfo read GetStaticRootType; + function IsStaticSystemHandleStored: boolean; override; + property IsCurrent: boolean read GetIsCurrent; published property RootHandle: TBoldElementHandle read GetRootHandle write SetRootHandle; property Enabled: Boolean read FEnabled write SetEnabled default True; - property RootTypeName: string read fRootTypeName write SetRootTypeName; + property RootTypeName: string read GetRootTypeName write SetRootTypeName stored IsRootTypeNameStored; + property OnBeginValueIdentityChanged: TNotifyEvent read + FOnBeginValueIdentityChanged write FOnBeginValueIdentityChanged; + property OnEndValueIdentityChanged: TNotifyEvent read + FOnEndValueIdentityChanged write FOnEndValueIdentityChanged; end; implementation uses + SysUtils, BoldDefs, - HandlesConst, BoldEnvironment; const @@ -82,6 +99,7 @@ implementation breValueIdentityChanged = 43; {---TBoldRootedHandle---} + constructor TBoldRootedHandle.Create(Owner: TComponent); begin inherited; @@ -96,6 +114,17 @@ constructor TBoldRootedHandle.Create(Owner: TComponent); fDeriver.OnDeriveAndSubscribe := DeriveAndSubscribe; end; +procedure TBoldRootedHandle.DoAssign(Source: TPersistent); +begin + inherited; + if Source is TBoldRootedHandle then with TBoldRootedHandle(Source) do + begin + self.RootHandle := RootHandle; + self.RootTypeName := RootTypeName; + self.Enabled := Enabled; + end; +end; + procedure TBoldRootedHandle.Loaded; begin inherited Loaded; @@ -110,6 +139,20 @@ procedure TBoldRootedHandle.Loaded; end; end; +function TBoldRootedHandle.GetStaticSystemHandle: TBoldAbstractSystemHandle; +begin + if (RootHandle is TBoldNonSystemHandle) then + Result := TBoldNonSystemHandle(RootHandle).StaticSystemHandle + else + if (RootHandle is TBoldAbstractSystemHandle) then + Result := RootHandle as TBoldAbstractSystemHandle + else + if Assigned(RootHandle) then + Result := nil + else + Result := inherited GetStaticSystemHandle; +end; + function TBoldRootedHandle.GetStaticSystemTypeInfo: TBoldSystemTypeInfo; begin if Assigned(InternalRootHandle) then @@ -120,9 +163,8 @@ function TBoldRootedHandle.GetStaticSystemTypeInfo: TBoldSystemTypeInfo; procedure TBoldRootedHandle.EffectiveRootValueChanged; begin - Assert (Assigned(fDeriver)); + Assert(Assigned(fDeriver)); MarkSubscriptionOutOfdate; - // ValueIdentityChanged; // fix for unknown bug.. JaNo will look at this. end; procedure TBoldRootedHandle.SetInternalRootHandle(Value: TBoldElementHandle); @@ -131,7 +173,7 @@ procedure TBoldRootedHandle.SetInternalRootHandle(Value: TBoldElementHandle); begin if (Value = self) or ((Value is TBoldRootedHandle) and TBoldRootedHandle(Value).IsRootLinkedTo(Self)) then - raise EBold.CreateFmt(sInternalRootHandle_CircRef, [ClassName]); + raise EBold.CreateFmt('%s.SetInternalRootHandle: Circular reference', [ClassName]); fInternalRootHandleSubscriber.CancelAllSubscriptions; fInternalRootHandle := Value; if Assigned(InternalRootHandle) then @@ -150,7 +192,7 @@ procedure TBoldRootedHandle.SetEnabled(Value: Boolean); else if Value <> FEnabled then begin FEnabled := Value; - SendEvent(self, beValueIdentityChanged); // can't call ValueIdentityChanged. We should send even when changing to not enabled + SendEvent(self, beValueIdentityChanged); if not Enabled then MarkSubscriptionOutOfDate; end; @@ -177,7 +219,7 @@ function TBoldRootedHandle.EffectiveRootValue: TBoldElement; if Assigned(InternalRootHandle) then Result := InternalRootHandle.Value else - Result:= nil; + Result := nil; end; procedure TBoldRootedHandle._ReceiveFromRoot(Originator: TObject; @@ -232,20 +274,25 @@ function TBoldRootedHandle.GetSubscribe: Boolean; function TBoldRootedHandle.GetStaticRootType: TBoldElementTypeInfo; begin + Result := nil; if assigned(InternalRootHandle) then result := InternalRootHandle.StaticBoldType - else if Assigned(StaticSystemTypeInfo) then - Result := StaticSystemTypeInfo.ElementTypeInfoByExpressionName[RootTypeName] else - Result := nil; + if Assigned(StaticSystemTypeInfo) then + begin + if (RootTypeName <> '') then + Result := StaticSystemTypeInfo.ElementTypeInfoByExpressionName[RootTypeName] + else + Result := TBoldAbstractSystemHandle.DefaultBoldSystemTypeInfo; + end; end; procedure TBoldRootedHandle.DefineProperties(Filer: TFiler); begin inherited; - Filer.DefineProperty('TrackBold', ReadTrackBold, nil, False); // do not localize - Filer.DefineProperty('DesignTimeContext', ReadDesignTimeContext, nil, False); // do not localize - Filer.DefineProperty('DesignTimeHandle', ReadDesignTimeHandle, nil, False); // do not localize + Filer.DefineProperty('TrackBold', ReadTrackBold, nil, False); + Filer.DefineProperty('DesignTimeContext', ReadDesignTimeContext, nil, False); + Filer.DefineProperty('DesignTimeHandle', ReadDesignTimeHandle, nil, False); end; procedure TBoldRootedHandle.ReadDesignTimeContext(Reader: TReader); @@ -279,6 +326,16 @@ function TBoldRootedHandle.IsRootLinkedTo(Handle: TBoldElementHandle): Boolean; Result := false; end; +function TBoldRootedHandle.IsRootTypeNameStored: Boolean; +begin + result := (fRootTypeName <> ''); +end; + +function TBoldRootedHandle.IsStaticSystemHandleStored: boolean; +begin + result := inherited IsStaticSystemHandleStored and not (RootHandle is TBoldAbstractSystemHandle) and not (RootHandle is TBoldNonSystemHandle); +end; + procedure TBoldRootedHandle.SetRootTypeName(Value: string); begin if Value <> RootTypeName then @@ -313,7 +370,7 @@ procedure TBoldRootedHandle.MarkOutOfDate; procedure TBoldRootedHandle.ValueIdentityChanged; begin if Enabled then - SendEvent(self, beValueIdentityChanged); + InternalValueIdentityChanged; end; function TBoldRootedHandle.GetRootHandle: TBoldElementHandle; @@ -321,16 +378,51 @@ function TBoldRootedHandle.GetRootHandle: TBoldElementHandle; result := InternalRootHandle; end; +function TBoldRootedHandle.GetRootTypeName: string; +begin + result := fRootTypeName; + if (result = '') then + begin + if Assigned(RootHandle) then + begin + if Assigned(RootHandle.BoldType) then + result := RootHandle.BoldType.AsString + end + else + if Assigned(StaticSystemTypeInfo) then + result := StaticSystemTypeInfo.AsString + end; +end; + procedure TBoldRootedHandle.SetRootHandle(const Value: TBoldElementHandle); begin InternalRootHandle := value; end; +function TBoldRootedHandle.GetIsCurrent: boolean; +begin + Result := fDeriver.IsCurrent; +end; + function TBoldRootedHandle.GetIsDeriving: Boolean; begin Result := fDeriver.IsDeriving; end; +procedure TBoldRootedHandle.InternalValueIdentityChanged; +begin + if Assigned(FOnBeginValueIdentityChanged) then begin + FOnBeginValueIdentityChanged(Self); + end; + try + SendEvent(self, beValueIdentityChanged); + finally + if Assigned(FOnEndValueIdentityChanged) then begin + FOnEndValueIdentityChanged(Self); + end; + end; +end; + function TBoldRootedHandle.RefersToComponent(Component: TBoldSubscribableComponent): Boolean; begin result := inherited RefersToComponent(Component); @@ -338,4 +430,6 @@ function TBoldRootedHandle.RefersToComponent(Component: TBoldSubscribableCompone result := IsRootLinkedTo(Component as TBoldElementHandle); end; +initialization + end. diff --git a/Source/Handles/Core/BoldSQLHandle.pas b/Source/Handles/Core/BoldSQLHandle.pas index fdfef1b0..f74d9995 100644 --- a/Source/Handles/Core/BoldSQLHandle.pas +++ b/Source/Handles/Core/BoldSQLHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSQLHandle; interface @@ -14,6 +17,7 @@ interface TBoldSQLHandle = class; { TBoldSQLHandle } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldSQLHandle = class(TBoldNonSystemHandle) private fBoldObjectClass: TBoldObjectClass; @@ -35,6 +39,7 @@ TBoldSQLHandle = class(TBoldNonSystemHandle) function GetStaticBoldType: TBoldElementTypeInfo; override; function GetValue: TBoldElement; override; procedure EnsureList(RaiseException: Boolean); + procedure DoAssign(Source: TPersistent); override; public { Public declarations } constructor Create(Owner: TComponent); override; @@ -59,7 +64,6 @@ implementation uses SysUtils, BoldDefs, - HandlesConst, BoldSubscription, BoldSystemRT; @@ -93,9 +97,9 @@ function TBoldSQLHandle.GetStaticBoldType: TBoldElementTypeInfo; procedure TBoldSQLHandle.ExecuteSQL; begin if not assigned(StaticSystemHandle) then - raise EBold.CreateFmt(sNoSystemHandle, [classname, 'ExecuteSQL', name]); // do not localize + raise EBold.CreateFmt('%s.ExecuteSQL: %s has no SystemHandle', [classname, name]); if not StaticSystemHandle.Active then - raise EBold.CreateFmt(sSystemHandleNotActive, [classname]); + raise EBold.CreateFmt('%s.ExecuteSQL: Systemhandle is not active', [classname]); if ClearBeforeExecute then ClearList; @@ -103,6 +107,23 @@ procedure TBoldSQLHandle.ExecuteSQL; StaticSystemHandle.System.GetAllInClassWithSQL(fObjectList, fBoldObjectClass, SQLWhereClause, SQLOrderByClause, Params, JoinInheritedTables, MaxAnswers, Offset); end; +procedure TBoldSQLHandle.DoAssign(Source: TPersistent); +begin + inherited; + if Source is TBoldSQLHandle then with TBoldSQLHandle(Source) do + begin + self.SQLWhereClause := SQLWhereClause; + self.SQLOrderByClause := SQLOrderByClause; + self.ListMode := ListMode; + self.ClassExpressionName := ClassExpressionName; + self.ClearBeforeExecute := ClearBeforeExecute; + self.MaxAnswers := MaxAnswers; + self.Offset := Offset; + self.Params.Assign(Params); + self.JoinInheritedTables := JoinInheritedTables; + end; +end; + procedure TBoldSQLHandle.ClearList; begin if assigned(fObjectList) then @@ -135,7 +156,7 @@ procedure TBoldSQLHandle.EnsureList(RaiseException: Boolean); begin if not assigned(StaticSystemHandle) and RaiseException then - raise EBold.CreateFmt(sNoSystemHandle, [ClassName, 'EnsureList', name]); // do not localize + raise EBold.CreateFmt('%s.EnsureList: %s not connected to a SystemHandle', [ClassName, name]); ElementTypeInfo := StaticBoldType; @@ -149,7 +170,7 @@ procedure TBoldSQLHandle.EnsureList(RaiseException: Boolean); end else if raiseException then - raise EBold.CreateFmt(sCannotCreateListDueToInvalidType, [ClassName, Name]); + raise EBold.CreateFmt('%s.EnsureList: Unable to create list (%s), cant find valid type', [ClassName, Name]); end; end; diff --git a/Source/Handles/Core/BoldSortedHandle.pas b/Source/Handles/Core/BoldSortedHandle.pas index 26fea4eb..9b94297c 100644 --- a/Source/Handles/Core/BoldSortedHandle.pas +++ b/Source/Handles/Core/BoldSortedHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSortedHandle; interface @@ -14,20 +17,25 @@ TBoldComparer = class; TBoldSortedHandle = class; { TBoldComparer } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldComparer = class(TBoldSubscribableComponentViaBoldElem) private FOnCompare: TBoldElementCompare; FOnSubscribe: TBoldElementSubscribe; fOnPrepareSort: TBoldPrepareListOperation; + FOnFinishSort: TBoldPrepareListOperation; public procedure Subscribe(boldElement: TBoldElement; Subscriber: TBoldSubscriber); virtual; function Compare(Item1, Item2: TBoldElement): Integer; virtual; procedure SortList(List: TBoldList); procedure PrepareSort(List: TBoldList); + procedure FinishSort(List: TBoldList); published property OnSubscribe: TBoldElementSubscribe read FOnSubscribe write FOnSubscribe; property OnCompare: TBoldElementCompare read FOnCompare write FOnCompare; property OnPrepareSort: TBoldPrepareListOperation read fOnPrepareSort write fOnPrepareSort; + property OnFinishSort: TBoldPrepareListOperation read FOnFinishSort write + FOnFinishSort; end; { TBoldSortedHandle } @@ -45,7 +53,12 @@ TBoldSortedHandle = class(TBoldRootedHandle) implementation uses - BoldSystemRT; + SysUtils, + Classes, + BoldDefs, + BoldSystemRT, + BoldElementList; + {---TBoldComparer---} procedure TBoldComparer.Subscribe(boldElement: TBoldElement; Subscriber: TBoldSubscriber); @@ -72,6 +85,8 @@ procedure TBoldSortedHandle.DeriveAndSubscribe(DerivedObject: TObject; SourceList: TBoldList; NewList: TBoldList; begin + if csDestroying in ComponentState then + raise EBold.CreateFmt('%s.DeriveAndSubscribe: %s Handle is in csDestroying state, can not DeriveAndSubscribe.', [classname, name]); if EffectiveRootValue = nil then ResultElement.SetOwnedValue(nil) else if not Assigned(BoldComparer) then @@ -82,22 +97,30 @@ procedure TBoldSortedHandle.DeriveAndSubscribe(DerivedObject: TObject; try EffectiveRootValue.GetAsList(ValueAsListHolder); SourceList := TBoldList(ValueAsListHolder.Value); - NewList := TBoldMemberFactory.CreateMemberFromBoldType(SourceList.BoldType) as TBoldList; + if (SourceList.BoldType is TBoldListTypeInfo) and not Assigned(TBoldListTypeInfo(SourceList.BoldType).ListElementTypeInfo) then + NewList := TBoldElementList.CreateWithTypeInfo(SourceList.BoldType) + else + NewList := TBoldMemberFactory.CreateMemberFromBoldType(SourceList.BoldType) as TBoldList; NewList.DuplicateMode := bldmAllow; + if Assigned(Subscriber) then SourceList.DefaultSubscribe(Subscriber, breResubscribe); SourceList.EnsureRange(0, SourceList.Count - 1); BoldComparer.PrepareSort(SourceList); - for i := 0 to SourceList.Count - 1 do - begin - NewList.Add(SourceList[i]); - if Assigned(Subscriber) then - BoldComparer.Subscribe(SourceList[I], Subscriber); + try + for i := 0 to SourceList.Count - 1 do + begin + NewList.Add(SourceList[i]); + if Assigned(Subscriber) then + BoldComparer.Subscribe(SourceList[I], Subscriber); + end; + NewList.Sort(BoldComparer.Compare); + NewList.MakeImmutable; + ResultElement.SetOwnedValue(NewList); + finally + BoldComparer.FinishSort(NewList); end; - NewList.Sort(BoldComparer.Compare); - NewList.MakeImmutable; - ResultElement.SetOwnedValue(NewList); finally ValueAsListHolder.Free; end; @@ -139,4 +162,12 @@ procedure TBoldComparer.PrepareSort(List: TBoldList); OnPrepareSort(list); end; +procedure TBoldComparer.FinishSort(List: TBoldList); +begin + if assigned(OnFinishSort) then + OnFinishSort(list); +end; + +initialization + end. diff --git a/Source/Handles/Core/BoldSystemHandle.pas b/Source/Handles/Core/BoldSystemHandle.pas index 13ac7cc0..0c9c2814 100644 --- a/Source/Handles/Core/BoldSystemHandle.pas +++ b/Source/Handles/Core/BoldSystemHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSystemHandle; interface @@ -9,13 +12,15 @@ interface BoldPersistenceHandle, BoldSubscription, BoldHandles, - BoldLockRegions; + BoldLockRegions, + BoldAbstractPersistenceHandleDB; type { Forward declaration of classes } TBoldSystemHandle = class; { TBoldSystemHandle } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldSystemHandle = class(TBoldAbstractSystemHandle) private fBoldSystem: TBoldSystem; @@ -38,6 +43,7 @@ TBoldSystemHandle = class(TBoldAbstractSystemHandle) procedure ReadTrackBold(Reader: TReader); procedure SetOnOptimisticLockingFailed(const Value: TBoldOptimisticLockingFailedEvent); procedure SetOnPreUpdate(Value: TNotifyEvent); + function GetPersistenceHandleDB: TBoldAbstractPersistenceHandleDB; protected function GetValue: TBoldElement; override; procedure Loaded; override; @@ -52,8 +58,10 @@ TBoldSystemHandle = class(TBoldAbstractSystemHandle) procedure UpdateDatabase; procedure InstallOclDefinitionLookUp(const Value: TBoldLookUpOclDefinition); function RefersToComponent(Component: TBoldSubscribableComponent): Boolean; override; + procedure Discard; property Persistent: Boolean read GetPersistent; property RegionFactory: TBoldRegionFactory read fRegionFactory; + property PersistenceHandleDB: TBoldAbstractPersistenceHandleDB read GetPersistenceHandleDB; published property AutoActivate: Boolean read GetAutoActivate write SetAutoActivate default False; {$IFNDEF T2H} @@ -73,7 +81,7 @@ implementation BoldRegionDefinitions, BoldEnvironment, BoldPersistenceController, - HandlesConst; + BoldPersistenceHandlePassthrough; const brePersistenceHandleDestroying = 100; @@ -92,6 +100,12 @@ destructor TBoldSystemHandle.Destroy; inherited Destroy; end; +procedure TBoldSystemHandle.Discard; +begin + if Assigned(System) then + System.Discard; +end; + procedure TBoldSystemHandle.Loaded; begin inherited Loaded; @@ -111,7 +125,7 @@ procedure TBoldSystemHandle.UpdateDatabase; if Assigned(System) then System.UpdateDatabase else - raise EBold.CreateFmt(sCannotUpdateDatebaseWithoutSystem, [ClassName, Name]); + raise EBold.CreateFmt('%s.UpdateDatabase (%s) cannot be invoked without a system', [ClassName, Name]); end; function TBoldSystemHandle.GetSystem: TBoldSystem; @@ -124,7 +138,6 @@ procedure TBoldSystemHandle.SetAutoActivate(Value: Boolean); if Value <> fAutoActivate then begin fAutoActivate := Value; - // During read AutoActivate means Activate! if (csReading in ComponentState) and not (csDesigning in ComponentState) then Active := AutoActivate; @@ -139,8 +152,8 @@ function TBoldSystemHandle.GetAutoActivate: Boolean; procedure TBoldSystemHandle.SetActive(Value: Boolean); var PController: TBoldPersistenceController; + vBoldSystem: TBoldSystem; begin - // During read Activation is deferred to Loaded if csReading in ComponentState then FStreamedActive := Value else @@ -148,15 +161,17 @@ procedure TBoldSystemHandle.SetActive(Value: Boolean); begin if Value then begin + if (csDesigning in ComponentState) then + exit; if not assigned(SystemTypeInfoHandle) then - raise EBold.CreateFmt(sUnableToActivateSystemWithoutTypeInfoHandle, [name]); + raise EBold.CreateFmt('Unable to activate a system without a SystemTypeInfoHandle (%s)', [name]); if not assigned(StaticSystemTypeInfo) then - raise EBold.Create(sUnableToFindTypeInfoHandle); + raise EBold.Create('Unable to find a SystemTypeInfo. Possible misstakes: Forgot to connect the SystemTypeInfoHandle to a Model, CreationOrder of the forms/dataModules'); if not StaticSystemTypeInfo.SystemIsRunnable then - raise EBold.CreateFmt(sUnableToActivateSystem, [BOLDCRLF, - StaticSystemTypeInfo.InitializationLog.Text]); + raise EBold.Create('Unable to activate system. Initialization errors in StaticSystemTypeInfo:' + BOLDCRLF + + StaticSystemTypeInfo.InitializationLog.Text); if Persistent then begin @@ -169,22 +184,21 @@ procedure TBoldSystemHandle.SetActive(Value: Boolean); if assigned(SystemTypeInfoHandle.RegionDefinitions) and not assigned(fRegionFactory) then begin SystemTypeInfoHandle.RegionDefinitions.AddSmallSubscription(fRegionDefinitionSubscriber, [beDestroying], breRegionDefinitionsDestroying); - SystemTypeInfoHandle.RegionDefinitions.AddSmallSubscription(fRegionDefinitionSubscriber, [beRegionDefinitionClearing], breRegionDefinitionClearing); + SystemTypeInfoHandle.RegionDefinitions.AddSubscription(fRegionDefinitionSubscriber, beRegionDefinitionClearing, breRegionDefinitionClearing); fRegionFactory := TBoldRegionFactory.Create(SystemTypeInfoHandle.RegionDefinitions); end; - try // will fail if no license + try fBoldSystem := TBoldSystem.CreatewithTypeInfo(nil, StaticSystemTypeInfo, PController, fRegionFactory); - except // If license control failed - fBoldSystem := nil; // Make sure we're not active + except + fBoldSystem := nil; FreeAndNil(fRegionFactory); if Persistent then PersistenceHandle.Active := False; raise; - //FIXME: Other cleanup required? end; - if Active then // I.e. there was a license + if Active then begin fBoldSystem.Evaluator.SetLookupOclDefinition(fOnLookupOclDefinition); fBoldSystem.IsDefault := IsDefault; @@ -194,10 +208,12 @@ procedure TBoldSystemHandle.SetActive(Value: Boolean); end else begin + fBoldSystem.EnsureCanDestroy; + vBoldSystem := fBoldSystem; + fBoldSystem := nil; if Persistent then PersistenceHandle.Active := false; - fBoldSystem.EnsureCanDestroy; //Will raise exception of destructor is constrained - FreeAndNil(fBoldSystem); + FreeAndNil(vBoldSystem); FreeAndNil(fRegionFactory); end; SendEvent(Self, beValueIdentityChanged); @@ -215,13 +231,30 @@ procedure TBoldSystemHandle.SetPersistenceHandle(NewHandle: TBoldPersistenceHand begin fPersistenceHandleSubscriber.CancelAllSubscriptions; if Active then - PanicShutDownSystem(sPersistenceHandleChangedOnRunningSystem); + PanicShutDownSystem('PersistenceHandle was changed on a running system.'); fPersistenceHandle := NewHandle; if assigned(fPersistenceHandle) then fPersistenceHandle.AddSmallSubscription(fPersistenceHandleSubscriber, [beDestroying], brePersistenceHandleDestroying); end; end; +function TBoldSystemHandle.GetPersistenceHandleDB: TBoldAbstractPersistenceHandleDB; +var + Handle: TBoldPersistenceHandle; +begin + result := nil; + Handle := PersistenceHandle; + repeat + if Handle is TBoldAbstractPersistenceHandleDB then + result := TBoldAbstractPersistenceHandleDB(Handle) + else + if Handle is TBoldPersistenceHandlePassthrough then + Handle := TBoldPersistenceHandlePassthrough(Handle).NextPersistenceHandle + else + exit; + until Assigned(result) or not Assigned(Handle); +end; + function TBoldSystemHandle.GetPersistent: Boolean; begin result := assigned(PersistenceHandle); @@ -231,14 +264,15 @@ procedure TBoldSystemHandle.ModelChanged; var WasActive: Boolean; begin - if Active then - PanicShutDownSystem(sModelChangedOnRunningSystem); WasActive := Active; + if Active then + PanicShutDownSystem('The model changed in a running system'); Active := False; - if WasActive then +{ if WasActive then Active := True else - SendEvent(self, beValueIdentityChanged); // type change regarded as idenitychange +} + SendEvent(self, beValueIdentityChanged); end; function TBoldSystemHandle.GetValue: TBoldElement; @@ -249,12 +283,12 @@ function TBoldSystemHandle.GetValue: TBoldElement; procedure TBoldSystemHandle.DefineProperties(Filer: TFiler); begin inherited; - Filer.DefineProperty('TrackBold', ReadTrackBold, nil, False); // do not localize + Filer.DefineProperty('TrackBold', ReadTrackBold, nil, False); end; procedure TBoldSystemHandle.ReadTrackBold(Reader: TReader); begin - Reader.ReadBoolean; // Just throw it away + Reader.ReadBoolean; end; procedure TBoldSystemHandle._ReceivePersistenceHandle(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); @@ -271,13 +305,13 @@ procedure TBoldSystemHandle._ReceiveRegionDefinitions(Originator: TObject; Origi beRegionDefinitionClearing: begin if Active then - PanicShutDownSystem(sRegionDefinitionsRemovedFromRunningSystem); + PanicShutDownSystem('RegionDefinitions were removed from a running system.'); FreeAndNil(fRegionFactory); end; end; end; -constructor TBoldSystemHandle.create(owner: TComponent); +constructor TBoldSystemHandle.Create(owner: TComponent); begin inherited; fPersistenceHandleSubscriber := TBoldPassthroughSubscriber.Create(_ReceivePersistenceHandle); @@ -288,7 +322,6 @@ procedure TBoldSystemHandle.PanicShutDownSystem(Message: String); var DirtyCount: integer; begin - // if we are destroying, then we can just ignore this problem, if csDestroying in ComponentState then exit; try @@ -296,13 +329,13 @@ procedure TBoldSystemHandle.PanicShutDownSystem(Message: String); System.Discard; Active := False; if DirtyCount >0 then - raise EBold.CreateFmt(sPanicShutDown, [Message, BOLDCRLF, system.DirtyObjects.Count]); + raise EBold.CreateFmt(Message + BOLDCRLF + 'System Panic shut down. %d objects discarded', [system.DirtyObjects.Count]); except on e: Exception do if BoldEffectiveEnvironment.RunningInIDE then BoldEffectiveEnvironment.HandleDesigntimeException(Self) else - raise; + raise; end; end; @@ -311,7 +344,7 @@ procedure TBoldSystemHandle.InstallOclDefinitionLookUp(const Value: TBoldLookUpO fOnLookupOclDefinition := Value; if assigned(SystemTypeInfoHandle) then SystemTypeInfoHandle.InstallOclDefinitionLookUp(Value); - + if Active then System.Evaluator.SetLookupOclDefinition(value); end; @@ -338,8 +371,6 @@ procedure TBoldSystemHandle.SetOnPreUpdate(Value: TNotifyEvent); fBoldSystem.OnPreUpdate := Value; end; -end. - - - +initialization +end. diff --git a/Source/Handles/Core/BoldVariableDefinition.pas b/Source/Handles/Core/BoldVariableDefinition.pas index 6622b1d8..10b885ef 100644 --- a/Source/Handles/Core/BoldVariableDefinition.pas +++ b/Source/Handles/Core/BoldVariableDefinition.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldVariableDefinition; interface @@ -17,4 +20,7 @@ TBoldVariableDefinition = class(TBoldOclVariables) implementation + +initialization + end. diff --git a/Source/Handles/Core/BoldVariableHandle.pas b/Source/Handles/Core/BoldVariableHandle.pas index 2bdf1019..0138a88a 100644 --- a/Source/Handles/Core/BoldVariableHandle.pas +++ b/Source/Handles/Core/BoldVariableHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldVariableHandle; interface @@ -9,6 +12,7 @@ interface BoldHandles; type + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldVariableHandle = class(TBoldNonSystemHandle) private fValueTypeName: String; @@ -23,6 +27,7 @@ TBoldVariableHandle = class(TBoldNonSystemHandle) function GetValue: TBoldElement; override; function GetStaticBoldType: TBoldElementTypeInfo; override; procedure StaticBoldTypeChanged; override; + procedure DoAssign(Source: TPersistent); override; public constructor Create(owner: TComponent); override; destructor Destroy; override; @@ -39,18 +44,25 @@ implementation BoldSubscription, BoldDefs, BoldSystemRT, - HandlesConst; + BoldRev; { TBoldVariableHandle } constructor TBoldVariableHandle.Create(owner: TComponent); -var - s: TStringList; begin inherited; - s := TStringList.Create; - s.OnChange := InitialvaluesChanged; - fInitialValues := s; + fInitialValues := TStringList.Create; + fInitialValues.OnChange := InitialvaluesChanged; +end; + +procedure TBoldVariableHandle.DoAssign(Source: TPersistent); +begin + inherited; + if Source is TBoldVariableHandle then with TBoldVariableHandle(Source) do + begin + self.ValueTypeName := ValueTypeName; + self.InitialValues.Assign(InitialValues); + end; end; procedure TBoldVariableHandle.CreateVariableElement; @@ -73,7 +85,7 @@ procedure TBoldVariableHandle.CreateVariableElement; end; end; -destructor TBoldVariableHandle.Destroy; +destructor TBoldVariableHandle.destroy; begin FreePublisher; FreeAndNil(fInitialValues); @@ -83,11 +95,11 @@ destructor TBoldVariableHandle.Destroy; function TBoldVariableHandle.GetStaticBoldType: TBoldElementTypeInfo; begin - if assigned(StaticSystemHandle) then + if assigned(StaticSystemTypeInfo) then begin - result := StaticSystemHandle.StaticSystemTypeInfo.ElementTypeInfoByExpressionName[ValueTypeName]; + Result := StaticSystemTypeInfo.ElementTypeInfoByExpressionName[ValueTypeName]; if assigned(result) and not (result.BoldValueType in [bvtAttr, bvtList]) then - raise EBold.CreateFmt(sOnlyListsAndAttributeTypesAllowed, [ClassName, ValueTypeName]); + raise EBold.CreateFmt('%s.GetStaticBoldType: Only lists and attributes are allowed as types (expr: %s)', [ClassName, ValueTypeName]); end else result := nil; @@ -97,10 +109,10 @@ function TBoldVariableHandle.GetValue: TBoldElement; begin if not (csDesigning in ComponentState) and not (csLoading in ComponentState) then begin - if not assigned(StaticSystemHandle) then - raise EBold.CreateFmt(sNoSystemHandle, [classname, 'GetValue', name]); // do not localize +// if not assigned(StaticSystemHandle) then +// raise EBold.CreateFmt('%s.Getvalue: %s is not connected to a systemhandle', [classname, name]); if not assigned(StaticBoldType) then - raise EBold.CreateFmt(sValueTypeNameInvalid, [classname, name, ValueTypeName]); + raise EBold.CreateFmt('%s.Getvalue: The ValueTypeName of %s does not seem to be valid (%s)', [classname, name, ValueTypeName]); end; if {not (csDesigning in ComponentState) and} diff --git a/Source/Handles/Core/HandlesConst.pas b/Source/Handles/Core/HandlesConst.pas index 2a421019..5ae35d82 100644 --- a/Source/Handles/Core/HandlesConst.pas +++ b/Source/Handles/Core/HandlesConst.pas @@ -93,4 +93,4 @@ interface implementation -end. \ No newline at end of file +end. diff --git a/Source/Handles/IDE/BoldHandlePropEditor.pas b/Source/Handles/IDE/BoldHandlePropEditor.pas index d6e00c8a..d1612e5b 100644 --- a/Source/Handles/IDE/BoldHandlePropEditor.pas +++ b/Source/Handles/IDE/BoldHandlePropEditor.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldHandlePropEditor; interface @@ -41,7 +44,7 @@ TBoldRootedHandleRootHandlePropertyEditor = class(TBoldComponentPropertyIndica procedure MyGetProc(const s: string); protected function AllMayBeSetTo(NewValue: TPersistent): boolean; - function ComponentMayBeSetTo(Component: TPersistent; NewValue: TPersistent):boolean; + function ComponentMayBeSetTo(Component: TPersistent; NewValue: TPersistent):boolean; virtual; property OrgGetProc: TGetStrProc read fOrgProc write fOrgProc; public procedure GetValues(Proc: TGetStrProc); override; @@ -64,9 +67,8 @@ implementation uses SysUtils, - BoldUtils, - HandlesConst; - + BoldUtils; + { TBoldHandlePropertyEditor } procedure TBoldRootedHandleRootHandlePropertyEditor.GetValues(Proc: TGetStrProc); begin @@ -92,14 +94,13 @@ function TBoldRootedHandleRootHandlePropertyEditor.AllMayBeSetTo(NewValue: TPers function TBoldRootedHandleRootHandlePropertyEditor.ComponentMayBeSetTo( Component: TPersistent; NewValue: TPersistent): boolean; begin - Assert(Component is TBoldRootedHandle); - if (NewValue = Component) or // Prevent link to self - ((NewValue is TBoldRootedHandle) and - TBoldRootedHandle(NewValue).IsRootLinkedTo(Component as TBoldRootedhandle)) then // Prevent circular links + if (NewValue = Component) or + ((NewValue is TBoldRootedHandle) and (Component is TBoldRootedHandle) and + TBoldRootedHandle(NewValue).IsRootLinkedTo(Component as TBoldRootedhandle)) then Result := False else Result := True; -end; +end; { TBoldOclExpressionForOclDefinition } @@ -109,7 +110,7 @@ function TBoldOclExpressionForOclDefinition.GetContextType( if component is TBoldOclDefinition then result := (Component as TBoldOclDefinition).GetContextType else - raise Exception.CreateFmt(sComnponentNotOCLDefinition, [ClassName]); + raise Exception.CreateFmt('%s.GetContextType: Component is not a TBoldOclDefinition', [ClassName]); end; { TBoldTypeNameSelectorForOclDefinition } @@ -125,25 +126,24 @@ function TBoldTypeNameSelectorForOclDefinition.GetContextType( if component is TBoldOclDefinition then result := (Component as TBoldOclDefinition).SystemTypeInfo else - raise Exception.CreateFmt(sComnponentNotOCLDefinition, [ClassName]); + raise Exception.CreateFmt('%s.GetContextType: Component is not a TBoldOclDefinition', [ClassName]); end; { TBoldOclVariablesEditor } function TBoldOclVariablesEditor.GetDefaultMethodName: string; -const - MethodName = 'Variables'; begin - Result := MethodName; + Result := 'Variables'; end; { TBoldOCLRepositoryEditor } function TBoldOCLRepositoryEditor.GetDefaultMethodName: string; -const - MethodName = 'OCLDefinitions'; begin - Result := MethodName; + Result := 'OCLDefinitions'; end; + +initialization + end. diff --git a/Source/Handles/IDE/BoldHandleReg.pas b/Source/Handles/IDE/BoldHandleReg.pas index 85a7f5bd..bce545ec 100644 --- a/Source/Handles/IDE/BoldHandleReg.pas +++ b/Source/Handles/IDE/BoldHandleReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldHandleReg; interface @@ -10,6 +13,7 @@ implementation SysUtils, BoldUtils, ActnList, + Actions, Classes, DesignIntf, BoldElements, @@ -33,39 +37,41 @@ implementation BoldVariableHandle, BoldSystemHandle, BoldSQLHandle, + BoldRawSQLHandle, BoldFilteredHandle, BoldSortedHandle, BoldReferenceHandle, - BoldVariableDefinition, +// BoldVariableDefinition, BoldOclRepository, BoldTypeNameSelector, BoldModelAwareComponentEditor, BoldUnloaderHandle ; -{.$R BoldHandleReg.res} +{$R BoldHandleReg.res} procedure RegisterActionsInDelphi; begin - // marco -// RegisterActions(BOLDACTIONGROUPNAME, -// [ -// TBoldUpdateDBAction, -// TBoldActivateSystemAction, -// TBoldFailureDetectionAction, -// TBoldListHandleAddNewAction, -// TBoldListHandleDeleteAction, -// TBoldListHandleFirstAction, -// TBoldListHandleLastAction, -// TBoldListHandleNextAction, -// TBoldListHandlePrevAction, -// TBoldListHandleMoveUpAction, -// TBoldListHandleMoveDownAction, -// TBoldSetCheckPointAction, -// TBoldUndoAction, -// TBoldRedoAction -// ], nil); + RegisterActions(BOLDACTIONGROUPNAME, + [ + TBoldUpdateDBAction, + TBoldDiscardChangesAction, + TBoldActivateSystemAction, + TBoldFailureDetectionAction, + TBoldCreateDatabaseAction, + TBoldListHandleAddNewAction, + TBoldListHandleDeleteAction, + TBoldListHandleFirstAction, + TBoldListHandleLastAction, + TBoldListHandleNextAction, + TBoldListHandlePrevAction, + TBoldListHandleMoveUpAction, + TBoldListHandleMoveDownAction, + TBoldSetCheckPointAction, + TBoldUndoAction, + TBoldRedoAction + ], nil); end; procedure RegisterComponentsOnPalette; @@ -79,6 +85,7 @@ procedure RegisterComponentsOnPalette; TBoldVariableHandle, TBoldListHandle, TBoldSQLHandle, + TBoldRawSQLHandle, TBoldCursorHandle, TBoldReferenceHandle, TBoldOclVariables, @@ -94,7 +101,7 @@ procedure RegisterComponentsOnPalette; RegisterComponents(BOLDPAGENAME_DEPRECATED, [ - TBoldVariableDefinition +// TBoldVariableDefinition ]); end; @@ -122,7 +129,9 @@ procedure RegisterEditors; RegisterPropertyEditor(TypeInfo(string), TBoldRootedHandle, 'RootTypeName', TBoldTypeNameSelectorPropertyForAllTypes); // do not localize RegisterPropertyEditor(TypeInfo(string), TBoldVariableHandle, 'ValueTypeName', TBoldTypeNameSelectorPropertyForVariableHandle); // do not localize RegisterPropertyEditor(TypeInfo(string), TBoldDerivedHandle, 'ValueTypeName', TBoldTypeNameSelectorPropertyForAllTypes); // do not localize + RegisterPropertyEditor(TypeInfo(string), TBoldDerivedHandle, 'ValueTypeName', TBoldTypeNameSelectorPropertyForVariableHandle); // do not localize RegisterPropertyEditor(TypeInfo(string), TBoldSQLHandle, 'ClassExpressionName', TBoldTypeNameSelectorForSQLHandle); // do not localize + RegisterPropertyEditor(TypeInfo(string), TBoldRawSQLHandle, 'ClassExpressionName', TBoldTypeNameSelectorForSQLHandle); // do not localize // Propeditor för listhandle.expression // Propeditor för Exprhandle.expression @@ -137,6 +146,7 @@ procedure RegisterEditors; RegisterComponentEditor(TBoldDerivedHandle, TBoldModelAwareComponentEditor); RegisterComponentEditor(TBoldVariableHandle, TBoldModelAwareComponentEditor); RegisterComponentEditor(TBoldSQLHandle, TBoldModelAwareComponentEditor); + RegisterComponentEditor(TBoldRawSQLHandle, TBoldModelAwareComponentEditor); RegisterComponentEditor(TBoldCursorHandle, TBoldModelAwareComponentEditor); RegisterComponentEditor(TBoldReferenceHandle, TBoldModelAwareComponentEditor); end; @@ -151,3 +161,4 @@ procedure Register; end. + diff --git a/Source/Handles/IDE/BoldHandleReg.res b/Source/Handles/IDE/BoldHandleReg.res new file mode 100644 index 00000000..cefccf4d Binary files /dev/null and b/Source/Handles/IDE/BoldHandleReg.res differ diff --git a/Source/Handles/IDE/BoldLockingReg.pas b/Source/Handles/IDE/BoldLockingReg.pas index 810254ea..ac46d9e3 100644 --- a/Source/Handles/IDE/BoldLockingReg.pas +++ b/Source/Handles/IDE/BoldLockingReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLockingReg; interface @@ -6,6 +9,8 @@ procedure Register; implementation +{$R BoldLockingReg.res} + uses SysUtils, BoldUtils, @@ -14,7 +19,6 @@ implementation BoldIDEConsts, BoldLockingHandles; -{.$R *.res} procedure RegisterComponentsOnPalette; begin @@ -27,3 +31,4 @@ procedure Register; end; end. + diff --git a/Source/Handles/IDE/BoldLockingReg.res b/Source/Handles/IDE/BoldLockingReg.res new file mode 100644 index 00000000..b1c70821 Binary files /dev/null and b/Source/Handles/IDE/BoldLockingReg.res differ diff --git a/Source/Handles/IDE/BoldManipulatorReg.pas b/Source/Handles/IDE/BoldManipulatorReg.pas index b9da93e9..503998c2 100644 --- a/Source/Handles/IDE/BoldManipulatorReg.pas +++ b/Source/Handles/IDE/BoldManipulatorReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldManipulatorReg; interface @@ -6,6 +9,8 @@ procedure Register; implementation +{$R BoldManipulators.res} + uses SysUtils, BoldUtils, @@ -25,3 +30,4 @@ procedure Register; end; end. + diff --git a/Source/Handles/IDE/BoldXMLReg.pas b/Source/Handles/IDE/BoldXMLReg.pas index 25ac31b6..e72b81fb 100644 --- a/Source/Handles/IDE/BoldXMLReg.pas +++ b/Source/Handles/IDE/BoldXMLReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldXMLReg; interface @@ -9,12 +12,12 @@ procedure Register; implementation uses + BoldGuard, BoldXMLProducers; procedure Register; begin - RegisterComponents('Bold XML', [TBoldXMLProducer]); // do not localize + RegisterComponents('Bold XML', [TBoldXMLProducer]); end; end. - diff --git a/Source/Handles/IDECOM/BoldComElementHandleReg.pas b/Source/Handles/IDECOM/BoldComElementHandleReg.pas index 7022acad..082ae3bc 100644 --- a/Source/Handles/IDECOM/BoldComElementHandleReg.pas +++ b/Source/Handles/IDECOM/BoldComElementHandleReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComElementHandleReg; interface @@ -14,7 +17,7 @@ implementation procedure Register; begin - RegisterComponents('Bold COM', [TBoldComServerElementHandle]); // do not localize + RegisterComponents('Bold COM',[TBoldComServerElementHandle]); end; end. diff --git a/Source/Handles/IDECOM/BoldComElementHandleReg.res b/Source/Handles/IDECOM/BoldComElementHandleReg.res new file mode 100644 index 00000000..11da8b90 Binary files /dev/null and b/Source/Handles/IDECOM/BoldComElementHandleReg.res differ diff --git a/Source/Handles/Manipulators/BoldManipulators.pas b/Source/Handles/Manipulators/BoldManipulators.pas index 9d93d49c..7faf8aae 100644 --- a/Source/Handles/Manipulators/BoldManipulators.pas +++ b/Source/Handles/Manipulators/BoldManipulators.pas @@ -1,9 +1,11 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldManipulators; interface uses - BoldSystem, BoldDefs, BoldElements, BoldHandles, @@ -21,6 +23,7 @@ TBoldManipulatorMapperCollection = class; TBoldManipulatorSetter = procedure(Element: TBoldElement; const NewValue: string) of object; { TBoldManipulator } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldManipulator = class(TBoldSubscribableComponentViaBoldElem) private fIdStringRepresentation: TBoldIdStringRepresentation; @@ -28,18 +31,14 @@ TBoldManipulator = class(TBoldSubscribableComponentViaBoldElem) fOnEncrypt: TBoldStringStringFunction; fOnDecrypt: TBoldStringStringFunction; FMappers: TBoldManipulatorMapperCollection; - fBoldSystem: TBoldSystem; - function RawIdStringForElement(Element: TBoldElement): string; // unencrypted - function ElementForRawIdString(IdString: string): TBoldElement; // unencrypted + function RawIdStringForElement(Element: TBoldElement): string; + function ElementForRawIdString(IdString: string): TBoldElement; function AddMapping(const RawIdString: string; const Mapping: string): string; function GetMapping(const IdString: string): string; function StripMapping(const IdString: string): string; procedure SetMappers(const Value: TBoldManipulatorMapperCollection); procedure SetBoldSystemHandle(const Value: TBoldAbstractSystemhandle); - function GetAttachedSystem: TBoldSystem; - procedure SetBoldSystem(const Value: TBoldSystem); protected - property AttachedSystem: TBoldSystem read GetAttachedSystem; procedure Notification(AComponent: TComponent; Operation: TOperation); override; public constructor Create(AOwner: TComponent); override; @@ -51,10 +50,9 @@ TBoldManipulator = class(TBoldSubscribableComponentViaBoldElem) function IdStringForElement(Element: TBoldElement; const Mapping: string = ''): string; procedure DeleteObject(IdString: string); function CreateObject(Classname: string): string; - procedure SetFromList(IdValuePairs: TStrings); + procedure SetFromList(IdValuePairs: TStrings); published property IdStringRepresentation:TBoldIdStringRepresentation read fIdStringRepresentation write fIdStringRepresentation; - property BoldSystem: TBoldSystem read fBoldSystem write SetBoldSystem; property BoldSystemHandle: TBoldAbstractSystemhandle read fBoldSystemHandle write SetBoldSystemHandle; property OnEncrypt: TBoldStringStringFunction read fOnEncrypt write fOnEncrypt; property OnDecrypt: TBoldStringStringFunction read fOnDecrypt write fOnDecrypt; @@ -95,21 +93,19 @@ TBoldManipulatorMapperCollection = class(TCollection) implementation -{.$R *.res} - uses SysUtils, BoldUtils, BoldId, BoldDefaultId, - HandlesConst; + BoldSystem; { TBoldManipulator } function TBoldManipulator.AddMapping(const RawIdString, Mapping: string): string; begin if Mapping <> '' then - Result := Format('%s[%s]', [RawIdString, Mapping]) // do not localize + Result := Format('%s[%s]', [RawIdString, Mapping]) else Result := RawIdString; end; @@ -129,6 +125,11 @@ function TBoldManipulator.ElementForRawIdString(IdString: string): TBoldElement; ColonPos: integer; ObjectId: TBoldObjectID; begin + if Trim(IdString) = '' then + begin + Result := nil; + exit; + end; if IdStringRepresentation = isrVerbose then IdString := Copy(IdString, Pos('.', IdString) + 1, MAXINT); ColonPos := Pos(':', IdString); @@ -145,7 +146,7 @@ function TBoldManipulator.ElementForRawIdString(IdString: string): TBoldElement; ObjectID := TBoldDefaultId.CreateWithClassID(0, false); (ObjectID as TBoldDefaultId).AsInteger := StrToInt(ObjectIdStr); end; - BoldObject := AttachedSystem.EnsuredLocatorByID[ObjectID].EnsuredBoldObject; // FIXME error handling if object has been deleted + BoldObject := BoldSystemHandle.System.EnsuredLocatorByID[ObjectID].EnsuredBoldObject; if ColonPos = 0 then result := BoldObject else if IdStringRepresentation = isrVerbose then @@ -181,7 +182,7 @@ function TBoldManipulator.GetValueAndId(Element: TBoldElement; else begin IdString := AddMapping(IdString, Mapping); - Result := Mappers.ItemByname[Mapping].GetAsString(Element); // FIXME error handling + Result := Mappers.ItemByname[Mapping].GetAsString(Element); end; if Assigned(fOnEncrypt) and (IdString <> '') then IdString := OnEncrypt(IdString); @@ -189,7 +190,6 @@ function TBoldManipulator.GetValueAndId(Element: TBoldElement; function TBoldManipulator.RawIdStringForElement(Element: TBoldElement): string; begin - Result := ''; if Element is TBoldObject then begin if IdStringRepresentation = isrVerbose then @@ -236,7 +236,7 @@ procedure TBoldManipulator.SetValue(IdString: string; const NewValue: string); NewId := OnDecrypt(NewId); NewElement := ElementForRawIdString(StripMapping(NewId)); if (NewElement is TBoldObject) then - r.BoldObject := TBoldObject(NewElement); // FIXME error handling + r.BoldObject := TBoldObject(NewElement); end; var @@ -256,13 +256,13 @@ procedure TBoldManipulator.SetValue(IdString: string; const NewValue: string); else if (Element is TBoldObjectReference) then SetObjectReference(TBoldObjectReference(Element), NewValue) else if (Element is TBoldObjectList) then - raise EBold.Create(sCannotSetMultiLinkFromValue) + raise EBold.Create('Can''t set Multilink from value') else if (Element is TBoldObject) then - raise EBold.Create(sCannotSetObjectFromValue); + raise EBold.Create('Can''t set Object from value'); end; end else - Mappers.ItemByname[Mapping].SetFromString(Element, NewValue); // FIXME error handling + Mappers.ItemByname[Mapping].SetFromString(Element, NewValue); end; function TBoldManipulator.StripMapping(const IdString: string): string; @@ -297,10 +297,10 @@ destructor TBoldManipulator.Destroy; function TBoldManipulator.CreateObject(Classname: string): string; begin - if Assigned(AttachedSystem) then - Result := IdStringForElement(AttachedSystem.CreateNewObjectByExpressionName(ClassName)) + if Assigned(BoldSystemhandle) then + Result := IdStringForElement(BoldSystemHandle.System.CreateNewObjectByExpressionName(ClassName)) else - raise EBold.CreateFmt(sNoSystemHandle, [classname, 'CreateObject', Name]); // do not localize + raise EBold.CreateFmt('%s.CreateObject: The manipulator is not connected to a systemhandle', [classname]); end; procedure TBoldManipulator.DeleteObject(IdString: string); @@ -337,21 +337,7 @@ function TBoldManipulator.DefaultTagForElement(Element: TBoldElement): string; else if Assigned(Element.BoldType) then Result := Element.BoldType.ExpressionName else - raise EBold.CreateFmt(sElementLacksTypeInfo, [ClassName]); -end; - -function TBoldManipulator.GetAttachedSystem: TBoldSystem; -begin - if BoldSystemHandle <> nil then - Result := BoldSystemHandle.System - else - Result := fBoldSystem; -end; - -procedure TBoldManipulator.SetBoldSystem(const Value: TBoldSystem); -begin - fBoldSystem := Value; - { TODO : Get OnDestroy notification for system} + raise EBold.CreateFmt('%s.DefaultTagForElement: Element lacks type information', [ClassName]); end; { TBoldManipulatorMapper } @@ -393,7 +379,7 @@ function TBoldManipulatorMapperCollection.GetItemByname( result := Items[i]; Exit; end; - raise EBold.CreateFmt(sUnknownMapping, [Name]); + raise EBold.CreateFmt('Unknown mapping: %s', [Name]); end; function TBoldManipulatorMapperCollection.GetItems(Index: integer): TBoldManipulatorMapper; diff --git a/Source/Handles/Manipulators/BoldManipulators.rc b/Source/Handles/Manipulators/BoldManipulators.rc index e392ae40..c60b00ab 100644 --- a/Source/Handles/Manipulators/BoldManipulators.rc +++ b/Source/Handles/Manipulators/BoldManipulators.rc @@ -1 +1 @@ -TBOLDMANIPULATOR BITMAP LOADONCALL TBoldManipulator.bmp \ No newline at end of file +TBOLDMANIPULATOR BITMAP LOADONCALL ..\..\..\Images\Components\TBoldManipulator.bmp diff --git a/Source/Handles/Manipulators/BoldManipulators.res b/Source/Handles/Manipulators/BoldManipulators.res new file mode 100644 index 00000000..d1baa5d0 Binary files /dev/null and b/Source/Handles/Manipulators/BoldManipulators.res differ diff --git a/Source/Handles/PessimisticLocking/BoldLockingHandles.pas b/Source/Handles/PessimisticLocking/BoldLockingHandles.pas index 23dc8089..eeff91b9 100644 --- a/Source/Handles/PessimisticLocking/BoldLockingHandles.pas +++ b/Source/Handles/PessimisticLocking/BoldLockingHandles.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLockingHandles; interface @@ -6,20 +9,25 @@ interface Classes, BoldDefs, BoldSubscription, + {$IFNDEF BOLD_NO_QUERIES} BoldLockHandler, + {$ENDIF} BoldLockHolder, BoldListenerHandle, BoldAbstractLockManagerHandle, BoldHandles; type - { TBoldLockingHandle } + + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldLockingHandle = class(TBoldSubscribableComponent) private fActive: Boolean; fSubscriber: TBoldPassthroughSubscriber; FSystemHandle: TBoldAbstractSystemHandle; + {$IFNDEF BOLD_NO_QUERIES} fLockHandler: TBoldPessimisticLockHandler; + {$ENDIF} fLockHolder: TBoldLockHolder; FListener: TBoldListenerHandle; FLockManager: TBoldAbstractLockManagerHandle; @@ -37,7 +45,9 @@ TBoldLockingHandle = class(TBoldSubscribableComponent) public constructor Create(AOwner: TComponent); override; destructor Destroy; override; + {$IFNDEF BOLD_NO_QUERIES} property LockHandler: TBoldPessimisticLockHandler read fLockHandler; + {$ENDIF} property LockHolder: TBoldLockHolder read GetLockHolder; property Active: Boolean read fActive; published @@ -52,7 +62,6 @@ TBoldLockingHandle = class(TBoldSubscribableComponent) implementation uses - HandlesConst, BoldUtils, SysUtils; @@ -65,16 +74,18 @@ procedure TBoldLockingHandle.Activate; if not assigned(SystemHandle.System) then raise EBoldInternal.CreateFmt('%s.Activate: Cannot activate Locking. The system is not active.', [classname]); if not assigned(Listener) then - raise EBold.CreateFmt(sCannotActivateWithoutListener, [classname]); + raise EBold.CreateFmt('%s.Activate: Cannot activate Locking without a listener. Set the Listener property of the %0:s', [classname]); if not assigned(LockManager) then - raise EBold.CreateFmt(sCannotActivateWithoutLockManager, [classname]); + raise EBold.CreateFmt('%s.Activate: Cannot activate Locking without a LockManager. Set the LockManager property of the %0:s', [classname]); if not Active then begin + {$IFNDEF BOLD_NO_QUERIES} fLockHandler := TBoldPessimisticLockHandler.CreateWithLockHolder(FSystemHandle.System, LockHolder); fLockHandler.OnActivityStart := OnActivityStart; fLockHandler.OnActivityEnd := OnActivityEnd; fLockHandler.OnProgress := OnProgress; + {$ENDIF} fActive := True; end; end; @@ -102,7 +113,9 @@ procedure TBoldLockingHandle.Deactivate; if Active then begin FreeAndNil(fLockHolder); + {$IFNDEF BOLD_NO_QUERIES} FreeAndNil(fLockHandler); + {$ENDIF} fActive := false; end; end; @@ -191,4 +204,6 @@ procedure TBoldLockingHandle._Receive(Originator: TObject; end; end; +initialization + end. diff --git a/Source/Handles/UnLoader/BoldUnloaderHandle.pas b/Source/Handles/UnLoader/BoldUnloaderHandle.pas index 7600dd31..81709058 100644 --- a/Source/Handles/UnLoader/BoldUnloaderHandle.pas +++ b/Source/Handles/UnLoader/BoldUnloaderHandle.pas @@ -1,3 +1,6 @@ +///////////////////////////////////////////////////////// + + unit BoldUnloaderHandle; interface @@ -12,10 +15,16 @@ interface Classes, ExtCtrls; +const + cTickInterval = 60 * 1000; // 1 minute + cScanPerTick = 50; // milliseconds, max time to spend scaning + cMinAgeForUnload = 5; // unit is the TickInterval so (cTickInterval * cMinAgeForUnload) = 5 minutes + type { Forward declaration of classes } TBoldUnloaderHandle = class; + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldUnloaderHandle = class(TComponent) private fActive: Boolean; @@ -32,6 +41,12 @@ TBoldUnloaderHandle = class(TComponent) procedure SetUnloadDelayedFetch(const Value: boolean); procedure SetMinAgeForUnload(const Value: integer); procedure SetScanPerTick(const Value: integer); + function GetOnMayStart: TBoldMayUnloadStartEvent; + procedure SetOnMayStart(const Value: TBoldMayUnloadStartEvent); + function GetOnReportUnload: TBoldReportUnloadEvent; + procedure SetOnReportUnload(const Value: TBoldReportUnloadEvent); + function GetUnloadFromCurrentClassList: boolean; + procedure SetUnloadFromCurrentClassList(const Value: boolean); property Unloader: TBoldUnloader read fUnloader; procedure SetBoldSystemHandle(const Value: TBoldSystemHandle); procedure Tick(Sender: Tobject); @@ -42,18 +57,22 @@ TBoldUnloaderHandle = class(TComponent) function GetOnMayUnload: TBoldUnloadObjectEvent; procedure SetOnMayInvalidate(const Value: TBoldInvalidateMemberEvent); procedure SetOnMayUnload(const Value: TBoldUnloadObjectEvent); + procedure PlaceSubscriptions; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; published - property TickIntervall: integer read GetTickInterval write SetTickInterval default 1000; + property TickInterval: integer read GetTickInterval write SetTickInterval default cTickInterval; property BoldSystemHandle: TBoldSystemHandle read fBoldSystemHandle write SetBoldSystemHandle; - property ScanPerTick: integer read GetScanPerTick write SetScanPerTick default 1000; - property MinAgeForUnload: integer read GetMinAgeForUnload write SetMinAgeForUnload default 300000; - property UnloadDelayedFetch: boolean read GetUnloadDelayedFetch write SetUnloadDelayedFetch; + property ScanPerTick: integer read GetScanPerTick write SetScanPerTick default cScanPerTick; + property MinAgeForUnload: integer read GetMinAgeForUnload write SetMinAgeForUnload default cMinAgeForUnload; + property UnloadDelayedFetch: boolean read GetUnloadDelayedFetch write SetUnloadDelayedFetch default false; + property UnloadFromCurrentClassList: boolean read GetUnloadFromCurrentClassList write SetUnloadFromCurrentClassList default false; property Active: boolean read fActive write SetActive default true; property OnMayInvalidate: TBoldInvalidateMemberEvent read GetOnMayInvalidate write SetOnMayInvalidate; property OnMayUnload: TBoldUnloadObjectEvent read GetOnMayUnload write SetOnMayUnload; + property OnMayStart: TBoldMayUnloadStartEvent read GetOnMayStart write SetOnMayStart; + property OnReportUnload: TBoldReportUnloadEvent read GetOnReportUnload write SetOnReportUnload; end; @@ -75,15 +94,16 @@ constructor TBoldUnloaderHandle.Create(AOwner: TComponent); fSubscriber := TBoldPassthroughSubscriber.Create(ReceiveFromSystemHandle); fTimer := TTimer.Create(Self); fTimer.Enabled := True; - TickIntervall := 1000; - ScanPertick := 1000; - MinAgeForUnload := 300000; + TickInterval := cTickInterval; + ScanPertick := cScanPertick; + MinAgeForUnload := cMinAgeForUnload; fTimer.OnTimer := Tick; Active := True; end; destructor TBoldUnloaderHandle.Destroy; begin + BoldSystemHandle := nil; FreeAndNil(fSubscriber); FreeAndNil(fUnLoader); FreeAndNil(fTimer); @@ -95,6 +115,11 @@ function TBoldUnloaderHandle.GetUnloadDelayedFetch: boolean; Result := Unloader.UnloadDelayedFetch; end; +function TBoldUnloaderHandle.GetUnloadFromCurrentClassList: boolean; +begin + result := Unloader.UnloadFromCurrentClassList; +end; + function TBoldUnloaderHandle.GetMinAgeForUnload: integer; begin Result := Unloader.MinAgeForUnload; @@ -110,16 +135,28 @@ function TBoldUnloaderHandle.GetTickInterval: integer; Result := fTimer.Interval; end; +procedure TBoldUnloaderHandle.PlaceSubscriptions; +begin + fSubscriber.CancelAllSubscriptions; + if assigned(fBoldSystemHandle) then + begin + fBoldSystemHandle.AddSmallSubscription(fSubscriber, [beDestroying], breHandleDestroyed); + fBoldSystemHandle.AddSmallSubscription(fSubscriber, [beValueIdentityChanged], breSystemChanged); + if assigned(fBoldSystemHandle.System) then + fBoldSystemHandle.System.AddSmallSubscription(fSubscriber, [beDestroying], beDestroying); + end; +end; + procedure TBoldUnloaderHandle.PropagateToUnloder; begin + PlaceSubscriptions; if Active then begin if Assigned(BoldSystemHandle) then fUnloader.BoldSystem := BoldSystemHandle.System else fUnloader.BoldSystem := nil; - if Assigned(fUnloader.BoldSystem) then - fUnloader.Active := True; + fUnloader.Active := Assigned(fUnloader.BoldSystem); end else fUnLoader.Active := False; @@ -146,15 +183,9 @@ procedure TBoldUnloaderHandle.SetActive(const Value: boolean); procedure TBoldUnloaderHandle.SetBoldSystemHandle( const Value: TBoldSystemHandle); begin - if Value <> BoldSystemHandle then + if Value <> fBoldSystemHandle then begin - fSubscriber.CancelAllSubscriptions; fBoldSystemHandle := Value; - if assigned(Value) then - begin - fBoldSystemHandle.AddSmallSubscription(fSubscriber, [beDestroying], breHandleDestroyed); - fBoldSystemHandle.AddSmallSubscription(fSubscriber, [beValueIdentityChanged], breSystemChanged); - end; PropagateToUnloder; end; end; @@ -165,6 +196,12 @@ procedure TBoldUnloaderHandle.SetUnloadDelayedFetch( Unloader.UnloadDelayedFetch := Value; end; +procedure TBoldUnloaderHandle.SetUnloadFromCurrentClassList( + const Value: boolean); +begin + Unloader.UnloadFromCurrentClassList := Value; +end; + procedure TBoldUnloaderHandle.SetMinAgeForUnload( const Value: integer); begin @@ -191,25 +228,43 @@ function TBoldUnloaderHandle.GetOnMayInvalidate: TBoldInvalidateMemberEvent; Result := Unloader.OnMayInvalidate; end; +function TBoldUnloaderHandle.GetOnMayStart: TBoldMayUnloadStartEvent; +begin + Result := Unloader.OnMayStart; +end; + function TBoldUnloaderHandle.GetOnMayUnload: TBoldUnloadObjectEvent; begin Result := Unloader.OnMayUnload; end; +function TBoldUnloaderHandle.GetOnReportUnload: TBoldReportUnloadEvent; +begin + result := Unloader.OnReportUnload; +end; + procedure TBoldUnloaderHandle.SetOnMayInvalidate( const Value: TBoldInvalidateMemberEvent); begin Unloader.OnMayInvalidate := Value; end; +procedure TBoldUnloaderHandle.SetOnMayStart(const Value: TBoldMayUnloadStartEvent); +begin + Unloader.OnMayStart := Value; +end; + procedure TBoldUnloaderHandle.SetOnMayUnload( const Value: TBoldUnloadObjectEvent); begin Unloader.OnMayUnload := Value; end; -end. - - +procedure TBoldUnloaderHandle.SetOnReportUnload( + const Value: TBoldReportUnloadEvent); +begin + Unloader.OnReportUnload := Value; +end; +end. diff --git a/Source/Handles/XML/BoldXMLProducers.pas b/Source/Handles/XML/BoldXMLProducers.pas index 24f40e62..bed828a3 100644 --- a/Source/Handles/XML/BoldXMLProducers.pas +++ b/Source/Handles/XML/BoldXMLProducers.pas @@ -1,16 +1,20 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldXMLProducers; interface uses - MSXML_TLB, + Bold_MSXML_TLB, BoldStringList, BoldManipulators, BoldDefs, BoldElements, BoldSystem, BoldSubscription, - Classes; + Classes + ; type TBoldXMLProducerOption = (xpoIncludeIdString, xpoIncludeValue); @@ -22,6 +26,7 @@ interface type TBoldAbstractXMLProducer = class; + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldXMLProducer = class; TBoldProduceEvent = procedure (const paramList: TBoldStringList; const DomDoc: IXMLDomDocument) of object; @@ -34,7 +39,7 @@ TBoldAbstractXMLProducer = class(TBoldSubscribableComponent) protected procedure Produce(const paramList: TBoldStringList; const DomDoc: IXMLDomDocument); virtual; abstract; procedure Notification(AComponent: TComponent; Operation: TOperation); override; - function getDocument(const paramList: TBoldStringList): IXMLDomDocument; + function getDocument(const paramList: TBoldStringList): IXMLDomDocument; property BoldManipulator: TBoldManipulator read FBoldManipulator write SetBoldManipulator; property XMLElementBoldIDName: string read FXMLElementBoldIDName write FXMLElementBoldIDName; public @@ -50,6 +55,7 @@ TBoldAbstractXMLProducer = class(TBoldSubscribableComponent) const XMLAttributes: TBoldStringList = nil): IXMLDomElement; end; + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldXMLProducer = class(TBoldAbstractXMLProducer) private FOnProduce: TBoldProduceEvent; @@ -62,12 +68,13 @@ TBoldXMLProducer = class(TBoldAbstractXMLProducer) implementation -{.$R *.res} +{$R BoldXMLProducers.res} uses SysUtils, BoldUtils, - HandlesConst; + HandlesConst + ; { TBoldXMLProducer } @@ -202,4 +209,5 @@ function TBoldAbstractXMLProducer.AddDomElement( Result.setAttribute(WideString(XMLAttributes.Names[i]), WideString(XMLAttributes.Strings[i])); end; + end. diff --git a/Source/Handles/XML/BoldXMLProducers.res b/Source/Handles/XML/BoldXMLProducers.res new file mode 100644 index 00000000..c9a68e02 Binary files /dev/null and b/Source/Handles/XML/BoldXMLProducers.res differ diff --git a/Source/MoldModel/Bld/BoldBld.pas b/Source/MoldModel/Bld/BoldBld.pas index 3414bb3e..afd50fc5 100644 --- a/Source/MoldModel/Bld/BoldBld.pas +++ b/Source/MoldModel/Bld/BoldBld.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldBld; interface @@ -16,12 +19,13 @@ TMoldBLDRW = class; {---Exceptions---} EBoldBLDParseError = class(EBold); + {---TMoldBLDRW---} TMoldBLDRW = class - class function ModelFromFile(const filename: string): TMoldModel; // returns dynamically allocated model, with parts. + class function ModelFromFile(const filename: string): TMoldModel; class procedure ModelToFile(Model: TMoldModel; const filename: string); class procedure ModelToStrings(Model: TMoldModel; s: TSTrings); - class function StringsToModel(s: TStrings): TMoldModel; // returns dynamically allocated model, with parts. + class function StringsToModel(s: TStrings): TMoldModel; end; @@ -36,8 +40,7 @@ implementation BoldTaggedValueSupport, BoldDefaultTaggedValues, BoldUMLTaggedValues, - BoldUMLTypes, - BoldMoldConsts; + BoldUMLTypes; const LINKEXTENSION: string = '.bld'; @@ -56,6 +59,8 @@ TPClass = class; TElementClass = class of TElement; + + TElementClassRecord = record ElementClass: TElementClass; MoldElementClass: TMoldElementClass; @@ -101,13 +106,13 @@ TReader = class(TBoldMemoryManagedObject) Position: Integer; CurrentToken: TToken; CurrentCharacter: Char; - procedure GetToken; // Get a token - procedure Skip; // skip to next non-whitespace character - procedure GetCharacter; // Get next character - procedure GetCharacterNotEof; // Get next character, don't allow EOF - function NextCharacter: Char; // Get next non-whitespace character, and return in - procedure EatStartBlock(const keyw: string); // Eat start block - function TryKeyword(const keyw: string): Boolean; // eat keyword if matching + procedure GetToken; + procedure Skip; + procedure GetCharacter; + procedure GetCharacterNotEof; + function NextCharacter: Char; + procedure EatStartBlock(const keyw: string); + function TryKeyword(const keyw: string): Boolean; function GetKeyword: string; procedure Eat(t: BLDTokenKind); procedure EatKeyword(const keyw: string); @@ -142,7 +147,7 @@ TModel = class(TElement) {---TElementList---} TElementList = class(TBoldMemoryManagedObject) class procedure Write(list: TMoldElementList; w: TWriter); - class procedure Read(parent: TMoldElement; r: TReader); // classes link themselves into the right list + class procedure Read(parent: TMoldElement; r: TReader); end; {---TPClass---} @@ -193,7 +198,7 @@ class procedure TMoldBLDRW.ModelToStrings(model: TMoldModel; s: TStrings); Exit; theWriter := TWriter.Create(s); try - theWriter.Put(Format('VERSION %d', [CURRENTVERSION])); // do not localize + theWriter.Put(Format('VERSION %d', [CURRENTVERSION])); Tmodel.Write(model, theWriter); finally theWriter.Free; @@ -213,13 +218,13 @@ class procedure TMoldBLDRW.ModelToFile(Model: TMoldModel; const Filename: string end; end; -class function TMoldBLDRW.StringsToModel(s:TStrings): TMoldModel; // returns dynamically allocated model, with parts. +class function TMoldBLDRW.StringsToModel(s:TStrings): TMoldModel; var reader: TReader; begin Result := nil; if s.Count = 0 then - Result := TMoldModel.Create(nil, 'New_Model') // do not localize + Result := TMoldModel.Create(nil, 'New_Model') else begin reader := TReader.Create(s); @@ -228,8 +233,7 @@ class function TMoldBLDRW.StringsToModel(s:TStrings): TMoldModel; // returns dyn reader.CurrentToken := TToken.Create; reader.GetCharacter; reader.GetToken; - // Get version information (if any) - if reader.TryKeyword('VERSION') then // do not localize + if reader.TryKeyword('VERSION') then reader.FFormatVersion := reader.GetInteger else reader.FFormatVersion := 1; @@ -240,12 +244,10 @@ class function TMoldBLDRW.StringsToModel(s:TStrings): TMoldModel; // returns dyn } Result := TElement.CreateAndRead(nil, reader) as TMoldModel; -// if reader.fFormatVersion < 11 then -// Result.RootClass.ClassID := Result.FreeClassID; except on e: EBoldBLDParseError do - raise EBoldBLDParseError.CreateFmt(sErrorOnPos, [e.Message, reader.LineNumber, reader.Position]); + raise EBoldBLDParseError.CreateFmt('%s Line: %d Position: %d', [e.Message, reader.LineNumber, reader.Position]); end; finally Reader.Free; @@ -319,7 +321,6 @@ procedure TWriter.PutQuotedString(const s: string); else if s[i] = BOLDLF then begin Put('\' + 'l'); - // DontIndent; end else Put(s[i]); @@ -336,9 +337,9 @@ procedure TWriter.PutBoolean(b: Boolean); begin doIndent; if b then - Put('TRUE') // do not localize + Put('TRUE') else - Put('FALSE'); // do not localize + Put('FALSE'); end; Procedure TWriter.PutClassReference(aClass: TMoldClass); @@ -346,7 +347,7 @@ procedure TWriter.PutBoolean(b: Boolean); if Assigned(aClass) then PutQuotedString(aClass.Name) else - PutQuotedString(''); // do not localize + PutQUotedString(''); end; {---TReader---} @@ -366,7 +367,7 @@ destructor TReader.Destroy; procedure TReader.Skip; begin - while (not EOS) and (CurrentCharacter in [SPACE, TAB]) do + while (not EOS) and CharInSet(CurrentCharacter, [SPACE, TAB]) do GetCharacter; end; @@ -383,12 +384,12 @@ procedure TReader.GetCharacter; Inc(fLineNumber); end; Position := 1; - CurrentCharacter := ' '; // Space for newline + CurrentCharacter := ' '; end; - + begin if EOS then - CurrentCharacter := ' ' // Space for newline + CurrentCharacter := ' ' else if (Position > fLineLength) then NextLine @@ -397,13 +398,12 @@ procedure TReader.GetCharacter; CurrentCharacter := Line[Position]; INC(Position); end; - // write(output, currentcharacter); // DEBUG only (or you'll get an IO error 103) end; procedure TReader.GetCharacterNotEof; begin if EOS then - raise EBoldBLDParseError.Create(sUnexpectedEOF) + raise EBoldBLDParseError.Create('BLD Reader: Unexpected EOF') else GetCharacter; end; @@ -414,9 +414,10 @@ function TReader.NextCharacter: Char; Result := CurrentCharacter; end; + var TokenBuffer: string = ' '; - TokenBufferLength: integer = 6; // TokenBuffer MUST consist of this many spaces to start with + TokenBufferLength: integer = 6; procedure TReader.GetToken; var @@ -446,7 +447,7 @@ procedure TReader.GetToken; begin Kind := INTVALUE; IntegerValue := ord(CurrentCharacter) - ord('0'); - while Nextcharacter in ['0'..'9'] do + while CharInSet(Nextcharacter, ['0'..'9']) do IntegerValue := IntegerValue * 10 + ord(CurrentCharacter) - ord('0') end; @@ -457,7 +458,7 @@ procedure TReader.GetToken; StartIndex := Position; FoundLength := 1; TokenBuffer[FoundLength] := CurrentCharacter; - while NextCharacter in ['A'..'Z','a'..'z'] do + while CharInSet(NextCharacter, ['A'..'Z','a'..'z']) do Inc(FoundLength); StringValue := Copy(LineWithToken, StartIndex-1, FoundLength); end; @@ -491,7 +492,7 @@ procedure TReader.GetToken; StringValue := Copy(TokenBuffer, 1, i); end; else - raise EBoldBLDParseError.CreateFmt(sBadCharacter, [IntToStr(ord(CurrentCharacter))]) + raise EBoldBLDParseError.CreateFmt('BLD Reader: Bad character %s', [IntToStr(ord(CurrentCharacter))]) end; end; @@ -500,13 +501,13 @@ procedure TReader.Eat(t: BLDTokenKind); if CurrentToken.Kind = t then GetToken else - raise EBoldBLDParseError.Create(sSyntaxError); + raise EBoldBLDParseError.Create('BLD Reader: Syntax error'); end; procedure TReader.EatKeyword(const keyw: string); begin if not TryKeyword(keyw) then - raise EBoldBLDParseError.CreateFmt(sAKeywordExpected, [keyw]); + raise EBoldBLDParseError.CreateFmt('BLD Reader: ''%s'' expected', [keyw]); end; procedure TReader.EatStartBlock(const keyw: string); @@ -532,7 +533,7 @@ function TReader.GetQuotedString: string; if CurrentToken.Kind = QSTRING then GetToken else - raise EBoldBLDParseError.Create(sQuotedStringExpected); + raise EBoldBLDParseError.Create('BLD Reader: Quoted string expected'); end; function TReader.GetKeyword: string; @@ -541,7 +542,7 @@ function TReader.GetKeyword: string; if CurrentToken.Kind = KEYWORD then GetToken else - raise EBoldBLDParseError.Create(sKeyWordTokenExpected); + raise EBoldBLDParseError.Create('BLD Reader: KEYWORD expected'); end; function TReader.GetInteger: integer; @@ -550,17 +551,17 @@ function TReader.GetInteger: integer; if CurrentToken.Kind = INTVALUE then GetToken else - raise EBoldBLDParseError.Create(sIntegerExpected); + raise EBoldBLDParseError.Create('BLD Reader: Integer expected'); end; function TReader.GetBoolean: Boolean; begin Result := False; - if (CurrentToken.Kind = KEYWORD) and (CurrentToken.StringValue = 'TRUE') then // do not localize + if (CurrentToken.Kind = KEYWORD) and (CurrentToken.StringValue = 'TRUE') then Result := True else - if (CurrentToken.Kind <> KEYWORD) or (CurrentToken.StringValue <> 'FALSE') then // do not localize - raise EBoldBLDParseError.Create(sBooleanExpected); + if (CurrentToken.Kind <> KEYWORD) or (CurrentToken.StringValue <> 'FALSE') then + raise EBoldBLDParseError.Create('BLD Reader: Boolean expected'); GetToken; end; @@ -569,7 +570,7 @@ function TReader.GetClassReference: TMoldClass; name: string; begin name := GetQuotedString; - if name = '' then // do not localize + if name = '' then Result := nil else Result := CurrentModel.GetClassByName(name); @@ -581,7 +582,7 @@ class procedure TModel.Write(element: TMoldElement; w: TWriter); model: TMoldModel; begin model := element as TMoldModel; - w.PutStartBlock('Model'); // do not localize + w.PutStartBlock('Model'); w.PutQuotedString(Model.Name); { version 11 } w.PutQuotedString(Model.RootClass.Name); @@ -591,10 +592,10 @@ class procedure TModel.Write(element: TMoldElement; w: TWriter); { version 17 } w.PutQuotedString(Model.NonDefaultTaggedValuesCommaText); - w.PutStartBlock('Classes'); // do not localize + w.PutStartBlock('Classes'); TElementList.Write(Model.Classes, w); w.PutEndBlock; - w.PutStartBlock('Associations'); // do not localize + w.PutStartBlock('Associations'); TElementList.Write(Model.Associations, w); w.PutEndBlock; w.PutEndBlock; @@ -615,11 +616,12 @@ class procedure TModel.Write(element: TMoldElement; w: TWriter); if r.FormatVersion >= 11 then model.RootClass.Name := r.GetQuotedString; + if r.FormatVersion >= 12 then if r.formatVersion < 19 then Model.BoldTVByName[TAG_PMAPPERNAME] := r.GetQuotedString; if r.FormatVersion >= 13 then - if r.formatVersion < 19 then r.GetQuotedString; // legacy, was Model.DatabaseName + if r.formatVersion < 19 then r.GetQuotedString; if r.FormatVersion >= 15 then begin @@ -641,12 +643,12 @@ class procedure TModel.Write(element: TMoldElement; w: TWriter); end; {get classes} - r.EatStartBlock('Classes'); // do not localize + r.EatStartBlock('Classes'); r.CurrentModel := model; TElementList.Read(model, r); r.Eat(RPAR); - r.EatStartBlock('Associations'); // do not localize + r.EatStartBlock('Associations'); TElementList.Read(model, r); r.Eat(RPAR); r.Eat(RPAR); @@ -662,7 +664,6 @@ class procedure TElement.Write(element: TMoldElement; w: TWriter); class procedure TElement.Read(element: TMoldElement; r: TReader); begin - // Do nothing end; class function TElement.CreateAndRead(parent: TMoldElement; r: TReader): TMoldElement; @@ -700,7 +701,7 @@ class procedure TPClass.Write(element: TMoldElement; w: TWriter); begin with element as TMoldClass do begin - w.PutStartBlock('Class'); // do not localize + w.PutStartBlock('Class'); inherited write(element, w); w.PutClassReference(SuperClass); @@ -713,10 +714,10 @@ class procedure TPClass.Write(element: TMoldElement; w: TWriter); { version 17 } w.PutQuotedString(NonDefaultTaggedValuesCommaText); - w.PutStartBlock('Attributes'); // do not localize + w.PutStartBlock('Attributes'); TElementList.Write(Attributes, w); w.PutEndBlock; - w.PutStartBlock('Methods'); // do not localize + w.PutStartBlock('Methods'); TElementList.Write(Methods, w); w.PutEndBlock; w.PutEndBlock; @@ -727,12 +728,10 @@ class procedure TPClass.Read(element: TMoldElement; r: TReader); begin with element as TMoldClass do begin - // note special handling for classes inherited read(element, r); if r.formatVersion < 19 then BoldTVByName[TAG_TABLENAME] := r.GetQuotedString; if r.formatVersion < 19 then BoldTVByName[TAG_TABLEMAPPING] := TBoldTaggedValueSupport.TableMappingToString(TTableMapping(r.GetInteger)); - if r.formatVersion < 19 then r.GetInteger; // used to be classid, read for backward comaptibility + if r.formatVersion < 19 then r.GetInteger; SuperClass := r.GetClassReference; - // for older versions superclass may be nil but should be RootClass if (not Assigned(SuperClass)) and (Element <> Model.RootClass) then SuperClass := Model.RootClass; @@ -766,13 +765,13 @@ class procedure TPClass.Read(element: TMoldElement; r: TReader); if r.FormatVersion >= 17 then begin NonDefaultTaggedValuesCommaText := r.GetQuotedString; - end; + end; - r.EatStartBlock('Attributes'); // do not localize + r.EatStartBlock('Attributes'); TElementList.Read(element, r); r.Eat(RPAR); - r.EatStartBlock('Methods'); // do not localize + r.EatStartBlock('Methods'); TElementList.Read(element, r); r.Eat(RPAR); r.Eat(RPAR); @@ -784,7 +783,7 @@ class procedure TAttribute.Write(element: TMoldElement; w: TWriter); begin with Element as TMoldAttribute do begin - w.PutStartBlock('Attribute'); // do not localize + w.PutStartBlock('Attribute'); inherited write(element, w); w.PutQuotedString(BoldType); { version 3 } @@ -841,7 +840,7 @@ class procedure TAttribute.Read(element: TMoldElement; r: TReader); Stereotype := r.GetQuotedString; Constraints.CommaText := r.GetQuotedString; Visibility := TVisibilityKind(r.GetInteger); - if r.formatVersion < 19 then {DelphiField := }r.GetQuotedString; // removed in version 18 + if r.formatVersion < 19 then {DelphiField := }r.GetQuotedString; if r.formatVersion < 19 then BoldTVByName[TAG_DPREAD] := TBoldTaggedValueSupport.DelphiPropertyAccessKindToString(TDelphiPropertyAccessKind(r.GetInteger)); if r.formatVersion < 19 then BoldTVByName[TAG_DPWRITE] := TBoldTaggedValueSupport.DelphiPropertyAccessKindToString(TDelphiPropertyAccessKind(r.GetInteger)); if r.formatVersion < 19 then {DerivationOCL := }r.GetQuotedString; @@ -861,7 +860,6 @@ class procedure TAttribute.Read(element: TMoldElement; r: TReader); end else begin - // FIXME: Jan, ta ställning till vad de andra ska bli /fredrik 96-11-04 BoldTVByName[TAG_DELPHINAME] := ColumnName; end; r.Eat(RPAR); @@ -873,7 +871,7 @@ class procedure TMethod.Write(element: TMoldElement; w: TWriter); begin with element as TMoldMethod do begin - w.PutStartBlock('Method'); // do not localize + w.PutStartBlock('Method'); inherited write(element, w); w.PutQuotedString(Signature); w.PutBoolean(IsClassMethod); @@ -906,6 +904,7 @@ class procedure TMethod.Read(element: TMoldElement; r: TReader); if r.formatVersion < 19 then BoldTVByName[TAG_DELPHINAME] := r.GetQuotedString; end; + if r.FormatVersion >= 16 then begin Stereotype := r.GetQuotedString; @@ -931,7 +930,7 @@ class procedure TRole.Write(element: TMoldElement; w: TWriter); begin with element as TMoldRole do begin - w.PutStartBlock('Role'); // do not localize + w.PutStartBlock('Role'); inherited write(element, w); w.PutBoolean(Navigable); { version 2 } @@ -947,7 +946,7 @@ class procedure TRole.Write(element: TMoldElement; w: TWriter); { version 17 } w.PutQuotedString(NonDefaultTaggedValuesCommaText); { version 13} - w.PutStartBlock('Qualifiers'); // do not localize + w.PutStartBlock('Qualifiers'); TElementList.Write(Qualifiers, w); w.PutEndBlock; w.PutEndBlock; @@ -979,7 +978,7 @@ class procedure TRole.Read(element: TMoldElement;r: TReader); BoldTVByName[TAG_DELPHINAME] := ColumnName; if r.FormatVersion >= 4 then - if r.formatVersion < 19 then r.GetBoolean; // legacy, was Mandatory + if r.formatVersion < 19 then r.GetBoolean; if r.formatVersion < 19 then BoldTVByName[TAG_EMBED] := BooleanToString((r.FormatVersion < 9) or { Embed introduced in v9, default True } r.GetBoolean); @@ -1006,7 +1005,7 @@ class procedure TRole.Read(element: TMoldElement;r: TReader); if r.FormatVersion >= 14 then begin - r.EatStartBlock('Qualifiers'); // do not localize + r.EatStartBlock('Qualifiers'); TElementList.Read(element, r); r.Eat(RPAR); end; @@ -1020,7 +1019,7 @@ class procedure TQualifier.Write(element: TMoldElement; w: TWriter); begin with Element as TMoldQualifier do begin - w.PutStartBlock('Qualifier'); // do not localize + w.PutStartBlock('Qualifier'); inherited write(element, w); w.PutQuotedString(BoldType); { version 19 } @@ -1049,7 +1048,7 @@ class procedure TAssociation.Write(element: TMoldElement;w: TWriter); begin with element as TMoldAssociation do begin - w.PutStartBlock('Association'); // do not localize + w.PutStartBlock('Association'); inherited write(element, w); w.PutClassReference(LinkClass); { version 16 } @@ -1060,7 +1059,7 @@ class procedure TAssociation.Write(element: TMoldElement;w: TWriter); { version 19 } w.PutBoolean(Derived); - w.PutStartBlock('Roles'); // do not localize + w.PutStartBlock('Roles'); TElementList.Write(Roles, w); w.PutEndBlock; w.PutEndBlock; @@ -1081,18 +1080,16 @@ class procedure TAssociation.Read(element: TMoldElement;r: TReader); Stereotype := r.GetQuotedString; Constraints.CommaText := r.GetQuotedString; end; - // support for older versions that did not store "Persistent" for associations StdTVByName[TAG_PERSISTENCE] := TV_PERSISTENCE_PERSISTENT; if r.FormatVersion >= 17 then begin NonDefaultTaggedValuesCommaText := r.GetQuotedString; end; - // Get aRole list if r.FormatVersion >= 19 then Derived := r.GetBoolean; - r.EatStartBlock('Roles'); // do not localize + r.EatStartBlock('Roles'); TElementList.Read(element, r); r.Eat(RPAR); r.Eat(RPAR); @@ -1104,13 +1101,13 @@ class procedure TAssociation.Read(element: TMoldElement;r: TReader); var TypeTable: array [typetableIndex] of TElementClassRecord = ( - (elementClass: TModel; moldElementClass: TMoldModel; name: 'Model'), // do not localize - (elementClass: TPClass; moldElementClass: TMoldClass; name: 'Class'), // do not localize - (elementClass: TAttribute; moldElementClass: TMoldAttribute; name: 'Attribute'), // do not localize - (elementClass: TMethod; moldElementClass: TMoldMethod; name: 'Method'), // do not localize - (elementClass: TAssociation; moldElementClass: TMoldAssociation; name: 'Association'), // do not localize - (elementClass: TRole; moldElementClass: TMoldRole; name: 'Role'), // do not localize - (elementClass: TQualifier; moldElementClass: TMoldQualifier; name: 'Qualifier') // do not localize + (elementClass: TModel; moldElementClass: TMoldModel; name: 'Model'), + (elementClass: TPClass; moldElementClass: TMoldClass; name: 'Class'), + (elementClass: TAttribute; moldElementClass: TMoldAttribute; name: 'Attribute'), + (elementClass: TMethod; moldElementClass: TMoldMethod; name: 'Method'), + (elementClass: TAssociation; moldElementClass: TMoldAssociation; name: 'Association'), + (elementClass: TRole; moldElementClass: TMoldRole; name: 'Role'), + (elementClass: TQualifier; moldElementClass: TMoldQualifier; name: 'Qualifier') ); function TypeTableByMoldElement(moldElement: TMoldElement): TElementClassRecord; @@ -1123,7 +1120,7 @@ function TypeTableByMoldElement(moldElement: TMoldElement): TElementClassRecord; Result := typetable[i]; Exit; end; - raise EBoldInternal.Create('TypeTableByMoldElement: moldElementClass not found in typetable'); // do not localize + raise EBoldInternal.Create('TypeTableByMoldElement: moldElementClass not found in typetable'); end; function TypeTableByName(name: string): TElementClassRecord; @@ -1136,7 +1133,7 @@ function TypeTableByName(name: string): TElementClassRecord; Result := typetable[i]; Exit; end; - raise EBoldInternal.CreateFmt('TypeTableByName: %s not found in typetable', [name]); // do not localize + raise EBoldInternal.CreateFmt('TypeTableByName: %s not found in typetable', [name]); end; function BooleanToMultiplicityString(Value: Boolean): String; @@ -1147,4 +1144,6 @@ function BooleanToMultiplicityString(Value: Boolean): String; Result := '1'; end; +initialization + end. diff --git a/Source/MoldModel/CodeGenerator/BoldGen.pas b/Source/MoldModel/CodeGenerator/BoldGen.pas index a5951088..708a53dc 100644 --- a/Source/MoldModel/CodeGenerator/BoldGen.pas +++ b/Source/MoldModel/CodeGenerator/BoldGen.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldGen; interface @@ -8,14 +11,14 @@ interface BoldTypeNameDictionary, BoldFileHandler, BoldTemplateExpander, - BoldDefs, - BoldMoldConsts; + BoldDefs; const INDENTSIZE = 2; DEBUGGERWORKAROUNDINTERVAL = 50; AddVisitorSupport = true; + type TBoldGenerator = class; TBoldGeneratorClass = class of TBoldGenerator; @@ -45,6 +48,7 @@ TBoldGenerator = class fGenerateMIDLCode: boolean; fGenerateIDLVariables: Boolean; procedure EnsureMethod(Strings: TStrings); + procedure InitializeTemplateForComponent(Template: TBoldTemplateHolder; Model: TMoldModel; Component: TMoldComponent; InitializeClasses: Boolean); virtual; function MethodToDelphiHeader(OwningClass: TMoldClass; Method: TMoldMethod; TagValue: Integer; AddSignature: Boolean; AutoOverride: Boolean): String; function MethodToCOMHeader(OwningClass: TMoldClass; Method: TMoldMethod; InterfaceCode: Boolean; ParametersToCoerce, ParametersToInterfaceCoerce: TStringList): String; function MethodToIDLHeader(OwningClass: TMoldClass; Method: TMoldMethod): String; @@ -63,7 +67,6 @@ TBoldGenerator = class property MethodIndex: TStringList read fMethodIndex; function FindInCurrentFile(s: String): Boolean; procedure InitializeMethodIndex; - procedure InitializeTemplateForComponent(Template: TBoldTemplateHolder; Model: TMoldModel; Component: TMoldComponent; InitializeClasses: Boolean); virtual; property CurrentClass: TMoldClass read fCurrentClass write fCurrentClass; property GenerateIDLVariables: Boolean read fGenerateIDLVariables write fGenerateIDLVariables; public @@ -168,7 +171,7 @@ procedure TBoldGenerator.ExpandTemplatelist(TemplateList: TBoldTemplateList); BoldLog.ProgressMax := MoldModel.Classes.Count * 3; - BoldLog.LogFmt(sLogGeneratingInPath, [BaseFilePath]); + BoldLog.LogFmt('Generating in path: %s', [BaseFilePath]); for ComponentIx := 0 to MoldModel.Components.Count - 1 do begin for TemplateIx := 0 to TemplateList.Count - 1 do @@ -178,30 +181,30 @@ procedure TBoldGenerator.ExpandTemplatelist(TemplateList: TBoldTemplateList); with TemplateList[TemplateIx] do begin - Variables.SetVariable('COMPONENTNAME', MoldModel.Components[ComponentIx].Name); // do not localize - BoldLog.LogFmt(sLogGeneratingFile, [ExpandedFileName]); + Variables.SetVariable('COMPONENTNAME', MoldModel.Components[ComponentIx].Name); + BoldLog.LogFmt('Generating file: %s', [ExpandedFileName]); SetCurrentFileHandler(BaseFilePath, ExpandedFileName, ModuleTypeForFile(ExpandedFileName), true, false); BoldFilehandler.Clear; - BoldLog.LogHeader := sLogInitializingVars; + BoldLog.LogHeader := 'Initializing variables'; InitializeTemplateForComponent(TemplateList[TemplateIx], MoldModel, MoldModel.Components[ComponentIx], true); if BoldLog.ProcessInterruption then exit; - - BoldLog.LogHeader := sLogExpandingTemplate; + + BoldLog.LogHeader := 'Expanding template'; BoldFilehandler.AddStrings(ExpandedTemplate); end; end; end; - if MoldModel.MainComponent.Name = BoldDefaultTaggedValueList.DefaultForClassAndTag['Model', TAG_UNITNAME] then // do not localize + if MoldModel.MainComponent.Name = BoldDefaultTaggedValueList.DefaultForClassAndTag['Model', TAG_UNITNAME] then begin BoldLog.Separator; - BoldLog.Log(sLogConsiderNameChange1, ltWarning); - BoldLog.Log(sLogConsiderNameChange2, ltWarning); + BoldLog.Log('You should consider naming your model and base unit', ltWarning); + BoldLog.Log('to avoid filename conflicts with other projects', ltWarning); BoldLog.Separator; end; end; @@ -231,12 +234,12 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH procedure internalInitialize; begin - AddVariable('MEMBERHASNATIVE' + PostFix, '1'); // do not localize + AddVariable('MEMBERHASNATIVE' + PostFix, '1'); if not MoldAttribute.Derived or MoldAttribute.ReverseDerived then - AddVariable('MEMBERISSETABLE' + PostFix, '1') // do not localize + AddVariable('MEMBERISSETABLE' + PostFix, '1') else - AddVariable('MEMBERISSETABLE' + PostFix, '0'); // do not localize - end; + AddVariable('MEMBERISSETABLE' + PostFix, '0'); + end; begin Mapping := TypeNameDictionary.MappingForModelName[MoldAttribute.BoldType]; @@ -244,11 +247,11 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH begin if UnmappedTypes.IndexOf(MoldAttribute.BoldType) = -1 then begin - BoldLog.LogFmt(sLogNoDelphiMappingForType, [MoldAttribute.BoldType], ltWarning); + BoldLog.LogFmt('No Delphimapping for type %s', [MoldAttribute.BoldType], ltWarning); UnmappedTypes.Add(MoldAttribute.BoldType); end; - Typename := 'TBoldAttribute'; // do not localize - ValueInterfacename := 'IBoldNullableValue'; // do not localize + Typename := 'TBoldAttribute'; + ValueInterfacename := 'IBoldNullableValue'; end else begin TypeName := Mapping.ExpandedDelphiName; @@ -259,16 +262,16 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH (Mapping.IDLType <> '') then begin internalInitialize; - AddVariable('MEMBERNATIVECOMTYPE' + PostFix, Mapping.ExpandedCOMType); // do not localize - AddVariable('MEMBERNATIVEIDLTYPE' + PostFix, Mapping.IDLType); // do not localize - AddVariable('DISPID' + PostFix, IntToHex(MoldAttribute.DispId, 8)); // do not localize + AddVariable('MEMBERNATIVECOMTYPE' + PostFix, Mapping.ExpandedCOMType); + AddVariable('MEMBERNATIVEIDLTYPE' + PostFix, Mapping.IDLType); + AddVariable('DISPID' + PostFix, IntToHex(MoldAttribute.DispId, 8)); if CompareText(Mapping.ExpandedCOMType, BoldWideStringTypeName) = 0 then - AddVariable('SETMEMBERASCONST' + PostFix, 'const '); // do not localize + AddVariable('SETMEMBERASCONST' + PostFix, 'const '); end else if typesWithoutNative.IndexOf(MoldAttribute.BoldType) = -1 then begin - BoldLog.LogFmt(sLogNoCOMMappingForType, [MoldAttribute.BoldType, MoldAttribute.MoldClass.Name, MoldAttribute.Name], ltWarning); + BoldLog.LogFmt('No COM/IDL mapping for type %s, No attribute generated for %s.%s', [MoldAttribute.BoldType, MoldAttribute.MoldClass.Name, MoldAttribute.Name], ltWarning); typesWithoutNative.Add(MoldAttribute.BoldType); end; end @@ -278,40 +281,39 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH (Mapping.ExpandedNativeType <> '') then begin internalInitialize; - AddVariable('MEMBERNATIVEACCESSOR' + PostFix, Mapping.ExpandedAccessor); // do not localize - AddVariable('MEMBERNATIVETYPE' + PostFix, Mapping.ExpandedNativeType); // do not localize + AddVariable('MEMBERNATIVEACCESSOR' + PostFix, Mapping.ExpandedAccessor); + AddVariable('MEMBERNATIVETYPE' + PostFix, Mapping.ExpandedNativeType); end else begin - if typesWithoutNative.IndexOf(MoldAttribute.BoldType) = -1 then + if GenerateIDLVariables and (typesWithoutNative.IndexOf(MoldAttribute.BoldType) = -1) then begin - BoldLog.LogFmt(sLogNoNativeMappingForType, [MoldAttribute.BoldType, MoldAttribute.Name, MoldAttribute.MoldClass.Name], ltWarning); + BoldLog.LogFmt('No native mapping for type %s used in attribute %s.%s, only Bold attribute generated', [MoldAttribute.BoldType, MoldAttribute.Name, MoldAttribute.MoldClass.Name], ltWarning); typesWithoutNative.Add(MoldAttribute.BoldType); end; end; - if MoldAttribute.EffectivePersistent then + if MoldAttribute.EffectivePersistent and + (Mapping.ValueInterfaceAccessor <> '') and + (Mapping.ValueInterfaceNativeType <> '') then begin - if (Mapping.ValueInterfaceAccessor <> '') and - (Mapping.ValueInterfaceNativeType <> '') then + AddVariable('MEMBERHASVALUEINTERFACENATIVE' + PostFix, '1'); + AddVariable('MEMBERVALUEINTERFACENATIVEACCESSOR' + PostFix, Mapping.ValueInterfaceAccessor); + AddVariable('MEMBERVALUEINTERFACENATIVETYPE' + PostFix, Mapping.ValueInterfaceNativeType); + end + else begin + if GenerateIDLVariables and (typesWithoutNative.IndexOf(MoldAttribute.BoldType) = -1) then begin - AddVariable('MEMBERHASVALUEINTERFACENATIVE' + PostFix, '1'); // do not localize - AddVariable('MEMBERVALUEINTERFACENATIVEACCESSOR' + PostFix, Mapping.ValueInterfaceAccessor); // do not localize - AddVariable('MEMBERVALUEINTERFACENATIVETYPE' + PostFix, Mapping.ValueInterfaceNativeType); // do not localize - end - else begin - if typesWithoutNative.IndexOf(MoldAttribute.BoldType) = -1 then - begin - BoldLog.LogFmt(sNoValueTypeMappingForType, [MoldAttribute.BoldType, MoldAttribute.Name, MoldAttribute.MoldClass.Name], ltWarning); - typesWithoutNative.Add(MoldAttribute.BoldType); - end; + BoldLog.LogFmt('No native mapping for type %s used in attribute %s.%s, only Bold attribute generated', [MoldAttribute.BoldType, MoldAttribute.Name, MoldAttribute.MoldClass.Name], ltWarning); + typesWithoutNative.Add(MoldAttribute.BoldType); end; end; + end; end; - AddVariable('MEMBERTYPE' + PostFix, TypeName); // do not localize - addVariable('MEMBERVALUEINTERFACE'+PostFix, ValueInterfaceName); // do not localize - AddVariable('MEMBERKIND' + PostFix, 'Attribute'); // do not localize - AddVariable('MEMBERVISIBILITY' + PostFix, VisibilityTOString[MoldAttribute.Visibility]); // do not localize + AddVariable('MEMBERTYPE' + PostFix, TypeName); + addVariable('MEMBERVALUEINTERFACE'+PostFix, ValueInterfaceName); + AddVariable('MEMBERKIND' + PostFix, 'Attribute'); + AddVariable('MEMBERVISIBILITY' + PostFix, VisibilityTOString[MoldAttribute.Visibility]); end; procedure InitializeNativeAttribute(MoldAttribute: TMoldAttribute; const PostFix: String); @@ -322,13 +324,13 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH ('None', 'Field', 'PrivateMethod', 'ProtectedVirtualMethod'); begin TypeName := GetNativeDelphiTypeForModelNameNoDefaults(MoldAttribute); - AddVariable('DelphiAttributeType' + PostFix, TypeName); // do not localize - AddVariable('DelphiAttributeKind' + PostFix, 'Attribute'); // do not localize - AddVariable('DelphiAttributeHasField' + PostFix, BoldBooleanToTemplateVar[MoldAttribute.HasDelphiField]); // do not localize + AddVariable('DelphiAttributeType' + PostFix, TypeName); + AddVariable('DelphiAttributeKind' + PostFix, 'Attribute'); + AddVariable('DelphiAttributeHasField' + PostFix, BoldBooleanToTemplateVar[MoldAttribute.HasDelphiField]); - AddVariable('DelphiAttributeVisibility' + PostFix, VisibilityToString[MoldAttribute.Visibility]); // do not localize - AddVariable('DelphiAttributePropertyRead' + PostFix, PropertyAccessKindToStr[MoldAttribute.DelphiPropertyRead]); // do not localize - AddVariable('DelphiAttributePropertyWrite' + PostFix, PropertyAccessKindToStr[MoldAttribute.DelphiPropertyWrite]); // do not localize + AddVariable('DelphiAttributeVisibility' + PostFix, VisibilityToString[MoldAttribute.Visibility]); + AddVariable('DelphiAttributePropertyRead' + PostFix, PropertyAccessKindToStr[MoldAttribute.DelphiPropertyRead]); + AddVariable('DelphiAttributePropertyWrite' + PostFix, PropertyAccessKindToStr[MoldAttribute.DelphiPropertyWrite]); end; procedure InitializeQualifier(MoldRole: TMoldRole; const PostFix: String); @@ -353,9 +355,9 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH Mapping := TypeNameDictionary.MappingForModelName[AttrOfOtherEnd.BoldType]; if assigned(Mapping) then begin - AddVariable('QUALIFIERNAME' + PostFix + '.' + IntToStr(i), AttrOfOtherEnd.ExpandedDelphiName); // do not localize - AddVariable('QUALIFIERBOLDTYPE' + PostFix + '.' + IntToStr(i), Mapping.ExpandedDelphiName); // do not localize - AddVariable('QUALIFIERACCESSOR' + PostFix + '.' + IntToStr(i), Mapping.ExpandedAccessor); // do not localize + AddVariable('QUALIFIERNAME' + PostFix + '.' + IntToStr(i), AttrOfOtherEnd.ExpandedDelphiName); + AddVariable('QUALIFIERBOLDTYPE' + PostFix + '.' + IntToStr(i), Mapping.ExpandedDelphiName); + AddVariable('QUALIFIERACCESSOR' + PostFix + '.' + IntToStr(i), Mapping.ExpandedAccessor); BoldGeneratorTemplatesManager.AddQualifierPropertyParam(QualifierPropertyParams, AttrOfOtherEnd.ExpandedDelphiName, Mapping.ExpandedNativeType); BoldGeneratorTemplatesManager.AddQualifierFunctionParam(QualifierFunctionParams, AttrOfOtherEnd.ExpandedDelphiName, Mapping.ExpandedNativeType); end @@ -365,10 +367,10 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH else AllOK := false; end; - AddVariable('QUALIFIERPROPERTYPARAMS' + PostFix, QualifierPropertyParams); // do not localize - AddVariable('QUALIFIERFUNCTIONPARAMS' + PostFix, QualifierFunctionParams); // do not localize - AddVariable('ROLEQUALIFIED' + PostFix, BoldBooleanToTemplateVar[AllOK and (MoldRole.Qualifiers.Count > 0)]); // do not localize - AddVariable('QUALIFIERCOUNT' + PostFix, IntToStr(MoldRole.Qualifiers.Count)); // do not localize + AddVariable('QUALIFIERPROPERTYPARAMS' + PostFix, QualifierPropertyParams); + AddVariable('QUALIFIERFUNCTIONPARAMS' + PostFix, QualifierFunctionParams); + AddVariable('ROLEQUALIFIED' + PostFix, BoldBooleanToTemplateVar[AllOK and (MoldRole.Qualifiers.Count > 0)]); + AddVariable('QUALIFIERCOUNT' + PostFix, IntToStr(MoldRole.Qualifiers.Count)); end; procedure InitializeRole(MoldRole: TMoldRole; const PostFix: String); @@ -379,50 +381,48 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH OtherEnd := MoldRole.MoldClass.LowestVisibleAncestor(MoldRole.OtherEnd.MoldClass); if (not MoldRole.Multi or UseTypedLists) and assigned(OtherEnd) then begin - AddVariable('MEMBERTYPE' + PostFix, OtherEnd.ExpandedDelphiName); // do not localize - AddVariable('MEMBERPERSISTENCEINTERFACE'+PostFix, MakePersistenceInterfaceName(OtherEnd)); // do not localize + AddVariable('MEMBERTYPE' + PostFix, OtherEnd.ExpandedDelphiName); + AddVariable('MEMBERPERSISTENCEINTERFACE'+PostFix, MakePersistenceInterfaceName(OtherEnd)); if GenerateIDLVariables then begin if GenerateMIDLCode then - AddVariable('MEMBERCOMTYPE' + PostFix, OtherEnd.ExpandedInterfaceName) // do not localize + AddVariable('MEMBERCOMTYPE' + PostFix, OtherEnd.ExpandedInterfaceName) else begin IDLTypeOfOtherEnd := MoldRole.MoldClass.LowestCommonSuperClass(OtherEnd); - - // stupid DelphiIDL-parser will not allow a list to know its own list-class since it is declared below itself if MoldRole.Multi and (MoldRole.MoldClass = IDLTypeOfOtherEnd) then IDLTypeOfOtherEnd := MoldRole.MoldClass.SuperClass; if assigned(IDLTypeOfOtherEnd) then - AddVariable('MEMBERCOMTYPE' + PostFix, IDLTypeOfOtherEnd.ExpandedInterfaceName) // do not localize + AddVariable('MEMBERCOMTYPE' + PostFix, IDLTypeOfOtherEnd.ExpandedInterfaceName) else - AddVariable('MEMBERCOMTYPE' + PostFix, 'IBoldObjectList') // do not localize + AddVariable('MEMBERCOMTYPE' + PostFix, 'IBoldObjectList') end; - AddVariable('MEMBERREALCOMTYPE' + PostFix, OtherEnd.ExpandedInterfaceName); // do not localize + AddVariable('MEMBERREALCOMTYPE' + PostFix, OtherEnd.ExpandedInterfaceName); end; end else begin - AddVariable('MEMBERTYPE' + PostFix, 'TBoldObject'); // do not localize + AddVariable('MEMBERTYPE' + PostFix, 'TBoldObject'); if GenerateIDLVariables then begin - AddVariable('MEMBERCOMTYPE' + PostFix, 'IBoldObject'); // do not localize - AddVariable('MEMBERREALCOMTYPE' + PostFix, 'IBoldObject'); // do not localize + AddVariable('MEMBERCOMTYPE' + PostFix, 'IBoldObject'); + AddVariable('MEMBERREALCOMTYPE' + PostFix, 'IBoldObject'); end; end; - AddVariable('DISPID' + PostFix, IntToHex(MoldRole.Dispid, 8)); // do not localize + AddVariable('DISPID' + PostFix, IntToHex(MoldRole.Dispid, 8)); if MoldRole.Multi then - AddVariable('MEMBERKIND' + PostFix, 'MultiRole') // do not localize + AddVariable('MEMBERKIND' + PostFix, 'MultiRole') else - AddVariable('MEMBERKIND' + PostFix, 'SingleRole'); // do not localize + AddVariable('MEMBERKIND' + PostFix, 'SingleRole'); - AddVariable('ISTRUEROLE' + PostFix, BoldBooleanToTemplateVar[MoldRole.RoleType = rtRole]); // do not localize - AddVariable('MEMBERVISIBILITY' + PostFix, VisibilityTOString[MoldRole.Visibility]); // do not localize - AddVariable('ROLENAVIGABLE' + PostFix, BoldBooleanToTemplateVar[MoldRole.Navigable]); // do not localize + AddVariable('ISTRUEROLE' + PostFix, BoldBooleanToTemplateVar[MoldRole.RoleType = rtRole]); + AddVariable('MEMBERVISIBILITY' + PostFix, VisibilityTOString[MoldRole.Visibility]); + AddVariable('ROLENAVIGABLE' + PostFix, BoldBooleanToTemplateVar[MoldRole.Navigable]); InitializeQualifier(MoldRole, PostFix); end; @@ -437,32 +437,31 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH if assigned(MoldClass) then case kind of - 0: result := 'object'; // do not localize + 0: result := 'object'; 1: result := ParameterDelphiType; 2: result := ''; end - else if SameText(ParameterType, 'STRING') then // do not localize + else if SameText(ParameterType, 'STRING') then case kind of - 0: result := 'attribute'; // do not localize - 1: result := 'TBAString'; // do not localize - 2: result := '.AsString'; // do not localize + 0: result := 'attribute'; + 1: result := 'TBAString'; + 2: result := '.AsString'; end - else if SameText(ParameterType, 'INTEGER') then // do not localize + else if SameText(ParameterType, 'INTEGER') then case kind of - 0: result := 'attribute'; // do not localize - 1: result := 'TBAInteger'; // do not localize - 2: result := '.AsInteger'; // do not localize + 0: result := 'attribute'; + 1: result := 'TBAInteger'; + 2: result := '.AsInteger'; end - else if SameText(ParameterType, 'DOUBLE') then // do not localize + else if SameText(ParameterType, 'DOUBLE') then case kind of - 0: result := 'attribute'; // do not localize - 1: result := 'TBAFloat'; // do not localize - 2: result := '.AsFloat'; // do not localize + 0: result := 'attribute'; + 1: result := 'TBAFloat'; + 2: result := '.AsFloat'; end else - Template.Variables.SetVariable('CASEMETHODISOCLCOMPATIBLE', '0'); // do not localize + Template.Variables.SetVariable('CASEMETHODISOCLCOMPATIBLE', '0'); end; - procedure InitializeDispIdMethod(MoldMethod: TMoldMethod; const postfix: String; DispIdOffset: integer); var i: integer; @@ -478,21 +477,19 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH ParametersToCoerce := TStringList.Create; ParametersToInterfaceCoerce := TStringList.create; try - AddVariable('COMMETHODHEADERINTERFACE' + PostFix, MethodToCOMHeader(MoldMethod.MoldClass, MoldMethod, true, ParametersToCoerce, ParametersToInterfaceCoerce)); // do not localize + AddVariable('COMMETHODHEADERINTERFACE' + PostFix, MethodToCOMHeader(MoldMethod.MoldClass, MoldMethod, true, ParametersToCoerce, ParametersToInterfaceCoerce)); if (ParametersToInterfaceCoerce.Count + ParametersTocoerce.Count) <> 0 then begin - // Com-adapter declares strings as WideString, but delphiclass as string... we must convert them if they are var-declared - VarDeclString := 'var' + BOLDCRLF; // do not localize + VarDeclString := 'var' + BOLDCRLF; ConvertString := ''; ConvertBackString := ''; for i := 0 to ParametersToCoerce.Count - 1 do begin - VarDeclString := VarDeclString + ' ' + ParametersToCoerce.Names[i] + '_temp: '+ ParametersToCoerce.values[ParametersToCoerce.Names[i]] + ';' + BOLDCRLF; // do not localize - ConvertString := ConvertString + ' ' + ParametersToCoerce.Names[i] + '_temp := ' + ParametersToCoerce.Names[i] + ';' + BOLDCRLF; // do not localize - ConvertBackString := ConvertBackString + ' ' + ParametersToCoerce.names[i] +' := ' + ParametersToCoerce.Names[i] + '_temp;' + BOLDCRLF; // do not localize + VarDeclString := VarDeclString + ' ' + ParametersToCoerce.Names[i] + '_temp: '+ ParametersToCoerce.values[ParametersToCoerce.Names[i]] + ';' + BOLDCRLF; + ConvertString := ConvertString + ' ' + ParametersToCoerce.Names[i] + '_temp := ' + ParametersToCoerce.Names[i] + ';' + BOLDCRLF; + ConvertBackString := ConvertBackString + ' ' + ParametersToCoerce.names[i] +' := ' + ParametersToCoerce.Names[i] + '_temp;' + BOLDCRLF; end; - for i := 0 to ParametersToInterfaceCoerce.Count - 1 do begin ParamName := ParametersToInterfaceCoerce.Names[i]; @@ -501,21 +498,21 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH ParamType := Copy(ParamType, 1, pos('=', ParamType) - 1); varDeclString := VarDeclString + - format(' %s_temp: %s;' + BOLDCRLF, [ParamName, ParamType]); // do not localize + format(' %s_temp: %s;' + BOLDCRLF, [ParamName, ParamType]); ConvertString := ConvertString + - format(' %s_temp := BoldComInterfaceToObject(%s) as %s;' + BOLDCRLF, [ParamName, ParamName, ParamType]); // do not localize + format(' %s_temp := BoldComInterfaceToObject(%s) as %s;' + BOLDCRLF, [ParamName, ParamName, ParamType]); ConvertBackString := ConvertBackString + - format(' BoldComCreateAdapter(%s_temp, False, %s, %s);' + BOLDCRLF, [ParamName, ParamInterfaceType, ParamName]); // do not localize + format(' BoldComCreateAdapter(%s_temp, False, %s, %s);' + BOLDCRLF, [ParamName, ParamInterfaceType, ParamName]); end; - AddVariable('COMMETHOD_TEMPVARS' + PostFix, VarDeclString); // do not localize - AddVariable('COMMETHOD_TEMPVARSCONVERT' + PostFix, ConvertString); // do not localize - AddVariable('COMMETHOD_TEMPVARSCONVERTBACK' + PostFix, ConvertBackString); // do not localize + AddVariable('COMMETHOD_TEMPVARS' + PostFix, VarDeclString); + AddVariable('COMMETHOD_TEMPVARSCONVERT' + PostFix, ConvertString); + AddVariable('COMMETHOD_TEMPVARSCONVERTBACK' + PostFix, ConvertBackString); end; - AddVariable('COMMETHODHEADERIMPLEMENTATION' + PostFix, MethodToCOMHeader(MoldMethod.MoldClass, MoldMethod, false, nil, nil)); // do not localize - AddVariable('METHODWRAPPERCALL' + PostFix, MethodToComCall(MoldMethod.MoldClass, MoldMethod, parametersToCoerce, ParametersToInterfaceCoerce)); // do not localize - AddVariable('IDLMETHODHEADER' + PostFix, MethodToIDLHeader(MoldMethod.MoldClass, MoldMethod)); // do not localize - AddVariable('METHODDISPID' + PostFix, IntToHex(DispIdOffset, 8)); // do not localize + AddVariable('COMMETHODHEADERIMPLEMENTATION' + PostFix, MethodToCOMHeader(MoldMethod.MoldClass, MoldMethod, false, nil, nil)); + AddVariable('METHODWRAPPERCALL' + PostFix, MethodToComCall(MoldMethod.MoldClass, MoldMethod, parametersToCoerce, ParametersToInterfaceCoerce)); + AddVariable('IDLMETHODHEADER' + PostFix, MethodToIDLHeader(MoldMethod.MoldClass, MoldMethod)); + AddVariable('METHODDISPID' + PostFix, IntToHex(DispIdOffset, 8)); finally ParametersToCoerce.Free; end; @@ -526,45 +523,43 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH i: integer; MethodType: String; begin - AddVariable('INTERFACEMETHODHEADER' + PostFix, MethodToDelphiHeader(MoldMethod.MoldClass, MoldMethod, Publictag, true, AutoOverride)); // do not localize - AddVariable('METHODNAME' + PostFix, MoldMethod.ExpandedDelphiName); // do not localize - AddVariable('METHODVISIBILITY' + PostFix, visibilityToString[MoldMethod.Visibility]); // do not localize + AddVariable('INTERFACEMETHODHEADER' + PostFix, MethodToDelphiHeader(MoldMethod.MoldClass, MoldMethod, Publictag, true, AutoOverride)); + AddVariable('METHODNAME' + PostFix, MoldMethod.ExpandedDelphiName); + AddVariable('METHODVISIBILITY' + PostFix, visibilityToString[MoldMethod.Visibility]); if MoldMethod.IsClassMethod then - MethodType := 'class ' // do not localize + MethodType := 'class ' else MethodType := ''; if MoldMethod.HasReturnValue then - MethodType := methodType + 'function' // do not localize + MethodType := methodType + 'function' else - MethodType := methodType + 'procedure'; // do not localize + MethodType := methodType + 'procedure'; - AddVariable('METHODKIND' + PostFix, MethodType); // do not localize + AddVariable('METHODKIND' + PostFix, MethodType); - AddVariable('METHODISOCLCOMPATIBLE' + PostFix, '1'); // do not localize + AddVariable('METHODISOCLCOMPATIBLE' + PostFix, '1'); if MoldMethod.HasReturnValue then begin - AddVariable('METHODRESULTBOLDTYPE' + PostFix, ParameterInfo(MoldMethod, MoldMethod.ReturnType, MoldMethod.DelphiReturnType, 1)); // do not localize - AddVariable('METHODRESULTACCESSOR' + PostFix, ParameterInfo(MoldMethod, MoldMethod.ReturnType, MoldMethod.DelphiReturnType, 2)); // do not localize - end - else - begin - AddVariable('METHODRESULTBOLDTYPE' + PostFix, 'TBAInteger'); // do not localize - AddVariable('METHODRESULTACCESSOR' + PostFix, '.AsInteger'); // do not localize + AddVariable('METHODRESULTBOLDTYPE' + PostFix, ParameterInfo(MoldMethod, MoldMethod.ReturnType, MoldMethod.DelphiReturnType, 1)); + AddVariable('METHODRESULTACCESSOR' + PostFix, ParameterInfo(MoldMethod, MoldMethod.ReturnType, MoldMethod.DelphiReturnType, 2)); + end else begin + AddVariable('METHODRESULTBOLDTYPE' + PostFix, 'TBAInteger'); + AddVariable('METHODRESULTACCESSOR' + PostFix, '.AsInteger'); end; for i := 0 to MoldMethod.Parameters.count - 1 do begin with TMoldParameter(MoldMethod.Parameters[i]) do begin - AddVariable('METHODPARAMETERKIND' + PostFix + '.' + IntToStr(i), ParameterInfo(MoldMethod, ParameterType, DelphiParameterType, 0)); // do not localize - AddVariable('METHODPARAMETERBOLDTYPE' + PostFix + '.' + IntToStr(i), ParameterInfo(MoldMethod, ParameterType, DelphiParameterType, 1)); // do not localize - AddVariable('METHODPARAMETERACCESSOR' + PostFix + '.' + IntToStr(i), ParameterInfo(MoldMethod, ParameterType, DelphiParameterType, 2)); // do not localize + AddVariable('METHODPARAMETERKIND' + PostFix + '.' + IntToStr(i), ParameterInfo(MoldMethod, ParameterType, DelphiParameterType, 0)); + AddVariable('METHODPARAMETERBOLDTYPE' + PostFix + '.' + IntToStr(i), ParameterInfo(MoldMethod, ParameterType, DelphiParameterType, 1)); + AddVariable('METHODPARAMETERACCESSOR' + PostFix + '.' + IntToStr(i), ParameterInfo(MoldMethod, ParameterType, DelphiParameterType, 2)); end; end; - AddVariable('METHODPARAMETERCOUNT' + PostFix, IntToStr(MoldMethod.Parameters.count)); // do not localize + AddVariable('METHODPARAMETERCOUNT' + PostFix, IntToStr(MoldMethod.Parameters.count)); end; procedure InitializeClass(MoldClass: TMoldClass; const PostFix: String); @@ -573,55 +568,59 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH Attribute: TMoldAttribute; Member: TMoldMember; MemberPostFix: String; + MethodCount : Integer; begin - AddVariable('CLASSNAME' + PostFix, MoldClass.ExpandedDelphiName); // do not localize + AddVariable('CLASSNAME' + PostFix, MoldClass.ExpandedDelphiName); if MoldClass.GUID <> '' then - AddVariable('CLASSGUID' + PostFix, MoldClass.GUID) // do not localize + AddVariable('CLASSGUID' + PostFix, MoldClass.GUID) else - AddVariable('CLASSGUID' + PostFix, BoldCreateGUIDAsString(true)); // do not localize + AddVariable('CLASSGUID' + PostFix, BoldCreateGUIDAsString(true)); if MoldClass.ListGUID <> '' then - AddVariable('LISTGUID' + PostFix, MoldClass.ListGUID) // do not localize + AddVariable('LISTGUID' + PostFix, MoldClass.ListGUID) else - AddVariable('LISTGUID' + PostFix, BoldCreateGUIDAsString(true)); // do not localize + AddVariable('LISTGUID' + PostFix, BoldCreateGUIDAsString(true)); - AddVariable('INTERFACENAME' + PostFix, MoldClass.ExpandedInterfaceName); // do not localize - AddVariable('PERSISTENCEINTERFACENAME' + PostFix, MakePersistenceInterfaceName(MoldClass)); // do not localize - AddVariable('PERSISTENCEINTERFACEGUID' + PostFix, BoldCreateGUIDWithBracketsAsString); // do not localize + AddVariable('INTERFACENAME' + PostFix, MoldClass.ExpandedInterfaceName); + AddVariable('PERSISTENCEINTERFACENAME' + PostFix, MakePersistenceInterfaceName(MoldClass)); + AddVariable('PERSISTENCEINTERFACEGUID' + PostFix, BoldCreateGUIDWithBracketsAsString); - AddVariable('ISVERSIONED' + PostFix, BoldBooleanToTemplateVar[MoldClass.Versioned]); // do not localize + AddVariable('ISVERSIONED' + PostFix, BoldBooleanToTemplateVar[MoldClass.Versioned]); - AddVariable('ISLINKCLASS' + PostFix, BoldBooleanToTemplateVar[Assigned(MoldClass.Association)]); // do not localize - AddVariable('CLASSEXPRESSIONNAME' + PostFix, MoldClass.ExpandedExpressionName); // do not localize + AddVariable('ISLINKCLASS' + PostFix, BoldBooleanToTemplateVar[Assigned(MoldClass.Association)]); + AddVariable('CLASSEXPRESSIONNAME' + PostFix, MoldClass.ExpandedExpressionName); if Assigned(MoldClass.SuperClass) then begin - AddVariable('SUPERCLASSNAME' + PostFix, MoldClass.SuperClass.ExpandedDelphiName); // do not localize - AddVariable('SUPERPERSISTENCEINTERFACENAME' + PostFix, MakePersistenceInterfaceName(MoldClass.SuperClass)); // do not localize + AddVariable('SUPERCLASSNAME' + PostFix, MoldClass.SuperClass.ExpandedDelphiName); + AddVariable('SUPERPERSISTENCEINTERFACENAME' + PostFix, MakePersistenceInterfaceName(MoldClass.SuperClass)); end else begin - AddVariable('SUPERCLASSNAME' + PostFix, 'TBoldObject'); // do not localize - AddVariable('SUPERCLASSNAMESPACEPREFIX' + PostFix, 'Boldsystem::'); // do not localize - AddVariable('CONSTRUCTORPARAMETER' + PostFix, ', true'); // do not localize - AddVariable('SUPERPERSISTENCEINTERFACENAME' + PostFix, 'IPersistentBoldObject'); // do not localize + AddVariable('SUPERCLASSNAME' + PostFix, 'TBoldObject'); + AddVariable('SUPERCLASSNAMESPACEPREFIX' + PostFix, 'Boldsystem::'); + AddVariable('CONSTRUCTORPARAMETER' + PostFix, ', true'); + AddVariable('SUPERPERSISTENCEINTERFACENAME' + PostFix, 'IPersistentBoldObject'); end; if GenerateIDLVariables then begin if assigned(MoldClass.SuperClass) then - AddVariable('SUPERINTERFACE' + PostFix, MoldClass.SuperClass.ExpandedInterfaceName) // do not localize + AddVariable('SUPERINTERFACE' + PostFix, MoldClass.SuperClass.ExpandedInterfaceName) else - AddVariable('SUPERINTERFACE' + PostFix, 'IBoldObject'); // do not localize + AddVariable('SUPERINTERFACE' + PostFix, 'IBoldObject'); if Assigned(MoldClass.SuperClass) then - AddVariable('SUPERADAPTERNAME' + PostFix, MoldClass.SuperClass.ExpandedDelphiName) // do not localize + AddVariable('SUPERADAPTERNAME' + PostFix, MoldClass.SuperClass.ExpandedDelphiName) else - AddVariable('SUPERADAPTERNAME' + PostFix, 'TBoldComObject'); // do not localize + AddVariable('SUPERADAPTERNAME' + PostFix, 'TBoldComObject'); end; if MoldClass.IntroducesManuallyDerivedMembers then - AddVariable('CLASSINTRODUCESMANUALLYDERIVEDMEMBERS' + PostFix, 'true'); // do not localize + AddVariable('CLASSINTRODUCESMANUALLYDERIVEDMEMBERS' + PostFix, 'true'); + + if MoldClass.IntroducesManuallyReverseDerivedMembers then + AddVariable('CLASSINTRODUCESMANUALLYREVERSEDERIVEDMEMBERS' + PostFix, 'true'); membercounter := 0; @@ -629,10 +628,10 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH begin Member := MoldClass.AllBoldMembers[i]; MemberpostFix := PostFix + '.' + IntTostr(i - MoldClass.FirstOwnBoldMemberIndex); - AddVariable('MEMBERNAME' + MemberPostFix, Member.ExpandedDelphiName); // do not localize - AddVariable('MEMBERINDEX' + MemberPostFix, IntToStr(i)); // do not localize + AddVariable('MEMBERNAME' + MemberPostFix, Member.ExpandedDelphiName); + AddVariable('MEMBERINDEX' + MemberPostFix, IntToStr(i)); - AddVariable('MEMBERPERSISTENT' + MemberPostFix, BoldBooleanToTemplateVar[Member.EffectivePersistent]); // do not localize + AddVariable('MEMBERPERSISTENT' + MemberPostFix, BoldBooleanToTemplateVar[Member.EffectivePersistent]); if Member is TMoldAttribute then InitializeAttribute(Member as TMoldAttribute, MemberPostFix) @@ -641,9 +640,28 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH Inc(MemberCounter); end; - AddVariable('MEMBERCOUNT' + Postfix, IntToStr(MemberCounter)); // do not localize + AddVariable('MEMBERCOUNT' + Postfix, IntToStr(MemberCounter)); + membercounter := 0; + + for i := 0 to MoldClass.AllBoldMembers.Count - 1 do + begin + Member := MoldClass.AllBoldMembers[i]; + MemberpostFix := '-ALL' + PostFix + '.' + IntTostr(i); + AddVariable('MEMBERNAME' + MemberPostFix, Member.ExpandedDelphiName); + AddVariable('MEMBERINDEX' + MemberPostFix, IntToStr(i)); + + AddVariable('MEMBERPERSISTENT' + MemberPostFix, BoldBooleanToTemplateVar[Member.EffectivePersistent]); + + if Member is TMoldAttribute then + InitializeAttribute(Member as TMoldAttribute, MemberPostFix) + else if Member is TMoldRole then + InitializeRole(Member as TMoldRole, MemberPostFix); + Inc(MemberCounter); + end; + AddVariable('MEMBERCOUNT-ALL' + Postfix , IntToStr(MemberCounter)); membercounter := 0; + for i := MoldClass.FirstOwnNativeAttributeIndex to MoldClass.AllNativeAttributes.Count - 1 do begin Attribute := MoldClass.AllNativeAttributes[i]; @@ -651,12 +669,12 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH if (Attribute.DelphiPropertyRead <> pkNone) or (Attribute.DelphiPropertyWrite <> pkNone) then begin MemberpostFix := PostFix + '.' + IntTostr(i - MoldClass.FirstOwnNativeAttributeIndex); - AddVariable('DelphiAttributeName' + MemberPostFix, Attribute.ExpandedDelphiName); // do not localize + AddVariable('DelphiAttributeName' + MemberPostFix, Attribute.ExpandedDelphiName); InitializeNativeAttribute(Attribute, MemberPostFix); Inc(MemberCounter); end; end; - AddVariable('DelphiAttributeCount' + Postfix, IntToStr(MemberCounter)); // do not localize + AddVariable('DelphiAttributeCount' + Postfix, IntToStr(MemberCounter)); for i := 0 to MoldClass.Methods.Count - 1 do InitializeMethod(MoldClass.Methods[i], PostFix + '.' + IntToStr(i), false); @@ -664,7 +682,7 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH for i := 0 to MoldClass.AllAutoOverrideMethods.Count - 1 do InitializeMethod(MoldClass.AllAutoOverrideMethods[i], PostFix + '.' + IntToStr(MoldClass.Methods.Count + i), true); - AddVariable('METHODCOUNT' + PostFix, IntToStr(MoldClass.Methods.Count + MoldClass.AllAutoOverrideMethods.Count)); // do not localize + AddVariable('METHODCOUNT' + PostFix, IntToStr(MoldClass.Methods.Count + MoldClass.AllAutoOverrideMethods.Count)); if GenerateIDLVariables then begin @@ -675,25 +693,27 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH InitializeDispIDMethod(MoldClass.Methods[i], PostFix + '.' + IntToStr(MemberCounter), MoldClass.Methods[i].DispId); Inc(MemberCounter); end; - AddVariable('DISPIDMETHODCOUNT' + PostFix, IntToStr(MemberCounter)); // do not localize + AddVariable('DISPIDMETHODCOUNT' + PostFix, IntToStr(MemberCounter)); end; Derivedcounter := 0; for i := 0 to MoldClass.AllBoldMembers.Count - 1 do begin - if MoldClass.AllBoldMembers[i].ManuallyDerived and + if (MoldClass.AllBoldMembers[i].Derived and((MoldClass.AllBoldMembers[i].Derivationocl = '') or MoldClass.AllBoldMembers[i].ReverseDerived)) and ((MoldClass.AllBoldMembers[i].MoldClass = MoldClass) or (TVIsTrue(MoldClass.AllBoldMembers[i].BoldTVByName[TAG_VIRTUALDERIVE]))) then begin - AddVariable('DERIVEDMEMBERINTRODUCEDHERE' + Postfix + '.' + IntToStr(DerivedCounter), BoldBooleanToTemplateVar[MoldClass.AllBoldMembers[i].MoldClass = MoldClass]); // do not localize - AddVariable('DERIVEDMEMBERREVERSEDERIVED' + Postfix + '.' + IntToStr(DerivedCounter), BoldBooleanToTemplateVar[MoldClass.AllBoldMembers[i].ReverseDerived]); // do not localize + AddVariable('DERIVEDMEMBERINTRODUCEDHERE' + Postfix + '.' + IntToStr(DerivedCounter), BoldBooleanToTemplateVar[MoldClass.AllBoldMembers[i].MoldClass = MoldClass]); + AddVariable('DERIVEDMEMBERREVERSEDERIVED' + Postfix + '.' + IntToStr(DerivedCounter), BoldBooleanToTemplateVar[MoldClass.AllBoldMembers[i].ReverseDerived]); + AddVariable('DERIVEDMEMBERFORWARDCODEDERVIED' + Postfix + '.' + IntToStr(DerivedCounter), BoldBooleanToTemplateVar[MoldClass.AllBoldMembers[i].ManuallyDerived]); - AddVariable('DERIVEDMEMBERNAME' + Postfix + '.' + IntToStr(DerivedCounter), MoldClass.AllBoldMembers[i].ExpandedDelphiName); // do not localize + AddVariable('DERIVEDMEMBERNAME' + Postfix + '.' + IntToStr(DerivedCounter), MoldClass.AllBoldMembers[i].ExpandedDelphiName); + AddVariable('DERIVEDMEMBERINDEX' + Postfix + '.' + IntToStr(DerivedCounter), IntToStr(i)); Inc(DerivedCounter); end; end; - AddVariable('DERIVEDMEMBERCOUNT' + Postfix, IntToStr(DerivedCounter)); // do not localize + AddVariable('DERIVEDMEMBERCOUNT' + Postfix, IntToStr(DerivedCounter)); end; procedure BuildListOfAllUsedUnits(StringList: TStringList); @@ -711,10 +731,10 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH begin Mapping := TypenameDictionary.MappingForModelName[Model.Classes[c].Attributes[a].BoldType]; if Assigned(Mapping) then - if (Mapping.UnitNameText = '') then - StringList.Add('BoldAttributes') // do not localize + if (Mapping.UnitName = '') then + StringList.Add('BoldAttributes') else - StringList.Add(Mapping.UnitNameText); + StringList.Add(Mapping.UnitName); end; end; end; @@ -722,39 +742,39 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH begin Template.Variables.Clear; if GenerateMIDLCode then - AddVariable('FORWARDDECLAREINTERFACES', '1'); // do not localize - AddVariable('USETYPEDLISTS', BoldBooleanToTemplateVar[useTypedLIsts]); // do not localize - AddVariable('UNITNAME', Component.Name); // do not localize + AddVariable('FORWARDDECLAREINTERFACES', '1'); + AddVariable('USETYPEDLISTS', BoldBooleanToTemplateVar[useTypedLIsts]); + AddVariable('UNITNAME', Component.Name); if MoldModel.GUID <> '' then - AddVariable('UNITGUID', MoldModel.GUID) // do not localize + AddVariable('UNITGUID', MoldModel.GUID) else - AddVariable('UNITGUID', BoldCreateGUIDAsString(true)); // do not localize + AddVariable('UNITGUID', BoldCreateGUIDAsString(true)); - AddVariable('CRC', MoldModel.CRC); // do not localize + AddVariable('CRC', MoldModel.CRC); - AddVariable('COPYRIGHTNOTICE', Model.BoldTVByName['CopyrightNotice']); // do not localize + AddVariable('COPYRIGHTNOTICE', Model.BoldTVByName['CopyrightNotice']); Dependencies := TStringList.Create; Component.GetInterfaceDependencies(Dependencies); for i := 0 to Dependencies.Count - 1 do begin - AddVariable('INTERFACEADAPTERDEPENDENCY.' + IntToStr(i), Dependencies[i] + 'Adapters'); // do not localize - AddVariable('INTERFACEDEPENDENCY.' + IntToStr(i), Dependencies[i]); // do not localize + AddVariable('INTERFACEADAPTERDEPENDENCY.' + IntToStr(i), Dependencies[i] + 'Adapters'); + AddVariable('INTERFACEDEPENDENCY.' + IntToStr(i), Dependencies[i]); end; - AddVariable('INTERFACEDEPENDENCIESCOUNT', IntToStr(Dependencies.Count)); // do not localize + AddVariable('INTERFACEDEPENDENCIESCOUNT', IntToStr(Dependencies.Count)); Component.GetImplementationDependencies(Dependencies); for i := 0 to Dependencies.Count - 1 do begin - AddVariable('IMPLEMENTATIONADAPTERDEPENDENCY.' + IntToStr(i), Dependencies[i] + 'Adapters'); // do not localize - AddVariable('IMPLEMENTATIONDEPENDENCY.' + IntToStr(i), Dependencies[i]); // do not localize + AddVariable('IMPLEMENTATIONADAPTERDEPENDENCY.' + IntToStr(i), Dependencies[i] + 'Adapters'); + AddVariable('IMPLEMENTATIONDEPENDENCY.' + IntToStr(i), Dependencies[i]); end; - AddVariable('IMPLEMENTATIONDEPENDENCIESCOUNT', IntToStr(Dependencies.Count)); // do not localize + AddVariable('IMPLEMENTATIONDEPENDENCIESCOUNT', IntToStr(Dependencies.Count)); BuildListOfAllUsedUnits(Dependencies); for i := 0 to Dependencies.Count-1 do - AddVariable('ATTRIBUTECLASSDEPENDENCY.'+IntToStr(i), Dependencies[i]); // do not localize - AddVariable('ATTRIBUTECLASSDEPENDENCIESCOUNT', IntToStr(Dependencies.Count)); // do not localize + AddVariable('ATTRIBUTECLASSDEPENDENCY.'+IntToStr(i), Dependencies[i]); + AddVariable('ATTRIBUTECLASSDEPENDENCIESCOUNT', IntToStr(Dependencies.Count)); Dependencies.Free; @@ -765,17 +785,17 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH temp := temp + Model.Components[i].Name end; - AddVariable('ALLCOMPONENTS', temp); // do not localize + AddVariable('ALLCOMPONENTS', temp); ClassCount := 0; - AddVariable('MODELNAME', MoldModel.ExpandedExpressionName); // do not localize + AddVariable('MODELNAME', MoldModel.ExpandedExpressionName); if MoldModel.Interfaceuses <> '' then - AddVarList(Template, 'INTERFACEUSES', MoldModel.InterfaceUses + ','); // do not localize + AddVarList(Template, 'INTERFACEUSES', MoldModel.InterfaceUses + ','); if MoldModel.ImplementationUses <> '' then - AddVarList(Template, 'IMPLEMENTATIONUSES', MoldModel.ImplementationUses + ','); // do not localize + AddVarList(Template, 'IMPLEMENTATIONUSES', MoldModel.ImplementationUses + ','); IncludeFiles := TStringList.Create; @@ -793,7 +813,7 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH end; if (ClassCount + 1) mod DEBUGGERWORKAROUNDINTERVAL = 0 then - AddVariable('DEBUGGERWORKAROUND.' + IntTostr(ClassCount), '1'); // do not localize + AddVariable('DEBUGGERWORKAROUND.' + IntTostr(ClassCount), '1'); InitializeClass(MoldModel.Classes[i], '.' + IntTostr(ClassCount)); inc(ClassCount); @@ -805,19 +825,17 @@ procedure TBoldGenerator.InitializeTemplateForComponent(Template: TBoldTemplateH end; end; - AddVariable('CLASSCOUNT', IntToStr(ClassCount)); // do not localize + AddVariable('CLASSCOUNT', IntToStr(ClassCount)); for i := 0 to IncludeFiles.Count - 1 do - AddVariable('INCLUDEFILE.' + IntToStr(i), IncludeFiles[i]); // do not localize - AddVariable('INCLUDEFILECOUNT', IntToStr(includeFiles.Count)); // do not localize + AddVariable('INCLUDEFILE.' + IntToStr(i), IncludeFiles[i]); + AddVariable('INCLUDEFILECOUNT', IntToStr(includeFiles.Count)); if GenerateBold1CompatibleCode then - AddVariable('DELPHIATTRIBUTEPOSTFIX', '_') // do not localize + AddVariable('DELPHIATTRIBUTEPOSTFIX', '_') else - AddVariable('BOLDATTRIBUTEPOSTFIX', 'Attribute'); // do not localize + AddVariable('BOLDATTRIBUTEPOSTFIX', 'Attribute'); IncludeFiles.Free; - -// Template.Variables.finalize; end; procedure TBoldGenerator.SetCurrentFileHandler(const path, Filename: string; ModuleType: TBoldModuleType; Show: boolean; IsIncFile: Boolean); @@ -856,8 +874,8 @@ procedure InitializeMethod(MoldClass: TMoldClass; MoldMethod: TMoldMethod; Varia begin inheritedCall := BoldGeneratorTemplatesManager.GenerateInheritedCall(MoldClass, MoldMethod); - Variables.SetVariable('INHERITEDCALL', InheritedCall); // do not localize - Variables.SetVariable('CLASSNAME', MoldClass.ExpandedDelphiName); // do not localize + Variables.SetVariable('INHERITEDCALL', InheritedCall); + Variables.SetVariable('CLASSNAME', MoldClass.ExpandedDelphiName); AddSuperClassName(Variables, MoldClass); end; @@ -880,14 +898,12 @@ procedure InitializeMethod(MoldClass: TMoldClass; MoldMethod: TMoldMethod; Varia LastIncFileName := CurrentIncFileName; CurrentIncFileName := CurrentClass.EffectiveIncFileName(BoldGeneratorTemplatesManager.DefaultIncFileExtension); - if AnsiCompareText(LastIncFileName, CurrentIncFileName) <> 0 then + if CompareText(LastIncFileName, CurrentIncFileName) <> 0 then begin SetCurrentFileHandler(BaseFilePath, CurrentIncFileName, mtIncFile, true, true); initializeMethodIndex; end; - BoldLog.LogFmt(sProcessingClassXFileY, [CurrentClass.Name, CurrentIncFileName]); - - // userdefined methods + BoldLog.LogFmt('Processing class %s, file %s', [CurrentClass.Name, CurrentIncFileName]); for i := 0 to CurrentClass.Methods.Count - 1 do if CurrentClass.Methods[i].FuncType <> dfAbstractVirtual then @@ -895,26 +911,22 @@ procedure InitializeMethod(MoldClass: TMoldClass; MoldMethod: TMoldMethod; Varia with BoldGeneratorTemplatesManager.MethodTemplate do begin InitializeMethod(CurrentClass, CurrentClass.Methods[i], Variables); - Variables.Setvariable('METHODHEADER', MethodToDelphiHeader(CurrentClass, CurrentClass.Methods[i], ImplementationTag, true, false)); // do not localize - Variables.SetVariable('CALLINHERITED', BoldBooleanToTemplateVar[CurrentClass.Methods[i].CanCallInherited]); // do not localize + Variables.Setvariable('METHODHEADER', MethodToDelphiHeader(CurrentClass, CurrentClass.Methods[i], ImplementationTag, true, false)); + Variables.SetVariable('CALLINHERITED', BoldBooleanToTemplateVar[CurrentClass.Methods[i].CanCallInherited]); EnsureMethod(ExpandedTemplate); end; end; - - // autooverride methods for i := 0 to CurrentClass.AllAutoOverrideMethods.Count - 1 do with BoldGeneratorTemplatesManager.MethodTemplate do begin MoldMethod := CurrentClass.AllAutoOverrideMethods[i]; InitializeMethod(CurrentClass, MoldMethod, Variables); - Variables.Setvariable('METHODHEADER', MethodToDelphiHeader(CurrentClass, CurrentClass.AllAutoOverrideMethods[i], ImplementationTag, true, true)); // do not localize + Variables.Setvariable('METHODHEADER', MethodToDelphiHeader(CurrentClass, CurrentClass.AllAutoOverrideMethods[i], ImplementationTag, true, true)); SuperMethodIsAbstract := (MoldMethod.funcType = dfAbstractVirtual) and (CurrentClass.SuperClass = MoldMethod.Moldclass); - Variables.SetVariable('CALLINHERITED', BoldBooleanToTemplateVar[not SuperMethodIsAbstract]); // do not localize + Variables.SetVariable('CALLINHERITED', BoldBooleanToTemplateVar[not SuperMethodIsAbstract]); EnsureMethod(ExpandedTemplate); end; - // native attributes get-method - for i := CurrentClass.FirstOwnNativeAttributeIndex to CurrentClass.AllNativeAttributes.Count - 1 do begin Attr := CurrentClass.AllNativeAttributes[i]; @@ -923,17 +935,15 @@ procedure InitializeMethod(MoldClass: TMoldClass; MoldMethod: TMoldMethod; Varia TypeName := GetNativeDelphiTypeForModelNameNoDefaults(Attr); with BoldGeneratorTemplatesManager.MethodTemplate do begin - Variables.SetVariable('CLASSNAME', CurrentClass.ExpandedDelphiName); // do not localize - Variables.Setvariable('METHODHEADER', BoldGeneratorTemplatesManager.readMethodSignature( // do not localize + Variables.SetVariable('CLASSNAME', CurrentClass.ExpandedDelphiName); + Variables.Setvariable('METHODHEADER', BoldGeneratorTemplatesManager.readMethodSignature( CurrentClass.ExpandedDelphiName, Attr.ExpandedDelphiName, TypeName)); - Variables.SetVariable('CALLINHERITED', BoldBooleanToTemplateVar[False]); // do not localize + Variables.SetVariable('CALLINHERITED', BoldBooleanToTemplateVar[False]); EnsureMethod(ExpandedTemplate); end; end; end; - // native attributes set-method - for i := CurrentClass.FirstOwnNativeAttributeIndex to CurrentClass.AllNativeAttributes.Count - 1 do begin Attr := CurrentClass.AllNativeAttributes[i]; @@ -942,57 +952,56 @@ procedure InitializeMethod(MoldClass: TMoldClass; MoldMethod: TMoldMethod; Varia TypeName := GetNativeDelphiTypeForModelNameNoDefaults(Attr); with BoldGeneratorTemplatesManager.MethodTemplate do begin - Variables.SetVariable('CLASSNAME', CurrentClass.ExpandedDelphiName); // do not localize - Variables.Setvariable('METHODHEADER', BoldGeneratorTemplatesManager.WriteMethodSignature( // do not localize + Variables.SetVariable('CLASSNAME', CurrentClass.ExpandedDelphiName); + Variables.Setvariable('METHODHEADER', BoldGeneratorTemplatesManager.WriteMethodSignature( CurrentClass.ExpandedDelphiName, Attr.ExpandedDelphiName, TypeName)); - Variables.SetVariable('CALLINHERITED', BoldBooleanToTemplateVar[false]); // do not localize + Variables.SetVariable('CALLINHERITED', BoldBooleanToTemplateVar[false]); EnsureMethod(ExpandedTemplate); end; end; end; - // derived Members (always procedures) - for i := 0 to CurrentClass.AllBoldMembers.Count - 1 do - if CurrentClass.AllBoldMembers[i].ManuallyDerived and ( - (i >= CurrentClass.FirstOwnBoldMemberIndex) or - (TVIsTrue(CurrentClass.AllBoldMembers[i].BoldTVByName[TAG_VIRTUALDERIVE]))) then + if (CurrentClass.AllBoldMembers[i].Derived and((CurrentClass.AllBoldMembers[i].DerivationOcl = '') or CurrentClass.AllBoldMembers[i].ReverseDerived)) and + ( + (i >= CurrentClass.FirstOwnBoldMemberIndex) or + (TVIsTrue(CurrentClass.AllBoldMembers[i].BoldTVByName[TAG_VIRTUALDERIVE])) + ) then begin - - with BoldGeneratorTemplatesManager.DerivedMethodTemplate do - begin - if (CurrentClass.AllBoldMembers[i] is TMoldAttribute) then - Mapping := TypeNameDictionary.MappingForModelName[(CurrentClass.AllBoldMembers[i] as TMoldAttribute).BoldType] - else - Mapping := nil; - if assigned(Mapping) and - (Mapping.ExpandedAccessor <> '') and - (Mapping.ExpandedNativeType <> '') then + if CurrentClass.AllBoldMembers[i].ManuallyDerived then + with BoldGeneratorTemplatesManager.DerivedMethodTemplate do begin - Variables.SetVariable('MEMBERHASNATIVE', '1'); // do not localize - Variables.SetVariable('MEMBERNATIVEACCESSOR', Mapping.ExpandedAccessor); // do not localize - Variables.SetVariable('MEMBERNATIVETYPE', Mapping.ExpandedNativeType); // do not localize - end - else - Variables.SetVariable('MEMBERHASNATIVE', '0'); // do not localize - - Variables.SetVariable('CLASSNAME', CurrentClass.ExpandedDelphiName); // do not localize - Variables.SetVariable('INHERITEDCALL', 'inherited'); // do not localize - Variables.SetVariable('INTRODUCEDHERE', BoldBooleanToTemplateVar [i >= CurrentClass.FirstOwnBoldMemberIndex]); // do not localize - Variables.SetVariable('MEMBERNAME', CurrentClass.AllBoldMembers[i].ExpandedDelphiName); // do not localize - AddSuperClassName(variables, CurrentClass); - EnsureMethod(ExpandedTemplate); - end; - if CurrentClass.AllBoldMembers[i].ReverseDerived then - with BoldGeneratorTemplatesManager.ReverseDeriveMethodTemplate do - begin - Variables.SetVariable('CLASSNAME', CurrentClass.ExpandedDelphiName); // do not localize - Variables.SetVariable('INHERITEDCALL', 'inherited'); // do not localize - Variables.SetVariable('INTRODUCEDHERE', BoldBooleanToTemplateVar[i >= CurrentClass.FirstOwnBoldMemberIndex]); // do not localize - Variables.SetVariable('MEMBERNAME', CurrentClass.AllBoldMembers[i].ExpandedDelphiName); // do not localize + if (CurrentClass.AllBoldMembers[i] is TMoldAttribute) then + Mapping := TypeNameDictionary.MappingForModelName[(CurrentClass.AllBoldMembers[i] as TMoldAttribute).BoldType] + else + Mapping := nil; + if assigned(Mapping) and + (Mapping.ExpandedAccessor <> '') and + (Mapping.ExpandedNativeType <> '') then + begin + Variables.SetVariable('MEMBERHASNATIVE', '1'); + Variables.SetVariable('MEMBERNATIVEACCESSOR', Mapping.ExpandedAccessor); + Variables.SetVariable('MEMBERNATIVETYPE', Mapping.ExpandedNativeType); + end else + Variables.SetVariable('MEMBERHASNATIVE', '0'); + + Variables.SetVariable('CLASSNAME', CurrentClass.ExpandedDelphiName); + Variables.SetVariable('INHERITEDCALL', 'inherited'); + Variables.SetVariable('INTRODUCEDHERE', BoldBooleanToTemplateVar [i >= CurrentClass.FirstOwnBoldMemberIndex]); + Variables.SetVariable('MEMBERNAME', CurrentClass.AllBoldMembers[i].ExpandedDelphiName); AddSuperClassName(variables, CurrentClass); EnsureMethod(ExpandedTemplate); end; + if CurrentClass.AllBoldMembers[i].Derived and CurrentClass.AllBoldMembers[i].ReverseDerived then + with BoldGeneratorTemplatesManager.ReverseDeriveMethodTemplate do + begin + Variables.SetVariable('CLASSNAME', CurrentClass.ExpandedDelphiName); + Variables.SetVariable('INHERITEDCALL', 'inherited'); + Variables.SetVariable('INTRODUCEDHERE', BoldBooleanToTemplateVar[i >= CurrentClass.FirstOwnBoldMemberIndex]); + Variables.SetVariable('MEMBERNAME', CurrentClass.AllBoldMembers[i].ExpandedDelphiName); + AddSuperClassName(variables, CurrentClass); + EnsureMethod(ExpandedTemplate); + end; end; end; BoldLog.progressStep; @@ -1002,7 +1011,6 @@ procedure InitializeMethod(MoldClass: TMoldClass; MoldMethod: TMoldMethod; Varia end; end; - function TBoldGenerator.MethodToCOMHeader(OwningClass: TMoldClass; Method: TMoldMethod; InterfaceCode: Boolean; ParametersToCoerce, ParametersToInterfaceCoerce: TStringList): String; begin result := BoldGeneratorTemplatesManager.MethodToCOMHeader(OwningClass, Method, InterfaceCode, ParametersToCoerce, ParametersToInterfaceCoerce, MoldModel, GenerateMIDLCode); @@ -1024,10 +1032,10 @@ function TBoldGenerator.MethodToIDLHeader(OwningClass: TMoldClass; Method: TMold params := params + ', '; Param := TMoldParameter(Method.Parameters[i]); case param.ParameterKind of - pdIn: P := '[in]'; // do not localize - pdOut: P := '[out]'; // do not localize - pdInout: P := '[in, out]'; // do not localize - pdReturn: P := '[out, retval]'; // do not localize + pdIn: P := '[in]'; + pdOut: P := '[out]'; + pdInout: P := '[in, out]'; + pdReturn: P := '[out, retval]'; end; paramType := TBoldMetaSupport.ParameterTypeToIDLType(Param.ParameterType, MoldModel, IsPtr); if not GenerateMIDLCode then @@ -1051,15 +1059,15 @@ function TBoldGenerator.MethodToIDLHeader(OwningClass: TMoldClass; Method: TMold if not GenerateMIDLCode then P := EnsureSafeIDLType(P, Method.MoldClass); - p := p + '*'; // retval + p := p + '*'; if IsPtr then p := p + '*'; - Params := Params + '[out, retval] ' + p + ' ReturnParam'; // do not localize + Params := Params + '[out, retval] ' + p + ' ReturnParam'; end; if params = '' then - params := 'void'; // do not localize + params := 'void'; result := Method.ExpandedDelphiName + '(' + Params + ')'; end; @@ -1086,7 +1094,6 @@ function TBoldGenerator.FindInCurrentFile(s: String): Boolean; begin result := false; s := Uppercase(s); - // This code only searches for the name, not the signature. for i := 0 to MethodIndex.count - 1 do begin @@ -1096,6 +1103,7 @@ function TBoldGenerator.FindInCurrentFile(s: String): Boolean; exit; end; end; + end; procedure TBoldGenerator.InitializeMethodIndex; @@ -1186,10 +1194,10 @@ procedure TBoldCodeGenInitializer.MoveClassTreeToComponent( begin TargetComponent := nil; if not assigned(SuperClass) then - raise Exception.Create(sMoveToComponent_NoSuperClass); + raise Exception.Create('MoveClassTreeToComponent: No SuperClass'); if not assigned(MoldModel) then - raise Exception.Create(sMoveToComponent_NoMoldModel); + raise Exception.Create('MoveClassTreeToComponent: No MoldModel'); for i := 0 to MoldModel.Classes.count - 1 do begin @@ -1210,7 +1218,7 @@ procedure TBoldCodeGenInitializer.EnsureDependency(const SubComponentName, SubComponent: TMoldComponent; SuperComponent: TMoldComponent; begin - if AnsiCompareText(SubComponentName, SuperComponentName) = 0 then + if CompareText(SubComponentName, SuperComponentName) = 0 then exit; SubComponent := FindComponent(SubComponentName); SuperComponent := FindComponent(SuperComponentname); @@ -1242,9 +1250,9 @@ function TBoldCodeGenInitializer.ValidateFileNames: Boolean; for j := 0 to MoldModel.Components.count - 1 do begin if (MoldModel.Classes[i].Component <> MoldModel.Components[j]) and - (ansiCompareText(MoldModel.Classes[i].EffectiveIncFileName(BoldGeneratorTemplatesManager.DefaultIncFileExtension), MoldModel.Components[j].Name + '.'+BoldGeneratorTemplatesManager.DefaultIncFileExtension) = 0) then + (CompareText(MoldModel.Classes[i].EffectiveIncFileName(BoldGeneratorTemplatesManager.DefaultIncFileExtension), MoldModel.Components[j].Name + '.'+BoldGeneratorTemplatesManager.DefaultIncFileExtension) = 0) then begin - BoldLog.LogFmt(sCollidingFileName, [MoldModel.Classes[i].Name, MoldModel.Components[j].Name]); + BoldLog.LogFmt('WARNING! class %s has a file name that collides with another component (%s)!', [MoldModel.Classes[i].Name, MoldModel.Components[j].Name]); result := false; end; end; @@ -1310,7 +1318,7 @@ procedure TBoldGenerator.GenerateComInterfaces; BoldLog.ProgressMax := MoldModel.Classes.Count * 2; - BoldLog.LogFmt(sLogGeneratingInPath, [BaseFilePath]); + BoldLog.LogFmt('Generating in path: %s', [BaseFilePath]); for ComponentIx := 0 to MoldModel.Components.Count - 1 do begin for j := 0 to BoldGeneratorTemplatesManager.ComFileTemplates.Count - 1 do @@ -1320,17 +1328,17 @@ procedure TBoldGenerator.GenerateComInterfaces; with BoldGeneratorTemplatesManager.COMFileTemplates[j] do begin - Variables.SetVariable('COMPONENTNAME', MoldModel.Components[ComponentIx].Name); // do not localize - BoldLog.LogFmt(sLogGeneratingFile, [ExpandedFileName]); + Variables.SetVariable('COMPONENTNAME', MoldModel.Components[ComponentIx].Name); + BoldLog.LogFmt('Generating file %s', [ExpandedFileName]); SetCurrentFileHandler(BaseFilePath, ExpandedFileName, ModuleTypeForFile(ExpandedFileName), true, false); BoldFilehandler.Clear; - BoldLog.LogHeader := sLogInitializingVars; + BoldLog.LogHeader := 'Initializing variables'; InitializeTemplateForComponent(BoldGeneratorTemplatesManager.COMFileTemplates[j], MoldModel, MoldModel.Components[ComponentIx], true); if BoldLog.ProcessInterruption then exit; - BoldLog.LogHeader := sLogExpandingTemplate; + BoldLog.LogHeader := 'Expanding template'; BoldFilehandler.AddStrings(ExpandedTemplate); end; end; @@ -1347,8 +1355,8 @@ procedure TBoldGenerator.AddVarList(Template: TBoldTemplateHolder; VariableBaseN while sList[sList.Count-1] = '' do sList.Delete(SList.Count-1); for i := 0 to sList.Count-1 do - Template.Variables.ForceAdd(Variablebasename + '.' + IntToStr(i), SList[i], []); - Template.Variables.ForceAdd(Variablebasename + 'COUNT', IntToStr(sList.Count), []); // do not localize + Template.Variables.ForceAdd(Variablebasename+'.'+IntToStr(i), SList[i], []); + Template.Variables.ForceAdd(Variablebasename+'COUNT', IntToStr(sList.Count), []); sList.Free; end; @@ -1356,9 +1364,9 @@ procedure TBoldGenerator.AddSuperClassName(variables: TBoldTemplateVariables; MoldClass: tMoldClass); begin if assigned(MoldClass.SuperClass) then - variables.SetVariable('SUPERCLASSNAME', MoldClass.SuperClass.ExpandedDelphiName) // do not localize + variables.SetVariable('SUPERCLASSNAME', MoldClass.SuperClass.ExpandedDelphiName) else - variables.SetVariable('SUPERCLASSNAME', 'TBoldObject') // do not localize + variables.SetVariable('SUPERCLASSNAME', 'TBoldObject') end; procedure TBoldCodeGenInitializer.MoveImplicitLinkClassesToAssociationEndComponent; @@ -1381,14 +1389,12 @@ procedure TBoldCodeGenInitializer.MoveImplicitLinkClassesToAssociationEndCompone if assigned(MoldModel.Classes[i].Association) then begin LinkClass := MoldModel.Classes[i]; - // Only do this for implicit link-classes... if LinkClass.TVByName[BOLDBOLDIFYPREFIX+TAG_AUTOCREATED] = TV_TRUE then begin Component1 := GetAssociationEndComponent(LinkClass.Association, 0); Component2 := GetAssociationEndComponent(LinkClass.Association, 1); - // if the two ends belong to the same component, and it differs - // from the link class, reassign the link class. if there is - // already a dependency between the new and the old component + + if assigned(Component1) and (Component1 <> LinkClass.Component) and (Component1 = Component2) and Component1.DependentOf(LinkClass.Component) then @@ -1408,11 +1414,9 @@ procedure TBoldCodeGenInitializer.MoveImplicitLinkClassesToSuperClassComponent; if assigned(MoldModel.Classes[i].Association) then begin LinkClass := MoldModel.Classes[i]; - // check if the link class is an implicit class in the default component if (LinkClass.Component = MoldModel.MainComponent) and (LinkClass.TVByName[BOLDBOLDIFYPREFIX+TAG_AUTOCREATED] = TV_TRUE) then begin - // if the linkclass inherits from a class in another component, then move it there. if (LinkClass.SuperClass.Component <> MoldModel.MainComponent) then LinkClass.Component := LinkClass.SuperClass.Component; end; @@ -1422,7 +1426,7 @@ procedure TBoldCodeGenInitializer.MoveImplicitLinkClassesToSuperClassComponent; function TBoldGenerator.MakePersistenceInterfaceName(MoldClass: TMoldClass): string; begin - result := BoldExpandName('IPersistent', MoldClass.Name, xtDelphi, -1, nccDefault) // do not localize + result := BoldExpandName('IPersistent', MoldClass.Name, xtDelphi, -1, nccDefault) end; procedure TBoldGenerator.GenerateBusinessObjectCode; @@ -1442,25 +1446,22 @@ procedure TBoldGenerator.GeneratePersistenceInterfaces; TemplateList.free; end else - raise EBold.create(sNoTemplateForPersistenceInterfaces); + raise EBold.create('No template defined for PersistenceInterfaces'); end; function TBoldGenerator.ModuleTypeForFile(const FileName: string): TBoldModuleType; -const - PASExtension = '.PAS'; - INCExtension = '.INC'; var Extension: string; begin Extension := UpperCase(ExtractFileExt(FileName)); - if Extension = PASExtension then + if Extension = '.PAS' then Result := mtUnit - else if Extension = INCExtension then + else if Extension = '.INC' then Result := mtIncFile else Result := mtText; end; -end. - +initialization +end. diff --git a/Source/MoldModel/CodeGenerator/BoldGeneratorTemplates.pas b/Source/MoldModel/CodeGenerator/BoldGeneratorTemplates.pas index 5e063b17..9b3a929e 100644 --- a/Source/MoldModel/CodeGenerator/BoldGeneratorTemplates.pas +++ b/Source/MoldModel/CodeGenerator/BoldGeneratorTemplates.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldGeneratorTemplates; interface @@ -5,7 +8,7 @@ interface uses Classes, BoldMeta, - BoldTemplateExpander; + BoldTemplateExpander; const publicTag = 0; @@ -31,10 +34,11 @@ TBoldGeneratorTemplateManager = class procedure InitializeTemplateList(TemplateList: TBoldTemplateList); virtual; procedure InitializeCOMTemplateList(TemplateList: TBoldTemplateList); virtual; function GetDefaultIncFileExtension: string; virtual; abstract; - function GetPersistenceInterfaceTemplate: TBoldTemplateHolder; virtual; + function GetPersistenceInterfaceTemplate: TBoldTemplateHolder; virtual; function GetTemplateList: TBoldTemplateList; function GetCOMTemplateList: TBoldTemplateList; public + destructor Destroy; override; function MethodToCOMHeader(OwningClass: TMoldClass; Method: TMoldMethod; InterfaceCode: Boolean; ParametersToCoerce: TStringList; ParametersToInterfaceCoerce: TStringList; MoldModel: TMoldModel; GenerateMIDLCode: Boolean): String; virtual; abstract; function MethodToCOMCall(OwningClass: TMoldClass; Method: TMoldMethod; ParametersToCoerce, ParametersToInterfaceCoerce: TStringList; MoldModel: TMoldModel): String; virtual; abstract; function ReadMethodSignature(ClassName, AttributeName, AttributeType: string): string; virtual; abstract; @@ -66,7 +70,8 @@ implementation uses SysUtils, - BoldDefs; + BoldDefs, + BoldRev; var G_BoldGeneratorTemplateManager: TBoldGeneratorTemplateManager; @@ -85,6 +90,13 @@ function BoldGeneratorTemplatesManager: TBoldGeneratorTemplateManager; { TBoldGeneratorTemplateManager } +destructor TBoldGeneratorTemplateManager.Destroy; +begin + FreeAndNil(fTemplateList); + FreeAndNil(fComTemplateList); + inherited; +end; + function TBoldGeneratorTemplateManager.GetCOMTemplateList: TBoldTemplateList; begin if not assigned(fCOMTemplateList) then @@ -120,4 +132,10 @@ procedure TBoldGeneratorTemplateManager.InitializeTemplateList(TemplateList: TBo begin end; +initialization + +finalization + FreeAndNil(G_BoldGeneratorTemplateManager); + + end. diff --git a/Source/MoldModel/CodeGenerator/BoldGeneratorTemplatesCPP.pas b/Source/MoldModel/CodeGenerator/BoldGeneratorTemplatesCPP.pas index f07e78db..74107b55 100644 --- a/Source/MoldModel/CodeGenerator/BoldGeneratorTemplatesCPP.pas +++ b/Source/MoldModel/CodeGenerator/BoldGeneratorTemplatesCPP.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldGeneratorTemplatesCPP; interface @@ -6,7 +9,8 @@ interface Classes, BoldMeta, BoldGeneratorTemplates, - BoldTemplateExpander; + BoldTemplateExpander + ; type { TBoldGeneratorTemplateCPPDM } @@ -26,6 +30,7 @@ TBoldGeneratorTemplateCPPDM = class(TDataModule) { Public declarations } end; + { TBoldCPPTemplateManager } TBoldCPPTemplateManager = class(TBoldGeneratorTemplateManager) private @@ -43,7 +48,7 @@ TBoldCPPTemplateManager = class(TBoldGeneratorTemplateManager) function GetDefaultIncFileExtension: string; override; property DataModule: TBoldGeneratorTemplateCPPDM read GetDataModule; public - destructor Destroy; override; + destructor destroy; override; function MethodToCOMHeader(OwningClass: TMoldClass; Method: TMoldMethod; InterfaceCode: Boolean; ParametersToCoerce: TStringList; ParametersToInterfaceCoerce: TStringList; MoldModel: TMoldModel; GenerateMIDLCode: Boolean): String; override; function MethodToCOMCall(OwningClass: TMoldClass; Method: TMoldMethod; ParametersToCoerce, ParametersToInterfaceCoerce: TStringList; MoldModel: TMoldModel): String; override; function ReadMethodSignature(ClassName, AttributeName, AttributeType: string): string; override; @@ -62,7 +67,6 @@ implementation uses SysUtils, - BoldRev, BoldUMLTypes, BoldTaggedValueSupport, BoldMetaSupport; @@ -71,7 +75,7 @@ implementation { TBoldCPPTemplateManager } -destructor TBoldCPPTemplateManager.Destroy; +destructor TBoldCPPTemplateManager.destroy; begin FreeAndNil(fDataModule); inherited; @@ -166,15 +170,12 @@ function TBoldCPPTemplateManager.MethodToCOMHeader(OwningClass: TMoldClass; Meth s := s + ParamType + ' '; end else - s := s + 'void '; // do not localize + s := s + 'void '; + s := s + '__safecall '; -// if InterfaceCode then - s := s + '__safecall '; // do not localize -// else -// s := s + '__fastcall '; // do not localize if not InterfaceCode then - s := s + OwningClass.ExpandedDelphiName + 'Adapter::'; // do not localize + s := s + OwningClass.ExpandedDelphiName + 'Adapter::'; s := s + Method.ExpandedDelphiName; @@ -195,7 +196,6 @@ function TBoldCPPTemplateManager.MethodToCOMHeader(OwningClass: TMoldClass; Meth if param.ParameterKind in [pdOut, pdInout] then begin - // ISJE params := params + 'var '; if assigned(ParametersToCoerce) and ((ParamType = BoldWideStringTypeName) or (ParamType = BoldWordBoolTypeName)) then @@ -211,7 +211,7 @@ function TBoldCPPTemplateManager.MethodToCOMHeader(OwningClass: TMoldClass; Meth end else if IsConst then - Params := Params + 'const '; // do not localize + Params := Params + 'const '; Params := Params + ParamType + ' ' + Param.ParameterName; end; @@ -238,7 +238,7 @@ function TBoldCPPTemplateManager.MethodToCOMCall(OwningClass: TMoldClass; Method end; begin - s := 'As' + OwningClass.ExpandedExpressionName + '->' + Method.ExpandedDelphiName; // do not localize + s := 'As' + OwningClass.ExpandedExpressionName + '->' + Method.ExpandedDelphiName; params := ''; for i := 0 to Method.Parameters.Count - 1 do @@ -247,11 +247,11 @@ function TBoldCPPTemplateManager.MethodToCOMCall(OwningClass: TMoldClass; Method params := params + ', '; Param := tMoldParameter(Method.Parameters[i]); if ParametersToInterfaceCoerce.IndexOfName(Param.ParameterName) <> -1 then - params := params + param.ParameterName + '_temp' // do not localize + params := params + param.ParameterName + '_temp' else if ParameterNeedsMarshalling(Param.ParameterType, InterfaceName) then - Params := Params + '((' + Param.DelphiParameterType + '*)' + '(BoldComInterfaceToObject(' + Param.ParameterName + ')))' // do not localize + Params := Params + '((' + Param.DelphiParameterType + '*)' + '(BoldComInterfaceToObject(' + Param.ParameterName + ')))' else if parametersToCoerce.IndexOfName(param.ParameterName) <> -1 then - params := params + param.ParameterName + '_temp' // do not localize + params := params + param.ParameterName + '_temp' else Params := params + Param.ParameterName; end; @@ -261,13 +261,15 @@ function TBoldCPPTemplateManager.MethodToCOMCall(OwningClass: TMoldClass; Method if Method.HasReturnValue then begin if ParameterNeedsMarshalling(Trim(method.ReturnType), InterfaceName) then - s := 'BoldComCreateAdapter(' + s + ', False, ' + '__uuidof(' + Interfacename + '), Result)' // do not localize + s := 'BoldComCreateAdapter(' + s + ', False, ' + '__uuidof(' + Interfacename + '), Result)' else - s := 'result := ' + s; // do not localize + s := 'result := ' + s; end; result := s + ';'; + end; + function TBoldCPPTemplateManager.MethodToCodeHeader( OwningClass: TMoldClass; Method: TMoldMethod; TagValue: Integer; AddSignature, AutoOverride: Boolean): String; @@ -278,22 +280,22 @@ function TBoldCPPTemplateManager.MethodToCodeHeader( s := ''; if (TagValue in [publicTag..PrivateTag]) and Method.IsClassMethod then - s := s + 'static '; // do not localize + s := s + 'static '; if (TagValue in [publicTag..PrivateTag]) and (Autooverride or (Method.FuncType in [dfvirtual]) or method.OverrideInAllSubclasses) then begin - s := s + 'virtual '; // do not localize + s := s + 'virtual '; end; if Method.HasReturnValue then s := s + Method.DelphiReturnType+' ' else - s := s + 'void '; // do not localize + s := s + 'void '; - s := s + '__fastcall '; // do not localize + s := s + '__fastcall '; if TagValue = ImplementationTag then s := s + OwningClass.ExpandedDelphiName + '::'; @@ -305,11 +307,11 @@ function TBoldCPPTemplateManager.MethodToCodeHeader( if Signature <> '' then s := s + '(' + Signature + ')' else - s := s + '(void)'; // do not localize + s := s + '(void)'; end; if Method.FuncType = dfAbstractVirtual then - s := s + ' = 0'; // do not localize + s := s + ' = 0'; result := s; end; @@ -335,22 +337,23 @@ function TBoldCPPTemplateManager.GetCPPSignature(MoldMethod: TMoldMethod): Strin result := result + ', '; { if Parameter.IsConst then - Result := Result + 'const ' // do not localize + Result := Result + 'const ' else if Parameter.ParameterKind = pdInOut then - Result := Result + 'var ' // do not localize + Result := Result + 'var ' else if Parameter.ParameterKind = pdOut then - Result := Result + 'out '; // do not localize + Result := Result + 'out '; } - result := result + format('%s %s', [ // do not localize + result := result + format('%s %s', [ AdaptCPPParameterType(Parameter.DelphiParameterType), Parameter.ParameterName]); end; + end; function TBoldCPPTemplateManager.GetDefaultIncFileExtension: string; begin - result := '_impl.cpp'; // do not localize + result := '_impl.cpp'; end; function TBoldCPPTemplateManager.StringContainsMethodHeader(s: String): Boolean; @@ -372,6 +375,7 @@ procedure TBoldCPPTemplateManager.AddQualifierFunctionParam(var Params: String; Params := Params + ParamType + ' ' + ParamName; end; + function TBoldCPPTemplateManager.GetSearchStringfromMethodHeader(header: String; SearchParameterList: Boolean): String; begin result := header; @@ -384,23 +388,24 @@ function TBoldCPPTemplateManager.GenerateInheritedCall( begin result := ''; if MoldMethod.HasReturnValue then - result := 'return '; // do not localize + result := 'return '; if assigned(MoldClass.SuperClass) then result := result + MoldClass.SuperClass.ExpandedDelphiName else - result := result + 'TBoldObject'; // do not localize + result := result + 'TBoldObject'; + + result := result + format('::%s(%s)', [Moldmethod.Name, MoldMethod.CallSignature]); - result := result + format('::%s(%s)', [Moldmethod.Name, MoldMethod.CallSignature]); // do not localize end; function TBoldCPPTemplateManager.ReadMethodSignature(ClassName, AttributeName, AttributeType: string): string; begin - result := format('%s __fastcall %s::Get%s()', [AttributeType, ClassName, AttributeName]); // do not localize + result := format('%s __fastcall %s::Get%s()', [AttributeType, ClassName, AttributeName]); end; function TBoldCPPTemplateManager.WriteMethodSignature(ClassName, AttributeName, AttributeType: string): string; begin - result := format('void __fastcall %s::Set%s(%s NewValue)', [ClassName, AttributeName, AttributeType]); // do not localize + result := format('void __fastcall %s::Set%s(%s NewValue)', [ClassName, AttributeName, AttributeType]); end; initialization diff --git a/Source/MoldModel/CodeGenerator/BoldGeneratorTemplatesDelphi.pas b/Source/MoldModel/CodeGenerator/BoldGeneratorTemplatesDelphi.pas index 30db28ea..baee8793 100644 --- a/Source/MoldModel/CodeGenerator/BoldGeneratorTemplatesDelphi.pas +++ b/Source/MoldModel/CodeGenerator/BoldGeneratorTemplatesDelphi.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldGeneratorTemplatesDelphi; interface @@ -6,7 +9,8 @@ interface Classes, BoldMeta, BoldGeneratorTemplates, - BoldTemplateExpander; + BoldTemplateExpander + ; type @@ -50,7 +54,7 @@ TBoldDelphiTemplateManager = class(TBoldGeneratorTemplateManager) function GetDefaultIncFileExtension: string; override; property DataModule: TBoldGeneratorTemplatesDelphiDM read GetDataModule; public - destructor Destroy; override; + destructor destroy; override; function MethodToCOMHeader(OwningClass: TMoldClass; Method: TMoldMethod; InterfaceCode: Boolean; ParametersToCoerce: TStringList; ParametersToInterfaceCoerce: TStringList; MoldModel: TMoldModel; GenerateMIDLCode: Boolean): String; override; function MethodToCOMCall(OwningClass: TMoldClass; Method: TMoldMethod; ParametersToCoerce, ParametersToInterfaceCoerce: TStringList; MoldModel: TMoldModel): String; override; function ReadMethodSignature(ClassName, AttributeName, AttributeType: string): string; override; @@ -73,20 +77,21 @@ TBoldDelphiTemplateManagerNameBound = class(TBoldDelphiTemplateManager) class procedure InstallTemplates; end; + implementation uses SysUtils, - BoldRev, BoldUMLTypes, BoldTaggedValueSupport, BoldMetaSupport; {$R *.dfm} + { TBoldDelphiTemplateManager } -destructor TBoldDelphiTemplateManager.Destroy; +destructor TBoldDelphiTemplateManager.destroy; begin FreeAndNil(fDataModule); inherited; @@ -165,11 +170,11 @@ function TBoldDelphiTemplateManager.MethodToCOMHeader(OwningClass: TMoldClass; M begin s := ''; if Method.HasReturnValue then - s := s + 'function ' // do not localize + s := s + 'function ' else - s := s + 'procedure '; // do not localize + s := s + 'procedure '; if not InterfaceCode then - s := s + OwningClass.ExpandedDelphiName + 'Adapter.'; // do not localize + s := s + OwningClass.ExpandedDelphiName + 'Adapter.'; s := s + Method.ExpandedDelphiName; @@ -188,8 +193,8 @@ function TBoldDelphiTemplateManager.MethodToCOMHeader(OwningClass: TMoldClass; M if param.ParameterKind in [pdOut, pdInout] then begin case param.ParameterKind of - pdOut: params := params + 'out '; // do not localize - pdInOut: params := params + 'var '; // do not localize + pdOut: params := params + 'out '; + pdInOut: params := params + 'var '; end; if assigned(ParametersToCoerce) and ((ParamType = BoldWideStringTypeName) or @@ -206,7 +211,7 @@ function TBoldDelphiTemplateManager.MethodToCOMHeader(OwningClass: TMoldClass; M end else if IsConst then - Params := Params + 'const '; // do not localize + Params := Params + 'const '; Params := Params + Param.ParameterName + ': ' + ParamType; end; if Params <> '' then @@ -223,7 +228,7 @@ function TBoldDelphiTemplateManager.MethodToCOMHeader(OwningClass: TMoldClass; M s := s + ';'; if InterfaceCode then - s := s + ' safecall;'; // do not localize + s := s + ' safecall;'; result := s; end; @@ -243,7 +248,7 @@ function TBoldDelphiTemplateManager.MethodToCOMCall(OwningClass: TMoldClass; Met end; begin - s := 'As' + OwningClass.ExpandedExpressionName + '.' + Method.ExpandedDelphiName; // do not localize + s := 'As' + OwningClass.ExpandedExpressionName + '.' + Method.ExpandedDelphiName; params := ''; for i := 0 to Method.Parameters.Count - 1 do @@ -252,11 +257,11 @@ function TBoldDelphiTemplateManager.MethodToCOMCall(OwningClass: TMoldClass; Met params := params + ', '; Param := tMoldParameter(Method.Parameters[i]); if ParametersToInterfaceCoerce.IndexOfName(Param.ParameterName) <> -1 then - params := params + param.ParameterName + '_temp' // do not localize + params := params + param.ParameterName + '_temp' else if ParameterNeedsMarshalling(Param.ParameterType, InterfaceName) then - Params := Params + 'BoldComInterfaceToObject(' + Param.ParameterName + ') as ' + Param.DelphiParameterType // do not localize + Params := Params + 'BoldComInterfaceToObject(' + Param.ParameterName + ') as ' + Param.DelphiParameterType else if parametersToCoerce.IndexOfName(param.ParameterName) <> -1 then - params := params + param.ParameterName + '_temp' // do not localize + params := params + param.ParameterName + '_temp' else Params := params + Param.ParameterName; end; @@ -267,9 +272,9 @@ function TBoldDelphiTemplateManager.MethodToCOMCall(OwningClass: TMoldClass; Met if Method.HasReturnValue then begin if ParameterNeedsMarshalling(Trim(method.ReturnType), InterfaceName) then - s :='BoldComCreateAdapter(' + s + ', False, ' + Interfacename + ', Result)' // do not localize + s :='BoldComCreateAdapter(' + s + ', False, ' + Interfacename + ', Result)' else - s := 'result := ' + s; // do not localize + s := 'result := ' + s; end; result := s + ';'; end; @@ -286,14 +291,14 @@ function TBoldDelphiTemplateManager.MethodToCodeHeader( begin s := ''; if Method.IsClassMethod then - s := s + 'class '; // do not localize + s := s + 'class '; - if AnsiCompareText(Method.Name, 'Destroy') = 0 then // do not localize - s := s + 'destructor ' // do not localize + if AnsiCompareText(Method.Name, 'Destroy') = 0 then + s := s + 'destructor ' else if Method.HasReturnValue then - s := s + 'function ' // do not localize + s := s + 'function ' else - s := s + 'procedure '; // do not localize + s := s + 'procedure '; if TagValue = ImplementationTag then s := s + OwningClass.ExpandedDelphiName + '.'; @@ -347,20 +352,20 @@ function TBoldDelphiTemplateManager.GetDelphiSignature( result := result + '; '; if Parameter.IsConst then - Result := Result + 'const ' // do not localize + Result := Result + 'const ' else if Parameter.ParameterKind = pdInOut then - Result := Result + 'var ' // do not localize + Result := Result + 'var ' else if Parameter.ParameterKind = pdOut then - Result := Result + 'out '; // do not localize + Result := Result + 'out '; - result := result + format('%s: %s', [Parameter.ParameterName, // do not localize + result := result + format('%s: %s', [Parameter.ParameterName, Parameter.DelphiParameterType]); end; end; function TBoldDelphiTemplateManager.GetDefaultIncFileExtension: string; begin - result := '.inc'; // do not localize + result := '.inc'; end; function TBoldDelphiTemplateManager.StringContainsMethodHeader(s: String): Boolean; @@ -368,16 +373,16 @@ function TBoldDelphiTemplateManager.StringContainsMethodHeader(s: String): Boole temp: String; begin temp := UpperCase(s); - result := (pos('PROCEDURE', temp) <> 0) or // do not localize - (pos('FUNCTION', temp) <> 0) or // do not localize - (pos('DESTRUCTOR', temp) <> 0); // do not localize + result := (pos('PROCEDURE', temp) <> 0) or + (pos('FUNCTION', temp) <> 0) or + (pos('DESTRUCTOR', temp) <> 0); end; procedure TBoldDelphiTemplateManager.AddQualifierParam(var Params: String; ParamName, ParamType: String); begin if Params <> '' then Params := Params + '; '; - Params := Params + ParamName+': '+ParamType; // do not localize + Params := Params + ParamName+': '+ParamType; end; procedure TBoldDelphiTemplateManager.AddQualifierFunctionParam(var Params: String; ParamName, ParamType: String); @@ -404,19 +409,20 @@ function TBoldDelphiTemplateManager.GetSearchStringfromMethodHeader(header: Stri function TBoldDelphiTemplateManager.GenerateInheritedCall(MoldClass: TMoldClass; MoldMethod: TMoldMethod): String; begin if not MoldMethod.HasReturnValue then - result := 'inherited' // do not localize + result := 'inherited' else - result := format('result := inherited %s(%s)', [Moldmethod.Name, MoldMethod.CallSignature]); // do not localize + result := format('result := inherited %s(%s)', [Moldmethod.Name, MoldMethod.CallSignature]); end; + function TBoldDelphiTemplateManager.ReadMethodSignature(ClassName, AttributeName, AttributeType: string): string; begin - result := format('function %s.Get%s: %s;', [ClassName, AttributeName, AttributeType]); // do not localize + result := format('function %s.Get%s: %s;', [ClassName, AttributeName, AttributeType]); end; function TBoldDelphiTemplateManager.WriteMethodSignature(ClassName, AttributeName, AttributeType: string): string; begin - result := format('procedure %s.Set%s(NewValue: %s);', [ClassName, AttributeName, AttributeType]); // do not localize + result := format('procedure %s.Set%s(NewValue: %s);', [ClassName, AttributeName, AttributeType]); end; function TBoldDelphiTemplateManager.GetPersistenceInterfaceTemplate: TBoldTemplateHolder; @@ -433,8 +439,8 @@ procedure TBoldDelphiTemplateManagerNameBound.InitializeTemplateList(TemplateLis if TemplateList.Count = 0 then begin template := DataModule.UnitTemplate.Template.Text; - Template := StringReplace(template, 'BoldMembers[$(MEMBERINDEX)]', 'BoldMemberByExpressionName[''$(MEMBERNAME)'']', [rfReplaceAll]); // do not localize - Template := StringReplace(template, '$(MEMBERINDEX)', '-1', [rfReplaceAll]); // do not localize + Template := StringReplace(template, 'BoldMembers[$(MEMBERINDEX)]', 'BoldMemberByExpressionName[''$(MEMBERNAME)'']', [rfReplaceAll]); + Template := StringReplace(template, '$(MEMBERINDEX)', '-1', [rfReplaceAll]); DataModule.UnitTemplate.Template.Text := Template; end; inherited; @@ -449,4 +455,4 @@ initialization {$IFDEF BOLD_DELPHI} TBoldDelphiTemplateManager.InstallTemplates; {$ENDIF} -end. \ No newline at end of file +end. diff --git a/Source/MoldModel/Core/BoldMeta.pas b/Source/MoldModel/Core/BoldMeta.pas index 7543e721..669a429c 100644 --- a/Source/MoldModel/Core/BoldMeta.pas +++ b/Source/MoldModel/Core/BoldMeta.pas @@ -1,15 +1,15 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldMeta; interface uses Classes, - BoldUtils, BoldDefs, BoldBase, BoldContainers, - BoldNameExpander, - BoldSharedStrings, BoldNamedValueList, BoldUMLTypes, BoldTypeNameDictionary, @@ -59,20 +59,20 @@ TMoldElement = class(TBoldMemoryManagedObject) fBoldTaggedValues: TBoldNamedValueList; fDispId: integer; FDefaultBoldTVList: TBoldTaggedValueList; - function GetExpandedDelphiName: string; + function GetExpandedDelphiName: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetBoldTVByName(const Tag, value: string); function GetBoldTVByName(const Tag: string): string; - function GetStdTVByName(const Tag: string): string; - function GetDelphiName: string; - function GetExpressionName: string; - function GetPMapperName: string; - procedure SetStdTVByName(const Tag, Value: string); - function GetDispId: integer; + function GetStdTVByName(const Tag: string): string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetDelphiName: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetExpressionName: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetPMapperName: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetStdTVByName(const Tag, Value: string); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetDispId: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetDefaultBoldTVList: TBoldTaggedValueList; function GetTVByName(const Tag: string): string; procedure SetTVByName(const Tag, Value: string); - function GetTaggedValues: TBoldNamedValueList; - function GetBoldTaggedValues: TBoldNamedValueList; + function GetTaggedValues: TBoldNamedValueList; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetBoldTaggedValues: TBoldNamedValueList; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetNonDefaultTaggedValuesCommaText: string; procedure SetNonDefaultTaggedValuesCommaText(const Value: string); protected @@ -80,8 +80,8 @@ TMoldElement = class(TBoldMemoryManagedObject) function GetModel: TMoldModel; virtual; abstract; procedure SetName(const S: string); virtual; function GetExpandedExpressionName: string; virtual; - function GetEvolutionState: TBoldEvolutionState; - function GetFormerNames: string; + function GetEvolutionState: TBoldEvolutionState; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetFormerNames: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetUMLClassName: string; virtual; abstract; property UMLClassName: string read GetUMLClassName; property DefaultBoldTVList: TBoldTaggedValueList read GetDefaultBoldTVList; @@ -125,23 +125,23 @@ TMoldModel = class(TMoldElement) fIsDestroying: Boolean; function CalculateCRC: Cardinal; procedure SetRootClass(NewRootClass: TMoldClass); - function GetUnitName: string; - function GetComponents: TMoldComponentList; - function GetMainComponent: TMoldComponent; - function GetInterfaceUses: string; - function GetUseGlobalId: Boolean; - function GetUseReadOnly: Boolean; - function GetUseModelVersion: Boolean; - function GetModelVersion: Integer; - function GetUseTimestamp: Boolean; - function GetUseXFiles: Boolean; - function GetUseClockLog: Boolean; - function GetImplementationUses: string; - function GetGUID: string; - function GetTypeLibVersion: String; - function GetOptimisticLocking: TBoldOptimisticLockingMode; - function GetUpdateWholeObjects: Boolean; - function GetExpandedUnitName: string; + function GetBoldUnitName: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetComponents: TMoldComponentList; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetMainComponent: TMoldComponent; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetInterfaceUses: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetUseGlobalId: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetUseReadOnly: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetUseModelVersion: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetModelVersion: Integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetUseTimestamp: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetUseXFiles: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetUseClockLog: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetImplementationUses: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetGUID: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetTypeLibVersion: String; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetOptimisticLocking: TBoldOptimisticLockingMode; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetUpdateWholeObjects: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetExpandedUnitName: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure RemoveAssoc(MoldAssoc: TMoldAssociation; ClassList: TMoldClassList; AssocList: TMoldAssociationList); procedure RemoveClass(MoldClass: TMoldClass; ClassList: TMoldClassList; AssocList: TMoldAssociationList); function GetNationalCharConversion: TBoldNationalCharConversion; @@ -157,7 +157,7 @@ TMoldModel = class(TMoldElement) public constructor Create(Parent: TMoldElement; const Name: string); override; destructor Destroy; override; - function GetClassByName(const name: string): TMoldClass; // Find if exists, otherwise create + function GetClassByName(const name: string): TMoldClass; function FindRoleByClassNameAndName(const boldclassName, roleName: string): TMoldRole; procedure EnsureLinkRoles; procedure EnsureTopSorted; @@ -181,7 +181,7 @@ TMoldModel = class(TMoldElement) function FindComponent(const ComponentName: string): TMoldComponent; function RenameComponent(const OldComponentName, NewComponentName: string): TMoldComponent; function EnsureComponent(const ComponentName: string): TMoldComponent; - property UnitName: string read GetUnitName; + property BoldUnitName: string read GetBoldUnitName; property ExpandedUnitName: string read GetExpandedUnitName; property GUID: string read GetGUID; property TypeLibVersion: String read GetTypeLibVersion; @@ -199,8 +199,9 @@ TMoldModel = class(TMoldElement) {---TMoldElementList---} TMoldElementList = class(TBoldIndexableList) private + class var IX_Name: integer; function GetItem(index: Integer): TMoldElement; - function GetItemByName(const name: string): TMoldElement; + function GetItemByName(const name: string): TMoldElement; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public constructor Create; procedure RemoveEntryReference(Item: TMoldElement); @@ -213,10 +214,12 @@ TMoldElementList = class(TBoldIndexableList) {---TMoldClassList---} TMoldClassList = class(TMoldElementList) private - function GetItem(index: Integer): TMoldClass; - function GetItemByName(const name: string): TMoldClass; - function GetItemByExpressionName(const ExpressionName: String): TMoldClass; - function GetItemByDelphiName(const DelphiName: String): TMoldClass; + class var IX_ExpressionName: integer; + class var IX_DelphiName: integer; + function GetItem(index: Integer): TMoldClass; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByName(const name: string): TMoldClass; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByExpressionName(const ExpressionName: String): TMoldClass; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByDelphiName(const DelphiName: String): TMoldClass; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public constructor Create; property Items[index: Integer]: TMoldClass read GetItem; default; @@ -228,8 +231,8 @@ TMoldClassList = class(TMoldElementList) { TMoldMemberList } TMoldMemberList = class(TMoldElementList) private - function GetItem(index: Integer): TMoldMember; - function GetItemByName(const name: string): TMoldMember; + function GetItem(index: Integer): TMoldMember; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByName(const name: string): TMoldMember; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public property Items[index: Integer]: TMoldMember read GetItem; default; property ItemsByName[const name: string]: TMoldMember read GetItemByName; @@ -238,8 +241,8 @@ TMoldMemberList = class(TMoldElementList) {---TMoldRoleList---} TMoldRoleList = class(TMoldMemberList) private - function GetItem(index: Integer): TMoldRole; - function GetItemByName(const name: string): TMoldRole; + function GetItem(index: Integer): TMoldRole; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByName(const name: string): TMoldRole; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public property Items[index: Integer]: TMoldRole read GetItem; default; property ItemsByName[const name: string]: TMoldRole read GetItemByName; @@ -248,8 +251,8 @@ TMoldRoleList = class(TMoldMemberList) {---TMoldMethodList---} TMoldMethodList = class(TMoldElementList) private - function GetItem(index: Integer): TMoldMethod; - function GetItemByName(const name: string): TMoldMethod; + function GetItem(index: Integer): TMoldMethod; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByName(const name: string): TMoldMethod; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public property Items[index: Integer]: TMoldMethod read GetItem; default; property ItemsByName[const name: string]: TMoldMethod read GetItemByName; @@ -258,8 +261,8 @@ TMoldMethodList = class(TMoldElementList) {---TMoldAssociationList---} TMoldAssociationList = class(TMoldElementList) private - function GetItem(index: Integer): TMoldAssociation; - function GetItemByName(const name: string): TMoldAssociation; + function GetItem(index: Integer): TMoldAssociation; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByName(const name: string): TMoldAssociation; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public property Items[index: Integer]: TMoldAssociation read GetItem; default; property ItemsByName[const name: string]: TMoldAssociation read GetItemByName; @@ -268,8 +271,8 @@ TMoldAssociationList = class(TMoldElementList) {---TMoldAttributeList---} TMoldAttributeList = class(TMoldMemberList) private - function GetItem(index: Integer): TMoldAttribute; - function GetItemByName(const name: string): TMoldAttribute; + function GetItem(index: Integer): TMoldAttribute; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByName(const name: string): TMoldAttribute; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public property Items[index: Integer]: TMoldAttribute read GetItem; default; property ItemsByName[const name: string]: TMoldAttribute read GetItemByName; @@ -278,8 +281,8 @@ TMoldAttributeList = class(TMoldMemberList) {---TMoldQualifierList---} TMoldQualifierList = class(TMoldElementList) private - function GetItem(index: Integer): TMoldQualifier; - function GetItemByName(const name: string): TMoldQualifier; + function GetItem(index: Integer): TMoldQualifier; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByName(const name: string): TMoldQualifier; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public property Items[index: Integer]: TMoldQualifier read GetItem; default; property ItemsByName[const name: string]: TMoldQualifier read GetItemByName; @@ -304,50 +307,50 @@ TMoldClass = class(TMoldElement) fPersistent: Boolean; fLastDispId: integer; fAllPossibleNames: TStringList; + fTopSortedIndex: integer; procedure SetSuperClass(super: TMoldClass); - function GetIncFileName: string; -// function GetExpandedTableName(const TablePrefix: String):string; - function GetIsRootClass: Boolean; + function GetIncFileName: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetIsRootClass: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure InitializeClass(Parent: TMoldModel); - function GetTopSortedIndex:Integer; - procedure SetComponent(const Value: TMoldComponent); + procedure SetComponent(const Value: TMoldComponent); {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetAllNativeAttributes: TMoldAttributeList; function GetAllBoldMembers: TMoldMemberList; function GetIntroducesManuallyDerivedMembers: Boolean; - function GetFirstOwnBoldMemberIndex: integer; - function GetFirstOwnNativeAttributeIndex: integer; + function GetFirstOwnBoldMemberIndex: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetFirstOwnNativeAttributeIndex: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetHasManuallyDerivedMembers: Boolean; function GetAllAutoOverrideMethods: TMoldMethodList; - function GetComponent: TMoldComponent; - function GetTablemapping: TTableMapping; - function GetUnitName: string; - function GetImported: Boolean; - function GetTableName: string; - procedure SetUnitName(const Value: string); - procedure SetIncFileName(const Value: string); - function GetDefaultStringRepresentation: String; - function GetEffectiveDefaultStringRepresentation: String; + function GetComponent: TMoldComponent; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetTableMapping: TTableMapping; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetBoldUnitName: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetImported: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetTableName: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetBoldUnitName(const Value: string); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetIncFileName(const Value: string); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetDefaultStringRepresentation: String; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetEffectiveDefaultStringRepresentation: String; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetHasCodeStubs: Boolean; function GetVersioned: Boolean; - function GetGuid: String; - function GetListGuid: String; - function GetOptimisticLocking: TBoldOptimisticLockingMode; - function GetExpandedUnitName: string; + function GetGuid: String; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetListGuid: String; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetOptimisticLocking: TBoldOptimisticLockingMode; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetExpandedUnitName: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure TrimRemoved; - function GetEffectiveEvolutionState: TBoldEvolutionState; - function GetFirstDispId: integer; - function GetLastDispId: integer; + function GetEffectiveEvolutionState: TBoldEvolutionState; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetFirstDispId: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetLastDispId: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetAllPossibleNames: TStringList; function GetHasDelphiAttributesWithAccessorFunctions: Boolean; function CalculateCRC: Cardinal; function GetEffectiveOptimisticLocking: TBoldOptimisticLockingMode; - function GetGenerateDefaultRegion: Boolean; - function GetStorage: TBoldStorage; + function GetGenerateDefaultRegion: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetStorage: TBoldStorage; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetIntroducesManuallyReverseDerivedMembers: Boolean; protected procedure AssignMemberDispIds; function GetModel: TMoldModel; override; function GetExpandedExpressionName: string; override; - function GetExpandedInterfaceName: string; + function GetExpandedInterfaceName: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetEffectivePersistent: Boolean; function GetHasNotNullMembers: Boolean; function GetUMLClassName: string; override; @@ -356,7 +359,6 @@ TMoldClass = class(TMoldElement) destructor Destroy; override; function ChildTo(MoldClass: TMoldClass): Boolean; procedure NameChanged; override; -// procedure MainTables(Strings: TStrings; const AllowChild, AllowParent: Boolean; TablePrefix: String); function FindStoringClass(DefiningClass: TMoldClass; AbovedefiningClass: Boolean; Member: TMoldMember): TMoldClass; function LowestCommonSuperClass(otherClass: TMoldClass): TMoldClass; function LowestVisibleAncestor(MoldClass:TMoldClass): TMoldClass; @@ -369,15 +371,14 @@ TMoldClass = class(TMoldElement) property Attributes: TMoldAttributeList read FAttributes; property Methods: TMoldMethodList read FMethods; property Roles: TMoldRoleList read FRoles; - property Association: TMoldAssociation read FAssociation write fAssociation; // For relationship classes only + property Association: TMoldAssociation read FAssociation write fAssociation; property IsAbstract: Boolean read FIsAbstract write fIsAbstract; property Imported: Boolean read GetImported; -// property ExpandedTableName[const TablePrefix: String]: string read GetExpandedTableName; - property UnitName: string read GetUnitName write SetUnitName; + property BoldUnitName: string read GetBoldUnitName write SetBoldUnitName; property ExpandedUnitName: string read GetExpandedUnitName; property IncFileName: string read GetIncFileName write SetIncFileName; property HasNotNullMembers: Boolean read GetHasNotNullMembers; - property TopSortedIndex:integer read GetTopSortedIndex; + property TopSortedIndex:integer read fTopSortedIndex; property Component:TMoldComponent read GetComponent write SetComponent; property AllBoldMembers: TMoldMemberList read GetAllBoldMembers; property AllNativeAttributes: TMoldAttributeList read GetAllNativeAttributes; @@ -385,6 +386,7 @@ TMoldClass = class(TMoldElement) property FirstOwnBoldMemberIndex:integer read GetFirstOwnBoldMemberIndex; property FirstOwnNativeAttributeIndex:integer read GetFirstOwnNativeAttributeIndex; property IntroducesManuallyDerivedMembers: Boolean read GetIntroducesManuallyDerivedMembers; + property IntroducesManuallyReverseDerivedMembers: Boolean read GetIntroducesManuallyReverseDerivedMembers; property HasManuallyDerivedMembers: Boolean read GetHasManuallyDerivedMembers; property HasDelphiAttributesWithAccessorFunctions: Boolean read GetHasDelphiAttributesWithAccessorFunctions; property EffectivePersistent: Boolean read GetEffectivePersistent; @@ -413,13 +415,14 @@ TMoldMember = class(TMoldElement) private FMoldClass: TMoldClass; fVisibility: TVisibilityKind; -// function GetExpandedColumnName: string; + fIndex: integer; function GetDerived: Boolean; virtual; abstract; function GetReverseDerived: Boolean; virtual; abstract; - function GetDerivationOCL: String; + function GetDerivationOCL: String; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetMemberExists: boolean; virtual; - function GetColumnName: string; + function GetColumnName: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetTypeStreamName: string; virtual; abstract; + function GetIndex: integer; protected function GetEffectiveDelayedFetch: Boolean; virtual; function GetModel: TMoldModel; override; @@ -429,11 +432,13 @@ TMoldMember = class(TMoldElement) function GetMoldClass: TMoldClass; function GetManuallyDerived: Boolean; function GetStorage: TBoldStorage; virtual; abstract; + function GetIsAttribute: boolean; virtual; abstract; + function GetIsRole: boolean; virtual; abstract; public + constructor Create(Parent: TMoldElement; const Name: string); override; property MoldClass: TMoldClass read GetMoldClass; property ColumnName: string read GetColumnName; property EffectiveDelayedFetch: Boolean read GetEffectiveDelayedFetch; -// property ExpandedColumnName: string read GetExpandedColumnName; property Visibility: TVisibilityKind read fVisibility write fVisibility; property Derived: Boolean read GetDerived; property ManuallyDerived: Boolean read GetManuallyDerived; @@ -444,6 +449,9 @@ TMoldMember = class(TMoldElement) property TypeStreamName: string read GetTypeStreamName; property FormerNames: String read GetFormerNames; property Storage: TBoldStorage read GetStorage; + property IsAttribute: boolean read GetIsAttribute; + property IsRole: boolean read GetIsRole; + property Index: integer read GetIndex; end; {---TMoldAttribute---} @@ -455,21 +463,23 @@ TMoldAttribute = class(TMoldMember) function CalculateCRC: Cardinal; function GetDerived: Boolean; override; function GetReverseDerived: Boolean; override; - function GetAllowNull: Boolean; - function GetAttributeKind: TBoldAttributeKind; - function GetDelphiPropertyRead: TDelphiPropertyAccessKind; - function GetDelphiPropertyWrite: TDelphiPropertyAccessKind; - function GetHasDelphiField: Boolean; - function GetLength: Integer; - function GetPersistent: Boolean; + function GetAllowNull: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetAttributeKind: TBoldAttributeKind; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetDelphiPropertyRead: TDelphiPropertyAccessKind; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetDelphiPropertyWrite: TDelphiPropertyAccessKind; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetHasDelphiField: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetLength: Integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetPersistent: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetTypeStreamName: string; override; - function GetDefaultDBValue: string; + function GetDefaultDBValue: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected function GetEffectivePersistent: Boolean; override; function GetEffectiveDelayedFetch: Boolean; override; function GetHasDispId: boolean; override; function GetUMLClassName: string; override; function GetStorage: TBoldStorage; override; + function GetIsAttribute: boolean; override; + function GetIsRole: boolean; override; public constructor Create(Parent: TMoldElement; const Name: string); override; destructor Destroy; override; @@ -497,14 +507,14 @@ TMoldMethod = class(TMoldElement) FReturnType: string; fParameters: TBoldObjectArray; fVisibility: TVisibilityKind; - procedure setSignature(Value: string); + procedure SetSignature(Value: string); function GetSignature: String; - function GetParameters: TBoldObjectArray; + function GetParameters: TBoldObjectArray; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetCallSignature: string; - function GetFuncType: TDelphiFunctionType; - function GetOverrideInAllSubclasses: Boolean; + function GetFuncType: TDelphiFunctionType; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetOverrideInAllSubclasses: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetDelphiReturnType: String; - function GetHasReturnValue: Boolean; + function GetHasReturnValue: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetCanCallInherited: Boolean; protected function GetModel: TMoldModel; override; @@ -538,7 +548,7 @@ TMoldParameter= class(TBoldMemoryManagedObject) fOwningMethod: TMoldMethod; function GetDelphiParameterType: String; public - constructor create(OwningMethod: TMoldMethod); + constructor Create(OwningMethod: TMoldMethod); property ParameterName: String read FParameterName write fParameterName; property ParameterType: String read FParameterType write fParameterType; property ParameterKind: TBoldParameterDirectionKind read FParameterKind write fParameterKind; @@ -560,33 +570,35 @@ TMoldRole = class(TMoldMember) fMultiplicity: String; function CalculateCRC: Cardinal; function GetOtherEnd: TMoldRole; - procedure setAssociation(Association: TMoldAssociation); - function GetHasLinkRole: Boolean; + procedure SetAssociation(Association: TMoldAssociation); + function GetHasLinkRole: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetLinkRole: TMoldRole; procedure EnsureLinkRole; - function GetMainRole: TMoldRole; + function GetMainRole: TMoldRole; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetMulti: Boolean; function GetDerived: Boolean; override; function GetReverseDerived: Boolean; override; - function GetMandatory: Boolean; - function GetEmbed: Boolean; - function GetEffectiveEmbed: Boolean; - function GetEffectiveOrdered: Boolean; + function GetMandatory: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetEmbed: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetEffectiveEmbed: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetEffectiveOrdered: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetTypeStreamName: string; override; - function GetQualifiedMulti: Boolean; - function GetDefaultRegionMode: TBoldAssociationEndDefaultRegionMode; + function GetQualifiedMulti: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetDefaultRegionMode: TBoldAssociationEndDefaultRegionMode; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetEffectiveDefaultRegionMode: TBoldAssociationEndDefaultRegionMode; protected function GetEffectiveDelayedFetch: Boolean; override; function GetModel: TMoldModel; override; - procedure SetMoldClass(NewMoldClass: TMoldClass); override; + procedure setMoldClass(NewMoldClass: TMoldClass); override; function GetEffectivePersistent: Boolean; override; - function GetDeleteAction: TDeleteAction; - function GetEffectiveDeleteAction: TDeleteAction; + function GetDeleteAction: TDeleteAction; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetEffectiveDeleteAction: TDeleteAction; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetMemberExists: boolean; override; function GetHasDispId: boolean; override; function GetUMLClassName: string; override; function GetStorage: TBoldStorage; override; + function GetIsAttribute: boolean; override; + function GetIsRole: boolean; override; public constructor Create(Parent: TMoldElement; const Name: string); override; destructor Destroy; override; @@ -594,13 +606,13 @@ TMoldRole = class(TMoldMember) property Association: TMoldAssociation read FAssociation write setAssociation; property Multi: Boolean read GetMulti; property Navigable: Boolean read FNavigable write fNavigable; - property OtherEnd: TMoldRole read GetOtherEnd; // Only binary association so far + property OtherEnd: TMoldRole read GetOtherEnd; property Ordered: Boolean read FOrdered write fOrdered; property EffectiveOrdered: Boolean read GetEffectiveOrdered; property Mandatory: Boolean read GetMandatory; property Embed: Boolean read GetEmbed; property EffectiveEmbedded: Boolean read GetEffectiveEmbed; - property MoldClass: TMoldClass read GetMoldClass write SetMoldClass; + property MoldClass: TMoldClass read GetMoldClass write setMoldClass; property Qualifiers: TMoldQualifierList read FQualifiers; property QualifiedMulti: Boolean read GetQualifiedMulti; property HasLinkRole: Boolean read GetHasLinkRole; @@ -624,12 +636,12 @@ TMoldAssociation = class(TMoldElement) FRoles: TMoldRoleList; fLinkRoles: TMoldRolelist; fInnerLinkRoles: TMoldRoleList; - FLinkClass: TMoldClass; // For n-n relations only + FLinkClass: TMoldClass; fAllPossibleNames: TStringList; procedure SetLinkClass(Value: TMoldClass); - function GetPersistent: Boolean; + function GetPersistent: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetAllPossibleNames: TStringList; - function GetStorage: TBoldStorage; + function GetStorage: TBoldStorage; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected function GetModel: TMoldModel; override; function GetEffectivePersistent: Boolean; @@ -683,7 +695,7 @@ TMoldComponent = class(TBoldMemoryManagedObject) { TMoldComponentList } TMoldComponentList = Class(TList) private - function GetItem(index: Integer): TMoldComponent; + function GetItem(index: Integer): TMoldComponent; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetItemByName(const name: string): TMoldComponent; public property Items[index: Integer]: TMoldComponent read GetItem; default; @@ -695,17 +707,15 @@ implementation uses SysUtils, BoldDefaultStreamNames, + BoldDefaultTaggedValues, BoldGuard, BoldHashIndexes, BoldMetaSupport, - BoldDefaultTaggedValues, + BoldMoldConsts, + BoldNameExpander, + BoldSharedStrings, BoldUMLTaggedValues, - BoldMoldConsts; - -var - IX_Name: integer = -1; - IX_ExpressionName: integer = -1; - IX_DelphiName: integer = -1; + BoldUtils; type {---TNameIndex---} @@ -800,16 +810,16 @@ constructor TMoldModel.Create(Parent: TMoldElement; const Name: string); FAssociations := TMoldAssociationList.Create; fDispIdAssigningState := dasNotStarted; - BoldTVByName[TAG_DELPHINAME] := TV_NAME; // FIXME + BoldTVByName[TAG_DELPHINAME] := TV_NAME; + + FRootClass := TMoldClass.Create(self, Format('%sRoot',[name])); - FRootClass := TMoldClass.Create(self, Format('%sRoot',[name])); // do not localize end; destructor TMoldModel.Destroy; var i: integer; begin - // note, associations first fIsDestroying := true; FreeAndNil(fAssociations); FreeAndNil(fClasses); @@ -825,6 +835,11 @@ function TMoldModel.GetModel: TMoldModel; Result := self; end; +function TMoldClassList.GetItemByName(const name: string): TMoldClass; +begin + Result := TMoldClass(TBoldCaseSensitiveStringHashIndex(Indexes[IX_Name]).FindByString(name)); +end; + function TMoldModel.FindRoleByClassNameAndName(const boldclassName, roleName: string): TMoldRole; var MoldClass: TMoldClass; @@ -842,35 +857,14 @@ function TMoldModel.GetClassByName(const name: string): TMoldClass; Result := TMoldClass.Create(self, name); end; -function ClassesComparer(Item1, Item2: Pointer): Integer; +function ClassesComparer(Item1, Item2: TObject): Integer; begin - if (TObject(Item1) is TMoldClass) and (TObject(Item1) is TMoldClass) then - result := AnsiCompareStr(TMoldClass(Item1).name, TMoldClass(Item2).Name) + if (Item1 is TMoldClass) and (Item1 is TMoldClass) then + result := CompareStr(TMoldClass(Item1).name, TMoldClass(Item2).Name) else raise EBoldInternal.Create('ooops, class was not a class in TMoldModel.EnsureTopSorted'); end; -procedure TMoldModel.EnsureTopSorted; -var - ClassIx, SubClassIx: Integer; -begin - if Topsorted then - Exit; - Classes.OwnsEntries := false; - Classes.Clear; - Classes.OwnsEntries := true; - Classes.Add(RootClass); - ClassIx := 0; - while ClassIx < Classes.Count do - begin - Classes[ClassIx].SubClasses.Sort(ClassesComparer); - for SubClassIx := 0 to Classes[ClassIx].SubClasses.Count-1 do - Classes.Add(Classes[ClassIx].SubClasses[SubClassIx]); - inc(ClassIx); - end; - fTopSorted := True; -end; - procedure TMoldModel.SetRootClass(NewRootClass: TMoldClass); begin if Assigned(NewRootClass) then @@ -883,9 +877,30 @@ function TMoldClass.GetIntroducesManuallyDerivedMembers: Boolean; begin result := false; for i := 0 to Attributes.Count-1 do - result := result or (Attributes[i].Derived and (Attributes[i].DerivationOCL = '')); + result := result or + (Attributes[i].Derived and (Attributes[i].DerivationOCL = '')); for i := 0 to Roles.Count-1 do - result := result or (Roles[i].Derived and (Roles[i].DerivationOCL = '')); + result := result or (Roles[i].Derived and (Roles[i].DerivationOCL = '') and {Roles[i].Embed and} Roles[i].Navigable); +end; + +function TMoldClass.GetIntroducesManuallyReverseDerivedMembers: Boolean; +var + i: integer; +begin + result := false; + for i := 0 to Attributes.Count-1 do + result := result or + (Attributes[i].Derived and Attributes[i].ReverseDerived); +end; + +function TMoldAssociationList.GetItem(index: Integer): TMoldAssociation; +begin + Result := TMoldAssociation(inherited Items[index]); +end; + +function TMoldRoleList.GetItem(index: Integer): TMoldRole; +begin + Result := TMoldRole(inherited Items[index]); end; procedure TMoldModel.EnsureLinkRoles; @@ -904,11 +919,6 @@ procedure TMoldModel.EnsureLinkRoles; { TMoldClass } -function TMoldClass.GetTopSortedIndex:Integer; -begin - result := FModel.classes.IndexOf(self); -end; - constructor TMoldClass.Create(Parent: TMoldElement; const Name: string); begin inherited Create(Parent, Name); @@ -916,6 +926,7 @@ constructor TMoldClass.Create(Parent: TMoldElement; const Name: string); InitializeClass(TMoldModel(Parent)); end; + procedure TMoldClass.InitializeClass(Parent: TMoldModel); begin FModel := Parent; @@ -936,15 +947,13 @@ destructor TMoldClass.Destroy; i: Integer; TempSuperClass: TMoldClass; begin - // it should be safe to do the subclass unlinking during model destruction - // but at least Aholas model from 2001-06-01 gives an AV at one point during the resizing of - // the subclasseslist. Not performing this operation during model destruction - // is an optimization, but it is very annoying that it crashes on the above model. + + + if not Model.fIsdestroying then begin TempSuperClass := SuperClass; SuperClass := nil; - // set all children to inherit from parent instead, as this will unlink, do it backwards if Assigned(SubClasses) then for i := SubClasses.Count - 1 downto 0 do fSubClasses[i].SuperClass := TempSuperClass; @@ -965,6 +974,7 @@ destructor TMoldClass.Destroy; freeAndNil(fAllBoldMembers); freeAndNil(fAllNativeAttributes); FreeAndNil(fAllPossibleNames); + FreeAndNil(fAllAutoOverrideMethods); if Assigned(Model) and assigned(Model.Classes) then Model.Classes.RemoveEntryReference(self); @@ -976,6 +986,7 @@ function TMoldClass.GetModel: TMoldModel; Result := FModel; end; + procedure TMoldClass.NameChanged; begin if Assigned(Model) and assigned(Model.Classes) then @@ -1020,6 +1031,11 @@ function TMoldClass.GetIsRootClass: Boolean; Result := Model.RootClass = self; end; +function TMoldClassList.GetItem(index: Integer): TMoldClass; +begin + Result := TMoldClass(inherited Items[index]); +end; + function TMoldClass.GetEffectivePersistent: Boolean; var AllSubClassesTransient: Boolean; @@ -1038,7 +1054,7 @@ function TMoldClass.GetEffectivePersistent: Boolean; function TMoldClass.GetExpandedExpressionName: string; begin Result := inherited GetExpandedExpressionName; - if (length(result) > 0) and (Result[1] in ['a'..'z']) then + if (length(result) > 0) and CharInSet(Result[1], ['a'..'z']) then begin Result[1] := UpCase(Result[1]); result := BoldSharedStringManager.GetSharedString(Result); @@ -1069,12 +1085,11 @@ procedure TMoldClass.MainTables(Strings: TStrings; const AllowChild, AllowParent function TMoldClass.FindStoringClass(DefiningClass: TMoldClass; AbovedefiningClass: Boolean; Member:TMoldMember): TMoldClass; begin - // Since the defining class of the links of associationclasses is actually the other end, - // we have to return back to the link-class, unless it is a common member, and not a relation) + if Assigned(Association) and (member is TMoldRole) and (TMoldRole(Member).association = Association) then - DefiningClass := self; //CHECKME: Was Model.RootClass + DefiningClass := self; result := nil; if AbovedefiningClass then @@ -1118,14 +1133,20 @@ function TMoldClass.LowestVisibleAncestor(MoldClass: TMoldClass): TMoldClass; result := nil; end; +function TMoldAttributeList.GetItem(index: Integer): TMoldAttribute; +begin + Result := TMoldAttribute(inherited Items[index]); +end; + function TMoldClass.GetAllBoldMembers: TMoldMemberList; var i: integer; -procedure TryAdd(Member: TMoldMember); -begin - if Member.MemberExists then - fAllBoldMembers.Add(Member); -end; + + procedure TryAdd(Member: TMoldMember); + begin + if Member.MemberExists then + fAllBoldMembers.Add(Member); + end; begin if not assigned(fAllBoldMembers) then begin @@ -1134,8 +1155,11 @@ procedure TryAdd(Member: TMoldMember); fAllBoldMembers.OwnsEntries := false; if Assigned(SuperClass) then + begin + AllBoldMembers.Capacity := SuperClass.AllBoldMembers.count + Attributes.Count + (Roles.Count*2); for i := 0 to SuperClass.AllBoldMembers.count-1 do AllBoldMembers.Add(SuperClass.AllBoldMembers[i]); + end; fFirstOwnBoldMemberIndex := fAllBoldMembers.Count; @@ -1202,7 +1226,7 @@ constructor TMoldElementList.Create; function TMoldElementList.GetItemByName(const name: string): TMoldElement; begin - Result := TMoldElement(TNameIndex(Indexes[IX_Name]).FindByString(name)); + Result := TMoldElement(TBoldCaseSensitiveStringHashIndex(Indexes[IX_Name]).FindByString(name)); end; function TMoldElementList.GetItem(index: Integer): TMoldElement; @@ -1222,7 +1246,7 @@ function TMoldElementList.MakeUniqueName(const prefix: string): string; i := 0; repeat inc(i); - Result := Format('%s%d', [prefix, i]); // do not localize + Result := Format('%s%d', [prefix, i]); until ItemsByName[Result] = nil; end; @@ -1244,35 +1268,21 @@ constructor TMoldClassList.Create; SetIndexVariable(IX_DelphiName, AddIndex(TDelphiNameIndex.Create)); end; -function TMoldClassList.GetItem(index: Integer): TMoldClass; -begin - Result := TMoldClass(inherited Items[index]); -end; - function TMoldClassList.GetItemByDelphiName(const DelphiName: String): TMoldClass; begin - Result := TMoldClass(TNameIndex(Indexes[IX_DelphiName]).FindByString(DelphiName)); + Result := TMoldClass(TBoldCaseSensitiveStringHashIndex(Indexes[IX_DelphiName]).FindByString(DelphiName)); end; function TMoldClassList.GetItemByExpressionName(const ExpressionName: String): TMoldClass; begin - Result := TMoldClass(TNameIndex(Indexes[IX_ExpressionName]).FindByString(Expressionname)); -end; - -function TMoldClassList.GetItemByName(const name: string): TMoldClass; -begin - Result := TMoldClass(TNameIndex(Indexes[IX_Name]).FindByString(name)); + Result := TMoldClass(TBoldCaseSensitiveStringHashIndex(Indexes[IX_ExpressionName]).FindByString(Expressionname)); end; {---TMoldRoleList---} -function TMoldRoleList.GetItem(index: Integer): TMoldRole; -begin - Result := TMoldRole(inherited Items[index]); -end; function TMoldRoleList.GetItemByName(const name: string): TMoldRole; begin - Result := TMoldRole(TNameIndex(Indexes[IX_Name]).FindByString(name)); + Result := TMoldRole(TBoldCaseSensitiveStringHashIndex(Indexes[IX_Name]).FindByString(name)); end; {---TMoldMethodList---} @@ -1283,29 +1293,21 @@ function TMoldMethodList.GetItem(index: Integer): TMoldMethod; function TMoldMethodList.GetItemByName(const name: string): TMoldMethod; begin - Result := TMoldMethod(TNameIndex(Indexes[IX_Name]).FindByString(name)); + Result := TMoldMethod(TBoldCaseSensitiveStringHashIndex(Indexes[IX_Name]).FindByString(name)); end; {---TMoldAssociationList---} -function TMoldAssociationList.GetItem(index: Integer): TMoldAssociation; -begin - Result := TMoldAssociation(inherited Items[index]); -end; function TMoldAssociationList.GetItemByName(const name: string): TMoldAssociation; begin - Result := TMoldAssociation(TNameIndex(Indexes[IX_Name]).FindByString(name)); + Result := TMoldAssociation(TBoldCaseSensitiveStringHashIndex(Indexes[IX_Name]).FindByString(name)); end; {---TMoldAttributeList---} -function TMoldAttributeList.GetItem(index: Integer): TMoldAttribute; -begin - Result := TMoldAttribute(inherited Items[index]); -end; function TMoldAttributeList.GetItemByName(const name: string): TMoldAttribute; begin - Result := TMoldAttribute(TNameIndex(Indexes[IX_Name]).FindByString(name)); + Result := TMoldAttribute(TBoldCaseSensitiveStringHashIndex(Indexes[IX_Name]).FindByString(name)); end; {---TMoldQualifierList---} @@ -1316,7 +1318,7 @@ function TMoldQualifierList.GetItem(index: Integer): TMoldQualifier; function TMoldQualifierList.GetItemByName(const name: string): TMoldQualifier; begin - Result := TMoldQualifier(TNameIndex(Indexes[IX_Name]).FindByString(name)); + Result := TMoldQualifier(TBoldCaseSensitiveStringHashIndex(Indexes[IX_Name]).FindByString(name)); end; {---TMoldMember---} @@ -1329,13 +1331,20 @@ function TMoldMember.GetModel: TMoldModel; function TMoldMember.GetExpandedExpressionName: string; begin Result := inherited GetExpandedExpressionName; - if (length(result) > 0) and (Result[1] in ['A'..'Z']) then + if (length(result) > 0) and CharInSet(Result[1], ['A'..'Z']) then begin - Result[1] := chr(ord(Result[1]) + 32); // Make into lowercase + Result[1] := chr(ord(Result[1]) + 32); result := BoldSharedStringManager.GetSharedString(Result); end; end; +function TMoldMember.GetIndex: integer; +begin + if (fIndex = -1) and Assigned(FMoldClass) then + fIndex := FMoldClass.AllBoldMembers.IndexOf(self); + result := fIndex; +end; + procedure TMoldMember.SetMoldClass(NewMoldClass: TMoldClass); begin fMoldClass := NewMoldClass; @@ -1352,7 +1361,7 @@ constructor TMoldAttribute.Create(Parent: TMoldElement; const Name: string); inherited Create(Parent, Name); Assert(Parent is TMoldClass); SetMoldClass(TMoldClass(Parent)); - BoldType := 'String'; // do not localize + BoldType := 'String'; MoldClass.Attributes.Add(self); end; @@ -1403,10 +1412,6 @@ procedure TMoldMethod.NameChanged; end; procedure TMoldMethod.setSignature(Value: string); -const - ConstParam = 'CONST '; - VarParam = 'VAR '; - OutParam = 'OUT '; var i:integer; ParamType, @@ -1430,20 +1435,20 @@ procedure TMoldMethod.setSignature(Value: string); next := copy(value, 1, pos(';', value) - 1); value := copy(value, pos(';', value) + 1, maxint); - if Pos(ConstParam, UpperCase(Next)) > 0 then + if Pos(UpperCase('const '), UpperCase(Next)) > 0 then begin IsConst := True; - Delete(Next, Pos(ConstParam, UpperCase(Next)), Length(ConstParam)); + Delete(Next, Pos(UpperCase('const '), UpperCase(Next)), Length('const ')); end - else if Pos(VarParam, UpperCase(Next)) > 0 then + else if Pos(UpperCase('var '), UpperCase(Next)) > 0 then begin IsVar := True; - Delete(Next, Pos(VarParam, UpperCase(Next)), Length(VarParam)); + Delete(Next, Pos(UpperCase('var '), UpperCase(Next)), Length('var ')); end - else if Pos(OutParam, UpperCase(Next)) > 0 then + else if Pos(UpperCase('out '), UpperCase(Next)) > 0 then begin IsOut := True; - Delete(Next, Pos(OutParam, UpperCase(Next)), Length(OutParam)); + Delete(Next, Pos(UpperCase('out '), UpperCase(Next)), Length('out ')); end; if pos(':', next) <> 0 then @@ -1489,13 +1494,13 @@ function TMoldMethod.GetSignature: String; Assert(Parameters[i] is TMoldParameter); Param := TMoldParameter(Parameters[i]); if Param.IsConst then - Result := Result + 'const ' // do not localize + Result := Result + 'const ' else if Param.ParameterKind = pdInOut then - Result := Result + 'var ' // do not localize + Result := Result + 'var ' else if Param.ParameterKind = pdOut then - Result := Result + 'out '; // do not localize + Result := Result + 'out '; - result := result + format('%s: %s', [ // do not localize + result := result + format('%s: %s', [ TMoldParameter(parameters[i]).ParameterName, TMoldParameter(parameters[i]).ParameterType]); end; @@ -1503,7 +1508,7 @@ function TMoldMethod.GetSignature: String; function TMoldMethod.GetUMLClassName: string; begin - result := 'Operation'; // do not localize + result := 'Operation'; end; {---TMoldRole---} @@ -1514,7 +1519,7 @@ constructor TMoldRole.Create(Parent: TMoldElement; const Name: string); begin Association := TMoldAssociation(Parent); end; - Multiplicity := '0..1'; // do not localize + Multiplicity := '0..1'; Navigable := True; fRoleType := rtRole; FQualifiers := TMoldQualifierList.Create; @@ -1548,7 +1553,7 @@ function TMoldRole.GetEffectivePersistent: Boolean; Result := association.effectivePersistent and (not Derived) and (RoleType <> rtLinkRole); end; -procedure TMoldRole.setAssociation(Association: TMoldAssociation); +procedure TMoldRole.SetAssociation(Association: TMoldAssociation); var oldAssociation: TMoldAssociation; begin @@ -1612,6 +1617,16 @@ function TMoldRole.GetHasLinkRole: Boolean; result := (RoleType = rtRole) and Assigned(Association.LinkClass); end; +function TMoldRole.GetIsAttribute: boolean; +begin + result := false; +end; + +function TMoldRole.GetIsRole: boolean; +begin + result := true; +end; + function TMoldRole.GetLinkRole: TMoldRole; begin MoldClass.Model.EnsureLinkRoles; @@ -1629,7 +1644,6 @@ procedure TMoldRole.EnsureLinkRole; begin if HasLinkRole and not assigned(fRelatedRole) then begin - // make sure the additional roles comes in a known order if Association.Roles.IndexOf(self) = 1 then OtherEnd.EnsureLinkRole; if MoldClass.ChildTo(OtherEnd.MoldClass) or otherEnd.MoldClass.ChildTo(MoldClass) then @@ -1643,14 +1657,14 @@ procedure TMoldRole.EnsureLinkRole; fRelatedRole.fRoleType := rtLinkRole; fRelatedRole.MoldClass := MoldClass; fRelatedRole.FOrdered := Ordered; - fRelatedRole.Association := Association; //adds to association.LInkRole + fRelatedRole.Association := Association; fRelatedRole.FNavigable := Navigable; fRelatedRole.BoldTVByName[TAG_EMBED] := TV_FALSE; fRelatedRole.fVisibility := Visibility; InnerLinkRole := TMoldRole.Create(self, OtherEnd.Name); InnerLinkRole.fRoleType := rtInnerLinkRole; InnerLinkRole.MoldClass := Association.LinkClass; - InnerLinkRole.Association := Association; //adds to association.InnerLInkRole + InnerLinkRole.Association := Association; InnerLinkRole.Multiplicity := '1'; InnerLinkRole.Ordered := false; InnerLinkRole.BoldTVByName[TAG_EMBED] := TV_TRUE; @@ -1672,7 +1686,7 @@ function TMoldRole.GetMainRole: TMoldRole; function TMoldRole.GetUMLClassName: string; begin - result := 'AssociationEnd'; // do not localize + result := 'AssociationEnd'; end; {---TMoldAssociation---} @@ -1713,12 +1727,9 @@ function TMoldAssociation.GetModel: TMoldModel; function TMoldAssociation.GetEffectivePersistent: Boolean; begin - // associations are made implicitly transient if either class is transient during Boldify - // but the classes could still be "effective transient" Result := Persistent and not derived and - // the middle test below that the associationend is not the same as the - // link-class is just to avoid a recursion between class.effectivepersistent - // and association.effectivePersistent. Should they be the same, the model is invalid anyway... + + assigned(Roles[0].MoldClass) and (Roles[0].MoldClass <> LinkClass) and Roles[0].MoldClass.EffectivePersistent and assigned(Roles[1].MoldClass) and (Roles[1].MoldClass <> LinkClass) and Roles[1].MoldClass.EffectivePersistent; end; @@ -1734,7 +1745,7 @@ procedure TMoldAssociation.SetLinkClass(Value: TMoldClass); begin if Assigned(Value.Association) and (Value.Association <> self) then - raise EBold.CreateFmt(sClassIsRelation, [value.Name]); + raise EBold.Create(sClassIsRelation); FLinkClass := Value; LinkClass.Association := self; end; @@ -1742,7 +1753,7 @@ procedure TMoldAssociation.SetLinkClass(Value: TMoldClass); function TMoldAssociation.GetUMLClassName: string; begin - result := 'Association'; // do not localize + result := 'Association'; end; {---TMoldQualifier---} @@ -1768,7 +1779,7 @@ function TMoldQualifier.GetModel: TMoldModel; function TMoldQualifier.GetUMLClassName: string; begin - result := 'Attribute'; // do not localize + result := 'Attribute'; end; function TMoldClass.GetHasManuallyDerivedMembers: Boolean; @@ -1778,7 +1789,7 @@ function TMoldClass.GetHasManuallyDerivedMembers: Boolean; result := false; for i := 0 to AllBoldMembers.Count-1 do if AllBoldMembers[i].Derived and - (AllBoldMembers[i].DerivationOCL = '') then + ((AllBoldMembers[i].DerivationOCL = '') or AllBoldMembers[i].ReverseDerived) then begin result := true; exit; @@ -1826,17 +1837,17 @@ function TMoldClass.GetComponent: TMoldComponent; procedure TMoldClass.SetComponent(const Value: TMoldComponent); begin if assigned(Value) then - UnitName := Value.Name + BoldUnitName := Value.Name else - UnitName := ''; + BoldUnitName := ''; end; -function TMoldClass.GetTablemapping: TTableMapping; +function TMoldClass.GetTableMapping: TTableMapping; begin result := TBoldTaggedValueSupport.StringToTableMapping(BoldTVByName[TAG_TABLEMAPPING]); end; -function TMoldClass.GetUnitName: string; +function TMoldClass.GetBoldUnitName: string; begin result := BoldTVByName[TAG_UNITNAME]; end; @@ -1851,7 +1862,7 @@ function TMoldClass.GetTableName: string; result := BoldTVByName[TAG_TABLENAME]; end; -procedure TMoldClass.SetUnitName(const Value: string); +procedure TMoldClass.SetBoldUnitName(const Value: string); begin BoldTVByName[TAG_UNITNAME] := Value; end; @@ -1948,7 +1959,7 @@ function TMoldClass.GetOptimisticLocking: TBoldOptimisticLockingMode; function TMoldClass.GetExpandedUnitName: string; begin - result := BoldExpandName(UnitName, Name, xtDelphi, -1, Model.NationalCharConversion); + result := BoldExpandName(BoldUnitName, Name, xtDelphi, -1, Model.NationalCharConversion); end; procedure TMoldClass.TrimRemoved; @@ -2041,7 +2052,7 @@ function TMoldClass.GetHasDelphiAttributesWithAccessorFunctions: Boolean; function TMoldClass.GetUMLClassName: string; begin - result := 'Class'; // do not localize + result := 'Class'; end; function TMoldClass.CalculateCRC: Cardinal; @@ -2081,8 +2092,7 @@ function TMoldClass.GetStorage: TBoldStorage; function TMoldComponentList.GetItem(index: Integer): TMoldComponent; begin - Result := TMoldComponent(inherited Items[index]); -// Result := TMoldComponent(inherited Items[index]); + Result := TMoldComponent(inherited Items[index]); end; function TMoldComponentList.GetItemByName(const name: string): TMoldComponent; @@ -2096,7 +2106,6 @@ function TMoldComponentList.GetItemByName(const name: string): TMoldComponent; result := Items[i]; break; end; -// Result := TMoldComponent(TNameIndex(Indexes[IX_Name]).FindByString(name)); end; { TMoldComponent } @@ -2136,7 +2145,6 @@ constructor TMoldComponent.create(MoldModel: TMoldModel); begin inherited create; fDependencies := TMoldComponentlist.Create; -// fDependencies.OwnsEntries := false; fMoldModel := MoldModel; end; @@ -2150,7 +2158,7 @@ function TMoldComponent.dependentOf(Component: TMoldComponent): Boolean; dependencyList.Free; end; -destructor TMoldComponent.Destroy; +destructor TMoldComponent.destroy; begin FreeAndNil(fDependencies); inherited; @@ -2163,8 +2171,7 @@ function TMoldRole.GetMulti: Boolean; rtLinkRole: Result := (GetUpperLimitForMultiplicity(Multiplicity) > 1) or (fRelatedRole.Qualifiers.Count > 0); rtInnerLinkRole: Result := false; else - // there are only three rolekinds, this mainly to fool compiler hints; - raise EBold.CreateFmt(sUnknownRoleType, [ClassName, MoldClass.Name, Name]); + raise EBold.CreateFmt('%s.GetMulti: Unknown roletype for %s.%s', [ClassName, MoldClass.Name, Name]); end; end; @@ -2237,7 +2244,7 @@ function TMoldModel.RenameComponent(const OldComponentName, result.Name := NewComponentName; end; -function TMoldModel.GetUnitName: string; +function TMoldModel.GetBoldUnitName: string; begin result := BoldTVByName[TAG_UNITNAME]; end; @@ -2250,7 +2257,6 @@ procedure TMoldElement.SetBoldTVByName(const Tag, value: string); TrimmedValue := BoldTrim(Value); Definition := DefaultBoldTVList.DefinitionForTag[Tag]; if Assigned(Definition) and (Definition.DefaultValue = TrimmedValue) then - // do Nothing else BoldTaggedValues.ValueByName[Tag] := TrimmedValue; end; @@ -2301,7 +2307,7 @@ function TMoldRole.GetReverseDerived: Boolean; function TMoldMember.GetDerivationOCL: String; begin - result := BoldTVByName['DerivationOCL']; // do not localize + result := BoldTVByName['DerivationOCL']; end; function TMoldMember.GetMemberExists: boolean; @@ -2345,18 +2351,17 @@ function TMoldMethod.GetCallSignature: string; function TMoldModel.GetMainComponent: TMoldComponent; var - UnitName: String; + BoldUnitName: String; begin - UnitName := ExpandedUnitName; - if UnitName = '' then - UnitName := ExpandedDelphiName; + BoldUnitName := ExpandedUnitName; + if BoldUnitName = '' then + BoldUnitName := ExpandedDelphiName; - Result := EnsureComponent(unitName); + Result := EnsureComponent(BoldUnitName); end; procedure TMoldElement.NameChanged; begin - // do nothing end; function TMoldElement.GetDelphiName: string; @@ -2369,6 +2374,12 @@ function TMoldModel.GetInterfaceUses: string; result := BoldTVByName[TAG_INTERFACEUSES]; end; +constructor TMoldMember.Create(Parent: TMoldElement; const Name: string); +begin + inherited Create(Parent, Name); + fIndex := -1; +end; + function TMoldMember.GetColumnName: string; begin result := BoldTVByName[TAG_COLUMNNAME]; @@ -2392,7 +2403,6 @@ function TMoldRole.GetMandatory: Boolean; function TMoldElement.GetExpressionName: string; begin result := BoldTVByName[TAG_EXPRESSIONNAME]; - // associations does not have a Tagged value ExpressionName, but they still have an ExpressionName in Mold. if result = '' then result := TV_NAME; end; @@ -2456,7 +2466,7 @@ function TMoldAttribute.GetPersistent: Boolean; function TMoldAttribute.GetUMLClassName: string; begin - result := 'Attribute'; // do not localize + result := 'Attribute'; end; function TMoldAssociation.GetPersistent: Boolean; @@ -2495,6 +2505,7 @@ function TMoldModel.GetUseXFiles: Boolean; result := TVIsTrue(BoldTVByName[TAG_USEXFILES]); end; + function TMoldModel.GetImplementationUses: string; begin result := BoldTVByName[TAG_IMPLEMENTATIONUSES]; @@ -2539,13 +2550,9 @@ function TMoldMethod.GetHasDispId: Boolean; begin result := (FuncType in [dfNormal, dfVirtual, dfDynamic, dfAbstractVirtual]) and (Visibility = vkPublic); - - // each parameter must be a valid COM/IDL type - if Assigned(fParameters) then // Due to lazy create + if Assigned(fParameters) then for i := 0 to fParameters.Count -1 do result := result and (TBoldMetaSupport.ParameterTypeToIDLType(TMoldParameter(fParameters[i]).ParameterType, MoldClass.Model, dummy) <> ''); - - // returntype must be valid result := result and ((returnType = '') or (TBoldMetaSupport.ParameterTypeToIDLType(returnType, MoldClass.Model, dummy) <> '')); end; @@ -2600,7 +2607,7 @@ function TMoldRole.GetTypeStreamName: string; function TMoldModel.GetExpandedUnitName: string; begin - result := BoldExpandName(UnitName, Name, xtDelphi, -1, Model.NationalCharConversion); + result := BoldExpandName(BoldUnitName, Name, xtDelphi, -1, Model.NationalCharConversion); end; procedure TMoldElement.SetStdTVByName(const Tag, Value: string); @@ -2673,7 +2680,7 @@ procedure TMoldModel.TrimRemoved; i: integer; begin if fLinkRolesEnsured then - raise EBold.Create(sCannotTrimAfterLinkRolesEnsured); + raise EBold.Create('Can not trim removed elements after the linkroles have been ensured...'); ClassList := TMoldClassList.Create; AssocList := TMoldAssociationList.Create; @@ -2687,7 +2694,6 @@ for i := classes.count-1 downto 0 do if Associations[i].EvolutionState = esRemoved then RemoveAssoc(Associations[i], ClassList, AssocList); finally - // this will free all elements in the lists... FreeAndNil(ClassList); freeAndNil(AssocList); end; @@ -2698,7 +2704,7 @@ for i := classes.count-1 downto 0 do function TMoldModel.GetUMLClassName: string; begin - result := 'Model'; // do not localize + result := 'Model'; end; function TMoldRole.GetEffectiveDelayedFetch: Boolean; @@ -2725,6 +2731,28 @@ function TMoldElement.GetHasDispId: boolean; Result := false; end; +procedure TMoldModel.EnsureTopSorted; +var + ClassIx, SubClassIx: Integer; +begin + if Topsorted then + Exit; + Classes.OwnsEntries := false; + Classes.Clear; + Classes.OwnsEntries := true; + Classes.Add(RootClass); + ClassIx := 0; + while ClassIx < Classes.Count do + begin + Classes[ClassIx].SubClasses.Sort(ClassesComparer); + for SubClassIx := 0 to Classes[ClassIx].SubClasses.Count-1 do + Classes.Add(Classes[ClassIx].SubClasses[SubClassIx]); + Classes[ClassIx].fTopSortedIndex := ClassIx; + inc(ClassIx); + end; + fTopSorted := True; +end; + procedure TMoldModel.AssignDispIds; var i: integer; @@ -2739,7 +2767,7 @@ procedure TMoldModel.AssignDispIds; function TMoldElement.GetDispId: integer; begin if not HasDispId then - raise EBold.Create(sMemberHasNoDispID); + raise EBold.Create('member has no Dispid'); if not Model.DispIdsAssigned then Model.AssignDispIds; Result := fDispId; @@ -2759,6 +2787,16 @@ function TMoldAttribute.GetHasDispId: boolean; end; end; +function TMoldAttribute.GetIsAttribute: boolean; +begin + result := true; +end; + +function TMoldAttribute.GetIsRole: boolean; +begin + result := false; +end; + function TMoldRole.GetHasDispId: boolean; begin Result := False; @@ -2818,7 +2856,6 @@ function TMoldAssociation.GetAllPossibleNames: TStringList; try for Rn1Ix := 0 to Rolenames1.Count-1 do for Rn2Ix := 0 to RoleNames2.Count-1 do - // skip the combination of the two current names (they are last in each list)... if not ((Rn1Ix = Rolenames1.Count-1) and (Rn2Ix = Rolenames2.Count-1)) then begin fAllPossibleNames.Add(RoleNames1[Rn1Ix]+Rolenames2[Rn2Ix]); @@ -2840,7 +2877,7 @@ function TMoldAssociation.GetStorage: TBoldStorage; { TMoldParameter } -constructor TMoldParameter.create(OwningMethod: TMoldMethod); +constructor TMoldParameter.Create(OwningMethod: TMoldMethod); begin inherited Create; fOwningMethod := OwningMethod; @@ -2907,13 +2944,13 @@ function TMoldRole.CalculateCRC: Cardinal; function TMoldModel.CRC: string; begin EnsureCRC; - result := BoldTVByName['CRC']; // do not localize + result := BoldTVByName['CRC']; end; procedure TMoldModel.EnsureCRC; begin - if BoldTVByName['CRC'] = '' then // do not localize - BoldTVByName['CRC'] := intToStr(CalculateCRC); // do not localize + if BoldTVByName['CRC'] = '' then + BoldTVByName['CRC'] := intToStr(CalculateCRC); end; function TMoldModel.GetDefaultDeleteAction(AggregationKind: TAggregationKind): TDeleteAction; @@ -2975,7 +3012,7 @@ function TMoldMethod.GetCanCallInherited: Boolean; end; function TMoldElement.GetDefaultBoldTVList: TBoldTaggedValueList; - procedure DoGet; // own procedure avoids string handling overhead + procedure DoGet; begin fDefaultBoldTVList := BoldDefaultTaggedValueList.ListForClassName[UMLClassName]; end; @@ -3054,13 +3091,16 @@ procedure TMoldElement.SetNonDefaultTaggedValuesCommaText( G := TBoldGuard.Create(StringList); StringList := TStringList.Create; Stringlist.CommaText := Value; + if StringList.Count = 0 then + exit; + TaggedValues.Capacity := StringList.Count; for i := 0 to StringList.Count-1 do begin Line := StringList[i]; EqualPos := Pos('=', Line); Assert(EqualPos <> 0); Name := Copy(Line, 1, EqualPos-1); - if Name = 'Persistence' then // do not localize + if Name = 'Persistence' then Name := TAG_PERSISTENCE; TVByName[Name] := Copy(Line, EqualPos + 1, MaxInt); end; @@ -3103,4 +3143,9 @@ function TMoldRole.GetStorage: TBoldStorage; result := Association.Storage; end; +initialization + TMoldElementList.IX_Name := -1; + TMoldClassList.IX_ExpressionName := -1; + TMoldClassList.IX_DelphiName := -1; + end. diff --git a/Source/MoldModel/Core/BoldMetaSupport.pas b/Source/MoldModel/Core/BoldMetaSupport.pas index cc758daa..8a4c8eee 100644 --- a/Source/MoldModel/Core/BoldMetaSupport.pas +++ b/Source/MoldModel/Core/BoldMetaSupport.pas @@ -1,11 +1,12 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldMetaSupport; interface uses - BoldMeta, - BoldDefaultTaggedValues, - BoldDefs; + BoldMeta; type { forward declarations } @@ -52,11 +53,12 @@ TBoldNamePairRecord = record BoldWideStringTypeName = 'WideString'; BoldWordBoolTypeName = 'WordBool'; + implementation uses SysUtils, - BoldUtils; + BoldRev; type TBoldCOMIDLTypeNameMapping = record @@ -67,19 +69,19 @@ TBoldCOMIDLTypeNameMapping = record const BoldCOMIDLTypeNameMapping: array[0..21] of TBoldCOMIDLTypeNameMapping = ( - (DelphiName: 'String'; IDLName: 'BSTR'; ComName: BoldWideStringTypeName), //Type Conversion, Automation safe - (DelphiName: 'Integer'; IDLName: 'long'; ComName: 'Integer'), //Automation safe - (DelphiName: 'Boolean'; IDLName: 'VARIANT_BOOL'; ComName: BoldWordBoolTypeName), //Type Conversion, Automation safe - (DelphiName: 'Currency'; IDLName: 'CURRENCY'; ComName: 'Currency'), //Automation safe - (DelphiName: 'Double'; IDLName: 'double'; ComName: 'Double'), //Automation safe - (DelphiName: 'TDateTime'; IDLName: 'DATE'; ComName: 'TDateTime'), //Automation safe - (DelphiName: 'Longint'; IDLName: 'long'; ComName: 'Longint'), //Automation safe - (DelphiName: 'Smallint'; IDLName: 'short'; ComName: 'Smallint'), //Automation safe - (DelphiName: 'Single'; IDLName: 'float'; ComName: 'Single'), //Automation safe - (DelphiName: 'WideString'; IDLName: 'BSTR'; ComName: 'WideString'), //Automation safe - (DelphiName: 'WordBool'; IDLName: 'VARIANT_BOOL'; ComName: 'WordBool'), //Automation safe - (DelphiName: 'OleVariant'; IDLName: 'VARIANT'; ComName: 'OleVariant'), //Automation safe - (DelphiName: 'Variant'; IDLName: 'VARIANT'; ComName: 'OleVariant'), //Type Conversion, Automation safe + (DelphiName: 'String'; IDLName: 'BSTR'; ComName: BoldWideStringTypeName), + (DelphiName: 'Integer'; IDLName: 'long'; ComName: 'Integer'), + (DelphiName: 'Boolean'; IDLName: 'VARIANT_BOOL'; ComName: BoldWordBoolTypeName), + (DelphiName: 'Currency'; IDLName: 'CURRENCY'; ComName: 'Currency'), + (DelphiName: 'Double'; IDLName: 'double'; ComName: 'Double'), + (DelphiName: 'TDateTime'; IDLName: 'DATE'; ComName: 'TDateTime'), + (DelphiName: 'Longint'; IDLName: 'long'; ComName: 'Longint'), + (DelphiName: 'Smallint'; IDLName: 'short'; ComName: 'Smallint'), + (DelphiName: 'Single'; IDLName: 'float'; ComName: 'Single'), + (DelphiName: 'WideString'; IDLName: 'BSTR'; ComName: 'WideString'), + (DelphiName: 'WordBool'; IDLName: 'VARIANT_BOOL'; ComName: 'WordBool'), + (DelphiName: 'OleVariant'; IDLName: 'VARIANT'; ComName: 'OleVariant'), + (DelphiName: 'Variant'; IDLName: 'VARIANT'; ComName: 'OleVariant'), (DelphiName: 'Shortint'; IDLName: 'byte'; ComName: 'Shortint'), (DelphiName: 'Int64'; IDLName: '__int64'; ComName: 'Int64'), (DelphiName: 'Byte'; IDLName: 'unsigned char'; ComName: 'Byte'), @@ -139,8 +141,9 @@ class function TBoldMetaSupport.ParameterTypeToInterfaceType( result := ''; MoldClass := MoldModel.Classes.ItemsByName[ParameterType]; if assigned(MoldClass) then - result := MoldClass.ExpandedInterfaceName - else + result := MoldClass.ExpandedInterfaceName; + + if not Assigned(MoldClass) then begin MoldClass := MoldModel.Classes.ItemsByDelphiName[ParameterType]; if assigned(MoldClass) then @@ -158,17 +161,29 @@ class function TBoldMetaSupport.ParameterTypeToInterfaceType( end; end; - if SameText(ParameterType, 'IDispatch') then // do not localize + if (result ='') and (ParameterType <> 'TList') and (Pos('List',ParameterType) = Length(ParameterType)-3) then begin - result := 'IDispatch'; // do not localize + MoldClass := MoldModel.Classes.ItemsByDelphiName[Copy(ParameterType,1, Length(ParameterType) - 4)]; + if not Assigned(MoldClass) then + MoldClass := MoldModel.Classes.ItemsByName[Copy(ParameterType,1, Length(ParameterType) - 4)]; + + if assigned(MoldClass) then + result := MoldClass.ExpandedInterfaceName + 'List'; + end; + + if SameText(ParameterType, 'IDispatch') then + begin + result := 'IDispatch'; exit; end; - if SameText(ParameterType, 'IUnknown') then // do not localize + if SameText(ParameterType, 'IUnknown') then begin - result := 'IUnknown'; // do not localize + result := 'IUnknown'; exit; end; end; +initialization + end. diff --git a/Source/MoldModel/Core/BoldMoldConsts.pas b/Source/MoldModel/Core/BoldMoldConsts.pas index 7106995f..a83547ff 100644 --- a/Source/MoldModel/Core/BoldMoldConsts.pas +++ b/Source/MoldModel/Core/BoldMoldConsts.pas @@ -1,53 +1,18 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldMoldConsts; interface resourcestring + sRecursiveAssignment = 'Attempt to make recursive assignment'; - sClassIsRelation = 'Class "%s" is already relation class for another association'; - -//BoldBld - sErrorOnPos = '%s Line: %d Position: %d'; - sUnexpectedEOF = 'BLD Reader: Unexpected EOF'; - sBadCharacter = 'BLD Reader: Bad character %s'; - sSyntaxError = 'BLD Reader: Syntax error'; - sAKeywordExpected = 'BLD Reader: ''%s'' expected'; - sQuotedStringExpected = 'BLD Reader: Quoted string expected'; - sKeyWordTokenExpected = 'BLD Reader: KEYWORD expected'; - sIntegerExpected = 'BLD Reader: Integer expected'; - sBooleanExpected = 'BLD Reader: Boolean expected'; - -//BoldGen - sLogGeneratingInPath = 'Generating in path: %s'; - sLogGeneratingFile = 'Generating file: %s'; - sLogInitializingVars = 'Initializing variables'; - sLogExpandingTemplate = 'Expanding template'; - sLogConsiderNameChange1 = 'You should consider naming your model and base unit'; - sLogConsiderNameChange2 = 'to avoid filename conflicts with other projects'; - sLogNoDelphiMappingForType = 'No Delphimapping for type %s'; - sLogNoCOMMappingForType = 'No COM/IDL mapping for type %s, No attribute generated for %s.%s'; - sLogNoNativeMappingForType = 'No native mapping for type %s used in attribute %s.%s, only Bold attribute generated'; - sNoValueTypeMappingForType = 'No Valueinterface mapping for type %s used in persistent attribute %s.%s'; - sProcessingClassXFileY = 'Processing class %s, file %s'; - sMoveToComponent_NoSuperClass = 'MoveClassTreeToComponent: No SuperClass'; - sMoveToComponent_NoMoldModel = 'MoveClassTreeToComponent: No MoldModel'; - sCollidingFileName = 'WARNING! class %s has a file name that collides with another component (%s)!'; - sNoTemplateForPersistenceInterfaces = 'No template defined for PersistenceInterfaces'; - -//BoldMeta - sUnknownRoleType = '%s.GetMulti: Unknown roletype for %s.%s'; - sCannotTrimAfterLinkRolesEnsured = 'Can not trim removed elements after the linkroles have been ensured...'; - sMemberHasNoDispID = 'Member has no Dispid'; - -//BoldTypeNameHandleReg - sEditTypeNames = 'Edit type names'; + sClassIsRelation = 'Class is already relation class for another association'; + +implementation -//BoldNameExpander - sNameHasInvalidChars = 'Name has invalid characters'; - sNameTooLong = 'Name is too long'; - sNameCannotBeEmpty = 'Name can not be empty'; - sInvalidFirstChar = 'Name must begin with an alpha-character or underscore'; -implementation +initialization end. diff --git a/Source/MoldModel/Core/BoldNameExpander.pas b/Source/MoldModel/Core/BoldNameExpander.pas index c0ed8390..b26c0697 100644 --- a/Source/MoldModel/Core/BoldNameExpander.pas +++ b/Source/MoldModel/Core/BoldNameExpander.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldNameExpander; interface @@ -6,11 +9,6 @@ interface BoldDefs, BoldTaggedValueSupport; -// Ideas for the future: -// German double-S to ss -// Handle danish ae, oe -// Drawbacks: Performance! - type { forward declarations } TBoldAbstractNameExpander = class; @@ -24,7 +22,7 @@ TBoldDelphiNameExpanderClass = class of TBoldDelphiNameExpander; TBoldExpressionNameExpanderClass = class of TBoldExpressionNameExpander; TExpansionType = (xtDelphi, xtSQL, xtExpression); - TBoldCharacterSet = set of char; + TBoldCharacterSet = set of {$IFDEF BOLD_UNICODE}AnsiChar{$ELSE}Char{$ENDIF}; { TBoldAbstractNameExpander } TBoldAbstractNameExpander = class @@ -47,7 +45,6 @@ TBoldSQLNameExpander = class(TBoldAbstractNameExpander) protected function GetValidCharacters: TBoldCharacterSet; override; public -// function TruncateName(const Name: String; MaxIdentifierLength: integer): string; override; function ExpandName(const Name, ReplacementName: string): string; override; end; @@ -78,8 +75,8 @@ TBoldExpressionNameExpander = class(TBoldAbstractNameExpander) BoldSQLNameExpanderNameLimit: integer = 255; BoldSQLNameExpanderUpperCaseNames: boolean = false; -function BoldExpandName(Name, ReplacementName: string; ExpansionType: TExpansionType; MaxIdentifierLength: integer; NationalCharConversion: TBoldNationalCharConversion): string; -function BoldExpandPrefix(value: String; const ReplacementName, Prefix: String; MaxIdentifierLength: integer; NationalCharConversion: TBoldNationalCharConversion): String; +function BoldExpandName(const Name, ReplacementName: string; ExpansionType: TExpansionType; MaxIdentifierLength: integer; NationalCharConversion: TBoldNationalCharConversion): string; +function BoldExpandPrefix(const value: String; const ReplacementName, Prefix: String; MaxIdentifierLength: integer; NationalCharConversion: TBoldNationalCharConversion): String; implementation @@ -87,15 +84,14 @@ implementation SysUtils, BoldUtils, BoldSharedStrings, - BoldDefaultTaggedValues, - BoldMoldConsts; + BoldDefaultTaggedValues; var BoldSQLNameExpander: TBoldSQLNameExpander = nil; BoldDelphiNameExpander: TBoldDelphiNameExpander = nil; BoldExpressionNameExpander: TBoldExpressionNameExpander = nil; -function BoldExpandName(Name, ReplacementName: string; +function BoldExpandName(const Name, ReplacementName: string; ExpansionType: TExpansionType; MaxIdentifierLength: integer; NationalCharConversion: TBoldNationalCharConversion): string; @@ -110,10 +106,10 @@ function BoldExpandName(Name, ReplacementName: string; BoldSQLNameExpander.Free; BoldSQLNameExpander := BoldSQLNameExpanderClass.Create; end; - + if MaxIdentifierLength = -1 then MaxIdentifierLength := BoldSQLNameExpanderNameLimit; - + CurrentNameExpander := BoldSQLNameExpander; end; xtDelphi: begin @@ -146,7 +142,7 @@ function BoldExpandName(Name, ReplacementName: string; result := BoldSharedStringManager.GetSharedString(Result); end; -function BoldExpandPrefix(value: String; +function BoldExpandPrefix(const value: String; const ReplacementName, Prefix: String; MaxIdentifierLength: integer; NationalCharConversion: TBoldNationalCharConversion): String; @@ -184,7 +180,7 @@ function TBoldAbstractNameExpander.ExpandName(const Name, ReplacementName: strin DoExpand(Copy(S, I + TV_NAME_Length, MaxInt)) else Result := S; - end; + end; end; begin Result := DoExpand(Name); @@ -278,7 +274,7 @@ function TBoldAbstractNameExpander.MapCharacters(const Name: String; validChars := ValidCharacters; if validChars <> [] then for i := 1 to Length(result) do - if not (result[i] in ValidChars) then + if not CharInSet(result[i], ValidChars) then result[i] := MapCharacter[result[i], NationalCharConversion]; end; @@ -320,18 +316,18 @@ function TBoldAbstractNameExpander.ValidateName(Name: String; if name <> MapCharacters(Name, NationalCharConversion) then begin result := false; - reason := sNameHasInvalidChars; + reason := 'Name has invalid characters'; end; if name <> truncateName(Name, MaxIdentifierLength) then begin result := false; - reason := sNameTooLong; + reason := 'Name is too long'; end; if result then begin if not LanguageIsCaseSensitive then name := UpperCase(Name); - end; + end; end; { TBoldSQLNameExpander } @@ -386,7 +382,7 @@ function TBoldDelphiNameExpander.MapCharacters(const Name: String; NationalCharConversion: TBoldNationalCharConversion): string; begin result := inherited MapCharacters(Name, NationalCharConversion); - if (length(result) > 0) and not (result[1] in ['a'..'z', 'A'..'Z', '_']) then + if (length(result) > 0) and not CharInSet(result[1], ['a'..'z', 'A'..'Z', '_']) then result[1] := MapCharacter[result[1], NationalCharConversion]; end; @@ -399,12 +395,12 @@ function TBoldDelphiNameExpander.ValidateName(Name: String; if result and (length(name) = 0) then begin result := false; - reason := sNameCannotBeEmpty; + reason := 'Name can not be empty'; end; - if result and not (name[1] in ['a'..'z', 'A'..'Z', '_']) then + if result and not CharInSet(name[1], ['a'..'z', 'A'..'Z', '_']) then begin result := false; - reason := sInvalidFirstChar; + reason := 'Name must begin with an alpha-character or underscore'; end; end; @@ -419,7 +415,7 @@ function TBoldExpressionNameExpander.MapCharacters(const Name: String; NationalCharConversion: TBoldNationalCharConversion): string; begin result := inherited MapCharacters(Name, NationalCharConversion); - if (length(result) > 0) and not (result[1] in ['a'..'z', 'A'..'Z', '_']) then + if (length(result) > 0) and not CharInSet(result[1], ['a'..'z', 'A'..'Z', '_']) then result[1] := MapCharacter[result[1], NationalCharConversion]; end; @@ -432,13 +428,13 @@ function TBoldExpressionNameExpander.ValidateName(Name: String; if result and (length(name) = 0) then begin result := false; - reason := sNameCannotBeEmpty; + reason := 'Name can not be empty'; end; - if result and not (name[1] in ['a'..'z', 'A'..'Z', '_']) then + if result and not CharInSet(name[1], ['a'..'z', 'A'..'Z', '_']) then begin result := false; - reason := sInvalidFirstChar; + reason := 'Name must begin with an alpha-character or underscore'; end; end; diff --git a/Source/MoldModel/Handles/BoldAbstractModel.pas b/Source/MoldModel/Handles/BoldAbstractModel.pas index 542698f1..667e8bc5 100644 --- a/Source/MoldModel/Handles/BoldAbstractModel.pas +++ b/Source/MoldModel/Handles/BoldAbstractModel.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAbstractModel; interface @@ -13,7 +16,6 @@ interface beModelChanged = 25; type - // Forward declarations of all classes TBoldAbstractModel = class; { TBoldAbstractModel } @@ -36,10 +38,10 @@ TBoldAbstractModel = class(TBoldSubscribableComponent) procedure DefineProperties(Filer: TFiler); override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure EnsureMoldModelCurrent; virtual; - procedure SetFromModel(model: TMoldModel); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; + procedure SetFromModel(model: TMoldModel); //PATCH CFloury made public procedure UpdateDesigner; procedure WriteToBeRemovedInfoToFile(FileName: String); property MoldModel: TMoldModel read GetMoldModel; @@ -64,7 +66,6 @@ implementation constructor TBoldAbstractModel.Create(AOwner: TComponent); begin inherited Create(AOwner); - fComponentStyle := fComponentStyle - [csInheritable]; SetFromModel(nil); end; @@ -96,7 +97,6 @@ procedure TBoldAbstractModel.DefineProperties(Filer: TFiler); begin ModelAsStrings := TStringList.Create; AncestorModelAsStrings := TStringList.Create; - // takes care of not writing the model on an inherited form if it has not been changed TMoldBLDRW.ModelToStrings(RawMoldModel, ModelAsStrings); TMoldBLDRW.ModelToStrings((Filer.Ancestor as TBoldAbstractModel).RawMoldModel,AncestorModelAsStrings); Result := not ModelAsStrings.Equals(AncestorModelAsStrings); @@ -105,7 +105,7 @@ procedure TBoldAbstractModel.DefineProperties(Filer: TFiler); begin inherited DefineProperties(Filer); - Filer.DefineProperty('Model', ReadModel, WriteModel, DoWriteModel); // do not localize + Filer.DefineProperty('Model', ReadModel, WriteModel, DoWriteModel); end; procedure TBoldAbstractModel.ReadModel(Reader: TReader); @@ -285,9 +285,12 @@ procedure TBoldAbstractModel.WriteToBeRemovedInfoToFile(FileName: String); end; end; + procedure TBoldAbstractModel.EnsureMoldModelCurrent; begin end; +initialization + end. diff --git a/Source/MoldModel/Handles/BoldTypeNameHandle.pas b/Source/MoldModel/Handles/BoldTypeNameHandle.pas index f61270e0..6dc4d551 100644 --- a/Source/MoldModel/Handles/BoldTypeNameHandle.pas +++ b/Source/MoldModel/Handles/BoldTypeNameHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldTypeNameHandle; interface @@ -11,6 +14,7 @@ interface TBoldTypeNameHandle = class; { TBoldTypeNameHandle } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldTypeNameHandle = class(TComponent) private FDictionary: TBoldTypeNameDictionary; @@ -47,4 +51,6 @@ procedure TBoldTypeNameHandle.SetDictionary(const Value: TBoldTypeNameDictionary FDictionary.Assign(Value); end; +initialization + end. diff --git a/Source/MoldModel/IDE/BoldModelReg.pas b/Source/MoldModel/IDE/BoldModelReg.pas index 62d29b1f..9131ff23 100644 --- a/Source/MoldModel/IDE/BoldModelReg.pas +++ b/Source/MoldModel/IDE/BoldModelReg.pas @@ -1,25 +1,31 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldModelReg; interface +uses + DesignIntf, + Classes; + procedure Register; implementation +{$R BoldModelReg.res} + uses SysUtils, - DesignIntf, - Classes, BoldUtils, + BoldGuard, BoldTypeNameHandle, BoldAbstractModel, BoldIDEConsts; -{.$R BoldModelReg.res} - procedure Register; begin RegisterComponents(BOLDPAGENAME_MISC, [TBoldTypeNameHandle]); end; -end. +end. diff --git a/Source/MoldModel/IDE/BoldModelReg.res b/Source/MoldModel/IDE/BoldModelReg.res new file mode 100644 index 00000000..056025f7 Binary files /dev/null and b/Source/MoldModel/IDE/BoldModelReg.res differ diff --git a/Source/MoldModel/IDE/BoldTypeNameHandleReg.pas b/Source/MoldModel/IDE/BoldTypeNameHandleReg.pas index a5c1e06d..79d7c82e 100644 --- a/Source/MoldModel/IDE/BoldTypeNameHandleReg.pas +++ b/Source/MoldModel/IDE/BoldTypeNameHandleReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldTypeNameHandleReg; interface @@ -37,13 +40,15 @@ implementation Controls, BoldTypeNameDictionary, BoldTypeNameHandle, - BoldTypeNameEditor, - BoldMoldConsts; + + BoldTypeNameEditor, + BoldGuard, + BoldRev; procedure Register; begin RegisterComponentEditor(TBoldTypeNameHandle, TBoldTypeNameEditor); - RegisterPropertyEditor(TypeInfo(TBoldTypeNameDictionary), TBoldTypeNameHandle, 'Dictionary', TBoldTypeNamePropEditor); // do not localize + RegisterPropertyEditor(TypeInfo(TBoldTypeNameDictionary), TBoldTypeNameHandle, 'Dictionary', TBoldTypeNamePropEditor); end; { TTBoldModelEditor } @@ -55,23 +60,21 @@ procedure TBoldTypeNameEditor.ExecuteVerb(index: Integer); with Component as TBoldTypeNameHandle do begin EditorForm := TBoldTypeNameEditorForm.Create(nil); - try - EditorForm.LoadFromDictionary(Dictionary); - - if EditorForm.ShowModal = mrOK then - begin - EditorForm.SaveToDictionary(Dictionary); - Designer.Modified; - end; - finally - EditorForm.Free; + EditorForm.LoadFromDictionary(Dictionary); + + if EditorForm.ShowModal = mrOK then + begin + EditorForm.SaveToDictionary(Dictionary); + Designer.Modified; end; + + EditorForm.Free; end; end; function TBoldTypeNameEditor.GetVerb(index: Integer): string; begin - result := sEditTypeNames; + result := 'Edit type names'; end; function TBoldTypeNameEditor.GetVerbCount: Integer; @@ -107,7 +110,7 @@ function TBoldTypeNamePropEditor.GetAttributes: TPropertyAttributes; function TBoldTypeNamePropEditor.GetValue: String; begin - result := 'TBoldTypeNameDictionary'; // do not localize + result := 'TBoldTypeNameDictionary'; end; end. diff --git a/Source/MoldModel/TypeNameDictionary/BoldTypeNameDictionary.pas b/Source/MoldModel/TypeNameDictionary/BoldTypeNameDictionary.pas index b8fb4885..1f9b85f6 100644 --- a/Source/MoldModel/TypeNameDictionary/BoldTypeNameDictionary.pas +++ b/Source/MoldModel/TypeNameDictionary/BoldTypeNameDictionary.pas @@ -1,10 +1,12 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldTypeNameDictionary; interface uses - Classes, - BoldDefs; + Classes; type TBoldTypeNameDictionary = class; @@ -19,7 +21,7 @@ TBoldTypeNameMapping = class(TCollectionItem) FNativeType: String; FMapperName: String; fContentsName: String; - fUnitName: String; + fBoldUnitName: String; fComType: String; fIDLType: String; fValueInterface: String; @@ -53,13 +55,13 @@ TBoldTypeNameMapping = class(TCollectionItem) property MapperName: String read FMapperName write fMapperName; property Accessor: String read FAccessor write fAccessor; property NativeType: String read FNativeType write fNativeType; - property UnitNameText: String read fUnitName write fUnitName; + property BoldUnitName: String read fBoldUnitName write fBoldUnitName; + property UnitName: String read fBoldUnitName write fBoldUnitName stored false; property ComType: String read fComType write fComType; property IDLType: String read fIDLType write fIDLType; property ValueInterface: String read fValueInterface write fValueInterface; property ValueInterfaceAccessor: String read fValueInterfaceAccessor write fValueInterfaceAccessor; property ValueInterfaceNativeType: String read fValueInterfaceNativeType write fValueInterfaceNativeType; - end; TBoldTypeNameDictionary = class(TCollection) @@ -90,16 +92,18 @@ implementation uses SysUtils, - BoldUtils, + BoldDefs, BoldNameExpander, BoldTaggedValueSupport; const - DefaultMappings: array[0..29, 0..12] of String = ( -// ModelName ExpressionName DelphiName Contentname PMapper Accessor NativeType Unit ComType IDL ValueInterface - (DEFAULTNAMELITERAL,'String', 'TBA', '', 'TBoldPM', 'As', '', 'BoldAttributes', 'WideString', 'BSTR', 'IBoldStringContent', 'AsString', 'String'), + DefaultMappings: array[0..32, 0..12] of String = ( + (DEFAULTNAMELITERAL,'String', 'TBA', '', 'TBoldPM', 'As', '', 'BoldAttributes', 'WideString', 'BSTR', 'IBoldStringContent', 'AsString', 'String'), ('String', 'String', 'TBA', '', 'TBoldPM', 'As', '', 'BoldAttributes', 'WideString', 'BSTR', 'IBoldStringContent', 'AsString', 'String'), ('AnsiString', 'String', 'TBA', '', 'TBoldPM', 'As', '', 'BoldAttributes', 'WideString', 'BSTR', 'IBoldStringContent', 'AsString', 'String'), + ('UnicodeString', 'UnicodeString','TBA', 'String', 'TBoldPM', 'AsString', 'String', 'BoldAttributes', 'WideString', 'BSTR', 'IBoldUnicodeStringContent', 'AsUnicodeString', 'String'), + ('Text', 'Text', 'TBA', 'String', 'TBoldPM', 'AsString', 'String', 'BoldAttributes', 'WideString', 'BSTR', 'IBoldAnsiStringContent', 'AsAnsiString', 'AnsiString'), + ('UnicodeText', 'UnicodeText', 'TBA', 'String', 'TBoldPM', 'AsString', 'String', 'BoldAttributes', 'WideString', 'BSTR', 'IBoldUnicodeStringContent', 'AsUnicodeString', 'String'), ('', 'Numeric', 'TBA', '', '', '', '', 'BoldAttributes', '', '', '', '', ''), ('Integer', 'Integer', 'TBA', '', 'TBoldPM', 'As', '', 'BoldAttributes', 'Integer', 'LONG', 'IBoldIntegerContent', 'AsInteger', 'integer'), ('Int', 'Integer', 'TBA', '', 'TBoldPM', 'As', '', 'BoldAttributes', 'Integer', 'LONG', 'IBoldIntegerContent', 'AsInteger', 'integer'), @@ -145,7 +149,7 @@ procedure TBoldTypeNameDictionary.AddDefaultMappings; MapperName := DefaultMappings[i, 4]; Accessor := DefaultMappings[i, 5]; NativeType := DefaultMappings[i, 6]; - UnitNameText := DefaultMappings[i, 7]; + BoldUnitName := DefaultMappings[i, 7]; ComType := DefaultMappings[i, 8]; IDLType := DefaultMappings[i, 9]; ValueInterface := DefaultMappings[i, 10]; @@ -243,7 +247,7 @@ procedure TBoldTypeNameDictionary.SaveToStringList(StrList: TStringList); function TBoldTypeNameMapping.GetAsString: string; begin - Result := Format('ModelName=%s,ExpressionName=%s,DelphiName=%s,ContentsName=%s,MapperName=%s,AccessorName=%s,NativeType=%s,UnitName=%s,ComType=%s,IDLType=%s,ValueInterface=%s,ValueInterfaceAccessor=%s,ValueInterfaceNativeType=%s', // do not localize + Result := Format('ModelName=%s,ExpressionName=%s,DelphiName=%s,ContentsName=%s,MapperName=%s,AccessorName=%s,NativeType=%s,UnitName=%s,ComType=%s,IDLType=%s,ValueInterface=%s,ValueInterfaceAccessor=%s,ValueInterfaceNativeType=%s', [ModelName, ExpressionName, DelphiName, @@ -251,7 +255,7 @@ function TBoldTypeNameMapping.GetAsString: string; MapperName, Accessor, NativeType, - UnitNameText, + BoldUnitName, ComType, IDLType, ValueInterface, @@ -285,26 +289,30 @@ function TBoldTypeNameMapping.GetExpandedContentsName: String; end; procedure TBoldTypeNameMapping.SetAsString(const Value: string); +var + vTmpList: TStringList; begin - with TStringList.Create do + vTmpList := TStringList.Create; try - CommaText := value; - ModelName := Values['ModelName']; // do not localize - ExpressionName := Values['ExpressionName']; // do not localize - DelphiName := Values['DelphiName']; // do not localize - if Values['StreamName'] <> '' then // do not localize - ContentsName := Values['StreamName'] // do not localize + vTmpList.CommaText := value; + ModelName := vTmpList.Values['ModelName']; + ExpressionName := vTmpList.Values['ExpressionName']; + DelphiName := vTmpList.Values['DelphiName']; + + if vTmpList.Values['StreamName'] <> '' then + ContentsName := vTmpList.Values['StreamName'] else - ContentsName := Values['ContentsName']; // do not localize - MapperName := Values['MapperName']; // do not localize - Accessor := Values['AccessorName']; // do not localize - NativeType := Values['NativeType']; // do not localize - UnitNameText := Values['UnitName']; // do not localize - ComType := Values['ComType']; // do not localize - IDLType := Values['IDLType']; // do not localize - ValueInterface := Values['ValueInterface']; // do not localize - ValueInterfaceAccessor := Values['ValueInterfaceAccessor']; // do not localize - ValueInterfaceNativeType := Values['ValueInterfaceNativeType']; // do not localize + ContentsName := vTmpList.Values['ContentsName']; + + MapperName := vTmpList.Values['MapperName']; + Accessor := vTmpList.Values['AccessorName']; + NativeType := vTmpList.Values['NativeType']; + BoldUnitName := vTmpList.Values['UnitName']; + ComType := vTmpList.Values['ComType']; + IDLType := vTmpList.Values['IDLType']; + ValueInterface := vTmpList.Values['ValueInterface']; + ValueInterfaceAccessor := vTmpList.Values['ValueInterfaceAccessor']; + ValueInterfaceNativeType := vTmpList.Values['ValueInterfaceNativeType']; finally Free; end; @@ -313,7 +321,7 @@ procedure TBoldTypeNameMapping.SetAsString(const Value: string); procedure TBoldTypeNameMapping.DefineProperties(Filer: TFiler); begin inherited; - Filer.DefineProperty('StreamName', ReadStreamName, nil, False); // do not localize + Filer.DefineProperty('StreamName', ReadStreamName, nil, False); end; procedure TBoldTypeNameMapping.ReadStreamName(Reader: TReader); @@ -324,8 +332,7 @@ procedure TBoldTypeNameMapping.ReadStreamName(Reader: TReader); procedure TBoldTypeNameMapping.AssignTo(Dest: TPersistent); begin if dest is TBoldTypeNameMapping then - with dest as TBoldTypeNameMapping do - begin + with dest as TBoldTypeNameMapping do begin ModelName := self.ModelName; ExpressionName := self.ExpressionName; DelphiName := self.DelphiName; @@ -333,7 +340,7 @@ procedure TBoldTypeNameMapping.AssignTo(Dest: TPersistent); MapperName := self.MapperName; Accessor := self.Accessor; NativeType := self.NativeType; - UnitNameText := self.UnitNameText; + BoldUnitName := self.BoldUnitName; ComType := self.ComType; IDLType := self.IDLType; ValueInterface := self.ValueInterface; @@ -344,9 +351,11 @@ procedure TBoldTypeNameMapping.AssignTo(Dest: TPersistent); inherited; end; + function TBoldTypeNameMapping.GetExpandedComType: String; begin result := BoldExpandName(ComType, ExpressionName, xtExpression, -1, nccDefault); end; + end. diff --git a/Source/MoldModel/UtilsGUI/BoldTypeNameEditor.pas b/Source/MoldModel/UtilsGUI/BoldTypeNameEditor.pas index 4f901522..181f5471 100644 --- a/Source/MoldModel/UtilsGUI/BoldTypeNameEditor.pas +++ b/Source/MoldModel/UtilsGUI/BoldTypeNameEditor.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldTypeNameEditor; interface @@ -57,25 +60,26 @@ implementation uses SysUtils, - BoldUtils; + BoldUtils, + BoldRev; {$R *.dfm} procedure TBoldTypeNameEditorForm.FormCreate(Sender: TObject); begin - StringGrid1.Cells[0, 0] := 'ModelName'; // do not localize - StringGrid1.Cells[1, 0] := 'ExpressionName'; // do not localize - StringGrid1.Cells[2, 0] := 'DelphiName'; // do not localize - StringGrid1.Cells[3, 0] := 'ContentName'; // do not localize - StringGrid1.Cells[4, 0] := 'PMapper'; // do not localize - StringGrid1.Cells[5, 0] := 'Accessor'; // do not localize - StringGrid1.Cells[6, 0] := 'NativeType'; // do not localize - StringGrid1.Cells[7, 0] := 'UnitName'; // do not localize - StringGrid1.Cells[8, 0] := 'ComType'; // do not localize - StringGrid1.Cells[9, 0] := 'IDLType'; // do not localize - StringGrid1.Cells[10, 0] := 'ValueInterface'; // do not localize - StringGrid1.Cells[11, 0] := 'VI-accessor'; // do not localize - StringGrid1.Cells[12, 0] := 'VI-NativeType'; // do not localize + StringGrid1.Cells[0, 0] := 'ModelName'; + StringGrid1.Cells[1, 0] := 'ExpressionName'; + StringGrid1.Cells[2, 0] := 'DelphiName'; + StringGrid1.Cells[3, 0] := 'ContentName'; + StringGrid1.Cells[4, 0] := 'PMapper'; + StringGrid1.Cells[5, 0] := 'Accessor'; + StringGrid1.Cells[6, 0] := 'NativeType'; + StringGrid1.Cells[7, 0] := 'UnitName'; + StringGrid1.Cells[8, 0] := 'ComType'; + StringGrid1.Cells[9, 0] := 'IDLType'; + StringGrid1.Cells[10, 0] := 'ValueInterface'; + StringGrid1.Cells[11, 0] := 'VI-accessor'; + StringGrid1.Cells[12, 0] := 'VI-NativeType'; end; procedure TBoldTypeNameEditorForm.btnAddClick(Sender: TObject); @@ -83,12 +87,12 @@ procedure TBoldTypeNameEditorForm.btnAddClick(Sender: TObject); StringGrid1.RowCount := StringGrid1.RowCount + 1; StringGrid1.Row := StringGrid1.RowCount - 1; StringGrid1.Col := 0; - Stringgrid1.Cells[2, StringGrid1.RowCount - 1] := 'TXX'; // do not localize - Stringgrid1.Cells[3, StringGrid1.RowCount - 1] := ''; // do not localize - Stringgrid1.Cells[4, StringGrid1.RowCount - 1] := 'TBoldPM'; // do not localize - Stringgrid1.Cells[5, StringGrid1.RowCount - 1] := 'as'; // do not localize - Stringgrid1.Cells[6, StringGrid1.RowCount - 1] := 'T'; // do not localize - Stringgrid1.Cells[10, StringGrid1.RowCount - 1] := 'IBoldContent'; // do not localize + Stringgrid1.Cells[2, StringGrid1.RowCount - 1] := 'TXX'; + Stringgrid1.Cells[3, StringGrid1.RowCount - 1] := ''; + Stringgrid1.Cells[4, StringGrid1.RowCount - 1] := 'TBoldPM'; + Stringgrid1.Cells[5, StringGrid1.RowCount - 1] := 'as'; + Stringgrid1.Cells[6, StringGrid1.RowCount - 1] := 'T'; + Stringgrid1.Cells[10, StringGrid1.RowCount - 1] := 'IBoldContent'; StringGrid1.SetFocus; end; @@ -105,6 +109,7 @@ procedure TBoldTypeNameEditorForm.btnDeleteClick(Sender: TObject); end; end; + procedure TBoldTypeNameEditorForm.btnDownClick(Sender: TObject); begin MoveRow(1); @@ -174,7 +179,7 @@ procedure TBoldTypeNameEditorForm.LoadFromDictionary(Dictionary: TBoldTypeNameDi StringGrid1.Cells[4, i + 1] := Dictionary.Mapping[i].MapperName; StringGrid1.Cells[5, i + 1] := Dictionary.Mapping[i].Accessor; StringGrid1.Cells[6, i + 1] := Dictionary.Mapping[i].NativeType; - StringGrid1.Cells[7, i + 1] := Dictionary.Mapping[i].UnitNameText; + StringGrid1.Cells[7, i + 1] := Dictionary.Mapping[i].UnitName; StringGrid1.Cells[8, i + 1] := Dictionary.Mapping[i].ComType; StringGrid1.Cells[9, i + 1] := Dictionary.Mapping[i].IdlType; StringGrid1.Cells[10, i + 1] := Dictionary.Mapping[i].ValueInterface; @@ -199,7 +204,7 @@ procedure TBoldTypeNameEditorForm.SaveToDictionary(Dictionary: TBoldTypeNameDict MapperName := StringGrid1.Cells[4, i]; Accessor := StringGrid1.Cells[5, i]; NativeType := StringGrid1.Cells[6, i]; - UnitNameText := StringGrid1.Cells[7, i]; + UnitName := StringGrid1.Cells[7, i]; ComType := StringGrid1.Cells[8, i]; IDLType := StringGrid1.Cells[9, i]; ValueInterface := StringGrid1.Cells[10, i]; @@ -242,7 +247,6 @@ procedure TBoldTypeNameEditorForm.MergeDefaultsmappings1Click(Sender: TObject); Mapping := CurrentMappings.ExactMappingForModelName[DefaultMappings.Mapping[i].modelName] else begin - // our abstract types does not have model names. Fortuantely, for j := 0 to CurrentMappings.Count - 1 do if CompareText(DefaultMappings.Mapping[i].ExpressionName, CurrentMappings.Mapping[j].ExpressionName) = 0 then begin @@ -262,4 +266,6 @@ procedure TBoldTypeNameEditorForm.MergeDefaultsmappings1Click(Sender: TObject); end; end; +initialization + end. diff --git a/Source/ObjectSpace/BORepresentation/BoldAttributes.pas b/Source/ObjectSpace/BORepresentation/BoldAttributes.pas index a664147a..0b0ea64c 100644 --- a/Source/ObjectSpace/BORepresentation/BoldAttributes.pas +++ b/Source/ObjectSpace/BORepresentation/BoldAttributes.pas @@ -1,9 +1,13 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAttributes; interface uses Classes, + SysUtils, BoldSystem, BoldSystemRT, BoldDefs, @@ -11,14 +15,16 @@ interface BoldSubscription, BoldElements, BoldDomainElement, - BoldValueInterfaces; + BoldValueInterfaces, + BoldFreeStandingValues; + {$IFNDEF BOLD_NO_QUERIES} const {Query events} bqBaseAttributes = bqMaxSystem + 1; bqMaySetContentType = bqBaseAttributes + 0; bqMaxAttributes = bqBaseAttributes + 0; - + {$ENDIF} type {Declare New Exceptions Types} @@ -42,54 +48,163 @@ TBAValueSetValue = class; TBAValueSetValueList = class; TBAValueSet = class; + TBAValueSetClass = class of TBAValueSet; + {---TBAString---} + { Base class for all string attributes. Before Unicode (Delphi 2009) this class + constains an AnsiString, after Unicode (Delphi 2009 and up) a UnicodeString. + + The descendants TBAAnsiString and TBAUnicodeString only contains implementation + and an additional data field, if it is a different string kind compared to + this class in the respective Delphi version. + This ensures that TBAString can be used as a base class for all string attributes + which helps in type checks and comparation and on the other hand it can be + instanciated and then uses the default string type of the Delphi version. } TBAString = class(TBoldAttribute) + strict private + FValue: string; private - fValue: string; - procedure SetDataValue(NewValue: string); - procedure SetContent(NewValue: string); + class var AttributeTypeInfo: TBoldElementTypeInfo; + procedure SetDataValue(const NewValue: string); + procedure SetContent(const NewValue: string); protected - procedure AssignContentValue(Source: IBoldValue); override; + function GetAttributeTypeInfoForType: TBoldElementTypeInfo; override; + procedure AssignContentValue(const Source: IBoldValue); override; procedure FreeContent; override; + function GetAsAnsiString: TBoldAnsiString; virtual; + function GetAsUnicodeString: TBoldUnicodeString; virtual; function GetStringRepresentation(Representation: TBoldRepresentation): string; override; - procedure SetStringRepresentation(Representation: TBoldRepresentation; Value: string); override; + procedure SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); override; + function GetValue: string; virtual; function MaySetValue(NewValue: String; Subscriber: TBoldSubscriber): Boolean; virtual; - function ProxyClass: TBoldMember_ProxyClass; override; + function GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; + procedure SetAsAnsiString(const Value: TBoldAnsiString); virtual; + procedure SetAsUnicodeString(const Value: TBoldUnicodeString); virtual; + procedure SetValue(const Value: string); virtual; + function GetFreeStandingClass: TBoldFreeStandingElementClass; override; + property Value: string read GetValue write SetValue; public + constructor CreateWithValue(const Value: string); procedure Assign(Source: TBoldElement); override; - procedure AssignValue(Source: IBoldValue); override; + procedure AssignValue(const Source: IBoldValue); override; function CompareToAs(CompType: TBoldCompareType; BoldElement: TBoldElement): Integer; override; - function ValidateString(Value: string; Representation: TBoldRepresentation): Boolean; override; + function ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; override; function CanSetValue(NewValue: string; Subscriber: TBoldSubscriber): Boolean; function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; override; procedure SetEmptyValue; override; + function IsNullOrEmpty: Boolean; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; + property AsAnsiString: TBoldAnsiString read GetAsAnsiString write + SetAsAnsiString; + property AsUnicodeString: TBoldUnicodeString read GetAsUnicodeString write + SetAsUnicodeString; end; {$IFNDEF T2H} TBAString_Proxy = class(TBoldAttribute_Proxy, IBoldStringContent) private + class var fLastUsed: array[TBoldDomainElementProxyMode] of TBoldMember_Proxy; + class var fLastUsedAsInterface: array[TBoldDomainElementProxyMode] of IBoldValue; + function GetContentAsAnsiString: TBoldAnsiString; + function GetContentAsUnicodeString: TBoldUnicodeString; function GetProxedString: TBAString; procedure SetContentAsString(const NewValue: String); - function GetContentAsString: String; + function GetContentAsString: String; override; + procedure SetContentAsAnsiString(const NewValue: TBoldAnsiString); + procedure SetContentAsUnicodeString(const NewValue: TBoldUnicodeString); protected - property ProxedString: TBAString read GetProxedString ; + property ProxedString: TBAString read GetProxedString; + class function MakeProxy(ProxedMember: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; end; {$ENDIF} + {---TBAAnsiString---} + TBAAnsiString = class(TBAString) + private + function ProxyClass: TBoldMember_ProxyClass; + {$IFDEF BOLD_UNICODE} + private + fValue: TBoldAnsiString; + procedure SetContent(NewValue: TBoldAnsiString); + procedure SetDataValue(NewValue: TBoldAnsiString); + {$ENDIF} + protected + {$IFDEF BOLD_UNICODE} + procedure FreeContent; override; + function GetValue: string; override; + procedure SetValue(const Value: string); override; + function GetAsAnsiString: TBoldAnsiString; override; + procedure SetAsAnsiString(const Value: TBoldAnsiString); override; + {$ENDIF} + function GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; + public + function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; + out Obj): Boolean; override; + {$IFDEF BOLD_UNICODE} + function ValidateCharacter(C: Char; Representation: TBoldRepresentation): + Boolean; override; + function ValidateString(const Value: string; Representation: TBoldRepresentation): + Boolean; override; + {$ENDIF} + end; + + {---TBAUnicodeString---} + TBAUnicodeString = class(TBAString) + private + {$IFNDEF BOLD_UNICODE} + fValue: TBoldUnicodeString; + procedure SetContent(NewValue: TBoldUnicodeString); + procedure SetDataValue(NewValue: TBoldUnicodeString); + {$ENDIF} + function ProxyClass: TBoldMember_ProxyClass; + protected + {$IFNDEF BOLD_UNICODE} + procedure FreeContent; override; + function GetAsUnicodeString: TBoldUnicodeString; override; + function GetValue: string; override; + procedure SetAsUnicodeString(const Value: TBoldUnicodeString); override; + procedure SetValue(const Value: string); override; + {$ENDIF} + function GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; + public + function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; + out Obj): Boolean; override; + end; + + {---TBAText---} + TBAText = class(TBAAnsiString) + protected + public + function ValidateString(const Value: string; Representation: TBoldRepresentation): + Boolean; override; + end; + + {---TBAUnicodeText---} + TBAUnicodeText = class(TBAUnicodeString) + public + function ValidateString(const Value: string; Representation: TBoldRepresentation): + Boolean; override; + end; {---TBATrimmedString---} TBATrimmedString = class(TBAString) protected - procedure SetStringRepresentation(Representation: TBoldRepresentation; Value: string); override; + procedure SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); override; end; {---TBANumeric---} TBANumeric = class(TBoldAttribute) + private + class var AttributeTypeInfo: TBoldElementTypeInfo; protected function GetAsFloat: Double; virtual; abstract; procedure SetAsInteger(Value: integer); virtual; abstract; + function GetAttributeTypeInfoForType: TBoldElementTypeInfo; override; public procedure SetEmptyValue; override; + function IsVariantTypeCompatible(const Value: Variant): Boolean; override; + function IsNullOrZero: boolean; virtual; + function CompareToAs(CompType: TBoldCompareType; BoldElement: TBoldElement): Integer; override; property AsFloat: Double read GetAsFloat; property AsInteger: Integer write SetAsInteger; end; @@ -101,26 +216,32 @@ TBAInteger = class(TBANumeric) procedure SetDataValue(NewValue: Integer); procedure SetContent(NewValue: Integer); protected - procedure AssignContentValue(Source: IBoldValue); override; + procedure FreeContent; override; + procedure AssignContentValue(const Source: IBoldValue); override; function CheckRangeWithBounds(Value, Min, Max: integer): boolean; function GetAsInteger: integer; virtual; function GetAsFloat: Double; override; function GetStringRepresentation(Representation: TBoldRepresentation): string; override; procedure SetAsInteger(Value: integer); override; - procedure SetStringRepresentation(Representation: TBoldRepresentation; Value: string); override; + procedure SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); override; function MaySetValue(NewValue: integer; Subscriber: TBoldSubscriber): Boolean; virtual; - function ProxyClass: TBoldMember_ProxyClass; override; + function GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; + function GetFreeStandingClass: TBoldFreeStandingElementClass; override; public + constructor CreateWithValue(Value: integer); procedure Assign(Source: TBoldElement); override; - procedure AssignValue(Source: IBoldValue); override; + procedure AssignValue(const Source: IBoldValue); override; function CanSetValue(Value: integer; Subscriber: TBoldSubscriber): Boolean; function CheckRange(Value: integer): Boolean; virtual; function CompareToAs(CompType: TBoldCompareType; BoldElement: TBoldElement): Integer; override; function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; override; + procedure SetEmptyValue; override; procedure SetAsVariant(const Value: Variant); override; function GetAsVariant: Variant; override; - function ValidateString(Value: string; Representation: TBoldRepresentation): Boolean; override; + function ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; override; function ValidateCharacter(C: Char; Representation: TBoldRepresentation): Boolean; override; + function IsVariantTypeCompatible(const Value: Variant): Boolean; override; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; property AsInteger: integer read GetAsInteger write SetAsInteger; end; @@ -171,22 +292,28 @@ TBAFloat = class(TBANumeric) procedure SetContent(NewValue: Double); procedure SetDataValue(NewValue: Double); protected - procedure AssignContentValue(Source: IBoldValue); override; + procedure FreeContent; override; + procedure AssignContentValue(const Source: IBoldValue); override; function GetAsFloat: Double; override; function GetStringRepresentation(Representation: TBoldRepresentation): string; override; procedure SetAsFloat(Value: Double); virtual; procedure SetAsInteger(Value: integer); override; - procedure SetStringRepresentation(Representation: TBoldRepresentation; Value: string); override; + procedure SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); override; function MaySetValue(NewValue: Double; Subscriber: TBoldSubscriber): Boolean; virtual; - function ProxyClass: TBoldMember_ProxyClass; override; + function GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; + function GetFreeStandingClass: TBoldFreeStandingElementClass; override; public + constructor CreateWithValue(Value: double); procedure SetAsVariant(const Value: Variant); override; function GetAsVariant: Variant; override; - function ValidateString(Value: string; Representation: TBoldRepresentation): Boolean; override; + function ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; override; function ValidateCharacter(C: Char; Representation: TBoldRepresentation): Boolean; override; + function IsVariantTypeCompatible(const Value: Variant): Boolean; override; + procedure SetEmptyValue; override; procedure Assign(Source: TBoldElement); override; - procedure AssignValue(Source: IBoldValue); override; + procedure AssignValue(const Source: IBoldValue); override; function CompareToAs(CompType: TBoldCompareType; BoldElement: TBoldElement): Integer; override; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; property AsInteger: Integer write SetAsInteger; property AsFloat: Double read GetAsFloat write SetAsFloat; function CanSetValue(NewValue: Double; Subscriber: TBoldSubscriber): Boolean; @@ -200,24 +327,30 @@ TBACurrency = class(TBANumeric) procedure SetContent(NewValue: Currency); procedure SetDataValue(NewValue: Currency); protected - procedure AssignContentValue(Source: IBoldValue); override; + procedure FreeContent; override; + procedure AssignContentValue(const Source: IBoldValue); override; function GetAsCurrency: Currency; function GetAsFloat: Double; override; function GetStringRepresentation(Representation: TBoldRepresentation): string; override; procedure SetAsCurrency(Value: Currency); procedure SetAsFloat(Value: Double); virtual; procedure SetAsInteger(Value: integer); override; - procedure SetStringRepresentation(Representation: TBoldRepresentation; Value: string); override; + procedure SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); override; function MaySetValue(NewValue: Currency; Subscriber: TBoldSubscriber): Boolean; virtual; - function ProxyClass: TBoldMember_ProxyClass; override; + function GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; + function GetFreeStandingClass: TBoldFreeStandingElementClass; override; public + constructor CreateWithValue(Value: currency); procedure SetAsVariant(const Value: Variant); override; function GetAsVariant: Variant; override; - function ValidateString(Value: string; Representation: TBoldRepresentation): Boolean; override; + function ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; override; function ValidateCharacter(C: Char; Representation: TBoldRepresentation): Boolean; override; + function IsVariantTypeCompatible(const Value: Variant): Boolean; override; + procedure SetEmptyValue; override; procedure Assign(Source: TBoldElement); override; - procedure AssignValue(Source: IBoldValue); override; + procedure AssignValue(const Source: IBoldValue); override; function CompareToAs(CompType: TBoldCompareType; BoldElement: TBoldElement): Integer; override; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; property AsCurrency: Currency read GetAsCurrency write SetAsCurrency; property AsFloat: Double read GetAsFloat write SetAsFloat; property AsInteger: Integer write SetAsInteger; @@ -225,63 +358,75 @@ TBACurrency = class(TBANumeric) function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; override; end; - {-- TBoldBlobStream --} - - TBoldBlobStreamMode = (bmRead, bmWrite, bmReadWrite); - { TBoldBlobStream } TBoldBlobStream = class(TStream) private + fData: TBytes; fBlobAttr: TBABlob; - fMode: TBoldBlobStreamMode; - fPosition: Integer; - function GetBlobSize: Integer; - procedure StartModifyOfBlob(Operation: String); - procedure EndModifyOfBlob; - procedure FailModifyOfBlob; - procedure InternalSetSize(NewSize: Integer; BlobEvents: Boolean); + fPosition: Int64; + function GetBlobSize: Int64; + procedure InternalSetSize(NewSize: Int64; BlobEvents: Boolean); public - constructor Create(BlobAttr: TBABlob; Mode: TBoldBlobStreamMode); - function Read(var Buffer; Count: integer): integer; override; - function Write(const Buffer; Count: integer): integer; override; - function Seek(Offset: integer; Origin: Word): integer; override; + constructor Create(BlobAttr: TBABlob); + function Read(var Buffer; Count: Longint): Longint; override; + function Write(const Buffer; Count: Longint): Longint; override; + function Seek(Offset: Longint; Origin: Word): Longint; override; procedure Clear; procedure Truncate; procedure LoadFromStream(Stream: TStream); - procedure LoadFromFile(const FileName: string); + procedure LoadFromFile(const aFileName: string; aMode: Word = fmShareDenyNone); procedure SaveToStream(Stream: TStream); procedure SaveToFile(const FileName: string); - procedure SetSize(NewSize: integer); override; + procedure SetSize(NewSize: Longint); override; deprecated; + procedure SetSize(const NewSize: Int64); override; + function IsDataSame(AData: Pointer; ASize: Int64): boolean; end; {---TBABlob---} TBABlob = class(TBoldAttribute) private - FValue: string; - procedure SetContent(NewValue: string); - procedure SetDataValue(NewValue: string); + fStream: TBoldBlobStream; + fSupressEventCount: integer; + procedure SetContent(NewValue: TBoldAnsiString); + procedure SetDataValue(NewValue: TBoldAnsiString); + function GetBlobSize: Int64; + function GetAsStream: TBoldBlobStream; protected - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; procedure FreeContent; override; + procedure SetAsVariant(const Value: Variant); override; function GetStringRepresentation(Representation: TBoldRepresentation): string; override; - procedure SetStringRepresentation(Representation: TBoldRepresentation; Value: string); override; - function GetAsBlob: String; - procedure SetAsBlob(NewValue: String); - function MaySetValue(NewValue: String; Subscriber: TBoldSubscriber): Boolean; virtual; - function ProxyClass: TBoldMember_ProxyClass; override; + procedure SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); override; + function GetAsBlob: TBoldAnsiString; + procedure SetAsBlob(NewValue: TBoldAnsiString); + function MaySetValue(NewValue: TBoldAnsiString; Subscriber: TBoldSubscriber): Boolean; virtual; + function GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; + function GetFreeStandingClass: TBoldFreeStandingElementClass; override; + function SupressEvents: Boolean; + procedure BeginSupressEvents; + procedure EndSupressEvents; + procedure StartModifyOfBlob(const Operation: String); + procedure EndModifyOfBlob; + procedure FailModifyOfBlob; public - procedure SetAsVariant(const Value: Variant); override; - function GetAsVariant: Variant; override; - function CreateBlobStream(Mode: TBoldBlobStreamMode): TBoldBlobStream; + destructor Destroy; override; + procedure Initialize; override; procedure SetToNull; override; procedure Assign(Source: TBoldElement); override; - procedure AssignValue(Source: IBoldValue); override; + procedure AssignValue(const Source: IBoldValue); override; property ContentType: string index brShort read GetStringRepresentation write SetStringRepresentation; - function CanSetValue(NewValue: string; Subscriber: TBoldSubscriber): Boolean; + function CanSetValue(NewValue: TBoldAnsiString; Subscriber: TBoldSubscriber): Boolean; function CompareToAs(CompareType: TBoldCompareType; BoldElement: TBoldElement): Integer; override; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; function IsEqualAs(CompareType: TBoldCompareType; BoldElement: TBoldElement): Boolean; override; function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; override; procedure SetEmptyValue; override; + property BlobSize: Int64 read GetBlobSize; + procedure LoadFromStream(Stream: TStream); + procedure LoadFromFile(const aFileName: string; aMode: Word = fmShareDenyNone); + procedure SaveToStream(Stream: TStream); + procedure SaveToFile(const FileName: string); + property AsStream: TBoldBlobStream read GetAsStream; end; {-- TBATypedBlob --} @@ -292,14 +437,16 @@ TBATypedBlob = class(TBABlob) procedure SetContentTypeContent(NewValue: String); protected function GetStringRepresentation(Representation: TBoldRepresentation): string; override; - procedure SetStringRepresentation(Representation: TBoldRepresentation; Value: string); override; + procedure SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); override; function GetContentTypeContent: String; - function ProxyClass: TBoldMember_ProxyClass; override; + function GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; + function GetFreeStandingClass: TBoldFreeStandingElementClass; override; public - procedure AssignValue(Source: IBoldValue); override; + procedure AssignValue(const Source: IBoldValue); override; procedure SetToNull; override; function CanSetContentType(Value: string; Subscriber: TBoldSubscriber): Boolean; function CompareToAs(CompareType: TBoldCompareType; BoldElement: TBoldElement): Integer; override; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; function IsEqualAs(CompareType: TBoldCompareType; BoldElement: TBoldElement): Boolean; override; function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; override; end; @@ -308,22 +455,23 @@ TBATypedBlob = class(TBABlob) TBABlobImageJPEG = class(TBABlob) protected function GetStringRepresentation(Representation: TBoldRepresentation): string; override; - procedure SetStringRepresentation(Representation: TBoldRepresentation; Value: string); override; + procedure SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); override; end; {-- TBABlobImageBMP --} TBABlobImageBMP = class(TBABlob) protected function GetStringRepresentation(Representation: TBoldRepresentation): string; override; - procedure SetStringRepresentation(Representation: TBoldRepresentation; Value: string); override; + procedure SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); override; end; {---TBAMoment---} - TBAMoment = class(TBoldAttribute) + TBAMoment = class(TBANumeric) private FValue: TDateTime; + class var AttributeTypeInfo: TBoldElementTypeInfo; procedure SetDataValue(NewValue: TDateTime); - procedure SetContent(NewValue: TDateTime); + procedure SetDateTimeContent(NewValue: TDateTime); function GetDays: Word; function GetHours: Word; function GetMinutes: Word; @@ -331,6 +479,9 @@ TBAMoment = class(TBoldAttribute) function GetSeconds: Word; function GetYears: Word; protected + procedure FreeContent; override; + function GetAsFloat: Double; override; + procedure SetAsInteger(Value: integer); override; function GetAsDate: TDateTime; function GetAsDateTime: TDateTime; function GetAsTime: TDateTime; @@ -338,7 +489,7 @@ TBAMoment = class(TBoldAttribute) procedure SetAsDateTime(Value: TDateTime); procedure SetAsTime(Value: TDateTime); function MaySetValue(NewValue: TDateTime; Subscriber: TBoldSubscriber): Boolean; virtual; - property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime; + function GetAttributeTypeInfoForType: TBoldElementTypeInfo; override; property AsDate: TDateTime read GetAsDate write SetAsDate; property AsTime: TDateTime read GetAsTime write SetAsTime; property Seconds: Word read GetSeconds; @@ -353,18 +504,24 @@ TBAMoment = class(TBoldAttribute) procedure Assign(Source: TBoldElement); override; function CanSetValue(NewValue: TDateTime; Subscriber: TBoldSubscriber): Boolean; function CompareToAs(CompType: TBoldCompareType; BoldElement: TBoldElement): Integer; override; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; + function IsVariantTypeCompatible(const Value: Variant): Boolean; override; procedure SetEmptyValue; override; + property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime; + function IsNullOrZero: boolean; override; end; {---TBADateTime---} TBADateTime = class(TBAMoment) protected - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; function GetStringRepresentation(Representation: TBoldRepresentation): string; override; - procedure SetStringRepresentation(Representation: TBoldRepresentation; Value: string); override; - function ProxyClass: TBoldMember_ProxyClass; override; + procedure SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); override; + function GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; + function GetFreeStandingClass: TBoldFreeStandingElementClass; override; public - procedure AssignValue(Source: IBoldValue); override; + constructor CreateWithValue(Value: TDateTime); + procedure AssignValue(const Source: IBoldValue); override; property AsDateTime; property AsDate; property AsTime; @@ -374,7 +531,7 @@ TBADateTime = class(TBAMoment) property Days; property Months; property Years; - function ValidateString(Value: string; Representation: TBoldRepresentation): Boolean; override; + function ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; override; function ValidateCharacter(C: Char; Representation: TBoldRepresentation): Boolean; override; function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; override; end; @@ -382,13 +539,15 @@ TBADateTime = class(TBAMoment) {---TBADate---} TBADate = class(TBAMoment) protected - procedure AssignContentValue(Source: IBoldValue); override; - procedure SetStringRepresentation(Representation: TBoldRepresentation; Value: string); override; + procedure AssignContentValue(const Source: IBoldValue); override; + procedure SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); override; function GetStringRepresentation(Representation: TBoldRepresentation): string; override; - function ProxyClass: TBoldMember_ProxyClass; override; + function GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; + function GetFreeStandingClass: TBoldFreeStandingElementClass; override; public - procedure AssignValue(Source: IBoldValue); override; - function ValidateString(Value: string; Representation: TBoldRepresentation): Boolean; override; + constructor CreateWithValue(Value: TDateTime); + procedure AssignValue(const Source: IBoldValue); override; + function ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; override; function ValidateCharacter(C: Char; Representation: TBoldRepresentation): Boolean; override; function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; override; property AsDate; @@ -402,13 +561,15 @@ TBATime = class(TBAMoment) private function GetAsSeconds: cardinal; protected - procedure AssignContentValue(Source: IBoldValue); override; - procedure SetStringRepresentation(Representation: TBoldRepresentation; Value: string); override; + procedure AssignContentValue(const Source: IBoldValue); override; + procedure SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); override; function GetStringRepresentation(Representation: TBoldRepresentation): string; override; - function ProxyClass: TBoldMember_ProxyClass; override; + function GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; + function GetFreeStandingClass: TBoldFreeStandingElementClass; override; public - procedure AssignValue(Source: IBoldValue); override; - function ValidateString(Value: string; Representation: TBoldRepresentation): Boolean; override; + constructor CreateWithValue(Value: TDateTime); + procedure AssignValue(const Source: IBoldValue); override; + function ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; override; function ValidateCharacter(C: Char; Representation: TBoldRepresentation): Boolean; override; function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; override; property AsTime; @@ -425,7 +586,7 @@ TBAValueSetValue = class(TBoldElement) FStringRepresentations: TStringList; protected function GetStringRepresentation(Representation: TBoldRepresentation): string; override; - procedure SetStringRepresentation(Representation: TBoldRepresentation; Value: string); override; + procedure SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); override; function GetAsInteger: Integer; procedure SetAsInteger(Value: Integer); procedure AddString(Value: string); @@ -436,6 +597,7 @@ TBAValueSetValue = class(TBoldElement) destructor Destroy; override; procedure DefaultSubscribe(Subscriber: TBoldSubscriber; RequestedEvent: TBoldEvent = breReEvaluate); override; procedure GetAsList(ResultList: TBoldIndirectElement); override; + function CompareToAs(CompareType: TBoldCompareType; BoldElement: TBoldElement): Integer; override; property AsInteger: Integer read GetAsInteger write SetAsInteger; property StringRepresentationCount: Integer read GetStringRepresentationCount; end; @@ -466,6 +628,7 @@ TBAValueSetValueList = class(TBoldMemoryManagedObject) TBAValueSet = class(TBoldAttribute) private FValue: TBAValueSetValue; + class var AttributeTypeInfo: TBoldElementTypeInfo; procedure CheckIllegalValue; function GetAsInteger: Integer; procedure SetAsInteger(Value: Integer); @@ -473,45 +636,52 @@ TBAValueSet = class(TBoldAttribute) procedure SetContentAsInteger(NewValue: Integer); procedure SetDataValue(NewValue: TBAValueSetValue); protected + procedure FreeContent; override; function GetContentAsInteger: Integer; virtual; - procedure AssignContentValue(Source: IBoldValue); override; - procedure InitializeMember(OwningElement: TBoldDomainElement; ElementTypeInfo: TBoldElementTypeInfo); override; - function GetValues: TBAValueSetValueList; virtual; abstract; + procedure AssignContentValue(const Source: IBoldValue); override; + procedure Initialize; override; function GetStringRepresentation(Representation: TBoldRepresentation): string; override; - procedure SetStringRepresentation(Representation: TBoldRepresentation; Value: string); override; + procedure SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); override; function MaySetValue(NewValue: TBAValueSetValue; Subscriber: TBoldSubscriber): Boolean; virtual; property ContentAsInteger: Integer read GetContentAsInteger write SetContentAsInteger; - function ProxyClass: TBoldMember_ProxyClass; override; + function GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; + function GetAttributeTypeInfoForType: TBoldElementTypeInfo; override; + function GetFreeStandingClass: TBoldFreeStandingElementClass; override; public + class function GetValues: TBAValueSetValueList; virtual; procedure SetAsVariant(const Value: Variant); override; function GetAsVariant: Variant; override; - function ValidateString(Value: string; Representation: TBoldRepresentation): Boolean; override; + function ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; override; function ValidateCharacter(C: Char; Representation: TBoldRepresentation): Boolean; override; procedure Assign(Source: TBoldElement); override; function CompareToEnumLiteral(const str: String): Boolean; virtual; - procedure AssignValue(Source: IBoldValue); override; + procedure AssignValue(const Source: IBoldValue); override; function CompareToAs(CompType: TBoldCompareType; BoldElement: TBoldElement): Integer; override; - property Values: TBAValueSetValueList read GetValues; property AsInteger: Integer read GetAsInteger write SetAsInteger; + property Values: TBAValueSetValueList read GetValues; function CanSetValue(NewValue: TBAValueSetValue; Subscriber: TBoldSubscriber): Boolean; function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; override; procedure SetEmptyValue; override; end; - - {---TBABoolean---} TBABoolean = class(TBAValueSet) + private + class var _BooleanValues: TBAValueSetValueList; protected - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; function GetAsBoolean: Boolean; procedure SetAsBoolean(Value: Boolean); - function GetValues: TBAValueSetValueList; override; - function ProxyClass: TBoldMember_ProxyClass; override; + function GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; + function GetFreeStandingClass: TBoldFreeStandingElementClass; override; public + constructor CreateWithValue(Value: Boolean); + class function GetValues: TBAValueSetValueList; override; procedure SetAsVariant(const Value: Variant); override; function GetAsVariant: Variant; override; function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; override; + function IsVariantTypeCompatible(const Value: Variant): Boolean; override; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean; end; @@ -525,21 +695,24 @@ TBAConstraint = class(TBABoolean) protected function GetContentAsInteger: Integer; override; function GetStringRepresentation(Representation: TBoldRepresentation): string; override; - procedure InitializeMember(OwningElement: TBoldDomainElement; ElementTypeInfo: TBoldElementTypeInfo); override; + procedure Initialize; override; public destructor Destroy; override; procedure Assign(Source: TBoldElement); override; procedure DefaultSubscribe(Subscriber: TBoldSubscriber; RequestedEvent: TBoldEvent = breReEvaluate); override; procedure SubscribeToStringRepresentation(Representation: TBoldRepresentation; Subscriber: TBoldSubscriber; RequestedEvent: TBoldEvent = breReEvaluate); override; - procedure Initialize(Constraint: TBoldConstraintRTInfo; OwningElement: TBoldElement); + procedure InitializeConstraint(Constraint: TBoldConstraintRTInfo; OwningElement: TBoldElement); property Constraint: TBoldConstraintRTInfo read fConstraint; property OwningElement: TBoldElement read fOwningElement; end; +function VarRecToBoldAttribute(const Value: TVarRec): TBoldAttribute; +function VarArrayToBoldMemberList(const Values: array of const): TBoldMemberList; + implementation uses - SysUtils, + {$IFDEF BOLD_UNICODE}AnsiStrings,{$ENDIF} BoldNameExpander, BoldTaggedValueSupport, Variants, @@ -547,17 +720,43 @@ implementation BoldCoreConsts, BoldMemberTypeDictionary; +type + TBAAnsiString_Proxy = class(TBAString_Proxy, IBoldAnsiStringContent) + end; + + + TBoldSystemSubscriber = class(TBoldPassthroughSubscriber) + protected + procedure Receive(Originator: TObject; OriginalEvent: TBoldEvent; + RequestedEvent: TBoldRequestedEvent); override; + end; + var - _BooleanValues: TBAValueSetValueList; + _SystemSubscriber: TBoldSystemSubscriber; -const - DEFAULTNOW = ''; - Meth_GetStringRepresentation = 'GetStringRepresentation'; - Meth_SetStringRepresentation = 'SetStringRepresentation'; - Meth_AssignContentValue = 'AssignContentValue'; - Meth_AssignValue = 'AssignValue'; +procedure SubscribeToSystem; +begin + if not Assigned(_SystemSubscriber) then + _SystemSubscriber := TBoldSystemSubscriber.Create(nil); + TBoldSystem.DefaultSystem.AddSmallSubscription(_SystemSubscriber, [beDestroying], beDestroying); +end; + +{ TBoldSystemSubscriber } + +procedure TBoldSystemSubscriber.Receive(Originator: TObject; + OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); +begin + TBAString.AttributeTypeInfo := nil; + TBANumeric.AttributeTypeInfo := nil; + TBAMoment.AttributeTypeInfo := nil; + TBAValueSet.AttributeTypeInfo := nil; + FreeAndNil(_SystemSubscriber); +end; type + TBAUnicodeString_Proxy = class(TBAString_Proxy, IBoldUnicodeStringContent) + end; + TBAInteger_Proxy = class(TBoldAttribute_Proxy, IBoldIntegerContent) private function GetProxedInteger: TBAInteger; @@ -571,17 +770,20 @@ TBAFloat_Proxy = class(TBoldAttribute_Proxy, IBoldFloatContent) private function GetProxedFloat: TBAFloat; function GetContentAsFloat: Double; - procedure SetContentAsFloat(NewValue: Double); + procedure SetContentAsFloat(NewValue: Double); protected property ProxedFloat: TBAFloat read GetProxedFloat; end; - TBABlob_Proxy = class(TBoldAttribute_Proxy, IBoldBlobContent) + TBABlob_Proxy = class(TBoldAttribute_Proxy, IBoldBlobContent, IBoldBlobStreamContent) private function GetProxedBlob: TBABlob; - function GetContentAsBlob: String; - procedure SetContentAsBlob(const NewValue: String); - protected + function GetContentAsBlob: TBoldAnsiString; + procedure SetContentAsBlob(const NewValue: TBoldAnsiString); + function GetBlobAsStream: TStream; + procedure BeginSupressEvents; + procedure EndSupressEvents; + function SupressEvents: boolean; property ProxedBlob: TBABlob read GetProxedBlob; end; @@ -631,7 +833,7 @@ TBAValueSet_Proxy = class(TBoldAttribute_Proxy, IBoldIntegerContent, IBoldStri function GetContentAsInteger: Integer; procedure SetContentAsInteger(NewValue: Integer); procedure SetContentAsString(const NewValue: String); - function GetContentAsString: String; + function GetContentAsString: String; override; protected property ProxedValueSet: TBAValueSet read GetProxedValueSet; end; @@ -642,17 +844,46 @@ TBABoolean_Proxy = class(TBAValueSet_Proxy, IBoldBooleanContent) procedure SetContentAsBoolean(NewValue: Boolean); end; +function VarRecToBoldAttribute(Const Value: TVarRec): TBoldAttribute; +begin + case Value.VType of + vtInteger: Result := TBAInteger.CreateWithValue(value.VInteger); + vtInt64: Result := TBAInteger.CreateWithValue(value.VInt64^); + vtBoolean: Result := TBABoolean.CreateWithValue(value.VBoolean); + vtExtended: Result := TBAFloat.CreateWithValue(value.VExtended^); + vtString: Result := TBAString.CreateWithValue(value.VString^); + vtAnsiString: Result := TBAString.CreateWithValue(String(value.VAnsiString)); +{$IFDEF BOLD_UNICODE} + vtUnicodeString: Result := TBAString.CreateWithValue(String(value.vUnicodeString)); +{$ENDIF} + vtCurrency: Result := TBACurrency.CreateWithValue(value.VCurrency^); + vtWideString: Result := TBAString.CreateWithValue(PWideString(value.VWideString)^); + else + raise EBold.Create('Unsupported Variant type: ' + IntToStr(Value.Vtype)); + end; +end; + +function VarArrayToBoldMemberList(const Values: array of const): TBoldMemberList; +var + i: integer; +begin + result := TBoldMemberList.Create; + result.CloneMembers := false; + for I := 0 to length(Values) - 1 do + result.Add(VarRecToBoldAttribute(Values[i])); +end; + { TBAString } -procedure TBAString.SetDataValue(NewValue: string); +procedure TBAString.SetDataValue(const NewValue: string); begin BoldClearLastFailure; if not CanSetValue(NewValue, nil) then - BoldRaiseLastFailure(self, 'SetDataValue', ''); // do not localize + BoldRaiseLastFailure(self, 'SetDataValue', ''); if IsNull or (FValue <> NewValue) then begin if not StartModify then - BoldRaiseLastFailure(self, 'SetDataValue', ''); // do not localize + BoldRaiseLastFailure(self, 'SetDataValue', ''); try SetContent(NewValue); EndModify; @@ -663,12 +894,11 @@ procedure TBAString.SetDataValue(NewValue: string); end; end; -procedure TBAString.SetStringRepresentation(Representation: TBoldRepresentation; Value: string); +procedure TBAString.SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); begin if not ValidateString(Value, Representation) then - BoldRaiseLastFailure(self, Meth_SetStringRepresentation, sStringValidationFailed); + BoldRaiseLastFailure(self, 'SetStringRepresentation', 'String validation failed'); - EnsureValidString(Value, Representation); if Representation = brDefault then SetDataValue(Value) else @@ -679,7 +909,7 @@ function TBAString.GetStringRepresentation(Representation: TBoldRepresentation): begin BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, Meth_GetStringRepresentation, ''); + BoldRaiseLastFailure(self, 'GetStringRepresentation', ''); if Representation <> brDefault then inherited GetStringRepresentation(Representation); @@ -689,14 +919,14 @@ function TBAString.GetStringRepresentation(Representation: TBoldRepresentation): Result := FValue; end; -function TBAString.ValidateString(Value: string; Representation: TBoldRepresentation): Boolean; +function TBAString.ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; begin if Assigned(BoldAttributeRtInfo) then begin Result := (BoldAttributeRtInfo.Length = -1) or (Length(Value) <= BoldAttributeRtInfo.Length); if not result then - SetBoldLastFailureReason(TBoldFailureReason.Create(sStringTooLong, self)); + SetBoldLastFailureReason(TBoldFailureReason.CreateFmt('String too long. Max allowed: %d, actual: %d.', [BoldAttributeRtInfo.Length, Length(Value)] , self)); end else Result := True; @@ -722,29 +952,27 @@ function TBAString.CompareToAs(CompType: TBoldCompareType; BoldElement: TBoldEle if EitherIsNull(Self, TBAString(BoldElement)) then Result := NullSmallest(BoldElement) else - case CompType of - ctDefault: - Result := AnsiCompareText(AsString, TBAString(BoldElement).AsString); - ctAsString: - Result := CompareStr(AsString, TBAString(BoldElement).AsString); - ctAsText: - Result := CompareText(AsString, TBAString(BoldElement).AsString); - ctAsAnsiString: - Result := AnsiCompareStr(AsString, TBAString(BoldElement).AsString); - ctAsAnsiText: - Result := AnsiCompareText(AsString, TBAString(BoldElement).AsString); - else - Result := inherited CompareToAs(CompType, BoldElement); - end + Result := StringCompare(CompType, AsString, BoldElement.AsString); end else - Result := inherited CompareToAs(CompType, BoldElement); + if Assigned(BoldElement) then + Result := StringCompare(CompType, AsString, BoldElement.AsString) + else + result := -1; +end; + +constructor TBAString.CreateWithValue(const Value: string); +begin + inherited Create; + asString := value; end; function TBAString.CanSetValue(NewValue: string; Subscriber: TBoldSubscriber): Boolean; begin - result := MaySetValue(NewValue, Subscriber) and - SendQuery(bqMaySetValue, [NewValue], Subscriber) + result := MaySetValue(NewValue, Subscriber); +{$IFNDEF BOLD_NO_QUERIES} + result := result and SendQuery(bqMaySetValue, [NewValue], Subscriber) +{$ENDIF} end; function TBAString.MaySetValue(NewValue: String; @@ -754,31 +982,50 @@ function TBAString.MaySetValue(NewValue: String; end; -procedure TBAString.AssignValue(Source: IBoldValue); +procedure TBAString.AssignValue(const Source: IBoldValue); var s: IBoldStringContent; begin if source.QueryInterface(IBoldStringContent, S) = S_OK then SetDataValue(s.AsString) else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, Meth_AssignValue]); + raise EBold.CreateFmt('%s.AssignValue: unknown type of source', [classname]); end; -procedure TBAString.SetContent(NewValue: string); +procedure TBAString.SetContent(const NewValue: string); +var + bContentIsNull: Boolean; + sOldValue: string; begin + bContentIsNull := ContentIsNull; if (BoldPersistenceState = bvpsInvalid) or - ContentIsNull or (FValue <> NewValue) then + bContentIsNull or (fValue <> NewValue) then begin PreChange; - FValue := NewValue; + sOldValue := fValue; + fValue := NewValue; SetToNonNull; - Changed(beValueChanged, [NewValue]); + if bContentIsNull then begin + Changed(beValueChanged, [NewValue]); + end else begin + Changed(beValueChanged, [NewValue, sOldValue]); + end; end; end; function TBAString_Proxy.GetContentAsString: string; begin - result := ProxedString.FValue; + result := ProxedString.Value; +end; + +function TBAString_Proxy.GetContentAsAnsiString: TBoldAnsiString; +begin + result := ProxedString.AsAnsiString; +end; + +function TBAString_Proxy.GetContentAsUnicodeString: TBoldUnicodeString; +begin + result := ProxedString.AsUnicodeString; end; procedure TBAString_Proxy.SetContentAsString(const NewValue: string); @@ -786,9 +1033,30 @@ procedure TBAString_Proxy.SetContentAsString(const NewValue: string); ProxedString.SetContent(NewValue); end; -procedure TBAString.AssignContentValue(Source: IBoldValue); +procedure TBAString_Proxy.SetContentAsAnsiString(const NewValue: + TBoldAnsiString); +begin + if ProxedString is TBAAnsiString then begin + TBAAnsiString(ProxedString).SetContent(NewValue); + end else begin + ProxedString.SetContent(string(NewValue)); + end; +end; + +procedure TBAString_Proxy.SetContentAsUnicodeString(const NewValue: + TBoldUnicodeString); +begin + if ProxedString is TBAUnicodeString then begin + TBAUnicodeString(ProxedString).SetContent(NewValue); + end else begin + ProxedString.SetContent(string(NewValue)); + end; +end; + +procedure TBAString.AssignContentValue(const Source: IBoldValue); var s: IBoldStringContent; + sr: IBoldStringRepresentable; begin if not assigned(source) and CanSetToNull(nil) then SetContentToNull @@ -801,46 +1069,410 @@ procedure TBAString.AssignContentValue(Source: IBoldValue); else SetContent(s.AsString) end + else if source.QueryInterface(IBoldStringRepresentable, sr) = S_OK then + begin + if sr.IsNull then + SetContentToNull + else + SetContent(sr.AsString) + end else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, Meth_AssignContentValue]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); end; -function TBAString.ProxyClass: TBoldMember_ProxyClass; +function TBAString.GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin - result := TBAString_Proxy; + result := TBAString_Proxy.MakeProxy(self, mode); end; function TBAString.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; begin - if IsEqualGuid(IID, IBoldStringContent) then + if IsEqualGuid(IID, IBoldStringContent) then begin Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldStringContent') // do not localize + end else if IsEqualGUID(IID, IBoldAnsiStringContent) then begin + Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldAnsiStringContent') // do not localize + end else if IsEqualGUID(IID, IBoldUnicodeStringContent) then begin + Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldUnicodeStringContent') // do not localize + end else begin + Result := inherited ProxyInterface(IID, Mode, Obj); + end; +end; + +procedure TBAString.FreeContent; +begin + inherited; + FValue := ''; +end; + +function TBAString.GetAsAnsiString: TBoldAnsiString; +begin + Result := TBoldAnsiString(AsString); +end; + +function TBAString.GetAsUnicodeString: TBoldUnicodeString; +begin + Result := TBoldUnicodeString(AsString); +end; + +function TBAString.GetValue: string; +begin + Result := FValue; +end; + +function TBAString.IsEqualToValue(const Value: IBoldValue): Boolean; +var + vString: IBoldStringContent; +begin + Assert(Assigned(Value), ClassName + '.IsEqualToValue: Value can not be nil.'); + if Value.QueryInterface(IBoldStringContent, vString) = S_OK then + begin + if IsNull and vString.IsNull then + result := true + else + if IsNull or vString.IsNull then + result := false + else + result := StringCompare(ctCaseSensitive, Self.AsString, vString.asString) = 0 + end else - result := inherited ProxyInterface(IID, Mode, Obj); + result := inherited IsEqualToValue(Value); +end; + +function TBAString.IsNullOrEmpty: Boolean; +begin + Result := IsNull or (Value = ''); +end; + +procedure TBAString.SetAsAnsiString(const Value: TBoldAnsiString); +begin + AsString := string(Value); +end; + +procedure TBAString.SetAsUnicodeString(const Value: TBoldUnicodeString); +begin + AsString := string(Value); +end; + +procedure TBAString.SetEmptyValue; +begin + if FValue <> '' then + asString := ''; +end; + +procedure TBAString.SetValue(const Value: string); +begin + FValue := Value; +end; + +function TBAString.GetAttributeTypeInfoForType: TBoldElementTypeInfo; +begin + if not Assigned(AttributeTypeInfo) then + begin + AttributeTypeInfo := inherited GetAttributeTypeInfoForType; + SubscribeToSystem; + end; + result := AttributeTypeInfo; +end; + +function TBAString.GetFreeStandingClass: TBoldFreeStandingElementClass; +begin + result := TBFSString; +end; + +{ TBAAnsiString } + +{$IFDEF BOLD_UNICODE} +procedure TBAAnsiString.FreeContent; +begin + inherited; + fValue := ''; +end; + +function TBAAnsiString.GetAsAnsiString: TBoldAnsiString; +begin + BoldClearLastFailure; + if not CanRead(nil) then + BoldRaiseLastFailure(self, 'GetAsAnsiString', ''); // do not localize + + if IsNull then {IsNull ensures current} + Result := '' + else + Result := fValue; +end; + +function TBAAnsiString.GetValue: string; +begin + Result := String(fValue); +end; + +procedure TBAAnsiString.SetAsAnsiString(const Value: TBoldAnsiString); +begin + SetDataValue(Value); +end; + +procedure TBAAnsiString.SetContent(NewValue: TBoldAnsiString); +var + bContentIsNull: Boolean; + sOldValue: TBoldAnsiString; +begin + bContentIsNull := ContentIsNull; + if (BoldPersistenceState = bvpsInvalid) or + bContentIsNull or (fValue <> NewValue) then + begin + PreChange; + sOldValue := fValue; + fValue := NewValue; + SetToNonNull; + if bContentIsNull then begin + Changed(beValueChanged, [NewValue]); + end else begin + Changed(beValueChanged, [NewValue, sOldValue]); + end; + end; +end; + +procedure TBAAnsiString.SetDataValue(NewValue: TBoldAnsiString); +begin + BoldClearLastFailure; + if not CanSetValue(string(NewValue), nil) then + BoldRaiseLastFailure(self, 'SetDataValue', ''); // do not localize + + if IsNull or (fValue <> NewValue) then + begin + if not StartModify then + BoldRaiseLastFailure(self, 'SetDataValue', ''); // do not localize + try + SetContent(NewValue); + EndModify; + except + FailModify; + raise; + end; + end; +end; + +procedure TBAAnsiString.SetValue(const Value: string); +begin + fValue := TBoldAnsiString(Value); +end; + +function TBAAnsiString.ValidateCharacter(C: Char; Representation: + TBoldRepresentation): Boolean; +begin + Result := inherited ValidateCharacter(C, Representation); + Result := Result and (Ord(C) < 256); +end; + +function TBAAnsiString.ValidateString(const Value: string; Representation: + TBoldRepresentation): Boolean; +begin + Result := inherited ValidateString(Value, Representation); + if Result and (String(AnsiString(Value)) <> Value) then begin + Result := False; + SetBoldLastFailureReason(TBoldFailureReason.Create(sStringIsNotAnsiString, Self)); + end; +end; +{$ENDIF} + +function TBAAnsiString.GetProxy( + Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; +begin + result := TBAAnsiString_Proxy.MakeProxy(self, mode); +end; + +function TBAAnsiString.ProxyClass: TBoldMember_ProxyClass; +begin + result := TBAAnsiString_Proxy; +end; + +function TBAAnsiString.ProxyInterface(const IId: TGUID; Mode: + TBoldDomainElementProxyMode; out Obj): Boolean; +begin + if IsEqualGUID(IID, IBoldAnsiStringContent) then + Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldAnsiStringContent') // do not localize + else + Result := inherited ProxyInterface(IID, Mode, Obj); +end; + +{ TBAUnicodeString } + +function TBAUnicodeString.GetProxy( + Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; +begin + result := TBAUnicodeString_Proxy.MakeProxy(self, mode); +end; + +{$IFNDEF BOLD_UNICODE} +procedure TBAUnicodeString.FreeContent; +begin + inherited; + FValue := ''; +end; + +function TBAUnicodeString.GetAsUnicodeString: TBoldUnicodeString; +begin + BoldClearLastFailure; + if not CanRead(nil) then + BoldRaiseLastFailure(self, 'GetAsUnicodeString', ''); // do not localize + + if IsNull then {IsNull ensures current} + Result := '' + else + Result := fValue; +end; + +function TBAUnicodeString.GetValue: string; +begin + Result := String(FValue); +end; + +procedure TBAUnicodeString.SetAsUnicodeString(const Value: TBoldUnicodeString); +begin + SetDataValue(Value); +end; + +procedure TBAUnicodeString.SetContent(NewValue: TBoldUnicodeString); +var + bContentIsNull: Boolean; + sOldValue: TBoldUnicodeString; +begin + bContentIsNull := ContentIsNull; + if (BoldPersistenceState = bvpsInvalid) or + bContentIsNull or (fValue <> NewValue) then + begin + PreChange; + sOldValue := fValue; + fValue := NewValue; + SetToNonNull; + if bContentIsNull then begin + Changed(beValueChanged, [NewValue]); + end else begin + Changed(beValueChanged, [NewValue, sOldValue]); + end; + end; +end; + +procedure TBAUnicodeString.SetDataValue(NewValue: TBoldUnicodeString); +begin + BoldClearLastFailure; + if not CanSetValue(string(NewValue), nil) then + BoldRaiseLastFailure(self, 'SetDataValue', ''); // do not localize + + if IsNull or (fValue <> NewValue) then + begin + if not StartModify then + BoldRaiseLastFailure(self, 'SetDataValue', ''); // do not localize + try + SetContent(NewValue); + EndModify; + except + FailModify; + raise; + end; + end; +end; + +procedure TBAUnicodeString.SetValue(const Value: string); +begin + FValue := TBoldUnicodeString(Value); +end; +{$ENDIF} + +function TBAUnicodeString.ProxyClass: TBoldMember_ProxyClass; +begin + result := TBAUnicodeString_Proxy; +end; + +function TBAUnicodeString.ProxyInterface(const IId: TGUID; Mode: + TBoldDomainElementProxyMode; out Obj): Boolean; +begin + if IsEqualGUID(IID, IBoldUnicodeStringContent) then + Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldUnicodeStringContent') // do not localize + else + Result := inherited ProxyInterface(IID, Mode, Obj); +end; + +{ TBAText } + +function TBAText.ValidateString(const Value: string; Representation: + TBoldRepresentation): Boolean; +begin + // no inherited (inherited checks length) + Result := True; + // but we need AnsiString-Check + {$IFDEF BOLD_UNICODE} + if (String(AnsiString(Value)) <> Value) then begin + Result := False; + SetBoldLastFailureReason(TBoldFailureReason.Create(sStringIsNotAnsiString, Self)); + end; + {$ENDIF} +end; + +{ TBAUnicodeText } + +function TBAUnicodeText.ValidateString(const Value: string; Representation: + TBoldRepresentation): Boolean; +begin + // no inherited (inherited checks length) + Result := True; +end; + +{ TBATrimmedString } + +procedure TBATrimmedString.SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); +begin + inherited SetStringRepresentation(Representation, trim(Value)); +end; + +{ TBANumeric } + +function TBANumeric.CompareToAs(CompType: TBoldCompareType; + BoldElement: TBoldElement): Integer; +begin + if BoldElement is TBANumeric then + begin + if EitherIsNull(Self, TBoldAttribute(BoldElement)) then + Result := NullSmallest(BoldElement) + else + case CompType of + ctDefault: + if AsFloat = TBANumeric(BoldElement).AsFloat then + Result := 0 + else if AsFloat > TBANumeric(BoldElement).AsFloat then + Result := 1 + else + Result := -1; + else + Result := inherited CompareToAs(CompType, BoldElement); + end; + end else + Result := inherited CompareToAs(CompType, BoldElement); end; -procedure TBAString.FreeContent; +function TBANumeric.GetAttributeTypeInfoForType: TBoldElementTypeInfo; begin - inherited; - FValue := ''; + if not Assigned(AttributeTypeInfo) then + begin + AttributeTypeInfo := inherited GetAttributeTypeInfoForType; + SubscribeToSystem; + end; + result := AttributeTypeInfo; end; -procedure TBAString.SetEmptyValue; +function TBANumeric.IsNullOrZero: boolean; begin - asString := ''; + result := isNull or (AsFloat = 0); end; -{ TBATrimmedString } - -procedure TBATrimmedString.SetStringRepresentation(Representation: TBoldRepresentation; Value: string); +function TBANumeric.IsVariantTypeCompatible(const Value: Variant): Boolean; begin - inherited SetStringRepresentation(Representation, trim(Value)); + result := VarType(Value) in [varSmallInt, varInteger, varShortInt, varByte, varWord, varLongWord, varInt64]; end; -{ TBANumeric } - procedure TBANumeric.SetEmptyValue; begin - AsInteger := 0; + if AsFloat <> 0 then + AsInteger := 0; end; { TBAInteger } @@ -849,14 +1481,14 @@ procedure TBAInteger.SetDataValue(NewValue: Integer); begin BoldClearLastFailure; if not CanSetValue(NewValue, nil) then - BoldRaiseLastFailure(self, 'SetDataValue', ''); // do not localize + BoldRaiseLastFailure(self, 'SetDataValue', ''); if not CheckRange(NewValue) then - raise EBoldInternal.CreateFmt('%s: %s', [DisplayName, GetBoldLastFailureReason.Reason]); // do not localize + raise EBoldInternal.CreateFmt('%s: %s', [DisplayName, GetBoldLastFailureReason.Reason]); if IsNull or (FValue <> NewValue) then begin if not StartModify then - BoldRaiseLastFailure(self, 'SetDataValue', ''); // do not localize + BoldRaiseLastFailure(self, 'SetDataValue', ''); try SetContent(NewValue); EndModify; @@ -867,15 +1499,21 @@ procedure TBAInteger.SetDataValue(NewValue: Integer); end; end; +procedure TBAInteger.SetEmptyValue; +begin + if fValue <> 0 then + inherited; +end; + function TBAInteger.CheckRange(Value: integer): Boolean; begin result := CheckRangeWithBounds(Value, Low(integer), High(integer)); end; -procedure TBAInteger.SetStringRepresentation(Representation: TBoldRepresentation; Value: string); +procedure TBAInteger.SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); begin if not ValidateString(Value, Representation) then - BoldRaiseLastFailure(self, Meth_SetStringRepresentation, sStringValidationFailed); + BoldRaiseLastFailure(self, 'SetStringRepresentation', 'String validation failed'); if Representation = brDefault then if Value = '' then SetToNull @@ -889,20 +1527,44 @@ function TBAInteger.GetStringRepresentation(Representation: TBoldRepresentation) begin BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, Meth_GetStringRepresentation, ''); + BoldRaiseLastFailure(self, 'GetStringRepresentation', ''); if Representation <> brDefault then inherited GetStringRepresentation(Representation); if IsNull then {IsNull ensures current} Result := '' else - Str(GetAsInteger, Result); + Result := IntToStr(GetAsInteger); +end; + +function TBAInteger.IsEqualToValue(const Value: IBoldValue): Boolean; +var + vInteger: IBoldIntegerContent; +begin + Assert(Assigned(Value), ClassName + '.IsEqualToValue: Value can not be nil.'); + if Value.QueryInterface(IBoldIntegerContent, vInteger) = S_OK then + begin + if IsNull and vInteger.IsNull then + result := true + else + if IsNull or vInteger.IsNull then + result := false + else + result := Self.asInteger = vInteger.asInteger + end + else + result := inherited IsEqualToValue(Value); +end; + +function TBAInteger.IsVariantTypeCompatible(const Value: Variant): Boolean; +begin + result := inherited IsVariantTypeCompatible(Value) and CheckRange(Value); end; function TBAInteger.GetAsInteger: integer; begin BoldClearLastFailure; if not canRead(nil) then - BoldRaiseLastFailure(self, 'GetAsInteger', ''); // do not localize + BoldRaiseLastFailure(self, 'GetAsInteger', ''); EnsureNotNull; {ensures current} Result := FValue; end; @@ -911,7 +1573,7 @@ function TBAInteger.GetAsFloat: Double; begin BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, 'GetAsFloat', ''); // do not localize + BoldRaiseLastFailure(self, 'GetAsFloat', ''); EnsureNotNull; {ensures current} Result := FValue; end; @@ -923,10 +1585,10 @@ procedure TBAInteger.SetAsInteger(Value: integer); function TBAInteger.ValidateCharacter(C: Char; Representation: TBoldRepresentation): Boolean; begin - Result := C in ['0'..'9', '-', '+']; + Result := CharInSet(C, ['0'..'9', '-', '+']); end; -function TBAInteger.ValidateString(Value: string; Representation: TBoldRepresentation): Boolean; +function TBAInteger.ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; begin if value = '' then result := CanSetToNull(nil) @@ -965,30 +1627,29 @@ function TBAInteger.CompareToAs(CompType: TBoldCompareType; BoldElement: TBoldEl else Result := inherited CompareToAs(CompType, BoldElement); end; - end else if BoldElement is TBANumeric then - begin - if EitherIsNull(Self, TBoldAttribute(BoldElement)) then - Result := NullSmallest(BoldElement) - else - case CompType of - ctDefault: - if AsInteger = TBANumeric(BoldElement).AsFloat then - Result := 0 - else if AsInteger > TBANumeric(BoldElement).AsFloat then - Result := 1 - else - Result := -1; - else - Result := inherited CompareToAs(CompType, BoldElement); - end; - end else + end + else Result := inherited CompareToAs(CompType, BoldElement); end; +constructor TBAInteger.CreateWithValue(Value: integer); +begin + inherited Create; + asInteger := value; +end; + +procedure TBAInteger.FreeContent; +begin + inherited; + fValue := 0; +end; + function TBAInteger.CanSetValue(Value: Integer; Subscriber: TBoldSubscriber): Boolean; begin - result := MaySetValue(Value, Subscriber) and - SendQuery(bqMaySetValue, [Value], Subscriber); + result := MaySetValue(Value, Subscriber); +{$IFNDEF BOLD_NO_QUERIES} + result := result and SendQuery(bqMaySetValue, [Value], Subscriber) +{$ENDIF} end; function TBAInteger.MaySetValue(NewValue: integer; @@ -1005,12 +1666,12 @@ function TBAInteger.CheckRangeWithBounds(Value, Min, result := false; SetBoldLastFailureReason( TBoldFailureReason.createFmt( - sRangeError, - [ClassName, Min, MAX, Value], self)); + 'Value outside range, range is %d to %d. Attempted to set %d', + [Min, MAX, Value], self)); end else result := true; -end; +end; {---TBAByte---} function TBAByte.CheckRange(Value: integer): Boolean; @@ -1034,6 +1695,7 @@ function TBAShortInt.CheckRange(Value: integer): Boolean; result := CheckRangeWithBounds(Value, Low(ShortInt), High(ShortInt)); end; + function TBAShortInt.GetAsShortInt: ShortInt; begin result := AsInteger; @@ -1076,25 +1738,34 @@ procedure TBAWord.SetAsWord(const Value: Word); SetDataValue(Value); end; -procedure TBAInteger.AssignValue(Source: IBoldValue); +procedure TBAInteger.AssignValue(const Source: IBoldValue); var s: IBoldIntegerContent; begin if source.QueryInterface(IBoldIntegerContent, S) = S_OK then SetDataValue(s.AsInteger) else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, Meth_AssignValue]); + raise EBold.CreateFmt('%s.AssignValue: unknown type of source', [classname]); end; procedure TBAInteger.SetContent(NewValue: Integer); +var + bContentIsNull: Boolean; + sOldValue: Integer; begin + bContentIsNull := ContentIsNull; if (BoldPersistenceState = bvpsInvalid) or ContentIsNull or (FValue <> NewValue) then begin PreChange; + sOldValue := fValue; FValue := NewValue; SetToNonNull; - Changed(beValueChanged, [NewValue]); + if bContentIsNull then begin + Changed(beValueChanged, [NewValue]); + end else begin + Changed(beValueChanged, [NewValue, sOldValue]); + end; end; end; @@ -1108,7 +1779,7 @@ function TBAInteger_Proxy.GetContentAsInteger: Integer; result := ProxedInteger.fValue; end; -procedure TBAInteger.AssignContentValue(Source: IBoldValue); +procedure TBAInteger.AssignContentValue(const Source: IBoldValue); var s: IBoldIntegerContent; begin @@ -1124,20 +1795,20 @@ procedure TBAInteger.AssignContentValue(Source: IBoldValue); SetContent(s.AsInteger) end else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, Meth_AssignContentValue]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); end; function TBAInteger.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; begin if IsEqualGuid(IID, IBoldIntegerContent) then - Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldIntegerContent') // do not localize + Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldIntegerContent') else result := inherited ProxyInterface(IID, Mode, Obj); end; -function TBAInteger.ProxyClass: TBoldMember_ProxyClass; +function TBAInteger.GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin - result := TBAInteger_Proxy; + result := TBAInteger_Proxy.MakeProxy(self, mode); end; { TBAFloat } @@ -1146,12 +1817,12 @@ procedure TBAFloat.SetDataValue(NewValue: Double); begin BoldClearLastFailure; if not CanSetValue(NewValue, nil) then - BoldRaiseLastFailure(self, 'SetDataValue', ''); // do not localize + BoldRaiseLastFailure(self, 'SetDataValue', ''); if IsNull or (FValue <> NewValue) then begin if not StartModify then - BoldRaiseLastFailure(self, 'SetDataValue', ''); // do not localize + BoldRaiseLastFailure(self, 'SetDataValue', ''); try SetContent(NewValue); @@ -1163,10 +1834,16 @@ procedure TBAFloat.SetDataValue(NewValue: Double); end; end; -procedure TBAFloat.SetStringRepresentation(Representation: TBoldRepresentation; Value: string); +procedure TBAFloat.SetEmptyValue; +begin + if FValue <> 0 then + inherited; +end; + +procedure TBAFloat.SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); begin if not ValidateString(Value, Representation) then - BoldRaiseLastFailure(self, Meth_SetStringRepresentation, sStringValidationFailed); + BoldRaiseLastFailure(self, 'SetStringRepresentation', 'String validation failed'); if Representation = brDefault then if Value = '' then SetToNull @@ -1180,7 +1857,7 @@ function TBAFloat.GetStringRepresentation(Representation: TBoldRepresentation): begin BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, Meth_GetStringRepresentation, ''); + BoldRaiseLastFailure(self, 'GetStringRepresentation', ''); if Representation <> brDefault then inherited GetStringRepresentation(Representation); if IsNull then {IsNull ensures current} @@ -1189,11 +1866,35 @@ function TBAFloat.GetStringRepresentation(Representation: TBoldRepresentation): Result := FloatToStr(GetAsFloat); end; +function TBAFloat.IsEqualToValue(const Value: IBoldValue): Boolean; +var + vFloat: IBoldFloatContent; +begin + Assert(Assigned(Value), ClassName + '.IsEqualToValue: Value can not be nil.'); + if Value.QueryInterface(IBoldFloatContent, vFloat) = S_OK then + begin + if IsNull and vFloat.IsNull then + result := true + else + if IsNull or vFloat.IsNull then + result := false + else + result := Self.asFloat = vFloat.asFloat + end + else + result := inherited IsEqualToValue(Value); +end; + +function TBAFloat.IsVariantTypeCompatible(const Value: Variant): Boolean; +begin + result := (VarType(Value) in [varSmallInt, varInteger, varShortInt, varByte, varWord, varLongWord, varInt64, varSingle, varDouble, varCurrency]) +end; + function TBAFloat.GetAsFloat: Double; begin BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, 'GetAsFloat', ''); // do not localize + BoldRaiseLastFailure(self, 'GetAsFloat', ''); EnsureNotNull; {ensures current} Result := FValue; end; @@ -1210,10 +1911,10 @@ procedure TBAFloat.SetAsInteger(Value: Integer); function TBAFloat.ValidateCharacter(C: Char; Representation: TBoldRepresentation): Boolean; begin - Result := C in ['0'..'9', '-', '+', 'e', 'E', FormatSettings.DecimalSeparator]; + Result := CharInSet(C, ['0'..'9', '-', '+', 'e', 'E', {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}DecimalSeparator]); end; -function TBAFloat.ValidateString(Value: string; Representation: TBoldRepresentation): Boolean; +function TBAFloat.ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; var temp: Extended; begin @@ -1223,7 +1924,7 @@ function TBAFloat.ValidateString(Value: string; Representation: TBoldRepresentat begin result := TextToFloat(PChar(Value), temp, fvExtended); if not result then - FormatFailure(value, 'float'); // do not localize + FormatFailure(value, 'float'); end; end; @@ -1269,10 +1970,24 @@ function TBAFloat.CompareToAs(CompType: TBoldCompareType; BoldElement: TBoldElem Result := inherited CompareToAs(CompType, BoldElement); end; +constructor TBAFloat.CreateWithValue(Value: double); +begin + inherited Create; + asFloat := Value; +end; + +procedure TBAFloat.FreeContent; +begin + inherited; + fValue := 0; +end; + function TBAFloat.CanSetValue(NewValue: Double; Subscriber: TBoldSubscriber): Boolean; begin - result := MaySetValue(NewValue, Subscriber) and - SendQuery(bqMaySetValue, [NewValue], Subscriber); + result := MaySetValue(NewValue, Subscriber); +{$IFNDEF BOLD_NO_QUERIES} + result := result and SendQuery(bqMaySetValue, [NewValue], Subscriber) +{$ENDIF} end; function TBAFloat.MaySetValue(NewValue: Double; @@ -1281,24 +1996,34 @@ function TBAFloat.MaySetValue(NewValue: Double; result := True; end; -procedure TBAFloat.AssignValue(Source: IBoldValue); +procedure TBAFloat.AssignValue(const Source: IBoldValue); var s: IBoldFloatContent; begin if source.QueryInterface(IBoldFloatContent, S) = S_OK then SetDataValue(s.AsFloat) else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, Meth_AssignValue]); + raise EBold.CreateFmt('%s.AssignValue: unknown type of source', [classname]); end; procedure TBAFloat.SetContent(NewValue: Double); +var + bContentIsNull: Boolean; + sOldValue: Double; begin - if ContentIsNull or (FValue <> NewValue) then + bContentIsNull := ContentIsNull; + if (BoldPersistenceState = bvpsInvalid) or + ContentIsNull or (FValue <> NewValue) then begin PreChange; + sOldValue := fValue; FValue := NewValue; SetToNonNull; - Changed(beValueChanged, [NewValue]); + if bContentIsNull then begin + Changed(beValueChanged, [NewValue]); + end else begin + Changed(beValueChanged, [NewValue, sOldValue]); + end; end; end; @@ -1312,7 +2037,7 @@ procedure TBAFloat_Proxy.SetContentAsFloat(NewValue: Double); ProxedFloat.SetContent(NewValue); end; -procedure TBAFloat.AssignContentValue(Source: IBoldValue); +procedure TBAFloat.AssignContentValue(const Source: IBoldValue); var FloatContent: IBoldFloatContent; CurrencyContent: IBoldCurrencyContent; @@ -1344,20 +2069,20 @@ procedure TBAFloat.AssignContentValue(Source: IBoldValue); SetContent(IntegerContent.asInteger) end else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, Meth_AssignContentValue]); + raise EBold.CreateFmt('%s.AssignValue: unknown type of source', [classname]); end; function TBAFloat.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; begin if IsEqualGuid(IID, IBoldFloatContent) then - Result := RetrieveProxyInterface(IBoldFloatContent, Mode, obj, 'IBoldFloatContent') // do not localize + Result := RetrieveProxyInterface(IBoldFloatContent, Mode, obj, 'IBoldFloatContent') else result := inherited ProxyInterface(IID, Mode, Obj); end; -function TBAFloat.ProxyClass: TBoldMember_ProxyClass; +function TBAFloat.GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin - result := TBAFloat_Proxy; + result := TBAFloat_Proxy.MakeProxy(self, mode); end; { TBACurrency } @@ -1366,12 +2091,12 @@ procedure TBACurrency.SetDataValue(NewValue: Currency); begin BoldClearLastFailure; if not CanSetValue(NewValue, nil) then - BoldRaiseLastFailure(self, 'SetDataValue', ''); // do not localize + BoldRaiseLastFailure(self, 'SetDataValue', ''); if IsNull or (FValue <> NewValue) then begin if not StartModify then - BoldRaiseLastFailure(self, 'SetDataValue', ''); // do not localize + BoldRaiseLastFailure(self, 'SetDataValue', ''); try SetContent(NewValue); EndModify; @@ -1382,19 +2107,26 @@ procedure TBACurrency.SetDataValue(NewValue: Currency); end; end; -procedure TBACurrency.SetStringRepresentation(Representation: TBoldRepresentation; Value: string); +procedure TBACurrency.SetEmptyValue; +begin + if fValue <> 0 then + inherited; +end; + +procedure TBACurrency.SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); begin if not ValidateString(Value, Representation) then - BoldRaiseLastFailure(self, Meth_SetStringRepresentation, sStringValidationFailed); + BoldRaiseLastFailure(self, 'SetStringRepresentation', 'String validation failed'); if Representation = brDefault then begin if Value = '' then SetToNull else begin - if Value[Length(Value)] = FormatSettings.DecimalSeparator then - Value := Concat(Value, '0'); - SetDataValue(StrToCurr(Value)); + if Value[Length(Value)] = {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}DecimalSeparator then + SetDataValue(StrToCurr(Concat(Value, '0'))) + else + SetDataValue(StrToCurr(Value)); end; end else inherited SetStringRepresentation(Representation, Value); @@ -1404,7 +2136,7 @@ function TBACurrency.GetStringRepresentation(Representation: TBoldRepresentation begin BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, Meth_GetStringRepresentation, ''); + BoldRaiseLastFailure(self, 'GetStringRepresentation', ''); if Representation <> brDefault then inherited GetStringRepresentation(Representation); if IsNull then {IsNull ensures current} @@ -1413,6 +2145,30 @@ function TBACurrency.GetStringRepresentation(Representation: TBoldRepresentation Result := CurrToStr(GetAsCurrency); end; +function TBACurrency.IsEqualToValue(const Value: IBoldValue): Boolean; +var + vCurrency: IBoldCurrencyContent; +begin + Assert(Assigned(Value), ClassName + '.IsEqualToValue: Value can not be nil.'); + if Value.QueryInterface(IBoldCurrencyContent, vCurrency) = S_OK then + begin + if IsNull and vCurrency.IsNull then + result := true + else + if IsNull or vCurrency.IsNull then + result := false + else + result := Self.asCurrency = vCurrency.asCurrency + end + else + result := inherited IsEqualToValue(Value); +end; + +function TBACurrency.IsVariantTypeCompatible(const Value: Variant): Boolean; +begin + result := (VarType(Value) in [varSmallInt, varInteger, varShortInt, varByte, varWord, varLongWord, varInt64, varSingle, varDouble, varCurrency]) +end; + procedure TBACurrency.SetAsCurrency(Value: Currency); begin SetDataValue(Value); @@ -1422,7 +2178,7 @@ function TBACurrency.GetAsCurrency: Currency; begin BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, 'GetAsCurrency', ''); // do not localize + BoldRaiseLastFailure(self, 'GetAsCurrency', ''); EnsureNotNull; {ensures current} Result := FValue; end; @@ -1431,7 +2187,7 @@ function TBACurrency.GetAsFloat: Double; begin BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, 'GetAsFloat', ''); // do not localize + BoldRaiseLastFailure(self, 'GetAsFloat', ''); EnsureNotNull; {ensures current} Result := FValue; end; @@ -1446,7 +2202,7 @@ procedure TBACurrency.SetAsInteger(Value: integer); SetAsFloat(Value); end; -function TBACurrency.ValidateString(Value: string; Representation: TBoldRepresentation): Boolean; +function TBACurrency.ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; var Temp: Currency; begin @@ -1456,13 +2212,13 @@ function TBACurrency.ValidateString(Value: string; Representation: TBoldRepresen begin result := TextToFloat(PChar(Value), temp, fvCurrency); if not result then - FormatFailure(value, 'currency'); // do not localize + FormatFailure(value, 'currency'); end; end; function TBACurrency.ValidateCharacter(C: Char; Representation: TBoldRepresentation): Boolean; begin - Result := C in ['0'..'9', '-', '+', 'e', 'E', FormatSettings.DecimalSeparator]; + Result := CharInSet(C, ['0'..'9', '-', '+', 'e', 'E', {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}DecimalSeparator]); end; procedure TBACurrency.Assign(Source: TBoldElement); @@ -1511,10 +2267,24 @@ function TBACurrency.CompareToAs(CompType: TBoldCompareType; BoldElement: TBoldE Result := inherited CompareToAs(CompType, BoldElement); end; +constructor TBACurrency.CreateWithValue(Value: currency); +begin + inherited Create; + asCurrency := Value; +end; + +procedure TBACurrency.FreeContent; +begin + inherited; + fValue := 0; +end; + function TBACurrency.CanSetValue(NewValue: Currency; Subscriber: TBoldSubscriber): Boolean; begin - Result := MaySetValue(NewValue, Subscriber) and - SendQuery(bqMaySetValue, [NewValue], Subscriber); + result := MaySetValue(NewValue, Subscriber); +{$IFNDEF BOLD_NO_QUERIES} + result := result and SendQuery(bqMaySetValue, [NewValue], Subscriber) +{$ENDIF} end; function TBACurrency.MaySetValue(NewValue: Currency; @@ -1523,24 +2293,34 @@ function TBACurrency.MaySetValue(NewValue: Currency; Result := True; end; -procedure TBACurrency.AssignValue(Source: IBoldValue); +procedure TBACurrency.AssignValue(const Source: IBoldValue); var s: IBoldCurrencyContent; begin if source.QueryInterface(IBoldCurrencyContent, S) = S_OK then SetDataValue(s.AsCurrency) else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, Meth_AssignValue]); + raise EBold.CreateFmt('%s.AssignValue: unknown type of source', [classname]); end; procedure TBACurrency.SetContent(NewValue: Currency); +var + bContentIsNull: Boolean; + sOldValue: Currency; begin - if ContentIsNull or (FValue <> NewValue) then + bContentIsNull := ContentIsNull; + if (BoldPersistenceState = bvpsInvalid) or + ContentIsNull or (FValue <> NewValue) then begin PreChange; + sOldValue := fValue; FValue := NewValue; SetToNonNull; - Changed(beValueChanged, [NewValue]); + if bContentIsNull then begin + Changed(beValueChanged, [NewValue]); + end else begin + Changed(beValueChanged, [NewValue, sOldValue]); + end; end; end; @@ -1554,7 +2334,7 @@ function TBACurrency_Proxy.GetContentAsCurrency: Currency; result := ProxedCurrency.fValue; end; -procedure TBACurrency.AssignContentValue(Source: IBoldValue); +procedure TBACurrency.AssignContentValue(const Source: IBoldValue); var s: IBoldCurrencyContent; FloatContent: IBoldFloatContent; @@ -1585,55 +2365,48 @@ procedure TBACurrency.AssignContentValue(Source: IBoldValue); else SetContent(IntegerContent.AsInteger) end else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, Meth_AssignContentValue]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); end; function TBACurrency.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; begin if IsEqualGuid(IID, IBoldCurrencyContent) then - Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldCurrencyContent') // do not localize + Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldCurrencyContent') else result := inherited ProxyInterface(IID, Mode, Obj); end; -function TBACurrency.ProxyClass: TBoldMember_ProxyClass; +function TBACurrency.GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin - result := TBACurrency_Proxy; + result := TBACurrency_Proxy.MakeProxy(self, mode); end; { TBoldBlobStream } -constructor TBoldBlobStream.Create(BlobAttr: TBABlob; Mode: TBoldBlobStreamMode); +constructor TBoldBlobStream.Create(BlobAttr: TBABlob); begin inherited Create; fBlobAttr := BlobAttr; - fMode := Mode; - if (Mode in [bmReadWrite, bmWrite]) and not BlobAttr.Mutable then - BlobAttr.MutableError('Binary Large Object'); //FIXME Better representation of BLOBs!!! // do not localize - if Mode in [bmRead, bmReadWrite] then - fBlobAttr.EnsureNotNull; - if (Mode = bmWrite) then - Truncate; end; -function TBoldBlobStream.GetBlobSize: Integer; +function TBoldBlobStream.GetBlobSize: Int64; begin - Result := Length(fBlobAttr.fValue); + Result := Length(fData); end; -function TBoldBlobStream.Read(var Buffer; Count: integer): integer; +function TBoldBlobStream.Read(var Buffer; Count: Longint): Longint; begin if Count > Size - fPosition then Result := Size - fPosition else Result := Count; if Result > 0 then begin - Move(PChar(fBlobAttr.fValue)[fPosition], Buffer, Result); + Move(PAnsiChar(fBlobAttr.AsStream.fData)[fPosition], Buffer, Result); Inc(FPosition, Result); end; end; -function TBoldBlobStream.Write(const Buffer; Count: integer): integer; +function TBoldBlobStream.Write(const Buffer; Count: Longint): Longint; var EndPos: integer; begin @@ -1644,23 +2417,27 @@ function TBoldBlobStream.Write(const Buffer; Count: integer): integer; if EndPos > 0 then begin try - StartModifyOfBlob('Write'); // do not localize + if not fBlobAttr.SupressEvents then + fBlobAttr.StartModifyOfBlob('Write'); if EndPos > Size then begin - SetLength(fBlobAttr.fValue, EndPos); + SetLength(fData, EndPos); end; - System.Move(Buffer, PChar(fBlobAttr.fValue)[fPosition], Count); + System.Move(Buffer, PAnsiChar(fBlobAttr.AsStream.fData)[fPosition], Count); fPosition := EndPos; Result := Count; - EndModifyOfBlob; + if not fBlobAttr.SupressEvents then + fBlobAttr.EndModifyOfBlob; except - FailModifyOfBlob; + if not fBlobAttr.SupressEvents then + fBlobAttr.FailModifyOfBlob; + raise; end; end; end; end; -function TBoldBlobStream.Seek(Offset: integer; Origin: Word): integer; +function TBoldBlobStream.Seek(Offset: Longint; Origin: Word): Longint; begin case Origin of 0: FPosition := Offset; @@ -1670,6 +2447,11 @@ function TBoldBlobStream.Seek(Offset: integer; Origin: Word): integer; Result := FPosition; end; +procedure TBoldBlobStream.SetSize(NewSize: Longint); +begin + SetSize(Int64(NewSize)); +end; + procedure TBoldBlobStream.Clear; begin SetSize(0); @@ -1684,26 +2466,26 @@ procedure TBoldBlobStream.LoadFromStream(Stream: TStream); var Count: Integer; begin - Stream.Position := 0; - Count := Stream.Size; - InternalSetSize(Count, Count = 0); // dont send any events if we are going to set the stream-value below - if Count <> 0 then - begin - try - StartModifyOfBlob('LoadFromStream'); // do not localize - Stream.ReadBuffer(PChar(fBlobAttr.fValue)[0], Count); - EndModifyOfBlob; - except - FailModifyOfBlob; + try + fBlobAttr.StartModifyOfBlob('LoadFromStream'); + Count := Stream.Size; + InternalSetSize(Count, Count = 0); + if Count <> 0 then + begin + Stream.ReadBuffer(fBlobAttr.AsStream.fData, Count); end; + fBlobAttr.EndModifyOfBlob; + except + fBlobAttr.FailModifyOfBlob; + raise; end; end; -procedure TBoldBlobStream.LoadFromFile(const FileName: string); +procedure TBoldBlobStream.LoadFromFile(const aFileName: string; aMode: Word = fmShareDenyNone); var Stream: TStream; begin - Stream := TFileStream.Create(FileName, fmOpenRead); + Stream := TFileStream.Create(aFileName, aMode); try LoadFromStream(Stream); finally @@ -1713,8 +2495,9 @@ procedure TBoldBlobStream.LoadFromFile(const FileName: string); procedure TBoldBlobStream.SaveToStream(Stream: TStream); begin + fBlobAttr.EnsureContentsCurrent; if Size <> 0 then - Stream.WriteBuffer(PChar(fBlobAttr.fValue)[0], Size); + Stream.WriteBuffer(fBlobAttr.AsStream.fData, Size); end; procedure TBoldBlobStream.SaveToFile(const FileName: string); @@ -1729,67 +2512,61 @@ procedure TBoldBlobStream.SaveToFile(const FileName: string); end; end; -procedure TBoldBlobStream.SetSize(NewSize: integer); -begin - InternalSetSize(NewSize, true); -end; - -procedure TBoldBlobStream.EndModifyOfBlob; -begin - // we can not call SetToNull since that will cause recursive Modification. that must be done by InternalSetSize - if (Size<>0) then - fBlobAttr.SetToNonNull; - fBlobAttr.Changed(beValueChanged, [fBlobAttr.FValue]); - fBlobAttr.EndModify; -end; - -procedure TBoldBlobStream.FailModifyOfBlob; -begin - fBlobAttr.FailModify; -end; - -procedure TBoldBlobStream.StartModifyOfBlob(Operation: String); +procedure TBoldBlobStream.SetSize(const NewSize: Int64); begin - if not fBlobAttr.StartModify then - BoldRaiseLastFailure(fBlobAttr, 'BlobStream: ' + Operation, ''); // do not localize - fBlobAttr.PreChange; + if NewSize <> GetBlobSize then + InternalSetSize(NewSize, not fBlobAttr.SupressEvents); end; -procedure TBoldBlobStream.InternalSetSize(NewSize: Integer; BlobEvents: Boolean); +procedure TBoldBlobStream.InternalSetSize(NewSize: Int64; BlobEvents: Boolean); var - OldPosition: Integer; + OldPosition: Int64; begin + if NewSize = Size then + exit; OldPosition := fPosition; if (NewSize = 0) and (not assigned(fBlobAttr.BoldAttributeRTInfo) or fBlobAttr.BoldAttributeRTInfo.AllowNull) then - fBlobAttr.SetToNull + begin + SetLength(fData, 0); + if not fBlobAttr.SupressEvents and not fBlobAttr.BoldPersistenceStateIsInvalid then + fBlobAttr.SetToNull; + end else try if BlobEvents then - StartModifyOfBlob('SetSize'); // do not localize - SetLength(fBlobAttr.fValue, NewSize); + fBlobAttr.StartModifyOfBlob('SetSize'); + SetLength(fData, NewSize); if BlobEvents then - EndModifyOfBlob; + fBlobAttr.EndModifyOfBlob; except if BlobEvents then - FailModifyOfBlob; + fBlobAttr.FailModifyOfBlob; + raise end; if OldPosition > NewSize then Seek(0, soFromEnd); +end; +function TBoldBlobStream.IsDataSame(AData: Pointer; ASize: Int64): boolean; +begin + result := false; + if ASize = Length(fData) then + result := CompareMem(AData, fData, ASize); end; { TBABlob } -procedure TBABlob.SetDataValue(NewValue: string); + +procedure TBABlob.SetDataValue(NewValue: TBoldAnsiString); begin BoldClearLastFailure; if not CanSetValue(NewValue, nil) then - BoldRaiseLastFailure(self, 'SetDataValue', ''); // do not localize + BoldRaiseLastFailure(self, 'SetDataValue', ''); - if IsNull or (FValue <> NewValue) then + if IsNull or not AsStream.IsDataSame(PAnsiChar(NewValue), Length(NewValue)) then begin if not StartModify then - BoldRaiseLastFailure(self, 'SetDataValue', ''); // do not localize + BoldRaiseLastFailure(self, 'SetDataValue', ''); try SetContent(NewValue); EndModify; @@ -1800,29 +2577,47 @@ procedure TBABlob.SetDataValue(NewValue: string); end; end; -procedure TBABlob.SetStringRepresentation(Representation: TBoldRepresentation; Value: string); +procedure TBABlob.SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); begin if not ValidateString(Value, Representation) then - BoldRaiseLastFailure(self, Meth_SetStringRepresentation, sStringValidationFailed); + BoldRaiseLastFailure(self, 'SetStringRepresentation', 'String validation failed'); case Representation of - brDefault: SetDataValue(Value); + brDefault: SetDataValue(TBoldAnsiString(Value)); brShort: {Content type is lost when assigned to a Blob}; else inherited SetStringRepresentation(Representation, Value); end; end; +function TBABlob.SupressEvents: Boolean; +begin + result := fSupressEventCount > 0; +end; + +procedure TBABlob.BeginSupressEvents; +begin + Inc(fSupressEventCount); + StartModifyOfBlob('Write'); +end; + +procedure TBABlob.EndSupressEvents; +begin + EndModifyOfBlob; + Dec(fSupressEventCount); + Assert(fSupressEventCount >= 0); +end; + function TBABlob.GetStringRepresentation(Representation: TBoldRepresentation): string; begin BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, Meth_GetStringRepresentation, ''); + BoldRaiseLastFailure(self, 'GetStringRepresentation', ''); case Representation of brDefault: begin if IsNull then {IsNull ensures current} Result := '' else - Result := FValue; + Result := TEncoding.Default.GetString(AsStream.fData); end; brShort: begin Result := ''; @@ -1832,21 +2627,84 @@ function TBABlob.GetStringRepresentation(Representation: TBoldRepresentation): s end; end; -function TBABlob.GetAsBlob: String; +function TBABlob.GetAsBlob: TBoldAnsiString; +begin + result := TBoldAnsiString(TEncoding.Default.GetString(AsStream.fData)); +end; + +function TBABlob.GetAsStream: TBoldBlobStream; +begin + if not SupressEvents then + EnsureContentsCurrent; + if not Assigned(fStream) then + fStream := TBoldBlobStream.Create(self); + result := fStream; +end; + +function TBABlob.GetBlobSize: Int64; +begin + result := AsStream.GetBlobSize; +end; + +function TBABlob.GetFreeStandingClass: TBoldFreeStandingElementClass; +begin + result := TBFSBlob; +end; + +procedure TBABlob.SetAsBlob(NewValue: TBoldAnsiString); begin - result := GetStringRepresentation(brDefault); + SetStringRepresentation(brDefault, String(NewValue)); end; -procedure TBABlob.SetAsBlob(NewValue: String); +procedure TBABlob.SetAsVariant(const Value: Variant); +var + p: Pointer; begin - SetStringRepresentation(brDefault, NewValue); + if VarIsArray(Value) then + begin + if VarType(Value) <> VarArray + VarByte then + raise EBold.CreateFmt('%s.SetAsVariant: Unsupported type of variant array, type: %d.', [classname, VarType(Value)]); + AsStream.Clear; + p := VarArrayLock(Value); + try + AsStream.Write(p ^, VarArrayHighBound(Value, 1)); + finally + VarArrayUnlock(Value); + end; + end + else + inherited SetAsVariant(Value); end; procedure TBABlob.SetToNull; begin inherited; - // save memory by "disposing" of blob data - FValue := ''; + AsStream.Clear; +end; + +procedure TBABlob.StartModifyOfBlob(const Operation: String); +begin + if not SupressEvents and not StartModify then + BoldRaiseLastFailure(self, 'BlobStream: '+Operation, ''); + PreChange; +end; + +procedure TBABlob.EndModifyOfBlob; +begin + if (GetBlobSize<>0) then + SetToNonNull; + // Old value is not passed in as parameter when Blob is set via Stream + // TODO: If Old value is needed store it in StartModifyOfBlob + Changed(beValueChanged, [fStream.fData]); + if not SupressEvents then + EndModify; +end; + +procedure TBABlob.FailModifyOfBlob; +begin + if SupressEvents then + exit; + FailModify; end; procedure TBABlob.Assign(Source: TBoldElement); @@ -1857,7 +2715,8 @@ procedure TBABlob.Assign(Source: TBoldElement); SetToNull else begin - AsString := TBABlob(Source).AsString; + TBABlob(Source).AsStream.Position:=0; + LoadFromStream(TBABlob(Source).AsStream); ContentType := TBABlob(Source).ContentType; end; Exit; @@ -1866,55 +2725,85 @@ procedure TBABlob.Assign(Source: TBoldElement); inherited; end; -function TBABlob.CreateBlobStream(Mode: TBoldBlobStreamMode): TBoldBlobStream; -begin - Result := TBoldBlobStream.Create(Self, Mode); -end; - -function TBABlob.CanSetValue(NewValue: string; Subscriber: TBoldSubscriber): Boolean; +function TBABlob.CanSetValue(NewValue: TBoldAnsiString; Subscriber: TBoldSubscriber): Boolean; begin - Result := MaySetValue(NewValue, Subscriber) and - SendQuery(bqMaySetValue, [NewValue], Subscriber); + result := MaySetValue(NewValue, Subscriber); +{$IFNDEF BOLD_NO_QUERIES} + result := result and SendQuery(bqMaySetValue, [NewValue], Subscriber) +{$ENDIF} end; -function TBABlob.MaySetValue(NewValue: String; +function TBABlob.MaySetValue(NewValue: TBoldAnsiString; Subscriber: TBoldSubscriber): Boolean; begin Result := True; end; -procedure TBABlob.AssignValue(Source: IBoldValue); +procedure TBABlob.AssignValue(const Source: IBoldValue); var s: IBoldBlobContent; begin if source.QueryInterface(IBoldBlobContent, S) = S_OK then SetDataValue(s.AsBlob) else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, Meth_AssignValue]); + raise EBold.CreateFmt('%s.AssignValue: unknown type of source', [classname]); end; -procedure TBABlob.SetContent(NewValue: string); +procedure TBABlob.SetContent(NewValue: TBoldAnsiString); +var + bContentIsNull: Boolean; + aOldValue: TBytes; begin - if ContentIsNull or (FValue <> NewValue) then + bContentIsNull := ContentIsNull; + if bContentIsNull or not AsStream.IsDataSame(PAnsiChar(NewValue), Length(NewValue)) then begin PreChange; - FValue := NewValue; + aOldValue := Copy(AsStream.fData, 0, BlobSize); + if NewValue = '' then + begin + AsStream.Clear; + AsStream.Seek(0, soFromBeginning); + end + else + begin + AsStream.fData := BytesOf(NewValue); + AsStream.Seek(0, soFromEnd); + end; SetToNonNull; - Changed(beValueChanged, [NewValue]); + if bContentIsNull then begin + Changed(beValueChanged, [AsStream.fData]); + end else begin + Changed(beValueChanged, [AsStream.fData, aOldValue]); + end; end; end; -function TBABlob_Proxy.GetContentAsBlob: string; +procedure TBABlob_Proxy.BeginSupressEvents; +begin + ProxedBlob.BeginSupressEvents; +end; + +procedure TBABlob_Proxy.EndSupressEvents; +begin + ProxedBlob.EndSupressEvents; +end; + +function TBABlob_Proxy.GetBlobAsStream: TStream; +begin + result := ProxedBlob.AsStream; +end; + +function TBABlob_Proxy.GetContentAsBlob: TBoldAnsiString; begin - result := ProxedBlob.fValue; + SetString(result, PAnsiChar(ProxedBlob.AsStream.fData), ProxedBlob.BlobSize); end; -procedure TBABlob_Proxy.SetContentAsBlob(const NewValue: string); +procedure TBABlob_Proxy.SetContentAsBlob(const NewValue: TBoldAnsiString); begin ProxedBlob.SetContent(NewValue); end; -procedure TBABlob.AssignContentValue(Source: IBoldValue); +procedure TBABlob.AssignContentValue(const Source: IBoldValue); var s: IBoldBlobContent; begin @@ -1930,7 +2819,7 @@ procedure TBABlob.AssignContentValue(Source: IBoldValue); SetContent(s.AsBlob) end else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, Meth_AssignContentValue]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); end; function TBABlob.CompareToAs(CompareType: TBoldCompareType; @@ -1945,25 +2834,32 @@ function TBABlob.CompareToAs(CompareType: TBoldCompareType; Result := NullSmallest(CompareBlob) else begin - case CompareType of - ctDefault, ctAsString: - // will this really compare binary values with #0 inside? /joho - Result := CompareStr(fValue, CompareBlob.fValue); - ctAsText: - Result := CompareText(fValue, CompareBlob.fValue); - ctAsAnsiString: - Result := AnsiCompareStr(fValue, CompareBlob.fValue); - ctAsAnsiText: - Result := AnsiCompareText(fValue, CompareBlob.fValue); + if CompareBlob.BlobSize > MaxInt then + begin // memory compare, 2 results + if AsStream.IsDataSame(CompareBlob.AsStream.fData, CompareBlob.BlobSize) then + result := 0 else - result := inherited CompareToAs(CompareType, BoldElement); - end; + result := -1; + end + else // string compare, 3 results + Result := StringCompare(CompareType, AsString, CompareBlob.AsString); end; end else Result := inherited CompareToAs(CompareType, BoldElement); end; +destructor TBABlob.Destroy; +begin + FreeAndNil(fStream); + inherited; +end; + +procedure TBABlob.Initialize; +begin + inherited; +end; + function TBABlob.IsEqualAs(CompareType: TBoldCompareType; BoldElement: TBoldElement): Boolean; var @@ -1975,34 +2871,77 @@ function TBABlob.IsEqualAs(CompareType: TBoldCompareType; if EitherIsNull(self, CompareBlob) then result := CompareBlob.IsNull and IsNull else - result := CompareBlob.fValue = fValue; // will this really compare binary values with #0 inside? /joho + result := CompareBlob.AsStream.fData = AsStream.fData; end else Result := inherited IsEqualAs(CompareType, BoldElement); end; +function TBABlob.IsEqualToValue(const Value: IBoldValue): Boolean; +var + vBlob: IBoldBlobContent; +begin + Assert(Assigned(Value), ClassName + '.IsEqualToValue: Value can not be nil.'); + if Value.QueryInterface(IBoldBlobContent, vBlob) = S_OK then + begin + if IsNull and vBlob.IsNull then + result := true + else + if IsNull or vBlob.IsNull then + result := false + else + result := Self.GetAsBlob = vBlob.asBlob + end + else + result := inherited IsEqualToValue(Value); +end; + function TBABlob.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; begin if IsEqualGuid(IID, IBoldBlobContent) then - Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldBlobContent') // do not localize + Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldBlobContent') else result := inherited ProxyInterface(IID, Mode, Obj); end; -function TBABlob.ProxyClass: TBoldMember_ProxyClass; +function TBABlob.GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; +begin + result := TBABlob_Proxy.MakeProxy(self, mode); +end; + +procedure TBABlob.FreeContent; +begin + inherited; + if assigned(fStream) then + fStream.Clear; +end; + +procedure TBABlob.SetEmptyValue; +begin + if Assigned(BoldAttributeRTInfo) and not BoldAttributeRTInfo.AllowNull then + asString := '' + else + SetContentToNull; +end; + +procedure TBABlob.LoadFromFile(const aFileName: string; aMode: Word); +begin + AsStream.LoadFromFile(aFilename, aMode); +end; + +procedure TBABlob.LoadFromStream(Stream: TStream); begin - result := TBABlob_Proxy; + AsStream.LoadFromStream(Stream); end; -procedure TBABlob.FreeContent; +procedure TBABlob.SaveToFile(const FileName: string); begin - inherited; - FValue := ''; + AsStream.SaveToFile(FileName); end; -procedure TBABlob.SetEmptyValue; +procedure TBABlob.SaveToStream(Stream: TStream); begin - asString := ''; + AsStream.SaveToStream(Stream); end; { TBATypedBlob } @@ -2010,12 +2949,12 @@ procedure TBATypedBlob.SetContentType2(Value: string); begin BoldClearLastFailure; if not CanSetContentType(Value, nil) then - BoldRaiseLastFailure(self, 'SetContentType', ''); // do not localize + BoldRaiseLastFailure(self, 'SetContentType', ''); if ContentIsNull or (FContentType <> Value) then begin if not StartModify then - BoldRaiseLastFailure(self, 'SetContentType', ''); // do not localize + BoldRaiseLastFailure(self, 'SetContentType', ''); try SetContentTypeContent(Value); EndModify; @@ -2030,16 +2969,21 @@ function TBATypedBlob.GetContentTypeContent: String; begin BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, 'GetContentType', ''); // do not localize + BoldRaiseLastFailure(self, 'GetContentType', ''); result := ContentType; end; +function TBATypedBlob.GetFreeStandingClass: TBoldFreeStandingElementClass; +begin + result := TBFSTypedBlob; +end; + function TBATypedBlob.GetStringRepresentation(Representation: TBoldRepresentation): string; begin case Representation of brShort: begin if not CanRead(nil) then - BoldRaiseLastFailure(self, Meth_GetStringRepresentation, ''); + BoldRaiseLastFailure(self, 'GetStringRepresentation', ''); Result := FContentType; end; else @@ -2047,12 +2991,12 @@ function TBATypedBlob.GetStringRepresentation(Representation: TBoldRepresentatio end; end; -procedure TBATypedBlob.SetStringRepresentation(Representation: TBoldRepresentation; Value: string); +procedure TBATypedBlob.SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); begin case Representation of brShort: begin if not ValidateString(Value, Representation) then - BoldRaiseLastFailure(self, Meth_SetStringRepresentation, sStringValidationFailed); + BoldRaiseLastFailure(self, 'SetStringRepresentation', 'String validation failed'); SetContentType2(Value); end; else @@ -2068,10 +3012,14 @@ procedure TBATypedBlob.SetToNull; function TBATypedBlob.CanSetContentType(Value: string; Subscriber: TBoldSubscriber): Boolean; begin +{$IFDEF BOLD_NO_QUERIES} + result := True; +{$ELSE} Result := SendQuery(bqMaySetContentType, [Value], Subscriber); +{$ENDIF} end; -procedure TBATypedBlob.AssignValue(Source: IBoldValue); +procedure TBATypedBlob.AssignValue(const Source: IBoldValue); var s: IBoldTypedBlob; s2: IBoldBlobContent; @@ -2084,7 +3032,7 @@ procedure TBATypedBlob.AssignValue(Source: IBoldValue); SetDataValue(s2.AsBlob); end else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, Meth_AssignValue]); + raise EBold.CreateFmt('%s.AssignValue: unknown type of source', [classname]); end; function TBATypedBlob.CompareToAs(CompareType: TBoldCompareType; @@ -2110,15 +3058,27 @@ function TBATypedBlob.IsEqualAs(CompareType: TBoldCompareType; end else result := inherited IsEqualAs(CompareType, BoldElement); + +end; + +function TBATypedBlob.IsEqualToValue(const Value: IBoldValue): Boolean; +var + vTypedBlob: IBoldTypedBlob; +begin + Assert(Assigned(Value), ClassName + '.IsEqualToValue: Value can not be nil.'); + if Value.QueryInterface(IBoldTypedBlob, vTypedBlob) = S_OK then + result := (Self.ContentType = vTypedBlob.ContentTypeContent) and inherited IsEqualToValue(Value) + else + result := inherited IsEqualToValue(Value); end; {-- TBABlobImageJPEG --} -procedure TBABlobImageJPEG.SetStringRepresentation(Representation: TBoldRepresentation; Value: string); +procedure TBABlobImageJPEG.SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); begin case Representation of brShort: begin - if (Value <> '') and (Value <> ContentType) then - raise EBold.CreateFmt(sCannotAssignXtoY, [ClassName, Value, ContentType]); + if (Value<>'') and (Value<>ContentType) then + raise EBold.CreateFmt('%s.SetStringRepresentation: Can not assign a ''%s'' to a ''%s''', [ClassName, Value, ContentType]); end; else inherited SetStringRepresentation(Representation, Value); @@ -2129,7 +3089,7 @@ function TBABlobImageJPEG.GetStringRepresentation(Representation: TBoldRepresent begin case Representation of brShort: begin - Result := 'image/jpeg'; // do not localize + Result := 'image/jpeg'; end; else inherited GetStringRepresentation(Representation); @@ -2137,12 +3097,12 @@ function TBABlobImageJPEG.GetStringRepresentation(Representation: TBoldRepresent end; {-- TBABlobImageBMP --} -procedure TBABlobImageBMP.SetStringRepresentation(Representation: TBoldRepresentation; Value: string); +procedure TBABlobImageBMP.SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); begin case Representation of brShort: begin if (Value <> '') and (Value <> ContentType) then - raise EBold.CreateFmt(sCannotAssignXtoY, [ClassName, Value, ContentType]); + raise EBold.CreateFmt('%s.SetStringRepresentation: Can not assign a ''%s'' to a ''%s''', [ClassName, Value, ContentType]); end; else inherited SetStringRepresentation(Representation, Value); @@ -2153,7 +3113,7 @@ function TBABlobImageBMP.GetStringRepresentation(Representation: TBoldRepresenta begin case Representation of brShort: begin - Result := 'image/bitmap'; // do not localize + Result := 'image/bitmap'; end; else inherited GetStringRepresentation(Representation); @@ -2163,14 +3123,14 @@ function TBABlobImageBMP.GetStringRepresentation(Representation: TBoldRepresenta function TBATypedBlob.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; begin if IsEqualGuid(IID, IBoldTypedBlob) then - Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldTypedBlob') // do not localize + Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldTypedBlob') else result := inherited ProxyInterface(IID, Mode, Obj); end; -function TBATypedBlob.ProxyClass: TBoldMember_ProxyClass; +function TBATypedBlob.GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin - result := TBATypedBlob_Proxy; + result := TBATypedBlob_Proxy.MakeProxy(self, mode); end; procedure TBATypedBlob.SetContentTypeContent(NewValue: String); @@ -2178,7 +3138,7 @@ procedure TBATypedBlob.SetContentTypeContent(NewValue: String); PreChange; FContentType := NewValue; SetToNonNull; - Changed(beValueChanged, [NewValue]); + Changed(beValueChanged, [AsStream.fData]); end; { TBAMoment } @@ -2186,15 +3146,24 @@ procedure TBATypedBlob.SetContentTypeContent(NewValue: String); procedure TBAMoment.SetDataValue(NewValue: TDateTime); begin BoldClearLastFailure; +{$IFDEF NoNegativeDates} + if IsPartOfSystem then + begin + if (NewValue < 0) then + BoldRaiseLastFailure(self, 'SetDataValue', 'Attempt to set date before 1899-12-30'); + if (NewValue >= 1000*365) then + BoldRaiseLastFailure(self, 'SetDataValue', 'Attempt to set date after 2899-12-30'); + end; +{$ENDIF} if not CanSetValue(NewValue, nil) then - BoldRaiseLastFailure(self, 'SetDataValue', ''); // do not localize + BoldRaiseLastFailure(self, 'SetDataValue', ''); if IsNull or (FValue <> NewValue) then begin if not StartModify then - BoldRaiseLastFailure(self, 'SetDataValue', ''); // do not localize + BoldRaiseLastFailure(self, 'SetDataValue', ''); try - SetContent(NewValue); + SetDateTimeContent(NewValue); EndModify; except FailModify; @@ -2205,30 +3174,41 @@ procedure TBAMoment.SetDataValue(NewValue: TDateTime); function TBAMoment.CanSetValue(NewValue: TDateTime; Subscriber: TBoldSubscriber): Boolean; begin - result := MaySetValue(NewValue, Subscriber) and - SendQuery(bqMaySetValue, [NewValue], Subscriber); + result := MaySetValue(NewValue, Subscriber); +{$IFNDEF BOLD_NO_QUERIES} + result := result and SendQuery(bqMaySetValue, [NewValue], Subscriber) +{$ENDIF} end; function TBAMoment.MaySetValue(NewValue: TDateTime; Subscriber: TBoldSubscriber): Boolean; begin - result := True; +{$IFDEF NoNegativeDates} + result := not IsPartOfSystem or ((NewValue >= 0) and (NewValue < 1000*365000)); +{$ELSE} + result := true; +{$ENDIF} end; function TBAMoment.GetAsDateTime: TDateTime; begin BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, 'GetAsDateTime', ''); // do not localize + BoldRaiseLastFailure(self, 'GetAsDateTime', ''); EnsureNotNull; {ensures current} Result := FValue; end; +function TBAMoment.GetAsFloat: Double; +begin + Result := GetAsDateTime; +end; + function TBAMoment.GetAsDate: TDateTime; begin BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, 'GetAsDate', ''); // do not localize + BoldRaiseLastFailure(self, 'GetAsDate', ''); EnsureNotNull; {ensures current} Result := Int(fValue);; end; @@ -2237,7 +3217,7 @@ function TBAMoment.GetAsTime: TDateTime; begin BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, 'GetAsTime', ''); // do not localize + BoldRaiseLastFailure(self, 'GetAsTime', ''); EnsureNotNull; {ensures current} Result := frac(fValue); end; @@ -2247,6 +3227,11 @@ procedure TBAMoment.SetAsDateTime(Value: TDateTime); SetDataValue(Value); end; +procedure TBAMoment.SetAsInteger(Value: integer); +begin + SetAsDate(Value); +end; + procedure TBAMoment.SetAsDate(Value: TDateTime); begin if IsNull then @@ -2319,14 +3304,39 @@ function TBAMoment.CompareToAs(CompType: TBoldCompareType; BoldElement: TBoldEle Result := inherited CompareToAs(CompType, BoldElement); end; -procedure TBAMoment.SetContent(NewValue: TDateTime); +procedure TBAMoment.FreeContent; +begin + inherited; + FValue := 0; +end; + +procedure TBAMoment.SetDateTimeContent(NewValue: TDateTime); +var + bContentIsNull: Boolean; + sOldValue: TDateTime; begin - if ContentIsNull or (FValue <> NewValue) then +{$IFDEF NoNegativeDates} + if IsPartOfSystem then + begin + if NewValue < 0 then + raise EBoldInternal.Create('TBAMoment.SetContent setting a negative value. Should have been prevented by MaySetValue'); + if NewValue >=1000*365 then + raise EBoldInternal.Create('TBAMoment.SetContent setting a too big value. Should have been prevented by MaySetValue'); + end; +{$ENDIF} + bContentIsNull := ContentIsNull; + if (BoldPersistenceState = bvpsInvalid) or + ContentIsNull or (FValue <> NewValue) then begin PreChange; + sOldValue := fValue; FValue := NewValue; SetToNonNull; - Changed(beValueChanged, [NewValue]); + if bContentIsNull then begin + Changed(beValueChanged, [NewValue]); + end else begin + Changed(beValueChanged, [NewValue, sOldValue]); + end; end; end; @@ -2337,7 +3347,7 @@ function TBAMoment_Proxy.GetContentAsDate: TDateTime; procedure TBAMoment_Proxy.SetContentAsDate(NewValue: TDateTime); begin - ProxedMoment.SetContent(Int(NewValue) + GetContentAsTime); + ProxedMoment.SetDateTimeContent(Int(NewValue) + GetContentAsTime); end; function TBAMoment_Proxy.GetContentAsTime: TDateTime; @@ -2352,17 +3362,20 @@ function TBAMoment_Proxy.GetContentAsDateTime: TDateTime; procedure TBAMoment_Proxy.SetContentAsDateTime(NewValue: TDateTime); begin - ProxedMoment.SetContent(NewValue); + ProxedMoment.SetDateTimeContent(NewValue); end; procedure TBAMoment_Proxy.SetContentAsTime(NewValue: TDateTime); begin - ProxedMoment.SetContent(frac(NewValue) + GetContentAsDate); + ProxedMoment.SetDateTimeContent(frac(NewValue) + GetContentAsDate); end; procedure TBAMoment.SetEmptyValue; begin - SetAsDateTime(0); + if Assigned(BoldAttributeRTInfo) and not BoldAttributeRTInfo.AllowNull then + SetAsDateTime(0) + else + SetContentToNull; end; function TBAMoment.GetDays: Word; @@ -2407,17 +3420,69 @@ function TBAMoment.GetYears: Word; Result := Year; end; +function TBAMoment.IsEqualToValue(const Value: IBoldValue): Boolean; +var + vDateTime: IBoldDateTimeContent; + vDate: IBoldDateContent; + vTime: IBoldTimeContent; +begin + Assert(Assigned(Value), ClassName + '.IsEqualToValue: Value can not be nil.'); + if Value.QueryInterface(IBoldDateTimeContent, vDateTime) = S_OK then + begin + if Self.IsNull and vDateTime.IsNull then + result := true + else + if Self.IsNull or vDateTime.IsNull then + result := false + else + result := Self.asDateTime = vDateTime.asDateTime + end + else + if Value.QueryInterface(IBoldDateContent, vDate) = S_OK then + begin + if Self.IsNull and vDate.IsNull then + result := true + else + if Self.IsNull or vDate.IsNull then + result := false + else + result := Self.asDate = vDate.asDate + end + else + if Value.QueryInterface(IBoldTimeContent, vTime) = S_OK then + begin + if Self.IsNull and vTime.IsNull then + result := true + else + if Self.IsNull or vTime.IsNull then + result := false + else + result := Self.asTime = vTime.asTime + end + else + result := inherited IsEqualToValue(Value); +end; + +function TBAMoment.IsNullOrZero: boolean; +begin + result := isNull or (GetAsDateTime = 0); +end; + +function TBAMoment.IsVariantTypeCompatible(const Value: Variant): Boolean; +begin + result := (VarType(Value) in [varDate, varDouble, varInteger, varInt64]); +end; + { TBADateTime } -procedure TBADateTime.SetStringRepresentation(Representation: TBoldRepresentation; Value: string); +procedure TBADateTime.SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); begin if not ValidateString(Value, Representation) then - BoldRaiseLastFailure(self, Meth_SetStringRepresentation, sStringValidationFailed); + BoldRaiseLastFailure(self, 'SetStringRepresentation', 'String validation failed'); if Representation = brDefault then - // FIXME: What if only date supplied? if Value = '' then SetToNull - else if upperCase(Value) = DEFAULTNOW then + else if upperCase(Value) = '' then SetDataValue(now) else SetDataValue(StrToDateTime(Value)) @@ -2437,15 +3502,15 @@ function TBADateTime.GetStringRepresentation(Representation: TBoldRepresentation function TBADateTime.ValidateCharacter(C: Char; Representation: TBoldRepresentation): Boolean; begin - Result := C in ['0'..'9', ' ', FormatSettings.TimeSeparator, FormatSettings.DateSeparator]; + Result := CharInSet(C, ['0'..'9', ' ', {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}TimeSeparator, {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}DateSeparator]); end; -function TBADateTime.ValidateString(Value: string; Representation: TBoldRepresentation): Boolean; +function TBADateTime.ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; begin try if value = '' then result := CanSetToNull(nil) - else if upperCase(Value) = DEFAULTNOW then + else if upperCase(Value) = '' then result := true else begin @@ -2454,19 +3519,19 @@ function TBADateTime.ValidateString(Value: string; Representation: TBoldRepresen end; except Result := False; - FormatFailure(value, 'datetime'); // do not localize + FormatFailure(value, 'datetime'); end; end; {---TBADate---} -procedure TBADate.SetStringRepresentation(Representation: TBoldRepresentation; Value: string); +procedure TBADate.SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); begin if not ValidateString(Value, Representation) then - BoldRaiseLastFailure(self, Meth_SetStringRepresentation, sStringValidationFailed); + BoldRaiseLastFailure(self, 'SetStringRepresentation', 'String validation failed'); if Representation = brDefault then if Value = '' then SetToNull - else if upperCase(Value) = DEFAULTNOW then + else if upperCase(Value) = '' then SetDataValue(now) else try @@ -2489,15 +3554,15 @@ function TBADate.GetStringRepresentation(Representation: TBoldRepresentation): s function TBADate.ValidateCharacter(C: Char; Representation: TBoldRepresentation): Boolean; begin - Result := C in ['0'..'9', FormatSettings.DateSeparator]; + Result := CharInSet(C, ['0'..'9', {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}DateSeparator]); end; -function TBADate.ValidateString(Value: string; Representation: TBoldRepresentation): Boolean; +function TBADate.ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; begin try if value = '' then result := CanSetToNull(nil) - else if upperCase(Value) = DEFAULTNOW then + else if upperCase(Value) = '' then result := true else begin @@ -2506,19 +3571,19 @@ function TBADate.ValidateString(Value: string; Representation: TBoldRepresentati end; except Result := False; - FormatFailure(value, 'date'); // do not localize + FormatFailure(value, 'date'); end; end; {---TBATime---} -procedure TBATime.SetStringRepresentation(Representation: TBoldRepresentation; Value: string); +procedure TBATime.SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); begin if not ValidateString(Value, Representation) then - BoldRaiseLastFailure(self, Meth_SetStringRepresentation, sStringValidationFailed); + BoldRaiseLastFailure(self, 'SetStringRepresentation', 'String validation failed'); if Representation = brDefault then if Value = '' then SetToNull - else if upperCase(Value) = DEFAULTNOW then + else if upperCase(Value) = '' then SetDataValue(now) else SetDataValue(StrToTime(Value)) @@ -2538,15 +3603,15 @@ function TBATime.GetStringRepresentation(Representation: TBoldRepresentation): s function TBATime.ValidateCharacter(C: Char; Representation: TBoldRepresentation): Boolean; begin - Result := C in ['0'..'9', FormatSettings.TimeSeparator]; + Result := CharInSet(C, ['0'..'9', {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}TimeSeparator]); end; -function TBATime.ValidateString(Value: string; Representation: TBoldRepresentation): Boolean; +function TBATime.ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; begin try if value = '' then result := CanSetToNull(nil) - else if upperCase(Value) = DEFAULTNOW then + else if upperCase(Value) = '' then result := true else begin @@ -2555,7 +3620,7 @@ function TBATime.ValidateString(Value: string; Representation: TBoldRepresentati end; except Result := False; - FormatFailure(value, 'time'); // do not localize + FormatFailure(value, 'time'); end; end; @@ -2582,9 +3647,10 @@ function TBAValueSetValue.GetStringRepresentation(Representation: TBoldRepresent Result := FStringRepresentations.Strings[Representation]; end; -procedure TBAValueSetValue.SetStringRepresentation(Representation: TBoldRepresentation; Value: string); +procedure TBAValueSetValue.SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); begin - EnsureValidString(Value, Representation); + if not ValidateString(Value, Representation) then + BoldRaiseLastFailure(nil, 'SetStringRepresentation', 'String validation failed'); FStringRepresentations.Strings[Representation] := Value; end; @@ -2608,6 +3674,23 @@ function TBAValueSetValue.GetStringRepresentationCount: Integer; Result := FStringRepresentations.Count; end; +function TBAValueSetValue.CompareToAs(CompareType: TBoldCompareType; + BoldElement: TBoldElement): Integer; +begin + if BoldElement is TBAValueSetValue then + begin + if (TBAValueSetValue(BoldElement).AsInteger = AsInteger) then + Result := 0 + else + if AsInteger > TBAValueSetValue(BoldElement).AsInteger then + Result := 1 + else + Result := -1; + end + else + Result := inherited CompareToAs(CompareType, BoldElement); +end; + procedure TBAValueSetValue.DefaultSubscribe(Subscriber: TBoldSubscriber; RequestedEvent: TBoldEvent = breReEvaluate); begin if mutable then @@ -2620,9 +3703,10 @@ procedure TBAValueSetValue.GetAsList(ResultList: TBoldIndirectElement); end; {---TBAValueSetValueList---} + constructor TBAValueSetValueList.Create; begin - inherited; + inherited Create; FValueList := TList.Create; end; @@ -2675,28 +3759,38 @@ function TBAValueSetValueList.GetFirstValue: TBAValueSetValue; function TBAValueSetValueList.FindByString(Representation: TBoldRepresentation; Value: string): TBAValueSetValue; var - I: Integer; + i, j: Integer; + aValue: TBAValueSetValue; begin Result := nil; for I := 0 to FValueList.Count - 1 do - if CompareText(TBAValueSetValue(FValueList.Items[I]).StringRepresentation[Representation], Value) = 0 then - begin - Result := FValueList.Items[I]; - break; - end; + begin + aValue := TBAValueSetValue(FValueList.Items[I]); + for j := 0 to aValue.StringRepresentationCount - 1 do + if SameText(aValue.StringRepresentation[j], Value) then + begin + Result := FValueList.Items[I]; + exit; + end; + end; end; function TBAValueSetValueList.FindByText(Representation: TBoldRepresentation; Value: string): TBAValueSetValue; var - I: Integer; + i, j: Integer; + aValue: TBAValueSetValue; begin Result := nil; for I := 0 to FValueList.Count - 1 do - if AnsiCompareText(TBAValueSetValue(FValueList.Items[I]).StringRepresentation[Representation], Value) = 0 then - begin - Result := FValueList.Items[I]; - break; - end; + begin + aValue := TBAValueSetValue(FValueList.Items[I]); + for j := 0 to aValue.StringRepresentationCount - 1 do + if AnsiSameText(aValue.StringRepresentation[j], Value) then + begin + Result := FValueList.Items[I]; + exit; + end; + end; end; procedure TBAValueSetValueList.ToStrings(Representation: TBoldRepresentation; theStrings: TStrings); @@ -2715,33 +3809,39 @@ procedure TBAValueSetValueList.ToStringsWithNil end; -procedure TBADateTime.AssignValue(Source: IBoldValue); +procedure TBADateTime.AssignValue(const Source: IBoldValue); var s: IBoldDateTimeContent; begin if source.QueryInterface(IBoldDateTimeContent, S) = S_OK then SetDataValue(s.AsDateTime) else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, Meth_AssignValue]); + raise EBold.CreateFmt('%s.AssignValue: unknown type of source', [classname]); +end; + +constructor TBADateTime.CreateWithValue(Value: TDateTime); +begin + inherited Create; + asDateTime := Value; end; -procedure TBADateTime.AssignContentValue(Source: IBoldValue); +procedure TBADateTime.AssignContentValue(const Source: IBoldValue); var s: IBoldDateTimeContent; begin if not assigned(source) and CanSetToNull(nil) then SetContentToNull else if not assigned(source) then - SetContent(0) + SetDateTimeContent(0) else if source.QueryInterface(IBoldDateTimeContent, S) = S_OK then begin if s.IsNull then SetContentToNull else - SetContent(s.AsDateTime) + SetDateTimeContent(s.AsDateTime) end else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, Meth_AssignContentValue]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); end; function TBADateTime.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; @@ -2749,14 +3849,19 @@ function TBADateTime.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementPr if IsEqualGuid(IID, IBoldDateTimeContent) or IsEqualGuid(IID, IBoldDateContent) or IsEqualGuid(IID, IBoldTimeContent) then - Result := RetrieveProxyInterface(IID, Mode, obj, 'IBold[Date][Time]Content') // do not localize + Result := RetrieveProxyInterface(IID, Mode, obj, 'IBold[Date][Time]Content') else result := inherited ProxyInterface(IID, Mode, Obj); end; -function TBADateTime.ProxyClass: TBoldMember_ProxyClass; +function TBADateTime.GetFreeStandingClass: TBoldFreeStandingElementClass; begin - result := TBADateTime_Proxy; + result := TBFSDateTime; +end; + +function TBADateTime.GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; +begin + result := TBADateTime_Proxy.MakeProxy(self, mode); end; { TBAValueSet } @@ -2765,14 +3870,14 @@ procedure TBAValueSet.SetDataValue(NewValue: TBAValueSetValue); begin BoldClearLastFailure; if not CanSetValue(NewValue, nil) then - BoldRaiseLastFailure(self, 'SetDataValue', ''); // do not localize + BoldRaiseLastFailure(self, 'SetDataValue', ''); if not Assigned(NewValue) then - raise EBold.Create(sInvalidValue); + raise EBold.CreateFmt('%s: Invalid value', [ClassName]); - if IsNull or (FValue <> NewValue) then + if IsNull or not (FValue.IsEqual(NewValue)) then begin if not StartModify then - BoldRaiseLastFailure(self, 'SetDataValue', ''); // do not localize + BoldRaiseLastFailure(self, 'SetDataValue', ''); try SetContent(NewValue); EndModify; @@ -2787,19 +3892,24 @@ function TBAValueSet.GetStringRepresentation(Representation: TBoldRepresentation begin CheckIllegalValue; if IsNull then {IsNull ensures current} {IsNull checks MayRead} - Result := '' //FIXME: raise Exception? + Result := '' else Result := FValue.StringRepresentation[Representation]; end; -procedure TBAValueSet.SetStringRepresentation(Representation: TBoldRepresentation; Value: string); +class function TBAValueSet.GetValues: TBAValueSetValueList; +begin + result := nil; +end; + +procedure TBAValueSet.SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); var ValueSetValue: TBAValueSetValue; begin if not ValidateString(Value, Representation) then - BoldRaiseLastFailure(self, Meth_SetStringRepresentation, sStringValidationFailed); + BoldRaiseLastFailure(self, 'SetStringRepresentation', 'String validation failed'); ValueSetValue := Values.FindByString(Representation, Value); - assert(assigned(ValueSetValue), sCannotFindValueSetValue); + assert(assigned(ValueSetValue), 'ValidateString said OK, but SetStringRepresentation can not find a valuesetvalue'); SetDataValue(ValueSetValue) end; @@ -2808,7 +3918,7 @@ function TBAValueSet.GetAsInteger: Integer; BoldClearLastFailure; CheckIllegalValue; if not CanRead(nil) then - BoldRaiseLastFailure(self, 'GetAsInteger', ''); // do not localize + BoldRaiseLastFailure(self, 'GetAsInteger', ''); EnsureNotNull; {ensures current} Result := FValue.AsInteger; end; @@ -2819,12 +3929,15 @@ procedure TBAValueSet.SetAsInteger(Value: Integer); SetDataValue(Values.FindByInteger(Value)); end; -function TBAValueSet.ValidateString(Value: string; Representation: TBoldRepresentation): Boolean; +function TBAValueSet.ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; var ValueSetvalue: TBAValueSetValue; strList: TStringList; Str: String; begin + result := false; + if Value = '' then + exit; ValueSetValue := Values.FindByString(Representation, Value); Result := Assigned(ValueSetvalue); @@ -2834,7 +3947,7 @@ function TBAValueSet.ValidateString(Value: string; Representation: TBoldRepresen try Values.ToStrings(Representation, strList); Str := BoldSeparateStringList(StrList, ', ', '(', ')'); - SetBoldLastFailureReason(TBoldFailureReason.CreateFmt(sUnknownStringValue, [Value, Str], self)); + SetBoldLastFailureReason(TBoldFailureReason.CreateFmt('Unknown stringvalue ''%s'', Allowed values: %s', [Value, Str], self)); finally StrList.Free; end; @@ -2885,14 +3998,42 @@ function TBAValueSet.CompareToAs(CompType: TBoldCompareType; BoldElement: TBoldE Result := inherited CompareToAs(CompType, BoldElement); end; end + else + if BoldElement is TBAValueSetValue then + begin + // Since TBAValueSetValue has no BoldType we compare both Integer and String values to make sure they are the same + if (AsInteger = TBAValueSetValue(BoldElement).AsInteger) and (TBAValueSetValue(BoldElement).AsString = AsString) then + Result := 0 + else + Result := -1; + end + else + if BoldElement is TBAInteger then + begin + // Since TBAValueSetValue has no BoldType we compare both Integer and String values to make sure they are the same + if (AsInteger = TBAInteger(BoldElement).AsInteger) {and (TBAValueSetValue(BoldElement).AsString = AsString)} then + Result := 0 + else + Result := -1; + end + else + if BoldElement is TBAString then + begin + if (AsString = TBAString(BoldElement).AsString) then + Result := 0 + else + Result := -1; + end else Result := inherited CompareToAs(CompType, BoldElement); end; function TBAValueSet.CanSetValue(NewValue: TBAValueSetValue; Subscriber: TBoldSubscriber): Boolean; begin - result := MaySetValue(NewValue, Subscriber) and - SendQuery(bqMaySetValue, [NewValue], Subscriber); + result := MaySetValue(NewValue, Subscriber); +{$IFNDEF BOLD_NO_QUERIES} + result := result and SendQuery(bqMaySetValue, [NewValue], Subscriber) +{$ENDIF} end; function TBAValueSet.MaySetValue(NewValue: TBAValueSetValue; @@ -2901,36 +4042,45 @@ function TBAValueSet.MaySetValue(NewValue: TBAValueSetValue; result := True; end; -procedure TBAValueSet.InitializeMember(OwningElement: TBoldDomainElement; - ElementTypeInfo: TBoldElementTypeInfo); +procedure TBAValueSet.Initialize; begin inherited; if not Assigned(Values) then - raise EBold.CreateFmt(sValuesNotInitialized, [ClassName]); + raise EBold.CreateFmt('%s: Values not properly initalized', [ClassName]); if assigned(values.FValueList) and (values.fValueList.count <> 0) then FValue := Values.GetFirstValue else setToNull; end; -procedure TBAValueSet.AssignValue(Source: IBoldValue); +procedure TBAValueSet.AssignValue(const Source: IBoldValue); var s: IBoldIntegerContent; begin if source.QueryInterface(IBoldIntegerContent, S) = S_OK then SetDataValue(Values.FindByInteger(s.AsInteger)) else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, Meth_AssignValue]); + raise EBold.CreateFmt('%s.AssignValue: unknown type of source', [classname]); end; procedure TBAValueSet.SetContent(NewValue: TBAValueSetValue); +var + bContentIsNull: Boolean; + sOldValue: TBAValueSetValue; begin - if ContentIsNull or (FValue <> NewValue) then + bContentIsNull := ContentIsNull; + if (BoldPersistenceState = bvpsInvalid) or + bContentIsNull or not (fValue.IsEqual(NewValue)) then begin PreChange; - FValue := NewValue; + sOldValue := fValue; + fValue := NewValue; SetToNonNull; - Changed(beValueChanged, [NewValue]); + if bContentIsNull then begin + Changed(beValueChanged, [NewValue]); + end else begin + Changed(beValueChanged, [NewValue, sOldValue]); + end; end; end; @@ -2958,6 +4108,11 @@ function TBAValueSet.GetContentAsInteger: Integer; result := FValue.AsInteger; end; +function TBAValueSet.GetFreeStandingClass: TBoldFreeStandingElementClass; +begin + result := TBFSInteger; +end; + procedure TBAValueSet.SetContentAsInteger(NewValue: Integer); begin SetContent(Values.FindByInteger(NewValue)); @@ -2968,7 +4123,7 @@ procedure TBAValueSet_Proxy.SetContentAsInteger(NewValue: Integer); ProxedValueSet.ContentAsInteger:= NewValue; end; -procedure TBAValueSet.AssignContentValue(Source: IBoldValue); +procedure TBAValueSet.AssignContentValue(const Source: IBoldValue); var s: IBoldIntegerContent; begin @@ -2984,31 +4139,34 @@ procedure TBAValueSet.AssignContentValue(Source: IBoldValue); SetContent(Values.FindByInteger(s.AsInteger)) end else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, Meth_AssignContentValue]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); end; function TBAValueSet.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; begin if IsEqualGuid(IID, IBoldIntegerContent) or IsEqualGuid(IID, IBoldStringContent) then - Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldString/IntegerContent') // do not localize + Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldString/IntegerContent') else result := inherited ProxyInterface(IID, Mode, Obj); end; -function TBAValueSet.ProxyClass: TBoldMember_ProxyClass; +function TBAValueSet.GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin - result := TBAValueSet_Proxy; + result := TBAValueSet_Proxy.MakeProxy(self, mode); end; procedure TBAValueSet.SetEmptyValue; begin if Values.Count > 0 then - AsInteger := Values[0].AsInteger + begin + if AsInteger <> Values.GetFirstValue.AsInteger then + AsInteger := Values.GetFirstValue.AsInteger + end else if not assigned(BoldAttributeRTInfo) or BoldAttributeRTInfo.AllowNull then SetToNull else - raise EBold.CreateFmt(sNoLegalValuesAvailable, [classname, '']); //FIXME: Missing parameter + raise EBold.CreateFmt('%s.SetEmptyValue: There are no legal values, and null is not allowed for this attribute (%s)', [classname, '']); end; procedure TBAValueSet.CheckIllegalValue; @@ -3016,9 +4174,9 @@ procedure TBAValueSet.CheckIllegalValue; if not IsNull and not Assigned(FValue) then begin if BoldPersistenceState = bvpsCurrent then - raise EBold.Create(sBadDataInDB) + raise EBold.Create('Illegal value in valueset. Bad data in database?') else - raise EBold.Create(sCannotRead) + raise EBold.Create('Illegal value in valueset. Cannot read.') end; end; @@ -3029,12 +4187,25 @@ function TBAValueSet.CompareToEnumLiteral(const str: String): Boolean; BoldExpandName(AsString, '', xtExpression, -1, nccTrue)) end; +procedure TBAValueSet.FreeContent; +begin + inherited; + if Values.Count > 0 then + fValue := Values.GetFirstValue; +end; + { TBABoolean } +constructor TBABoolean.CreateWithValue(Value: Boolean); +begin + inherited Create; + AsBoolean := Value; +end; + function TBABoolean.GetAsBoolean: Boolean; begin BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, 'GetAsBoolean', ''); // do not localize + BoldRaiseLastFailure(self, 'GetAsBoolean', ''); EnsureNotNull; {ensures current} Result := Boolean(GetContentAsInteger); end; @@ -3044,127 +4215,182 @@ procedure TBABoolean.SetAsBoolean(Value: Boolean); SetAsInteger(Integer(Value)); end; -function TBABoolean.GetValues: TBAValueSetValueList; +class function TBABoolean.GetValues: TBAValueSetValueList; begin if not Assigned(_BooleanValues) then begin _BooleanValues := TBAValueSetValueList.Create; + //representation 1 2 3 + //--------------------------------------------- _BooleanValues.Add(Ord(False), ['N', 'F', 'False']); // do not localize _BooleanValues.Add(Ord(True), ['Y', 'T', 'True']); // do not localize +{ + _BooleanValues.Add(Ord(False), ['F', 'F', 'False']); + _BooleanValues.Add(Ord(False), ['False','F', 'False']); + _BooleanValues.Add(Ord(False), ['N', 'F', 'False']); + _BooleanValues.Add(Ord(True), ['T', 'T', 'True']); + _BooleanValues.Add(Ord(True), ['True', 'T', 'True']); + _BooleanValues.Add(Ord(True), ['Y', 'T', 'True']); +} end; Result := _BooleanValues; end; +function TBABoolean.IsEqualToValue(const Value: IBoldValue): Boolean; +var + vBoolean: IBoldBooleanContent; +begin + Assert(Assigned(Value), ClassName + '.IsEqualToValue: Value can not be nil.'); + if Value.QueryInterface(IBoldBooleanContent, vBoolean) = S_OK then + begin + if IsNull and vBoolean.IsNull then + result := true + else + if IsNull or vBoolean.IsNull then + result := false + else + result := Self.AsBoolean = vBoolean.asBoolean; + end + else + result := inherited IsEqualToValue(Value); +end; + +function TBABoolean.IsVariantTypeCompatible(const Value: Variant): Boolean; +begin + result := (VarType(Value) in [varBoolean]); +end; + function TBAInteger.GetAsVariant: Variant; begin - Result := AsInteger; + if IsNull then + Result := Null + else + Result := AsInteger; +end; + +function TBAInteger.GetFreeStandingClass: TBoldFreeStandingElementClass; +begin + result := TBFSInteger; end; procedure TBAInteger.SetAsVariant(const Value: Variant); begin - AsInteger := Value; + if IsVariantTypeCompatible(Value) then + AsInteger := Value + else + inherited SetAsVariant(Value); end; function TBAFloat.GetAsVariant: Variant; begin - Result := AsFloat; + if IsNull then + Result := Null + else + Result := AsFloat; +end; + +function TBAFloat.GetFreeStandingClass: TBoldFreeStandingElementClass; +begin + result := TBFSFloat; end; procedure TBAFloat.SetAsVariant(const Value: Variant); begin - AsFloat := Value; + if IsVariantTypeCompatible(Value) then + AsFloat := Value + else + inherited SetAsVariant(Value); end; function TBACurrency.GetAsVariant: Variant; begin - Result := AsCurrency; + if IsNull then + Result := Null + else + Result := AsCurrency; end; -procedure TBACurrency.SetAsVariant(const Value: Variant); +function TBACurrency.GetFreeStandingClass: TBoldFreeStandingElementClass; begin - AsCurrency := Value; + result := TBFSCurrency; end; -function TBABlob.GetAsVariant: Variant; -var - P: Pointer; - Data: string; - Size: Integer; +procedure TBACurrency.SetAsVariant(const Value: Variant); begin - // return byte array - Data := GetAsBlob; - Size := Length(Data); - if Size > 0 then - begin - Result := VarArrayCreate([0, Size], varByte); - P := VarArrayLock(Result); - try - Move(Pointer(Data)^, P^, Size); - finally - VarArrayUnlock(Result); - end; - end + if IsVariantTypeCompatible(Value) then + AsCurrency := Value else - Result := Null; + inherited SetAsVariant(Value); end; -procedure TBABlob.SetAsVariant(const Value: Variant); -var - P: Pointer; - Data: string; - Size: Integer; +function TBAMoment.GetAsVariant: Variant; begin - if VarIsArray(Value) and ((VarType(Value) and varTypeMask) = varByte) and - (VarArrayDimCount(Value) = 1) then - begin - Size := VarArrayHighBound(Value, 1); - SetLength(Data, Size); - P := VarArrayLock(Value); - try - Move(P^, Pointer(Data)^, Size); - finally - VarArrayUnlock(Value); - end; - SetAsBlob(Data); - end - else if VarIsNull(Value) then - begin - SetAsBlob(''); - end + if IsNull then + Result := Null else - begin - SetAsBlob(Value); - end; + Result := GetAsDateTime; end; -function TBAMoment.GetAsVariant: Variant; +function TBAMoment.GetAttributeTypeInfoForType: TBoldElementTypeInfo; begin - Result := GetAsDateTime; + if not Assigned(AttributeTypeInfo) then + begin + AttributeTypeInfo := inherited GetAttributeTypeInfoForType; + SubscribeToSystem; + end; + result := AttributeTypeInfo; end; procedure TBAMoment.SetAsVariant(const Value: Variant); begin - SetAsDateTime(Value); + if IsVariantTypeCompatible(Value) then + SetAsDateTime(Value) + else + inherited SetAsVariant(Value); end; function TBAValueSet.GetAsVariant: Variant; begin - Result := AsInteger; + if IsNull then + Result := Null + else + Result := AsString; +end; + +function TBAValueSet.GetAttributeTypeInfoForType: TBoldElementTypeInfo; +begin + if not Assigned(AttributeTypeInfo) then + begin + AttributeTypeInfo := inherited GetAttributeTypeInfoForType; + SubscribeToSystem; + end; + result := AttributeTypeInfo; end; procedure TBAValueSet.SetAsVariant(const Value: Variant); begin - AsInteger := Value; + AsString := Value; end; function TBABoolean.GetAsVariant: Variant; begin - Result := AsBoolean; + if IsNull then + Result := Null + else + Result := AsBoolean; +end; + +function TBABoolean.GetFreeStandingClass: TBoldFreeStandingElementClass; +begin + result := TBFSBoolean; end; procedure TBABoolean.SetAsVariant(const Value: Variant); begin - AsBoolean := Value; + if IsVariantTypeCompatible(Value) then + AsBoolean := Value + else + inherited SetAsVariant(Value); end; function TBAValueSetValueList.GetCount: integer; @@ -3183,24 +4409,36 @@ function TBAValueSetValue.GetBoldType: TBoldElementTypeInfo; result := nil; end; -procedure TBADate.AssignValue(Source: IBoldValue); +procedure TBADate.AssignValue(const Source: IBoldValue); var s: IBoldDateContent; begin if source.QueryInterface(IBoldDateContent, S) = S_OK then SetDataValue(s.AsDate) else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, Meth_AssignValue]); + raise EBold.CreateFmt('%s.AssignValue: unknown type of source', [classname]); +end; + +constructor TBADate.CreateWithValue(Value: TDateTime); +begin + inherited Create; + asDate := Value; end; -procedure TBATime.AssignValue(Source: IBoldValue); +procedure TBATime.AssignValue(const Source: IBoldValue); var s: IBoldTimeContent; begin if source.QueryInterface(IBoldTimeContent, S) = S_OK then SetDataValue(s.AsTime) else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, Meth_AssignValue]); + raise EBold.CreateFmt('%s.AssignValue: unknown type of source', [classname]); +end; + +constructor TBATime.CreateWithValue(Value: TDateTime); +begin + inherited Create; + AsTime := Value; end; function TBABoolean_Proxy.GetContentAsBoolean: Boolean; @@ -3213,45 +4451,45 @@ procedure TBABoolean_Proxy.SetContentAsBoolean(NewValue: Boolean); SetContentAsInteger(Integer(NewValue)); end; -procedure TBADate.AssignContentValue(Source: IBoldValue); +procedure TBADate.AssignContentValue(const Source: IBoldValue); var s: IBoldDateContent; begin if not assigned(source) and CanSetToNull(nil) then SetContentToNull else if not assigned(source) then - SetContent(0) + SetDateTimeContent(0) else if source.QueryInterface(IBoldDateContent, S) = S_OK then begin if s.IsNull then SetContentToNull else - SetContent(s.AsDate) + SetDateTimeContent(s.AsDate) end else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, Meth_AssignContentValue]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); end; -procedure TBATime.AssignContentValue(Source: IBoldValue); +procedure TBATime.AssignContentValue(const Source: IBoldValue); var s: IBoldTimeContent; begin if not assigned(source) and CanSetToNull(nil) then SetContentToNull else if not assigned(source) then - SetContent(0) + SetDateTimeContent(0) else if source.QueryInterface(IBoldTimeContent, S) = S_OK then begin if s.IsNull then SetContentToNull else - SetContent(s.AsTime) + SetDateTimeContent(s.AsTime) end else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, Meth_AssignContentValue]); + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); end; -procedure TBABoolean.AssignContentValue(Source: IBoldValue); +procedure TBABoolean.AssignContentValue(const Source: IBoldValue); var s: IBoldBooleanContent; begin @@ -3273,16 +4511,17 @@ procedure TBABoolean.AssignContentValue(Source: IBoldValue); function TBABoolean.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; begin if IsEqualGuid(IID, IBoldBooleanContent) then - Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldBooleanContent') // do not localize + Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldBooleanContent') else result := inherited ProxyInterface(IID, Mode, Obj); end; -function TBABoolean.ProxyClass: TBoldMember_ProxyClass; +function TBABoolean.GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin - result := TBABoolean_Proxy; + result := TBABoolean_Proxy.MakeProxy(self, mode); end; + { TBAConstraint } procedure TBAConstraint.DefaultSubscribe(Subscriber: TBoldSubscriber; RequestedEvent: TBoldEvent = breReEvaluate); @@ -3312,7 +4551,7 @@ procedure TBAConstraint.CalculateConstraint; asBoolean := false; end; -destructor TBAConstraint.Destroy; +destructor TBAConstraint.destroy; begin FreeAndNil(fElementSubscriber); inherited; @@ -3331,7 +4570,21 @@ function TBAConstraint.GetStringRepresentation(Representation: TBoldRepresentati 10: if assigned(constraint) then result := Constraint.ModelName; 11: if assigned(constraint) then - result := Constraint.ConstraintMessage; + begin + {$IFDEF OCLConstraintMessages} + if (OwningElement is TBoldDomainElement) then + begin + if Assigned(OwningElement.Evaluator.ExpressionType(Constraint.ConstraintMessage, OwningElement.BoldType, false)) then + result := TBoldDomainElement(OwningElement).EvaluateExpressionAsString(Constraint.ConstraintMessage, brDefault) + else + result := Constraint.ConstraintMessage; + end + else + {$ENDIF} + begin + result := Constraint.ConstraintMessage; + end; + end; 12: if assigned(constraint) then result := Constraint.ConstraintExpression; 13: if Owningelement is TBoldDomainElement then @@ -3343,9 +4596,16 @@ function TBAConstraint.GetStringRepresentation(Representation: TBoldRepresentati end; end; -procedure TBAConstraint.Initialize(Constraint: TBoldConstraintRTInfo; OwningElement: TBoldElement); +procedure TBAConstraint.InitializeConstraint(Constraint: TBoldConstraintRTInfo; OwningElement: TBoldElement); var ResType: TBoldElementTypeInfo; +const + sInvalidConstraint = 'Invalid Constraint: %s %s%s'; + sInvalidConstraintMessage = 'Invalid Constraint message: %s %s%s'; + sUnknownConstraintType = 'unknown type of constraint expression: %s (in context: %s)'; + sUnknownConstraintMessageType = 'unknown type of constraint message: %s (in context: %s)'; + sConstraintNotBoolean = 'Constraint is not Boolean: %s (in context %s)'; + sConstraintMessageString = 'Constraint message is not String: %s (in context %s)'; begin fOwningElement := OwningElement; if assigned(fOwningElement) then @@ -3357,18 +4617,38 @@ procedure TBAConstraint.Initialize(Constraint: TBoldConstraintRTInfo; OwningElem resType := Owningelement.Evaluator.ExpressionType(Constraint.ConstraintExpression, OwningElement.BoldType, true); except on e: Exception do - raise EBold.CreateFmt(sInvalidConstraint, [Constraint.ConstraintExpression, BOLDCRLF, e.message]); + raise EBold.CreateFmt('Invalid Constraint: %s ' + BOLDCRLF + '%s', [Constraint.ConstraintExpression, e.message]); end; if not assigned(ResType) then - raise EBold.CreateFmt(sUnknownConstraintType, [Constraint.ConstraintExpression, OwningElement.BoldType.AsString]); + raise EBold.CreateFmt('unknown type of constraint expression: %s (in context: %s)', [Constraint.ConstraintExpression, OwningElement.BoldType.AsString]); if not ResType.ConformsTo((BoldType.SystemTypeInfo as TboldSystemTypeInfo).AttributeTypeInfoByDelphiName[TBABoolean.ClassName]) then - raise EBold.CreateFmt(sConstraintNotBoolean, [Constraint.ConstraintExpression, OwningElement.BoldType.AsString]); + raise EBold.CreateFmt('Constraint is not Boolean: %s (in context %s)', [Constraint.ConstraintExpression, OwningElement.BoldType.AsString]); + + {$IFDEF OCLConstraintMessages} + if Constraint.ConstraintMessage <> '' then + begin + try + resType := Owningelement.Evaluator.ExpressionType(Constraint.ConstraintMessage, OwningElement.BoldType, false); + if not Assigned(resType) then + resType := Owningelement.Evaluator.ExpressionType(QuotedStr(Constraint.ConstraintMessage), OwningElement.BoldType, false); + except + on e: Exception do + raise EBold.CreateFmt(sInvalidConstraintMessage, [Constraint.ConstraintMessage, TBoldDomainElement(OwningElement).DisplayName, e.message]); + end; + + if not assigned(ResType) then + raise EBold.CreateFmt(sUnknownConstraintMessageType, [Constraint.ConstraintMessage, OwningElement.BoldType.AsString]); + + if not ResType.ConformsTo((BoldType.SystemTypeInfo as TboldSystemTypeInfo).AttributeTypeInfoByDelphiName[TBAString.ClassName]) then + raise EBold.CreateFmt(sConstraintMessageString, [Constraint.ConstraintMessage, OwningElement.BoldType.AsString]); + end; + {$ENDIF} end; end; -procedure TBAConstraint.InitializeMember(OwningElement: TBoldDomainElement; ElementTypeInfo: TBoldElementTypeInfo); +procedure TBAConstraint.Initialize; begin inherited; fElementSubscriber := TBoldPassthroughSubscriber.Create(Receive); @@ -3389,7 +4669,16 @@ procedure TBAConstraint.SubscribeToStringRepresentation( RequestedEvent: TBoldEvent = breReEvaluate); begin case Representation of - 10..13: ; // do nothing, static values... + 10: ; // do nothing, static values... + 11: + {$IFDEF OCLConstraintMessages} + if assigned(OwningElement) and (Constraint.ConstraintMessage <> '') then + begin + if Assigned(OwningElement.Evaluator.ExpressionType(Constraint.ConstraintMessage, OwningElement.BoldType, false)) then + OwningElement.SubscribeToExpression(Constraint.ConstraintMessage, Subscriber, RequestedEvent = breReSubscribe); + end + {$ENDIF}; + 12..13: ; // do nothing, static values... 14: if assigned(OwningElement) then OwningElement.SubscribeToStringRepresentation(brDefault, Subscriber, RequestedEvent); else inherited; @@ -3400,49 +4689,71 @@ procedure TBAConstraint.Assign(Source: TBoldElement); begin inherited; if Source is TBAConstraint then - Initialize(TBAConstraint(Source).Constraint, TBAConstraint(Source).OwningElement); + InitializeConstraint(TBAConstraint(Source).Constraint, TBAConstraint(Source).OwningElement); end; { TBAString_Proxy } function TBAString_Proxy.GetProxedString: TBAString; begin - result := ProxedElement as TBAString; + result := ProxedMember as TBAString; +end; + +class function TBAString_Proxy.MakeProxy(ProxedMember: TBoldMember; + Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; +begin + Result := fLastUsed[Mode]; + // Reuse proxy if we hold only reference + if Assigned(Result) and (Result.RefCount =1) then + begin + Result.Retarget(ProxedMember, Mode); + end + else + begin + Result := Create(ProxedMember, Mode); + fLastUsed[Mode] := Result; + fLastUsedAsInterface[Mode] := Result; // Inc refcount + end; end; { TBAInteger_Proxy } function TBAInteger_Proxy.GetProxedInteger: TBAInteger; begin - result := ProxedElement as TBAInteger; + result := ProxedMember as TBAInteger; end; { TBAFloat_Proxy } function TBAFloat_Proxy.GetProxedFloat: TBAFloat; begin - result := ProxedElement as TBAFloat; + result := ProxedMember as TBAFloat; end; { TBACurrency_Proxy } function TBACurrency_Proxy.GetProxedCurrency: TBACurrency; begin - result := ProxedElement as TBACurrency; + result := ProxedMember as TBACurrency; end; { TBABlob_Proxy } function TBABlob_Proxy.GetProxedBlob: TBABlob; begin - result := ProxedElement as TBABlob; + result := ProxedMember as TBABlob; +end; + +function TBABlob_Proxy.SupressEvents: Boolean; +begin + result := ProxedBlob.SupressEvents; end; { TBAValueSet_Proxy } function TBAValueSet_Proxy.GetProxedvalueSet: TBAValueSet; begin - result := ProxedElement as TBAValueSet; + result := ProxedMember as TBAValueSet; end; { TBABoolean_Proxy } @@ -3450,7 +4761,7 @@ function TBAValueSet_Proxy.GetProxedvalueSet: TBAValueSet; function TBADate.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; begin if IsEqualGuid(IID, IBoldDateContent) then - Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldDateContent') // do not localize + Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldDateContent') else result := inherited ProxyInterface(IID, Mode, Obj); end; @@ -3458,19 +4769,24 @@ function TBADate.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyM function TBATime.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; begin if IsEqualGuid(IID, IBoldTimeContent) then - Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldTimeContent') // do not localize + Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldTimeContent') else result := inherited ProxyInterface(IId, Mode, Obj); end; -function TBADate.ProxyClass: TBoldMember_ProxyClass; +function TBADate.GetFreeStandingClass: TBoldFreeStandingElementClass; +begin + result := TBFSDate; +end; + +function TBADate.GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin - result := TBADate_Proxy; + result := TBADate_Proxy.MakeProxy(self, mode); end; -function TBATime.ProxyClass: TBoldMember_ProxyClass; +function TBATime.GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin - result := TBATime_Proxy; + result := TBATime_Proxy.MakeProxy(self, mode); end; { TBATypedBlob_Proxy } @@ -3482,7 +4798,7 @@ function TBATypedBlob_Proxy.GetContentTypeContent: String; function TBATypedBlob_Proxy.GetProxedTypedBlob: TBATypedBlob; begin - result := ProxedElement as TBATypedBlob; + result := ProxedMember as TBATypedBlob; end; procedure TBATypedBlob_Proxy.SetContentTypeContent(const NewValue: String); @@ -3492,7 +4808,7 @@ procedure TBATypedBlob_Proxy.SetContentTypeContent(const NewValue: String); function TBAMoment_Proxy.GetProxedMoment: TBAMoment; begin - result := ProxedElement as TBAMoment; + result := ProxedMember as TBAMoment; end; function TBATime.GetAsSeconds: cardinal; @@ -3500,11 +4816,20 @@ function TBATime.GetAsSeconds: cardinal; Result := Seconds + (Minutes * 60) + (Hours * 3600); end; +function TBATime.GetFreeStandingClass: TBoldFreeStandingElementClass; +begin + result := TBFSTime; +end; + initialization with BoldMemberTypes do begin AddMemberTypeDescriptor(TBoldAttribute, alAbstract); AddMemberTypeDescriptor(TBAString, alConcrete); + AddMemberTypeDescriptor(TBAAnsiString, alConcrete); + AddMemberTypeDescriptor(TBAUnicodeString, alConcrete); + AddMemberTypeDescriptor(TBAText, alConcrete); + AddMemberTypeDescriptor(TBAUnicodeText, alConcrete); AddMemberTypeDescriptor(TBATrimmedString, alConcrete); AddMemberTypeDescriptor(TBANumeric, alAbstract); AddMemberTypeDescriptor(TBAInteger, alConcrete); @@ -3528,12 +4853,17 @@ initialization end; finalization - FreeAndNil(_BooleanValues); + FreeAndNil(TBABoolean._BooleanValues); + FreeAndNil(_SystemSubscriber); if BoldMemberTypesAssigned then with BoldMemberTypes do begin RemoveDescriptorByClass(TBoldAttribute); RemoveDescriptorByClass(TBAString); + RemoveDescriptorByClass(TBAAnsiString); + RemoveDescriptorByClass(TBAUnicodeString); + RemoveDescriptorByClass(TBAText); + RemoveDescriptorByClass(TBAUnicodeText); RemoveDescriptorByClass(TBATrimmedString); RemoveDescriptorByClass(TBANumeric); RemoveDescriptorByClass(TBAInteger); @@ -3557,4 +4887,3 @@ finalization end; end. - diff --git a/Source/ObjectSpace/BORepresentation/BoldDerivedValueSet.pas b/Source/ObjectSpace/BORepresentation/BoldDerivedValueSet.pas index 56475a1c..5509b609 100644 --- a/Source/ObjectSpace/BORepresentation/BoldDerivedValueSet.pas +++ b/Source/ObjectSpace/BORepresentation/BoldDerivedValueSet.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDerivedValueSet; interface @@ -23,7 +26,6 @@ implementation uses SysUtils, BoldDefs, - BoldCoreConsts, BoldSystemRT; procedure TBADerivedValueSetValueList.AddMembers(Int: Integer; Members: Array of TBoldMember); @@ -51,13 +53,13 @@ constructor TBADerivedValueSetValueList.create(System: TBoldSystem; ClassToFollo ClassTypeInfo := System.BoldSystemTypeInfo.ClassTypeInfoByExpressionName[ClassToFollow]; if not assigned(ClassTypeInfo) then - raise Ebold.createFmt(sNoClassCalledX, [ClassName, ClassToFollow]); + raise Ebold.createFmt('%s.create: No class called %s', [ClassName, ClassToFollow]); RTAttr := ClassTypeInfo.MemberRTInfoByExpressionName[IntValueAttribute]; if not assigned(RTAttr) then - raise Ebold.createFmt(sNoAttributeCalledX, [ClassName, ClassToFollow, IntValueAttribute]); + raise Ebold.createFmt('%s.create: No attribute called %s.%s', [ClassName, ClassToFollow, IntValueAttribute]); if not RTAttr.MemberClass.InheritsFrom(TBAInteger) then - raise Ebold.createFmt(sXIsNotAnInteger, [ClassName, ClassToFollow, IntValueAttribute]); + raise Ebold.createFmt('%s.create: %s.%s is not an integer', [ClassName, ClassToFollow, IntValueAttribute]); IntIndex := RTAttr.Index; @@ -68,16 +70,16 @@ constructor TBADerivedValueSetValueList.create(System: TBoldSystem; ClassToFollo begin RTAttr := ClassTypeInfo.MemberRTInfoByExpressionName[StrValueAttributes[i]]; if not assigned(RTAttr) then - raise Ebold.createFmt(sNoAttributeCalledX, [ClassName, ClassToFollow, StrValueAttributes[i]]); + raise Ebold.createFmt('%s.create: No attribute called %s.%s', [ClassName, ClassToFollow, StrValueAttributes[i]]); if not RTAttr.MemberClass.InheritsFrom(TBoldAttribute) then - raise Ebold.createFmt(sXIsNotAnAttribute, [ClassName, ClassToFollow, StrValueAttributes[i]]); + raise Ebold.createFmt('%s.create: %s.%s is not an Attribute', [ClassName, ClassToFollow, StrValueAttributes[i]]); IndexArr[i] := RTAttr.Index; end; ObjectList := System.Classes[ClassTypeInfo.TopSortedIndex]; if objectlist.count = 0 then - raise EBold.CreateFmt(sNoValuesInValueSetList, [Classname, ClassTypeInfo.ExpressionName]); + raise EBold.CreateFmt('%s.Create: No values in valuesetlist: %s', [Classname, ClassTypeInfo.ExpressionName]); for i := 0 to ObjectList.count - 1 do begin for j := 0 to High(StrValueAttributes) do @@ -86,4 +88,6 @@ constructor TBADerivedValueSetValueList.create(System: TBoldSystem; ClassToFollo end; end; +initialization + end. diff --git a/Source/ObjectSpace/BORepresentation/BoldDomainElement.pas b/Source/ObjectSpace/BORepresentation/BoldDomainElement.pas index 15ed0dbf..fbd71ef7 100644 --- a/Source/ObjectSpace/BORepresentation/BoldDomainElement.pas +++ b/Source/ObjectSpace/BORepresentation/BoldDomainElement.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDomainElement; interface @@ -11,13 +14,12 @@ interface type {forward declarations of all classes} TBoldDomainElementProxyMode = ( - bdepContents, // actual contents of member -// bDepObjectSpace, // the "fronside" inteferace, not used yet - bdepPMOut, // Interface to Persistence mapper - bdepPMIn, // Interface from Persistence mapper - bdepUnDo, //Interface To/From UnDo-handler - bdepInternalInitialize, // - bdRemove // ... + bdepContents, + bdepPMOut, + bdepPMIn, + bdepUnDo, + bdepInternalInitialize, + bdRemove ); type TBoldDomainElement = class; @@ -31,54 +33,64 @@ TBoldDomainElement = class(TBoldElement) private FOwningElement: TBoldDomainElement; protected - function GetDisplayName: String; virtual; abstract; + function GetDisplayName: String; override; function GetBoldDirty: Boolean; virtual; abstract; function MayCommit: Boolean; virtual; - procedure ReceiveEventFromOwned(Originator: TObject; OriginalEvent: TBoldEvent); virtual; + function GetBoldSystem: TBoldDomainElement; virtual; + procedure ReceiveEventFromOwned(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const); virtual; +{$IFNDEF BOLD_NO_QUERIES} function ReceiveQueryFromOwned(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; virtual; +{$ENDIF} procedure StateError(S: string); virtual; public - constructor Create(OwningElement: TBoldDomainElement); virtual; + constructor CreateWithOwner(OwningElement: TBoldDomainElement); virtual; function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; virtual; + procedure Discard; virtual; abstract; + procedure Invalidate; virtual; function CanCommit: Boolean; procedure SendEvent(OriginalEvent: TBoldEvent); override; procedure SendExtendedEvent(OriginalEvent: TBoldEvent; const Args: array of const); override; - function SendQuery(OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; override; +{$IFNDEF BOLD_NO_QUERIES} + function SendQuery(OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber; Originator: TObject = nil): Boolean; override; +{$ENDIF} property BoldDirty: Boolean read GetBoldDirty; property BoldPersistent: Boolean index befPersistent read GetElementFlag; property OwningElement: TBoldDomainElement read FOwningElement; - property DisplayName: String read GetDisplayName; + property BoldSystem: TBoldDomainElement read GetBoldSystem; end; { TBoldDomainElement_Proxy } TBoldDomainElement_Proxy = class(TBoldRefCountedObject) private fMode: TBoldDomainElementProxyMode; - fProxedElement: TBoldDomainElement; protected procedure UnsupportedMode(Mode: TBoldDomainElementProxyMode; Func: string); + procedure Retarget(Mode: TBoldDomainElementProxyMode); {$IFDEF BOLD_INLINE} inline; {$ENDIF} public - constructor Create(ProxedElement: TBoldDomainElement; Mode: TBoldDomainElementProxyMode); - property ProxedElement: TBoldDomainElement read fProxedElement; + constructor Create(Mode: TBoldDomainElementProxyMode); property Mode: TBoldDomainElementProxyMode read fMode; end; { TBoldDomainElementCollectionTraverser } TBoldDomainElementCollectionTraverser = class(TBoldIndexableListTraverser) private - function GetItem: TBoldDomainElement; + function GetItem: TBoldDomainElement; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public property Item: TBoldDomainElement read GetItem; + property Current: TBoldDomainElement read GetItem; end; { TBoldDomainElementCollection } TBoldDomainElementCollection = class(TBoldUnorderedIndexableList) + private + class var IX_DomainElementCollection: integer; protected function TraverserClass: TBoldIndexableListTraverserClass; override; public - constructor create; - procedure Add(item: TBoldDomainElement); - function Includes(item: TBoldDomainElement): Boolean; + constructor Create; + function GetEnumerator: TBoldDomainElementCollectionTraverser; + procedure Add(item: TBoldDomainElement); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function Includes(item: TBoldDomainElement): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function CreateTraverser: TBoldDomainElementCollectionTraverser; end; @@ -90,13 +102,10 @@ implementation BoldIndex, BoldHashIndexes; -var - IX_DomainElementCollection: integer = -1; - type TBoldDomainElementCollectionIndex = class(TBoldObjectHashIndex) protected - function ItemAsKeyObject(Item: TObject): TObject; override; + function ItemASKeyObject(Item: TObject): TObject; override; end; { TBoldDomainElement } @@ -109,7 +118,7 @@ procedure TBoldDomainElement.StateError(S: string); if Assigned(Self) then MyClassName := ClassName else - MyClassName := ''; // do not localize + MyClassName := ''; if Assigned(Self) and Assigned(OwningElement) then MyOwnerClassname := OwningElement.ClassName + '.' else @@ -140,52 +149,73 @@ procedure TBoldDomainElement.SetBoldPersistent(Value: Boolean); end; *) -constructor TBoldDomainElement.Create(OwningElement: TBoldDomainElement); +constructor TBoldDomainElement.CreateWithOwner(OwningElement: TBoldDomainElement); begin - inherited Create; FOwningElement := OwningElement; end; +function TBoldDomainElement.GetBoldSystem: TBoldDomainElement; +begin + result := nil; + if Assigned(OwningElement) then + result := OwningElement.BoldSystem + else + if self.ClassName = 'TBoldSystem' then + result := self; +end; + +function TBoldDomainElement.GetDisplayName: String; +begin + result := Inherited GetDisplayName; + if Assigned(OwningElement) then + result := OwningElement.DisplayName + '.' + result; +end; + procedure TBoldDomainElement.SendEvent(OriginalEvent: TBoldEvent); begin if Assigned(OwningElement) then - OwningElement.ReceiveEventFromOwned(self, OriginalEvent); - inherited; // SendEvent(Originator, OriginalEvent); + OwningElement.ReceiveEventFromOwned(self, OriginalEvent, []); + inherited; end; +{$IFNDEF BOLD_NO_QUERIES} function TBoldDomainElement.SendQuery( OriginalEvent: TBoldEvent; const Args: array of const; - Subscriber: TBoldSubscriber): Boolean; + Subscriber: TBoldSubscriber; Originator: TObject = nil): Boolean; begin result := True; if Assigned(OwningElement) then - result := OwningElement.ReceiveQueryFromOwned(self, OriginalEvent, Args, Subscriber); - if result then - result := inherited SendQuery(OriginalEvent, Args, Subscriber); + result := OwningElement.ReceiveQueryFromOwned(Originator, OriginalEvent, Args, Subscriber); + result := result and inherited SendQuery(OriginalEvent, Args, Subscriber, Originator); end; +{$ENDIF} -procedure TBoldDomainElement.ReceiveEventFromOwned(Originator: TObject; OriginalEvent: TBoldEvent); +procedure TBoldDomainElement.ReceiveEventFromOwned(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const); begin - // Intentionally left blank end; +{$IFNDEF BOLD_NO_QUERIES} function TBoldDomainElement.ReceiveQueryFromOwned(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; begin result := True; end; +{$ENDIF} procedure TBoldDomainElement.SendExtendedEvent(OriginalEvent: TBoldEvent; const Args: array of const); begin if Assigned(OwningElement) then - OwningElement.ReceiveEventFromOwned(self, OriginalEvent); + OwningElement.ReceiveEventFromOwned(self, OriginalEvent, Args); inherited; end; function TBoldDomainElement.CanCommit: Boolean; begin - result := MayCommit and SendQuery(bqMayCommit, [], nil); + result := MayCommit; +{$IFNDEF BOLD_NO_QUERIES} + result := result and SendQuery(bqMayCommit, [], nil); +{$ENDIF} end; function TBoldDomainElement.MayCommit: Boolean; @@ -198,12 +228,21 @@ function TBoldDomainElement.ProxyInterface(const IId: TGUID; Mode: TBoldDomainEl result := false; end; +procedure TBoldDomainElement.Invalidate; +begin +// do nothing +end; + { TBoldDomainElement_Proxy } -constructor TBoldDomainElement_Proxy.Create(ProxedElement: TBoldDomainElement; Mode: TBoldDomainElementProxyMode); +constructor TBoldDomainElement_Proxy.Create(Mode: TBoldDomainElementProxyMode); begin inherited create; - fProxedElement := ProxedElement; + fMode := Mode; +end; + +procedure TBoldDomainElement_Proxy.Retarget(Mode: TBoldDomainElementProxyMode); +begin fMode := Mode; end; @@ -219,7 +258,7 @@ procedure TBoldDomainElementCollection.Add(item: TBoldDomainElement); inherited Add(item); end; -constructor TBoldDomainElementCollection.create; +constructor TBoldDomainElementCollection.Create; begin inherited create; OwnsEntries := false; @@ -228,14 +267,17 @@ constructor TBoldDomainElementCollection.create; function TBoldDomainElementCollection.CreateTraverser: TBoldDomainElementCollectionTraverser; begin - result := TBoldDomainElementCollectionTraverser(inherited CreateTraverser); - Assert(Result is TBoldDomainElementCollectionTraverser); + result := inherited CreateTraverser as TBoldDomainElementCollectionTraverser; +end; + +function TBoldDomainElementCollection.GetEnumerator: TBoldDomainElementCollectionTraverser; +begin + result := CreateTraverser; end; function TBoldDomainElementCollection.Includes(item: TBoldDomainElement): Boolean; begin - Assert((Indexes[IX_DomainElementCollection] is TBoldDomainElementCollectionIndex)); - result := assigned(TBoldDomainElementCollectionIndex(Indexes[IX_DomainElementCollection]).FindByObject(Item)); + result := assigned(TBoldObjectHashIndex(Indexes[IX_DomainElementCollection]).FindByObject(Item)); end; function TBoldDomainElementCollectionIndex.ItemASKeyObject(Item: TObject): TObject; @@ -252,8 +294,11 @@ function TBoldDomainElementCollection.TraverserClass: TBoldIndexableListTraverse function TBoldDomainElementCollectionTraverser.GetItem: TBoldDomainElement; begin - Assert((inherited item) is TBoldDomainElement); result := TBoldDomainElement(inherited item); + Assert(result is TBoldDomainElement); end; +initialization + TBoldDomainElementCollection.IX_DomainElementCollection := -1; + end. diff --git a/Source/ObjectSpace/BORepresentation/BoldElementList.pas b/Source/ObjectSpace/BORepresentation/BoldElementList.pas index 1764518d..21dfe937 100644 --- a/Source/ObjectSpace/BORepresentation/BoldElementList.pas +++ b/Source/ObjectSpace/BORepresentation/BoldElementList.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldElementList; interface @@ -22,12 +25,14 @@ TBoldElementList = class(TBoldList) function GetElement(index: Integer): TBoldElement; override; function IncludesElement(Item: TBoldElement): Boolean; override; function IndexOfElement(Item: TBoldElement): Integer; override; - procedure InitializeMember(AOwningElement: TBoldDomainElement; ElementTypeInfo: TBoldElementTypeInfo); override; + procedure Initialize; override; procedure InsertElement(index: Integer; Element: TBoldElement); override; procedure SetElement(index: Integer; Value: TBoldElement); override; function InternalAddNew: TBoldElement; override; function GetCanCreateNew: Boolean; override; - function ProxyClass: TBoldMember_ProxyClass; override; + procedure InternalClear; override; + function GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; + //function ProxyClass: TBoldMember_ProxyClass; override; public procedure Assign(Source: TBoldElement); override; procedure InsertNew(index: Integer); override; @@ -49,7 +54,7 @@ implementation BoldSubscription, BoldSystemRT, BoldIndexableList, - BoldCoreConsts; + BoldRev; type { TBoldIndexableElementList } @@ -67,7 +72,7 @@ TBoldElementListController = class(TBoldListController) property List: TBoldIndexableElementList read fList; function GetStreamName: string; override; public - constructor Create(OwningList: TBoldList); + constructor Create(OwningList: TBoldList); override; destructor Destroy; override; procedure AddElement(Element: TBoldElement); override; function GetElement(index: Integer): TBoldElement; override; @@ -83,16 +88,15 @@ TBoldElementListController = class(TBoldListController) procedure TBoldElementList.AddElement(Element: TBoldElement); begin - if (ListController.IndexOfElement(Element) = -1) or DuplicateControl then + if (DuplicateMode = bldmAllow) or (ListController.IndexOfElement(Element) = -1) or DuplicateControl then begin - listcontroller.AddElement(Element); + ListController.AddElement(Element); Changed(beItemAdded, [Element]); end; end; procedure TBoldElementList.AllocateData; begin - // do nothing end; procedure TBoldElementList.Assign(Source: TBoldElement); @@ -105,7 +109,6 @@ procedure TBoldElementList.Assign(Source: TBoldElement); procedure TBoldElementList.FreeData; begin - // do nothing end; function TBoldElementList.GetCanCreateNew: Boolean; @@ -118,11 +121,25 @@ function TBoldElementList.GetCount: Integer; result := ListController.Count; end; +procedure TBoldElementList.InternalClear; +var + i: integer; +begin + for i := Count - 1 downto 0 do + RemoveByIndex(I); +end; + function TBoldElementList.GetElement(index: Integer): TBoldElement; begin result := ListController.GetElement(index); end; +function TBoldElementList.GetProxy( + Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; +begin + raise EBoldInternal.Create('TBoldElementList.GetProxy called'); +end; + function TBoldElementList.IncludesElement(Item: TBoldElement): Boolean; begin result := ListController.IncludesElement(item); @@ -133,7 +150,7 @@ function TBoldElementList.IndexOfElement(Item: TBoldElement): Integer; result := ListController.IndexOfElement(item); end; -procedure TBoldElementList.InitializeMember(AOwningElement: TBoldDomainElement; ElementTypeInfo: TBoldElementTypeInfo); +procedure TBoldElementList.Initialize; begin ListController := TBoldElementListController.Create(self); DuplicateMode := bldmAllow; @@ -148,12 +165,12 @@ procedure TBoldElementList.InsertElement(index: Integer; procedure TBoldElementList.InsertNew(index: Integer); begin - raise EBold.CreateFmt(sOperationNotAllowed, [className, 'InsertNew']); // do not localize + raise EBold.CreateFmt('%s.InsertNew: This operation is not allowed', [className]); end; function TBoldElementList.InternalAddNew: TBoldElement; begin - raise EBold.CreateFmt(sOperationNotAllowed, [className, 'InternalAddNew']); // do not localize + raise EBold.CreateFmt('%s.InternalAddNew: This operation is not allowed', [className]); end; procedure TBoldElementList.Move(CurIndex, NewIndex: Integer); @@ -161,10 +178,12 @@ procedure TBoldElementList.Move(CurIndex, NewIndex: Integer); ListController.Move(CurIndex, NewIndex); end; +(* function TBoldElementList.ProxyClass: TBoldMember_ProxyClass; begin - raise EBold.CreateFmt(sOperationNotAllowed, [className, 'ProxyClass']); // do not localize + raise EBold.CreateFmt('%s.ProxyClass: This operation is not allowed', [className]); end; +*) procedure TBoldElementList.RemoveByIndex(index: Integer); begin @@ -187,13 +206,14 @@ procedure TBoldElementListController.AddElement(Element: TBoldElement); constructor TBoldElementListController.Create(OwningList: TBoldList); begin + inherited; fList := TBoldIndexableElementList.Create; fList.OwnsEntries := false; end; function TBoldElementListController.CreateNew: TBoldElement; begin - raise EBold.Create(sNotImplemented); + raise EBold.Create('not implemented'); end; destructor TBoldElementListController.Destroy; @@ -214,13 +234,14 @@ function TBoldElementListController.GetCount: Integer; function TBoldElementListController.GetElement(index: Integer): TBoldElement; begin - result := list.Items[index] as TBoldElement; + result := TBoldElement(list.Items[index]); + Assert(result is TBoldElement, result.classname); end; function TBoldElementListController.GetStreamName: string; begin result := ''; - raise EBold.create(sNotImplemented); + raise EBold.create('not implemented'); end; function TBoldElementListController.IncludesElement(Item: TBoldElement): Boolean; @@ -250,7 +271,7 @@ procedure TBoldElementListController.RemoveByIndex(index: Integer); procedure TBoldElementListController.SetElement(index: Integer; Value: TBoldElement); begin - Raise EBold.Create(sCannotSetElementsInTypeLists); + List.Items[index] := Value; end; { TBoldElementListFactory } @@ -261,5 +282,3 @@ class function TBoldElementListFactory.CreateList(aSystem: TBoldSystem): TBoldEl end; end. - - diff --git a/Source/ObjectSpace/BORepresentation/BoldExternalObjectSpaceEventHandler.pas b/Source/ObjectSpace/BORepresentation/BoldExternalObjectSpaceEventHandler.pas index 1ede9016..dadfda3c 100644 --- a/Source/ObjectSpace/BORepresentation/BoldExternalObjectSpaceEventHandler.pas +++ b/Source/ObjectSpace/BORepresentation/BoldExternalObjectSpaceEventHandler.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldExternalObjectSpaceEventHandler; interface @@ -9,50 +12,89 @@ interface BoldSubscription, BoldAbstractDequeuer, BoldDefaultID, - BoldAbstractPropagatorHandle; + BoldAbstractPropagatorHandle, + BoldElementList, + BoldDomainElement, + BoldId, +{$IFDEF UseBoldOSSMessage} + BoldOSSMessage, +{$ENDIF} + BoldDefs; type TBoldClassChangedEvent = procedure (TheClass: TBoldObjectList) of object; TBoldEmbeddedStateChangedEvent = procedure (BoldObject: TBoldObject) of object; TBoldNonEmbeddedStateChangedEvent = procedure (BoldMember: TBoldMember) of object; - TBoldConflictEvent = procedure (BoldObject: TBoldObject) of object; + TBoldConflictEvent = procedure (ABoldElement: TBoldDomainElement) of object; TBoldLockLostEvent = procedure (LockName: String) of object; TBoldDoDisconnectEvent = procedure(aMessage: String; RemainDisconnectedMSec: integer) of object; TBoldExternalObjectSpaceEventHandler = class; - TBoldExternalObjectSpaceEventHandler = class(TBoldAbstractDequeuer) + EOSS = class(EBold) + end; + + EOSSConflict = class(EOSS) + private + FList: TBoldList; + public + constructor Create(AList: TBoldList); + destructor Destroy; override; + property List: TBoldList read FList; + end; + + TIdListArray = array of TBoldObjectIdList; + + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] + TBoldExternalObjectSpaceEventHandler = class(TBoldStringDequeuer) private fBoldSystemHandle: TBoldSystemHandle; fPropagatorHandle: TBoldAbstractPropagatorHandle; fPTSubscriber: TBoldPassthroughSubscriber; + fConflictingElements: TBoldElementList; {*** User events ***} - fOnClassChangedEvent: TBoldClassChangedEvent; - fOnEmbeddedStateChanged: TBoldEmbeddedStateChangedEvent; - fOnNonEmbeddedStateChanged: TBoldNonEmbeddedStateChangedEvent; fOnConflict: TBoldConflictEvent; fOnLockLost: TBoldLockLostEvent; - fOnObjectDeleted: TBoldEmbeddedStateChangedEvent; - fHandleNilObjects: Boolean; fDoDisconnect: TBoldDoDisconnectEvent; {*** End user events ***} + fOnClassChangedEvent: TBoldClassChangedEvent; + fOnEmbeddedStateChanged: TBoldEmbeddedStateChangedEvent; + fOnNonEmbeddedStateChanged: TBoldNonEmbeddedStateChangedEvent; + fOnObjectDeleted: TBoldEmbeddedStateChangedEvent; + fKeepClassesCurrent: boolean; + fObjectFetchArray: TIdListArray; + fIdFetchArray: TIdListArray; + fUseMemberLevelOSS: boolean; procedure SetPropagatorHandle(Value: TBoldAbstractPropagatorHandle); procedure SetBoldSystemHandle(aSystemHandle: TBoldSystemHandle); procedure _Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); function GetObjectByID(ObjectID: TBoldDefaultID): TBoldObject; procedure Subscribe(const DoSubscribe: Boolean); protected - procedure HandleMessage(aMsg: String); override; - procedure ClassChanged(ClassName: String); virtual; - procedure EmbeddedStateOfObjectChanged(ObjectID: TBoldDefaultID); virtual; - procedure NonEmbeddedStateOfObjectChanged(MemberName: String; ObjectID: TBoldDefaultID); virtual; - procedure ObjectDeleted(ObjectId: TBoldDefaultID); virtual; - procedure LockLost(LockName: String); virtual; - procedure Conflict(BoldObject: TBoldObject); + procedure HandleMessage(const aMsg: String); override; +{$IFDEF UseBoldOSSMessage} + procedure HandleObjectMessage(const AOSSMessage: TBoldOssMessage); +{$ENDIF} + procedure ClassChanged(const ClassName: String); virtual; + procedure MemberChanged(const ClassName, MemberName: String; ObjectID: TBoldDefaultID); virtual; + procedure EmbeddedStateOfObjectChanged(const ClassName: String; ObjectID: TBoldDefaultID); virtual; + procedure NonEmbeddedStateOfObjectChanged(const ClassName: String; const MemberName: String; ObjectID: TBoldDefaultID); virtual; + procedure ObjectCreated(const ClassName: String; ObjectId: TBoldDefaultID); virtual; + procedure ObjectDeleted(const ClassName: String;ObjectId: TBoldDefaultID); virtual; + procedure LockLost(const LockName: String); virtual; + procedure Conflict(AElement: TBoldDomainElement); virtual; + procedure ClearFetchList; + procedure FetchObject(ID: TBoldObjectId); + procedure FetchMember(Member: TBoldMember); + procedure FetchId(ID: TBoldObjectId); + procedure FetchLists; procedure Notification(AComponent: TComponent; Operation: TOperation); override; + function GetBoldSystem: TBoldSystem; + property BoldSystem: TBoldSystem read GetBoldSystem; + property ConflictingElements: TBoldElementList read fConflictingElements; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; - property HandleNilObjects: Boolean read fHandleNilObjects write fHandleNilObjects; + procedure DequeueAll; override; published property BoldSystemHandle: TBoldSystemHandle read fBoldSystemHandle write SetBoldSystemHandle; property OnClassChanged: TBoldClassChangedEvent read fOnClassChangedEvent write fOnClassChangedEvent; @@ -63,6 +105,8 @@ TBoldExternalObjectSpaceEventHandler = class(TBoldAbstractDequeuer) property OnConflict: TBoldConflictEvent read fOnConflict write fOnConflict; property OnDoDisconnect: TBoldDoDisconnectEvent read fDoDisconnect write fDoDisconnect; property PropagatorHandle: TBoldAbstractPropagatorHandle read fPropagatorHandle write SetPropagatorHandle; + property KeepClassesCurrent: boolean read fKeepClassesCurrent write fKeepClassesCurrent default true; + property UseMemberLevelOSS: boolean read fUseMemberLevelOSS write fUseMemberLevelOSS; end; implementation @@ -70,10 +114,8 @@ implementation uses SysUtils, BoldObjectSpaceExternalEvents, - BoldDomainElement, BoldValueSpaceInterfaces, - BoldDefs, - BoldCoreConsts; + BoldSystemRT; { TBoldDequeuer } @@ -81,11 +123,25 @@ constructor TBoldExternalObjectSpaceEventHandler.Create(aOwner: TComponent); begin inherited Create(aOwner); fPTSubscriber := TBoldPassthroughSubscriber.Create(_Receive); + fConflictingElements := TBoldElementList.Create; + fKeepClassesCurrent := true; +end; + +procedure TBoldExternalObjectSpaceEventHandler.DequeueAll; +begin + ClearFetchList; + try + inherited DequeueAll; + FetchLists; + finally + ClearFetchList; + end; end; destructor TBoldExternalObjectSpaceEventHandler.Destroy; begin FreeAndNil(fPTSubscriber); + FreeAndNil(fConflictingElements); inherited; end; @@ -106,115 +162,295 @@ procedure TBoldExternalObjectSpaceEventHandler._Receive(Originator: TObject; BoldSystemHandle := nil; end; -procedure TBoldExternalObjectSpaceEventHandler.HandleMessage(aMsg: String); +procedure TBoldExternalObjectSpaceEventHandler.HandleMessage(const aMsg: String); var ClassName, MemberName, LockName: String; SubsType: TBoldObjectSpaceSubscriptionType; - ObjectID: TBoldDefaultID; + ObjectID, ExactId: TBoldDefaultID; temp: string; + vEvents: TStringList; + vEvent: string; + i: integer; begin if not assigned(fBoldSystemHandle) then - raise EBold.CreateFmt(sEventHandlerNotConnected, [self.ClassName, name]); + raise EBold.CreateFmt('%s.HandleMessage: The Eventhandler (%s) is not connected to a systemhandle. Unable to handle messages', [self.ClassName, name]); if not assigned(fBoldSystemHandle.System) then - raise EBold.CreateFmt(sSystemHandleNotActive, [self.ClassName, fBoldSystemHandle.name]); - if pos('DISCONNECT:', aMsg) = 1 then // do not localize - begin - if Assigned(fPropagatorHandle) then - fPropagatorHandle.Connected := false; - if assigned(OnDoDisconnect) then + raise EBold.CreateFmt('%s.HandleMessage: The systemhandle (%s) is not active. Unable to handle messages', [self.ClassName, fBoldSystemHandle.name]); + vEvents := TStringList.Create; + vEvents.CommaText := aMsg; + try + for I := 0 to vEvents.Count - 1 do begin - temp := copy(aMsg, pos(':', aMsg)+1, maxint); - OnDoDisconnect( - copy(temp, pos(':', temp)+1, maxint), - StrToIntDef(copy(temp, 1, pos(':', temp)-1), -1) - ); - end; - end - else - begin - ObjectID := TBoldDefaultID.Create; - try - SubsType := TBoldObjectSpaceExternalEvent.DecodeExternalEvent(aMsg, - ClassName, - MemberName, - LockName, - ObjectID); - case SubsType of - bsClassChanged: ClassChanged(ClassName); - bsEmbeddedStateOfObjectChanged: EmbeddedStateOfObjectChanged(ObjectID); - bsObjectDeleted: ObjectDeleted(ObjectId); - bsNonEmbeddedStateOfObjectChanged: NonEmbeddedStateOfObjectChanged(MemberName, ObjectID); - bsLockLost: LockLost(LockName); + vEvent := Trim(vEvents[i]); + if pos('DISCONNECT:', vEvent) = 1 then + begin + if Assigned(fPropagatorHandle) then + fPropagatorHandle.Connected := false; + if assigned(OnDoDisconnect) then + begin + temp := copy(vEvent, pos(':', vEvent)+1, maxint); + OnDoDisconnect( + copy(temp, pos(':', temp)+1, maxint), + StrToIntDef(copy(temp, 1, pos(':', temp)-1), -1) + ); + end; + end + else + begin + ExactId := nil; + ObjectID := TBoldDefaultID.Create; + try + SubsType := TBoldObjectSpaceExternalEvent.DecodeExternalEvent(vEvent, + ClassName, + MemberName, + LockName, + ObjectID); + if (ClassName <> '') then + ExactId := ObjectID.CloneWithClassId(BoldSystem.BoldSystemTypeInfo.ClassTypeInfoByExpressionName[ClassName].TopSortedIndex, true) as TBoldDefaultID + else + ExactId := ObjectID.Clone as TBoldDefaultId; + case SubsType of + bsClassChanged: ClassChanged(ClassName); + bsMemberChanged: MemberChanged(ClassName, MemberName, ExactId); + bsEmbeddedStateOfObjectChanged: EmbeddedStateOfObjectChanged(ClassName, ExactId); + bsObjectCreated: ObjectCreated(ClassName, ExactId); + bsObjectDeleted: ObjectDeleted(ClassName, ExactId); + bsNonEmbeddedStateOfObjectChanged: NonEmbeddedStateOfObjectChanged(ClassName, MemberName, ExactId); + bsLockLost: LockLost(LockName); + end; + finally + FreeAndNil(ObjectID); + FreeAndNil(ExactId); + end; end; - finally - FreeAndNil(ObjectID); end; + finally + vEvents.free; end; end; -procedure TBoldExternalObjectSpaceEventHandler.ClassChanged(ClassName: String); +{$IFDEF UseBoldOSSMessage} +procedure TBoldExternalObjectSpaceEventHandler.HandleObjectMessage( + const AOSSMessage: TBoldOssMessage); var - theClass: TBoldObjectList; + vEvents: TStringList; + vEvent: string; + i: integer; begin - theClass := fBoldSystemHandle.System.ClassByExpressionName[ClassName]; - if Assigned(theClass) then + if not assigned(fBoldSystemHandle) then + raise EBold.CreateFmt('%s.HandleMessage: The Eventhandler (%s) is not connected to a systemhandle. Unable to handle messages', [self.ClassName, name]); + if not assigned(fBoldSystemHandle.System) then + raise EBold.CreateFmt('%s.HandleMessage: The systemhandle (%s) is not active. Unable to handle messages', [self.ClassName, fBoldSystemHandle.name]); + vEvents := TStringList.Create; + vEvents.Text := AOSSMessage.Events; + try + case AOSSMessage.MessageType of + mtFail:; // TODO: anything to do here ? maybe at least call event OnFail + mtSync : + begin + for I := 0 to vEvents.count-1 do + begin + vEvent := vEvents[i]; + HandleMessage(vEvent); + end; + end; + end; + finally + vEvents.free; + end; +end; +{$ENDIF} + +procedure TBoldExternalObjectSpaceEventHandler.ClassChanged(const ClassName: String); +var + ClassTypeInfo: TBoldClassTypeInfo; + ClassList: TBoldObjectList; +begin + ClassTypeInfo := BoldSystem.BoldSystemTypeInfo.ClassTypeInfoByExpressionName[ClassName]; + if not Assigned(ClassTypeInfo) then + raise EOSS.CreateFmt('Cannot find the class %s in the system.', [ClassName]); + if Assigned(fOnClassChangedEvent) then begin - if Assigned(fOnClassChangedEvent) then - fOnClassChangedEvent(theClass) - else - theClass.Invalidate; + ClassList := BoldSystem.Classes[ClassTypeInfo.TopSortedIndex]; + fOnClassChangedEvent(ClassList); end else - raise EBold.CreateFmt(sClassNotInSystem, [ClassName]); + repeat + ClassList := BoldSystem.Classes[ClassTypeInfo.TopSortedIndex]; + ClassList.Invalidate; + ClassTypeInfo := ClassTypeInfo.SuperClassTypeInfo; + until not Assigned(ClassTypeInfo); + SendExtendedEvent(self, boeClassChanged, [ClassName]); end; procedure TBoldExternalObjectSpaceEventHandler.EmbeddedStateOfObjectChanged( - ObjectID: TBoldDefaultID); + const ClassName: String; ObjectID: TBoldDefaultID); var CurrObj: TBoldObject; begin CurrObj := GetObjectByID(ObjectID); + if Assigned(fOnEmbeddedStateChanged) then + fOnEmbeddedStateChanged(CurrObj) + else if Assigned(CurrObj) then begin - if Assigned(fOnEmbeddedStateChanged) then - fOnEmbeddedStateChanged(CurrObj) - else + if not UseMemberLevelOSS then begin if (CurrObj.BoldDirty) then Conflict(CurrObj) else + begin + if CurrObj.ObjectHasSubscribers then + FetchObject(ObjectId); CurrObj.Invalidate; + end; end; - end - else if HandleNilObjects and Assigned(fOnEmbeddedStateChanged) then - fOnEmbeddedStateChanged(nil); + end; + SendExtendedEvent(self, boeEmbeddedStateOfObjectChanged, [CurrObj, className, ObjectId, CurrObj]); +end; + +procedure TBoldExternalObjectSpaceEventHandler.ClearFetchList; +var + i: integer; +begin + for I := 0 to high(fObjectFetchArray) do + begin + fObjectFetchArray[i].Free; + fObjectFetchArray[i] := nil; + end; + for I := 0 to high(fIdFetchArray) do + begin + fIdFetchArray[i].Free; + fIdFetchArray[i] := nil; + end; +end; + +procedure TBoldExternalObjectSpaceEventHandler.FetchId(ID: TBoldObjectId); +var + IdList: TBoldObjectIdList; +begin + Assert(Id.TopSortedIndexExact); + if (Length(fObjectFetchArray) > Id.TopSortedIndex) and Assigned(fObjectFetchArray[Id.TopSortedIndex]) then + begin + if fObjectFetchArray[Id.TopSortedIndex].IdInList[Id] then + exit; + end; + if Id.TopSortedIndex >= Length(fIdFetchArray) then + SetLength(fIdFetchArray, Id.TopSortedIndex+1); + IdList := fIdFetchArray[Id.TopSortedIndex]; + if not Assigned(IdList) then + begin + IdList := TBoldObjectIdList.Create; + fIdFetchArray[Id.TopSortedIndex] := IdList; + end; + IdList.AddIfNotInList(Id); +end; + +procedure TBoldExternalObjectSpaceEventHandler.FetchObject(ID: TBoldObjectId); +var + IdList: TBoldObjectIdList; +begin + Assert(Id.TopSortedIndexExact); + // first remove from IDFetchList if found + if (Length(fIdFetchArray) > Id.TopSortedIndex) and Assigned(fIdFetchArray[Id.TopSortedIndex]) then + begin + if fIdFetchArray[Id.TopSortedIndex].IdInList[Id] then + begin + fIdFetchArray[Id.TopSortedIndex].Remove(Id); + end; + end; + if Id.TopSortedIndex >= Length(fObjectFetchArray) then + SetLength(fObjectFetchArray, Id.TopSortedIndex+1); + IdList := fObjectFetchArray[Id.TopSortedIndex]; + if not Assigned(IdList) then + begin + IdList := TBoldObjectIdList.Create; + fObjectFetchArray[Id.TopSortedIndex] := IdList; + end; + IdList.AddIfNotInList(Id); +end; + +procedure TBoldExternalObjectSpaceEventHandler.FetchLists; +var + i: integer; + ClassTypeInfo: TBoldClassTypeInfo; + IDList: TBoldObjectIdList; + List: TBoldObjectList; + ClassList: TBoldObjectList; + TopSortedClasses: TBoldClassTypeInfoList; + vBoldSystem: TBoldSystem; +begin + vBoldSystem := BoldSystem; + TopSortedClasses := vBoldSystem.BoldSystemTypeInfo.TopSortedClasses; + for I := 0 to high(fIdFetchArray) do + begin + if Assigned(fIdFetchArray[i]) then + begin + IdList := fIdFetchArray[i]; + BoldSystem.FetchIdList(IdList, false); + end; + end; + for I := 0 to high(fObjectFetchArray) do + begin + if Assigned(fObjectFetchArray[i]) then + begin + IdList := fObjectFetchArray[i]; + BoldSystem.FetchIdList(IdList, true); + end; + end; +end; + +procedure TBoldExternalObjectSpaceEventHandler.FetchMember(Member: TBoldMember); +begin +// fMemberFetchList.Add(Member); end; procedure TBoldExternalObjectSpaceEventHandler.NonEmbeddedStateOfObjectChanged( - MemberName: String; ObjectID: TBoldDefaultID); + const ClassName: String; const MemberName: String; ObjectID: TBoldDefaultID); var CurrObj: TBoldObject; CurrMember: TBoldMember; + i: integer; begin CurrMember := nil; CurrObj := GetObjectByID(ObjectID); if Assigned(CurrObj) then - CurrMember := CurrObj.BoldMemberByExpressionName[MemberName]; - + begin + i := CurrObj.BoldMemberIndexByExpressionName[MemberName]; + if i = -1 then + raise EOSS.CreateFmt('Class %s does not have a member "%s", check OSS settings of other clients.', [CurrObj.DisplayName, MemberName]); + CurrMember := CurrObj.BoldMemberIfAssigned[i]; + end; if Assigned(CurrMember) then begin if Assigned(fOnNonEmbeddedStateChanged) then fOnNonEmbeddedStateChanged(CurrMember) else + if CurrMember.BoldDirty then + Conflict(CurrMember) + else + begin +// if CurrMember.MemberHasSubscribers then +// FetchMember(CurrMember); CurrMember.Invalidate; + end; end; + SendExtendedEvent(self, boeNonEmbeddedStateOfObjectChanged, [ObjectID, CurrObj, CurrMember, ClassName, MemberName]); end; procedure TBoldExternalObjectSpaceEventHandler.Conflict( - BoldObject: TBoldObject); + AElement: TBoldDomainElement); begin + fConflictingElements.Add(AElement); if Assigned(fOnConflict) then - fOnConflict(BoldObject); + fOnConflict(AElement); +end; + +function TBoldExternalObjectSpaceEventHandler.GetBoldSystem: TBoldSystem; +begin + result := nil; + if Assigned(fBoldSystemHandle) then + result := fBoldSystemHandle.System; end; function TBoldExternalObjectSpaceEventHandler.GetObjectByID(ObjectID: TBoldDefaultID): TBoldObject; @@ -227,29 +463,150 @@ function TBoldExternalObjectSpaceEventHandler.GetObjectByID(ObjectID: TBoldDefau Result := CurrLocator.BoldObject; end; -procedure TBoldExternalObjectSpaceEventHandler.LockLost(LockName: String); +procedure TBoldExternalObjectSpaceEventHandler.LockLost(const LockName: String); begin if Assigned(fOnLockLost) then fOnLockLost(LockName); end; -procedure TBoldExternalObjectSpaceEventHandler.ObjectDeleted(ObjectId: TBoldDefaultID); +procedure TBoldExternalObjectSpaceEventHandler.MemberChanged( + const ClassName, MemberName: String; ObjectID: TBoldDefaultID); var CurrObj: TBoldObject; + CurrMember: TBoldMember; + SizeOfInvalidatedList : Integer; + SizeOfInvalidatedListCategory : String; + sl: TStringList; + i,j: integer; + vHasConflicts: boolean; begin + CurrMember := nil; + CurrObj := GetObjectByID(ObjectID); + if Assigned(CurrObj) and UseMemberLevelOSS then + begin +// if CurrObj.BoldDirty then +// Conflict(CurrObj) +// else +// begin +// if CurrObj.ObjectHasSubscribers then +// FetchObject(ObjectId); +// CurrObj.Invalidate; + + sl := TStringList.Create; + try + sl.CommaText := MemberName; + vHasConflicts := false; + for i := 0 to sl.Count - 1 do + begin + j := CurrObj.BoldMemberIndexByExpressionName[sl[i]]; + if j = -1 then + raise EOSS.CreateFmt('Class %s does not have a member "%s", check OSS settings of other clients.', [CurrObj.DisplayName, MemberName]); + CurrMember := CurrObj.BoldMemberIfAssigned[j]; + if Assigned(CurrMember) then + begin + sl.Objects[i] := CurrMember; + if CurrMember.BoldDirty then + begin + vHasConflicts := true; + Conflict(CurrMember); + end; + end; + end; + if vHasConflicts then + begin + CurrObj.Discard; + exit; + end; +{ for I := sl.Count - 1 downto 0 do + begin + CurrMember := TBoldMember(sl.Objects[i]); + if Assigned(CurrMember) then + begin + if (CurrMember.BoldPersistenceState in [bvpsModified]) then + begin + vHasConflicts := true; + Conflict(CurrMember); // this is a conflict caused by local objectspace reacting to invalidate, treat it differently ? + end + else + if (CurrMember.BoldPersistenceState in [bvpsCurrent]) then + begin + CurrMember.Invalidate; + continue; // skip the sl.Delete(i) in order to keep invalidated members in list and refetch them + end; + sl.Delete(i); + end; + end; +} + if not vHasConflicts then + FetchObject(ObjectId); +// BoldSystem.FetchMembersWithObject(CurrObj, sl.CommaText); + finally + sl.free; + end; + +// end; + end; + SendExtendedEvent(self, boeMemberChanged, [ClassName, MemberName, ObjectId, CurrObj]); +end; + +procedure TBoldExternalObjectSpaceEventHandler.ObjectCreated(const ClassName: String; + ObjectId: TBoldDefaultID); +var + ClassTypeInfo: TBoldClassTypeInfo; + ClassList: TBoldObjectList; + BoldObject: TBoldObject; + Handled: boolean; +begin + ClassTypeInfo := BoldSystem.BoldSystemTypeInfo.ClassTypeInfoByExpressionName[ClassName]; + if not Assigned(ClassTypeInfo) then + raise EOSS.CreateFmt('Cannot find the class %s in the system.', [ClassName]); + BoldObject := nil; + Handled := false; + repeat + ClassList := BoldSystem.Classes[ClassTypeInfo.TopSortedIndex]; + if KeepClassesCurrent and (ClassList.BoldPersistenceState <> bvpsInvalid) then + begin + if not Handled then + begin + case ClassList.BoldPersistenceState of + bvpsCurrent: FetchObject(ObjectId); + bvpsTransient: FetchId(ObjectId); + end; + Handled := true; + end; + end + else + ClassList.Invalidate; + ClassTypeInfo := ClassTypeInfo.SuperClassTypeInfo; + until not Assigned(ClassTypeInfo); + SendExtendedEvent(self, boeObjectCreated, [ClassName, ObjectId, BoldObject]); +end; + +procedure TBoldExternalObjectSpaceEventHandler.ObjectDeleted(const ClassName: String; ObjectId: TBoldDefaultID); +var + ClassTypeInfo: TBoldClassTypeInfo; + ClassList: TBoldObjectList; + CurrObj: TBoldObject; +begin + ClassTypeInfo := BoldSystem.BoldSystemTypeInfo.ClassTypeInfoByExpressionName[ClassName]; + if not Assigned(ClassTypeInfo) then + raise EOSS.CreateFmt('Cannot find the class %s in the system.', [ClassName]); CurrObj := GetObjectByID(ObjectID); if Assigned(CurrObj) then begin if Assigned(fOnObjectDeleted) then fOnObjectDeleted(CurrObj) else + if (CurrObj.BoldDirty) then + Conflict(CurrObj) + else begin - if (CurrObj.BoldDirty) then - Conflict(CurrObj) - else - CurrObj.AsIBoldObjectContents[bdepPMIn].BoldExistenceState := besDeleted; + CurrObj.AsIBoldObjectContents[bdepPMIn].BoldExistenceState := besDeleted; + if CurrObj.BoldPersistenceState = bvpsInvalid then + CurrObj.SendEvent(beObjectDeleted); end; end; + SendExtendedEvent(self, boeObjectDeleted, [ClassName, ObjectId, CurrObj]); end; procedure TBoldExternalObjectSpaceEventHandler.Notification( @@ -293,4 +650,20 @@ procedure TBoldExternalObjectSpaceEventHandler.Subscribe( fPTSubscriber.CancelAllSubscriptions; end; +{ EOSSConflict } + +constructor EOSSConflict.Create(AList: TBoldList); +begin + FList := AList.Clone as TBoldList; + self.message := AList.AsDebugCommaText(); +end; + +destructor EOSSConflict.Destroy; +begin + FList.free; + inherited; +end; + +initialization + end. diff --git a/Source/ObjectSpace/BORepresentation/BoldLinks.pas b/Source/ObjectSpace/BORepresentation/BoldLinks.pas index 737da6e4..ad4bf697 100644 --- a/Source/ObjectSpace/BORepresentation/BoldLinks.pas +++ b/Source/ObjectSpace/BORepresentation/BoldLinks.pas @@ -1,3 +1,7 @@ + +{ Global compiler directives } +{$include bold.inc} + unit BoldLinks; interface @@ -8,7 +12,8 @@ interface BoldDomainElement, BoldId, BoldElements, - BoldSubscription; + BoldSubscription, + BoldFreeStandingValues; type {forward declarations of all classes} @@ -24,7 +29,6 @@ TBoldLinkObjectSingleLinkController = class; { TBoldDirectSingleLinkController } TBoldDirectSingleLinkController = class(TBoldAbstractObjectReferenceController) private - FOrderno: Integer; fLocator: TBoldObjectLocator; procedure AddToOtherEnd(Mode: TBoldLinkUnlinkMode); procedure RemoveFromOtherEnd(Mode: TBoldLinkUnlinkMode); @@ -33,19 +37,36 @@ TBoldDirectSingleLinkController = class(TBoldAbstractObjectReferenceController function MayUpdate: Boolean; override; procedure PreDiscard; override; procedure SetFromId(Id: TBoldObjectId; Mode: TBoldDomainElementProxyMode); virtual; - procedure SetOrderNo(NewORderNo: Integer; Mode: TBoldDomainElementProxyMode); function GetStreamName: String; override; - function ProxyClass: TBoldMember_ProxyClass; override; + function GetFreeStandingClass: TBoldFreeStandingElementClass; override; + function GetProxy(Member: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; + procedure SetOrderNo(NewORderNo: Integer; Mode: TBoldDomainElementProxyMode); virtual; abstract; + function GetOrderNo: Integer; virtual; abstract; public procedure MakeDbCurrent; override; function GetOtherEndController(aLocator: TBoldObjectLocator; AllowForceOtherEnd: Boolean): TBoldAbstractController; - procedure SetAndModifyOrderNo(index: Integer); + procedure SetAndModifyOrderNo(index: Integer); virtual;abstract; procedure Unlink(OldLocator: TBoldObjectLocator; Mode: TBoldLinkUnlinkMode); override; procedure LinkTo(NewLocator: TBoldObjectLocator; updateOrderNo: Boolean; Mode: TBoldLinkUnlinkMode); override; function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; override; function GetLocator: TBoldObjectLocator; override; procedure SetLocator(NewLocator: TBoldObjectLocator); override; - property OrderNo: Integer read fOrderNo; + property OrderNo: Integer read GetOrderNo; + end; + + TBoldOrderedDirectSingleLinkController = class(TBoldDirectSingleLinkController) + private + fOrderno: Integer; + public + procedure SetAndModifyOrderNo(index: Integer); override; + procedure SetOrderNo(NewORderNo: Integer; Mode: TBoldDomainElementProxyMode); override; + function GetOrderNo: Integer; override; + end; + + TBoldUnOrderedDirectSingleLinkController = class(TBoldDirectSingleLinkController) + procedure SetAndModifyOrderNo(index: Integer); override; + procedure SetOrderNo(NewOrderNo: Integer; Mode: TBoldDomainElementProxyMode); override; + function GetOrderNo: Integer; override; end; { TBoldIndirectSingleLinkController } @@ -53,16 +74,17 @@ TBoldIndirectSingleLinkController = class(TBoldAbstractObjectReferenceControll private fLinkObjectLocator: TBoldObjectLocator; fOtherEndLocator: TBoldObjectLocator; - function GetLinkObjectOwnLinkController(LinkObject: TBoldObject): TBoldLinkObjectSingleLinkController; - function GetLinkObjectOtherLinkController(LinkObject: TBoldObject): TBoldLinkObjectSingleLinkController; - function GetLinkObjectRoleController: TBoldLinkObjectReferenceController; + function GetLinkObjectOwnLinkController(LinkObject: TBoldObject): TBoldLinkObjectSingleLinkController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetLinkObjectOtherLinkController(LinkObject: TBoldObject): TBoldLinkObjectSingleLinkController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetLinkObjectRoleController: TBoldLinkObjectReferenceController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected function MayUpdate: Boolean; override; function NewLink(OtherLocator: TBoldObjectLocator; Mode: TBoldLinkUnlinkMode): TBoldObject; procedure DeleteLink(Mode: TBoldLinkUnlinkMode); procedure SetFromIds(Id1, Id2: TBoldObjectId; Mode: TBoldDomainElementProxyMode); function GetStreamName: String; override; - function ProxyClass: TBoldMember_ProxyClass; override; + function GetFreeStandingClass: TBoldFreeStandingElementClass; override; + function GetProxy(Member: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; public procedure MakeDbCurrent; override; function AssertIntegrity: Boolean; override; @@ -81,10 +103,11 @@ TBoldMultiLinkController = class(TBoldAbstractObjectListController) function GetCanCreateNew: Boolean; override; function CreateNew: TBoldElement; override; function IsInOrder: Boolean; virtual; abstract; - procedure Resort; virtual; abstract; // order after orderno of other end + procedure Resort; virtual; abstract; public procedure MarkPossiblyOutOfOrder; - procedure EnsureOrder; + procedure EnsureOrder; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure DoEnsureOrder; {$IFDEF BOLD_INLINE} inline; {$ENDIF} end; { TBoldDirectMultiLinkController } @@ -94,12 +117,13 @@ TBoldDirectMultiLinkController = class(TBoldMultiLinkController) procedure ReOrder; property LocatorList: TBoldObjectLocatorList read fLocatorList; protected - function GetOtherEndController(Locator: TBoldObjectLocator): TBoldDirectSingleLinkController; + function GetOtherEndController(Locator: TBoldObjectLocator): TBoldDirectSingleLinkController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SingleLinkUnlink(Locator: TBoldObjectLocator; OldLocator: TBoldObjectLocator;Mode: TBoldLinkUnlinkMode); - procedure SingleLinkLinkTo(Locator: TBoldObjectLocator; NewLocator: TBoldObjectLocator; updateOrderNo: Boolean; Mode: TBoldLinkUnlinkMode); + procedure SingleLinkLinkTo(Locator: TBoldObjectLocator; NewLocator: TBoldObjectLocator; updateOrderNo: Boolean; Mode: TBoldLinkUnlinkMode; aOrderNo: integer = -1); procedure SetFromIdList(ListOfOtherEnd: TBoldObjectIdList; Mode: TBoldDomainElementProxyMode); function GetStreamName: String; override; - function ProxyClass: TBoldMember_ProxyClass; override; + function GetFreeStandingClass: TBoldFreeStandingElementClass; override; + function GetProxy(Member: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; procedure PrepareClear; override; function CompareOrderNo(Index1, Index2: integer): integer; procedure Exchange(Index1, Index2: integer); @@ -107,7 +131,7 @@ TBoldDirectMultiLinkController = class(TBoldMultiLinkController) procedure ClearNoLongerReferring(NewList: TBoldObjectIdList); procedure Resort; override; public - constructor Create(OwningList: TBoldObjectList); + constructor Create(OwningList: TBoldObjectList); reintroduce; destructor Destroy; override; procedure LinkTo(NewLocator: TBoldObjectLocator; updateOrderNo: Boolean; Mode: TBoldLinkUnlinkMode); override; procedure Unlink(OldLocator: TBoldObjectLocator; Mode: TBoldLinkUnlinkMode); override; @@ -132,31 +156,32 @@ TBoldIndirectMultiLinkController = class(TBoldMultiLinkController) private fLinkLocatorList: TBoldObjectLocatorList; fReferredList: TBoldObjectLocatorList; - function GetLinkObjectOwnLinkController(LinkObject: TBoldObject): TBoldLinkObjectSingleLinkController; - function GetLinkObjectOtherLinkController(LinkObject: TBoldObject): TBoldLinkObjectSingleLinkController; + function GetLinkObjectOwnLinkController(LinkObject: TBoldObject): TBoldLinkObjectSingleLinkController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetLinkObjectOtherLinkController(LinkObject: TBoldObject): TBoldLinkObjectSingleLinkController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function NewLink(OtherLocator: TBoldObjectLocator; Mode: TBoldLinkUnlinkMode): TBoldObject; - function GetLinkObjectListController: TBoldLinkObjectListController; + function GetLinkObjectListController: TBoldLinkObjectListController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure DeleteLink(LinkObjectLocator: TBoldObjectLocator; Mode: TBoldLinkUnlinkMode); procedure ReOrder; property LinkLocatorList: TBoldObjectLocatorList read fLinkLocatorList; property ReferredLocatorList: TBoldObjectLocatorList read FReferredList; - function ControllerForLinkMember: TBoldAbstractObjectListController; + function ControllerForLinkMember: TBoldAbstractObjectListController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure ClearNoLongerReferring(NewList: TBoldObjectIdList); protected procedure SetFromIDLists(ListOfLinkObjects: TBoldObjectIdList; ListOfOtherEnd: TBoldObjectIdList; Mode: TBoldDomainElementProxyMode); function GetStreamName: String; override; - function ProxyClass: TBoldMember_ProxyClass; override; + function GetFreeStandingClass: TBoldFreeStandingElementClass; override; + function GetProxy(Member: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; procedure PrepareClear; override; function CompareOrderNo(Index1, Index2:integer): integer; procedure Exchange(Index1, Index2: integer); function IsInOrder: Boolean; override; procedure Resort; override; public - constructor Create(OwningList: TBoldObjectList); + constructor Create(OwningList: TBoldObjectList); reintroduce; destructor Destroy; override; function AssertIntegrity: Boolean; override; procedure LinkTo(NewLocator: TBoldObjectLocator; updateOrderNo: Boolean; Mode: TBoldLinkUnlinkMode); override; - procedure Unlink(OldLocator: TBoldObjectLocator; Mode: TBoldLinkUnlinkMode); override; + procedure UnLink(OldLocator: TBoldObjectLocator; Mode: TBoldLinkUnlinkMode); override; function GetCount: Integer; override; function GetLocator(index: Integer): TBoldObjectLocator; override; function GetLocatorByQualifiersAndSubscribe(MemberList: TBoldMemberList; Subscriber: TBoldSubscriber): TBoldObjectLocator; override; @@ -176,13 +201,14 @@ TBoldIndirectMultiLinkController = class(TBoldMultiLinkController) { TBoldLinkObjectListController } TBoldLinkObjectListController = class(TBoldAbstractObjectListController) private - function GetLocatorList: TBoldObjectLocatorList; - function GetMainListController: TBOldIndirectMultiLinkController; - function GetMainList: TBoldObjectList; + function GetLocatorList: TBoldObjectLocatorList; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetMainListController: TBOldIndirectMultiLinkController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetMainList: TBoldObjectList; {$IFDEF BOLD_INLINE} inline; {$ENDIF} property LocatorList: TBoldObjectLocatorList read GetLocatorList; protected function GetStreamName: string; override; - function ProxyClass: TBoldMember_ProxyClass; override; + function GetFreeStandingClass: TBoldFreeStandingElementClass; override; + function GetProxy(Member: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; public function GetCount: Integer; override; function GetLocator(index: Integer): TBoldObjectLocator; override; @@ -199,9 +225,9 @@ TBoldLinkObjectListController = class(TBoldAbstractObjectListController) end; { TBoldLinkObjectSingleLinkController } - TBoldLinkObjectSingleLinkController = class(TBoldDirectSingleLinkController) + TBoldLinkObjectSingleLinkController = class(TBoldOrderedDirectSingleLinkController) private - function OtherInnerLinkController: TBoldLinkObjectSingleLinkController; + function OtherInnerLinkController: TBoldLinkObjectSingleLinkController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected procedure SetFromId(Id: TBoldObjectId; Mode: TBoldDomainElementProxyMode); override; public @@ -212,7 +238,8 @@ TBoldLinkObjectSingleLinkController = class(TBoldDirectSingleLinkController) TBoldLinkObjectReferenceController = class(TBoldAbstractObjectReferenceController) protected function GetStreamName: string; override; - function ProxyClass: TBoldMember_ProxyClass; override; + function GetFreeStandingClass: TBoldFreeStandingElementClass; override; + function GetProxy(Member: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; public function GetLocator: TBoldObjectLocator; override; procedure SetLocator(NewLocator: TBoldObjectLocator); override; @@ -229,7 +256,8 @@ implementation uses SysUtils, Classes, - BoldCoreConsts, + TypInfo, + BoldGuard, BoldStreams, BoldValueSpaceInterfaces, @@ -238,77 +266,84 @@ implementation BoldDefs, BoldValueInterfaces, BoldIndexableList, - BoldSystemRT; + BoldSystemRT, + BoldMath, + BoldObjectListControllers, + BoldLogHandler; {---Proxies---} + { TBoldDirectSingleLinkController_Proxy } type TBoldDirectSingleLinkController_Proxy = class(TBoldMember_Proxy, IBoldObjectIdRef) private - function GetDirectSingleLinkController: TBoldDirectSingleLinkController; - // IBoldObjectIdRef - procedure SetFromId(Id: TBoldObjectId); - function GetId: TBoldObjectID; - function GetOrderNo: integer; + class var fLastUsed: array[TBoldDomainElementProxyMode] of TBoldMember_Proxy; + class var fLastUsedAsInterface: array[TBoldDomainElementProxyMode] of IBoldValue; + function GetDirectSingleLinkController: TBoldDirectSingleLinkController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetFromId(Id: TBoldObjectId; Adopt: Boolean); + function GetId: TBoldObjectID; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetOrderNo: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetOrderNo(NewOrder: Integer); protected - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; + class function MakeProxy(ProxedMember: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; property DirectSingleLInkController: TBoldDirectSingleLinkController read GetDirectSingleLinkController; end; { TBoldIndirectSingleLinkController_Proxy } TBoldIndirectSingleLinkController_Proxy = class(TBoldMember_Proxy, IBoldObjectIdRefPair) private - function GetInDirectSingleLinkController: TBoldInDirectSingleLinkController; - // IBoldObjectIdRefPair + function GetInDirectSingleLinkController: TBoldInDirectSingleLinkController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetFromIds(Id1, Id2: TBoldObjectId); - function GetId1: TBoldObjectID; - function GetId2: TBoldObjectID; - function GetOrderNo: integer; + function GetId1: TBoldObjectID; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetId2: TBoldObjectID; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetOrderNo: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetOrderNo(NewOrder: Integer); protected - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; property InDirectSingleLInkController: TBoldInDirectSingleLinkController read GetInDirectSingleLinkController; end; { TBoldDirectMultiLinkController_Proxy } TBoldDirectMultiLinkController_Proxy = class(TBoldMember_Proxy, IBoldObjectIdListRef) private - function GetDirectMultiLinkController: TBoldDirectMultiLinkController; - // IBoldObjectIdListRef + class var fLastUsed: array[TBoldDomainElementProxyMode] of TBoldMember_Proxy; + class var fLastUsedAsInterface: array[TBoldDomainElementProxyMode] of IBoldValue; + function GetDirectMultiLinkController: TBoldDirectMultiLinkController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetFromIdList(IdLIst: TBoldObjectIdList); - function GetIdList(Index: Integer): TBoldObjectID; - function GetCount: integer; + procedure SetList(IdList: TBoldObjectIdList); + function GetIdList(Index: Integer): TBoldObjectID; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetCount: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; property DirectMultiLinkController: TBoldDirectMultiLinkController read GetDirectMultiLinkController; + class function MakeProxy(ProxedMember: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; end; { TBoldInDirectMultiLinkController_Proxy } TBoldInDirectMultiLinkController_Proxy = class(TBoldMember_Proxy, IBoldObjectIdListRefPair) private - function GetInDirectMultiLinkController: TBoldInDirectMultiLinkController; - // IBoldObjectIdListRefPair - function GetIdList1(Index: Integer): TBoldObjectID; - function GetIdList2(Index: Integer): TBoldObjectID; + function GetInDirectMultiLinkController: TBoldInDirectMultiLinkController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetIdList1(Index: Integer): TBoldObjectID; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetIdList2(Index: Integer): TBoldObjectID; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetFromIdLists(IdList1, IdList2: TBoldObjectIdList); - function GetCount: integer; + function GetCount: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; property InDirectMultiLinkController: TBoldInDirectMultiLinkController read GetInDirectMultiLinkController; end; { TBoldDirectSingleLinkController_Proxy } -procedure TBoldDirectSingleLinkController_Proxy.AssignContentValue(Source: IBoldValue); +procedure TBoldDirectSingleLinkController_Proxy.AssignContentValue(const Source: IBoldValue); var s: IBoldObjectIdRef; ObjRef: TBoldObjectReference; begin if (not (Assigned(Source) and (source.QueryInterface(IBoldObjectIDRef, S) = S_OK))) then - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, 'AssignContentValue']); // do not localize - SetFromId(s.Id); - if Mode <>bdepContents then { TODO : Check why Orderno not included in contents } + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); + SetFromId(s.Id, false); + if Mode <>bdepContents then SetOrderNo(s.OrderNo); if Mode in [bdepUnDo, bdepContents] then begin @@ -333,15 +368,35 @@ function TBoldDirectSingleLinkController_Proxy.GetId: TBoldObjectID; function TBoldDirectSingleLinkController_Proxy.GetOrderNo: integer; begin - Result := DirectSingleLInkController.OrderNo; + Result := DirectSingleLInkController.OrderNo; end; -procedure TBoldDirectSingleLinkController_Proxy.SetFromId(Id: TBoldObjectId); +class function TBoldDirectSingleLinkController_Proxy.MakeProxy( + ProxedMember: TBoldMember; + Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; +begin + Result := fLastUsed[Mode]; + // Reuse proxy if we hold only reference + if Assigned(Result) and (Result.RefCount =1) then + begin + Result.Retarget(ProxedMember, Mode); + end + else + begin + Result := Create(ProxedMember, Mode); + fLastUsed[Mode] := Result; + fLastUsedAsInterface[Mode] := Result; // Inc refcount + end; +end; + +procedure TBoldDirectSingleLinkController_Proxy.SetFromId(Id: TBoldObjectId; adopt: Boolean); begin if Mode in [bdepPMIn, bdepContents, bdepUndo, bdepInternalInitialize] then DirectSingleLInkController.SetFromId(Id, Mode) else - UnsupportedMode(Mode, 'SetFromId'); // do not localize + UnsupportedMode(Mode, 'SetFromId'); + if Adopt then + Id.Free; end; procedure TBoldDirectSingleLinkController_Proxy.SetOrderNo(NewOrder: Integer); @@ -349,17 +404,17 @@ procedure TBoldDirectSingleLinkController_Proxy.SetOrderNo(NewOrder: Integer); if Mode in [bdepPMIn, bdepUnDo, bdepContents] then DirectSingleLInkController.SetOrderNo(NewOrder, Mode) else - UnsupportedMode(Mode, 'SetOrderNo'); // do not localize + UnsupportedMode(Mode, 'SetOrderNo'); end; { TBoldIndirectSingleLinkController_Proxy } -procedure TBoldIndirectSingleLinkController_Proxy.AssignContentValue(Source: IBoldValue); +procedure TBoldIndirectSingleLinkController_Proxy.AssignContentValue(const Source: IBoldValue); var s: IBoldObjectIdRefPair; begin if (not Assigned(Source)) or (source.QueryInterface(IBoldObjectIDRefPair, S) <> S_OK) then - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, 'AssignContentValue']); // do not localize + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); SetFromIds(s.Id1, s.Id2); end; @@ -386,7 +441,7 @@ function TBoldIndirectSingleLinkController_Proxy.GetInDirectSingleLinkController function TBoldIndirectSingleLinkController_Proxy.GetOrderNo: integer; begin - Result := 0; // Indirect link has no orderno + Result := 0; end; procedure TBoldIndirectSingleLinkController_Proxy.SetFromIds(Id1, Id2: TBoldObjectId); @@ -394,17 +449,17 @@ procedure TBoldIndirectSingleLinkController_Proxy.SetFromIds(Id1, Id2: TBoldObje if Mode in [bdepContents, bdepPMIn] then InDirectSingleLInkController.SetFromIds(Id1, Id2, Mode) else - UnsupportedMode(Mode, 'SetFromId'); // do not localize + UnsupportedMode(Mode, 'SetFromId'); end; procedure TBoldIndirectSingleLinkController_Proxy.SetOrderNo(NewOrder: Integer); begin - UnsupportedMode(Mode, 'SetOrderNo'); // do not localize + UnsupportedMode(Mode, 'SetOrderNo'); end; { TBoldDirectMultiLinkController_Proxy } -procedure TBoldDirectMultiLinkController_Proxy.AssignContentValue(Source: IBoldValue); +procedure TBoldDirectMultiLinkController_Proxy.AssignContentValue(const Source: IBoldValue); var s: IBoldObjectIdListRef; i: Integer; @@ -413,8 +468,9 @@ procedure TBoldDirectMultiLinkController_Proxy.AssignContentValue(Source: IBoldV begin G := TBoldGuard.Create(anIdList); if (not Assigned(Source)) or (source.QueryInterface(IBoldObjectIDListRef, S) <> S_OK) then - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, 'AssignContentValue']); // do not localize + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); anIdList := TBoldObjectIdList.Create; + anIdList.Capacity := s.Count; for i := 0 to s.Count - 1 do anIdList.Add(s.IdList[i]); SetFromIdList(anIdList) @@ -435,17 +491,51 @@ function TBoldDirectMultiLinkController_Proxy.GetIdList(Index: Integer): TBoldOb Result := DirectMultiLinkController.LocatorList[Index].BoldObjectId; end; +class function TBoldDirectMultiLinkController_Proxy.MakeProxy( + ProxedMember: TBoldMember; + Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; +begin + Result := fLastUsed[Mode]; + // Reuse proxy if we hold only reference + if Assigned(Result) and (Result.RefCount =1) then + begin + Result.Retarget(ProxedMember, Mode); + end + else + begin + Result := Create(ProxedMember, Mode); + fLastUsed[Mode] := Result; + fLastUsedAsInterface[Mode] := Result; // Inc refcount + end; +end; + procedure TBoldDirectMultiLinkController_Proxy.SetFromIdList(IdList: TBoldObjectIdList); begin if Mode in [bdepContents, bdepPMIn] then DirectMultiLinkController.SetFromIdList(IdLIst, Mode) else - UnsupportedMode(Mode, 'SetFromIdList'); // do not localize + UnsupportedMode(Mode, 'SetFromIdList'); +end; + +procedure TBoldDirectMultiLinkController_Proxy.SetList( + IdList: TBoldObjectIdList); +var + i: integer; + LocatorList: TBoldObjectLocatorList; +begin + IdList.Clear; + LocatorList := DirectMultiLinkController.LocatorList; + if LocatorList.Count > 0 then + begin + IdList.Capacity := LocatorList.Count; + for I := 0 to LocatorList.Count - 1 do + IdList.Add(LocatorList[I].BoldObjectId); + end; end; { TBoldInDirectMultiLinkController_Proxy } -procedure TBoldInDirectMultiLinkController_Proxy.AssignContentValue(Source: IBoldValue); +procedure TBoldInDirectMultiLinkController_Proxy.AssignContentValue(const Source: IBoldValue); var s: IBoldObjectIdListRefPair; i: Integer; @@ -455,13 +545,19 @@ procedure TBoldInDirectMultiLinkController_Proxy.AssignContentValue(Source: IBol begin G := TBoldGuard.Create(anIdList1, anIdList2); if (not Assigned(source)) or (source.QueryInterface(IBoldObjectIDListRefPair, S) <> S_OK) then - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, 'AssignContentValue']); // do not localize + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); anIdList1 := TBoldObjectIdList.Create; anIdList2 := TBoldObjectIdList.Create; - for i := 0 to s.Count - 1 do + i := s.Count; + if i > 0 then begin - anIdList1.Add(s.IdList1[i]); - anIdList2.Add(s.IdList2[i]); + anIdList1.Capacity := i; + anIdList2.Capacity := i; + for i := 0 to s.Count - 1 do + begin + anIdList1.Add(s.IdList1[i]); + anIdList2.Add(s.IdList2[i]); + end; end; SetFromIDLists(anIdList1, anIdList2) end; @@ -492,11 +588,32 @@ procedure TBoldInDirectMultiLinkController_Proxy.SetFromIdLists(IdList1, if Mode in [bdepPMIn, bDepContents] then InDirectMultiLinkController.SetFromIdLists(IdList1, IdList2, Mode) else - UnsupportedMode(Mode, 'SetFromIdLists'); // do not localize + UnsupportedMode(Mode, 'SetFromIdLists'); end; { TBoldDirectMultiLinkController } +function TBoldDirectMultiLinkController.GetOtherEndController(Locator: TBoldObjectLocator): TBoldDirectSingleLinkController; +begin + result := GetControllerForMember(Locator.EnsuredBoldObject.BoldMembers[RoleRTInfo.IndexOfOtherEnd]) as TBoldDirectSingleLinkController; +end; + +procedure TBoldMultiLinkController.DoEnsureOrder; +begin + if (fMayBeOutOfOrder) then + begin + if not IsInOrder then + Resort; + fMayBeOutOfOrder := false; + end; +end; + +procedure TBoldMultiLinkController.EnsureOrder; +begin + if (fMayBeOutOfOrder) then + DoEnsureOrder; +end; + procedure TBoldDirectMultiLinkController.AddLocator(Locator: TBoldObjectLocator); var OtherEndController: TBoldDirectSingleLinkController; @@ -506,13 +623,13 @@ procedure TBoldDirectMultiLinkController.AddLocator(Locator: TBoldObjectLocator) try BoldClearLastFailure; if not StartModify then - BoldRaiseLastFailure(OwningList, 'AddLocator', ''); // do not localize + BoldRaiseLastFailure(OwningList, 'AddLocator', ''); PreChange; LocatorList.Add(Locator); OtherEndController := GetOtherEndController(Locator); OtherEndController.LinkTo(OwningList.OwningObject.BoldObjectLocator, true, blulMarkModified); - if OwningObjectList.BoldRoleRtInfo.IsOrdered then - OtherEndController.SetAndModifyOrderNo(LocatorList.IndexOf(Locator)); // Complexity warning: A loop of adds will take O(n^2) + if RoleRTInfo.IsOrdered then + OtherEndController.SetAndModifyOrderNo(LocatorList.IndexOf(Locator)); Changed(beItemAdded, [Locator]); EndModify; @@ -535,10 +652,103 @@ destructor TBoldDirectMultiLinkController.Destroy; inherited; end; +type + TMultiLinkItem = class(TObject) + public + OrderNo: Integer; + ObjectId: TBoldObjectId; + end; + + TIndirectMultiLinkItem = class(TMultiLinkItem) + public + OtherObjectId: TBoldObjectId; + end; + + +function _CompareOrderNo(Item1, Item2: Pointer): Integer; +begin + Result := TMultiLinkItem(Item1).OrderNo - TMultiLinkItem(Item2).OrderNo; +end; + procedure TBoldDirectMultiLinkController.MakeDbCurrent; +{$IFDEF FetchFromClassList} + procedure FetchFromClassList; + var + ClassList: TBoldObjectList; + lBoldObjectIdList: TBoldObjectIdList; + lBoldGuard: IBoldGuard; + lBoldObject: TBoldObject; + lBoldObjectReference: TBoldObjectReference; + lOwnBoldObjectLocator: TBoldObjectLocator; + lMultiLinkItem: TMultiLinkItem; + lSortList: TList; + i: integer; + lIsOrdered: boolean; + CheckType: boolean; + lIndexOfOtherEnd: Integer; + lTopSortedIndex: integer; + OtherEndBoldClassTypeInfo: TBOldClassTypeInfo; + lTopSortedClasses: TBoldClassTypeInfoList; + begin + lBoldGuard := TBoldGuard.Create(lBoldObjectIdList, lSortList); + OtherEndBoldClassTypeInfo := RoleRTInfo.ClassTypeInfoOfOtherEnd; + lTopSortedIndex := RoleRTInfo.ClassTypeInfoOfOtherEnd.TopSortedIndex; + ClassList := BoldSystem.Classes[lTopSortedIndex]; + lOwnBoldObjectLocator := OwningObject.BoldObjectLocator; + lBoldObjectIdList := TBoldObjectIdList.Create; + lTopSortedClasses := BoldSystem.BoldSystemTypeInfo.TopSortedClasses; + if RoleRTInfo.IsOrdered then + lSortList := TList.Create; + lIsOrdered := RoleRTInfo.IsOrdered; + lIndexOfOtherEnd := RoleRTInfo.IndexOfOtherEnd; + CheckType := ClassList.BoldPersistenceState <> bvpsCurrent; + if CheckType then + ClassList := TBoldClassListController(GetControllerForMember(ClassList)).ClosestLoadedClassList{.FilterOnType(RoleRTInfo.ClassTypeInfoOfOtherEnd)}; + for i := 0 to ClassList.Count - 1 do + begin + if CheckType and (ClassList.Locators[i].BoldObjectID.TopSortedIndex < lTopSortedIndex) or + not ClassList.Locators[i].BoldClassTypeInfo.BoldIsA(OtherEndBoldClassTypeInfo) then + Continue; + lBoldObject := ClassList[i]; + lBoldObjectReference := lBoldObject.BoldMembers{IfAssigned}[lIndexOfOtherEnd] as TBoldObjectReference; + if Assigned(lBoldObjectReference) and (lBoldObjectReference.Locator = lOwnBoldObjectLocator) then + begin + if lIsOrdered then + begin + lMultiLinkItem := TMultiLinkItem.Create; + lMultiLinkItem.ObjectId := lBoldObject.BoldObjectLocator.BoldObjectId; + lMultiLinkItem.OrderNo := (GetControllerForMember(lBoldObjectReference) as TBoldDirectSingleLinkController).OrderNo; + lSortList.Add(lMultiLinkItem); + end + else + begin + lBoldObjectIdList.Add(lBoldObject.BoldObjectLocator.BoldObjectId); + end; + end; + end; + if lIsOrdered then + begin + lSortList.Sort(_CompareOrderNo); + for i := 0 to lSortList.Count - 1 do + begin + lMultiLinkItem := TMultiLinkItem(lSortList[i]); + lBoldObjectIdList.Add(lMultiLinkItem.ObjectId); + lMultiLinkItem.free; + end; + end; + + SetFromIdList(lBoldObjectIdList, bdepContents); + OwningObjectList.BoldPersistenceState := bvpsCurrent; + end; +{$ENDIF} begin EnsureOrder; - DbFetchOwningMember; +{$IFDEF FetchFromClassList} + if TBoldClassListController(GetControllerForMember(BoldSystem.Classes[RoleRTInfo.ClassTypeInfoOfOtherEnd.TopSortedIndex])).IsCurrentOrSuperClassIsCurrent then + FetchFromClassList + else +{$ENDIF} + DbFetchOwningMember; end; function TBoldDirectMultiLinkController.GetCount: Integer; @@ -557,13 +767,13 @@ function TBoldDirectMultiLinkController.GetLocatorByQualifiersAndSubscribe(Membe EnsureOrder; if not LocatorList.HasMembersIndex then begin - if assigned(OwningObjectList.BoldRoleRTInfo) and OwningObjectList.BoldRoleRTInfo.isQualified then + if assigned(RoleRTInfo) and RoleRTInfo.isQualified then begin OwningObjectList.EnsureObjects; - LocatorList.InitMembersIndex(OwningObjectList, OwningObjectList.BoldRoleRTInfo.Qualifiers) + LocatorList.InitMembersIndex(OwningObjectList, RoleRTInfo.Qualifiers) end else - raise EBold.CreateFmt(sRolenotQualified, [ClassName]); + raise EBold.CreateFmt('%s.GetLocatorByQualifiers: Object list does not have a member index or role is not qualified', [ClassName]); end; result := LocatorList.GetLocatorByAttributesAndSubscribe(MemberList, Subscriber); end; @@ -586,7 +796,7 @@ procedure TBoldDirectMultiLinkController.InsertLocator(index: Integer; Locator: try BoldClearLastFailure; if not StartModify then - BoldRaiseLastFailure(OwningList, 'InsertLocator', ''); // do not localize + BoldRaiseLastFailure(OwningList, 'InsertLocator', ''); PreChange; LocatorList.Insert(Index, Locator); @@ -603,19 +813,22 @@ procedure TBoldDirectMultiLinkController.InsertLocator(index: Integer; Locator: procedure TBoldDirectMultiLinkController.linkto(NewLocator: TBoldObjectLocator; updateOrderNo: Boolean; Mode: TBoldLinkUnlinkMode) ; begin - Assert((Mode <> blulMarkAdjusted) or (OwningList.BoldPersistenceState = bvpsCurrent)); - Assert(not IncludesLocator(NewLocator)); + Assert((Mode <> blulMarkAdjusted) or (OwningList.BoldPersistenceState = bvpsCurrent), OwningMember.DisplayName); + if IncludesLocator(NewLocator) then // this used to be an assert, but we now just exit + begin + exit; + end; BoldClearLastFailure; if Mode = blulMarkModified then if not StartModify then - BoldRaiseLastFailure(OwningList, 'Linkto', ''); // do not localize + BoldRaiseLastFailure(OwningList, 'Linkto', ''); PreChange; LocatorList.Add(NewLocator); if Mode = blulMarkAdjusted then OwningObjectList.Adjusted := True; - if updateOrderNo and OwningObjectList.BoldRoleRtInfo.IsOrdered then - GetOtherEndController(NewLocator).SetAndModifyOrderNo(LocatorList.IndexOf(NewLocator)); // Complexity warning: A loop of adds will take O(n^2) + if updateOrderNo and RoleRTInfo.IsOrdered then + GetOtherEndController(NewLocator).SetAndModifyOrderNo(LocatorList.IndexOf(NewLocator)); //TODO - This could have side effect when mode is blulMarkAdjusted Changed(beItemAdded, [NewLocator]); if Mode = blulMarkModified then EndModify; @@ -624,11 +837,13 @@ procedure TBoldDirectMultiLinkController.linkto(NewLocator: TBoldObjectLocator; procedure TBoldDirectMultiLinkController.Move(CurrentIndex, NewIndex: Integer); begin EnsureOrder; + if not RoleRTInfo.IsOrdered then + exit; BoldSystem.StartTransaction; try BoldClearLastFailure; if not StartModify then - BoldRaiseLastFailure(OwningList, 'Move', ''); // do not localize + BoldRaiseLastFailure(OwningList, 'Move', ''); PreChange; LocatorList.Move(CurrentIndex, NewIndex); @@ -653,7 +868,7 @@ procedure TBoldDirectMultiLinkController.RemoveByIndex(index: Integer); try BoldClearLastFailure; if not StartModify then - BoldRaiseLastFailure(OwningList, 'RemoveByIndex', ''); // do not localize + BoldRaiseLastFailure(OwningList, 'RemoveByIndex', ''); Locator := LocatorList[index]; PreChange; @@ -671,31 +886,30 @@ procedure TBoldDirectMultiLinkController.RemoveByIndex(index: Integer); procedure TBoldDirectMultiLinkController.ReOrder; var -{$IFOPT C+} // if Assertions on +{$IFOPT C+} index: Integer; {$ENDIF} I: Integer; Locator: TBoldObjectLocator; begin - if not OwningObjectList.BoldRoleRtInfo.IsOrdered then + if not RoleRTInfo.IsOrdered then exit; -{$IFOPT C+} // if Assertions on - index := OwningObjectList.BoldRoleRtInfo.IndexOfOtherEnd; +{$IFOPT C+} + index := RoleRTInfo.IndexOfOtherEnd; Assert(index <> -1); {$ENDIF} for I := 0 to LocatorList.Count - 1 do begin Locator := LocatorList[I]; - Locator.EnsureBoldObject; // Note, can give fetch during fetch, save till all fetched + Locator.EnsureBoldObject; GetOtherEndController(Locator).SetAndModifyOrderNo(I); end; end; procedure TBoldDirectMultiLinkController.SetFromIdList(ListOfOtherEnd: TBoldObjectIdList; Mode: TBoldDomainElementProxyMode); var + BoldSystem: TBoldSystem; NewListOfOtherEnd: TBoldObjectIdlist; - - // Ajdust NewListOfOtherEnd, return true if adjusted function AdjustList: boolean; procedure SafeCopyOptimisticValues; var @@ -712,8 +926,9 @@ procedure TBoldDirectMultiLinkController.SetFromIdList(ListOfOtherEnd: TBoldObje IndexOfOtherEnd: Integer; BoldClassTypeInfoOfOtherEnd: TBoldClassTypeInfo; begin - BoldClassTypeInfoOfOtherEnd := OwningObjectList.BoldRoleRtInfo.ClassTypeInfoOfOtherEnd; - IndexOfOtherEnd := OwningObjectList.BoldRoleRtInfo.IndexOfOtherEnd; + BoldSystem := self.BoldSystem; + BoldClassTypeInfoOfOtherEnd := RoleRTInfo.ClassTypeInfoOfOtherEnd; + IndexOfOtherEnd := RoleRTInfo.IndexOfOtherEnd; Result := False; {Adjust list} for I := newListOfOtherEnd.Count - 1 downto 0 do @@ -776,11 +991,13 @@ procedure TBoldDirectMultiLinkController.SetFromIdList(ListOfOtherEnd: TBoldObje PreserveOrder: Boolean; WasAdjusted: Boolean; LinkUnlinkMode: TBoldLinkUnlinkMode; + OrderHasChanged: boolean; + OwningBoldObjectLocator: TBoldObjectLocator; G: IBoldGuard; begin G := TBoldGuard.Create(NewListOfOtherEnd); PreChangeCalled := True; - if (mode = bdepPMIn) and (OwningMember.OwningObject.BoldObjectLocator.BoldObjectId.TimeStamp <> BOLDMAXTIMESTAMP) then // fetching old temporal versi + if (mode = bdepPMIn) and (OwningList.OwningObject.IsHistoricVersion) then mode := bdepContents; if assigned(ListOfOtherEnd) then NewListOfOtherEnd := ListOfOtherEnd.Clone @@ -796,9 +1013,10 @@ procedure TBoldDirectMultiLinkController.SetFromIdList(ListOfOtherEnd: TBoldObje LinkUnlinkMode := blulMarkAdjusted else LinkUnlinkMode := blulNone; - PreserveOrder := (mode = bdepContents) or ((mode = bdepPMIn) and OwningObjectList.BoldRoleRTInfo.IsOrdered and not WasAdjusted); - + PreserveOrder := (mode = bdepContents) or ((mode = bdepPMIn) and RoleRTInfo.IsOrdered and not WasAdjusted); + OwningBoldObjectLocator := OwningList.OwningObject.BoldObjectLocator; {we now have a list with the right objects} + OrderHasChanged := false; for I := GetCount - 1 downto 0 do begin OldLocator := LocatorList[i]; @@ -806,7 +1024,7 @@ procedure TBoldDirectMultiLinkController.SetFromIdList(ListOfOtherEnd: TBoldObje begin PreChangeIfNeeded; if mode = bdepPMIn then - SingleLinkUnlink(LocatorList[I], OwningList.OwningObject.BoldObjectLocator, LinkUnlinkMode); + SingleLinkUnlink(LocatorList[I], OwningBoldObjectLocator, LinkUnlinkMode); LocatorList.RemoveByIndex(I); Changed(beItemDeleted, [OldLocator]); end; @@ -821,43 +1039,51 @@ procedure TBoldDirectMultiLinkController.SetFromIdList(ListOfOtherEnd: TBoldObje begin PreChangeIfNeeded; if mode = bdepPMIn then - SingleLinkLinkTo(NewLocator, OwningList.OwningObject.BoldObjectLocator, false, LinkUnlinkMode); + SingleLinkLinkTo(NewLocator, OwningBoldObjectLocator, false, LinkUnlinkMode); LocatorList.Add(NewLocator); Changed(beItemAdded, [NewLocator]); end else if NewLocator = LocatorList[i] then - // All in order, do nothing - else if LocatorList.IndexOf(NewLocator) <> -1 then // locator in list, but at wrong place + else if LocatorList.IndexOf(NewLocator) <> -1 then begin PreChangeIfNeeded; LocatorList.Move(LocatorList.IndexOf(NewLocator), I); - Changed(beOrderChanged, []); + OrderHasChanged := true; end else - begin // locator not in list, insert it, + begin PreChangeIfNeeded; if mode = bdepPMIn then - SingleLinkLinkTo(NewLocator, OwningList.OwningObject.BoldObjectLocator, false, LinkUnlinkMode); + SingleLinkLinkTo(NewLocator, OwningBoldObjectLocator, false, LinkUnlinkMode); LocatorList.Insert(I, NewLocator); Changed(beItemAdded, [NewLocator]); end; end; end - else // Ignore Order + else begin - for I := 0 to NewListOfOtherEnd.Count - 1 do + if NewListOfOtherEnd.Count > 0 then begin - NewLocator := AssertedLocatorForId(NewListOfOtherEnd[I]); - if not IncludesLocator(NewLocator) then + LocatorList.Capacity := NewListOfOtherEnd.Count; + for I := 0 to NewListOfOtherEnd.Count - 1 do begin - PreChangeIfNeeded; - if mode = bdepPMIn then - SingleLinkLinkTo(NewLocator, OwningList.OwningObject.BoldObjectLocator, false, LinkUnlinkMode); - LocatorList.Add(NewLocator); - Changed(beItemAdded, [NewLocator]); + NewLocator := AssertedLocatorForId(NewListOfOtherEnd[I]); + if not IncludesLocator(NewLocator) then + begin + PreChangeIfNeeded; + if mode = bdepPMIn then + SingleLinkLinkTo(NewLocator, OwningBoldObjectLocator, false, LinkUnlinkMode); + LocatorList.Add(NewLocator); + Changed(beItemAdded, [NewLocator]); + end; end; end; end; + if OrderHasChanged then + begin + ReOrder; + Changed(beOrderChanged, []); + end; end; procedure TBoldDirectMultiLinkController.SetLocator(index: Integer; Locator: TBoldObjectLocator); @@ -867,7 +1093,7 @@ procedure TBoldDirectMultiLinkController.SetLocator(index: Integer; Locator: TBo try BoldClearLastFailure; if not StartModify then - BoldRaiseLastFailure(OwningList, 'SetLocator', ''); // do not localize + BoldRaiseLastFailure(OwningList, 'SetLocator', ''); PreChange; GetOtherEndController(LocatorList[index]).UnLink(OwningList.OwningObject.BoldObjectLocator, blulMarkModified); @@ -889,14 +1115,34 @@ function TBoldDirectMultiLinkController.GetStreamName: String; Result := BoldContentName_ObjectIdListRef; end; +function TBoldDirectMultiLinkController.GetFreeStandingClass: TBoldFreeStandingElementClass; +begin + Result := TBFSObjectIdListref; +end; + procedure TBoldDirectMultiLinkController.Unlink(OldLocator: TBoldObjectLocator; Mode: TBoldLinkUnlinkMode); begin - Assert((Mode <> blulMarkAdjusted) or (OwningList.BoldPersistenceState = bvpsCurrent)); - Assert(IncludesLocator(OldLocator)); + Assert((Mode <> blulMarkAdjusted) or (OwningList.BoldPersistenceState = bvpsCurrent), OwningMember.DisplayName); + if (Mode=blulMarkAdjusted) and (not IncludesLocator(OldLocator)) then //PATCH + begin + exit; //PATCH + end; + //The prevoius assert prevents unlink to work when controller is bvpsInvalid + //Current implementation of GetOtherEndController never return Invaild Members so this it not a problem + //But if the other end has fetched a new value from db and is current GetOtherEndController will return it + //This will lead to data corruption - Unlink will set correct value to nil! + + // PATCH + // changed from Assert(IncludesLocator(OldLocator)) to if, it's safe to exit if OldLocator is already removed - Daniel + if not IncludesLocator(OldLocator) then + begin + exit; + end; + BoldClearLastFailure; if Mode = blulMarkModified then if not StartModify then - BoldRaiseLastFailure(OwningList, 'Unlink', ''); // do not localize + BoldRaiseLastFailure(OwningList, 'Unlink', ''); PreChange; LocatorList.Remove(OldLocator); @@ -911,22 +1157,21 @@ function TBoldDirectMultiLinkController.ProxyInterface(const IId: TGUID; Mode: T begin if IsEqualGuid(IID, IBoldObjectIdListRef) then begin - result := ProxyClass.create(self.OwningList, Mode).GetInterface(IID, obj); + result := GetProxy(self.OwningList, Mode).GetInterface(IID, obj); if not result then - raise EBoldInternal.CreateFmt('ProxyClass for %s did not implement IBoldObjectIdListRef', [ClassName]); // do not localize + raise EBoldInternal.CreateFmt('ProxyClass for %s did not implement IBoldObjectIdListRef', [ClassName]); end else result := inherited ProxyInterface(IID, Mode, Obj); end; -function TBoldDirectMultiLinkController.ProxyClass: TBoldMember_ProxyClass; +function TBoldDirectMultiLinkController.GetProxy(Member: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin - result := TBoldDirectmultiLinkController_Proxy; + result := TBoldDirectmultiLinkController_Proxy.MakeProxy(Member ,Mode); end; procedure TBoldDirectMultiLinkController.FreeContent; begin - { TODO : Clear embedded links in locators. } LocatorList.Clear; end; @@ -935,6 +1180,11 @@ procedure TBoldDirectMultiLinkController.PrepareClear; OwningObjectList.EnsureObjects; end; +procedure TBoldDirectMultiLinkController.Exchange(Index1, Index2: integer); +begin + LocatorList.Exchange(Index1, Index2); +end; + procedure TBoldDirectMultiLinkController.Resort; begin BoldSort(0, LocatorList.Count - 1, CompareOrderNo, Exchange); @@ -948,11 +1198,11 @@ function TBoldDirectMultiLinkController.IsInOrder: Boolean; OrderNo1, OrderNo2: integer; begin Result := True; - if OwningObjectList.BoldRoleRTInfo.IsOrdered then + if RoleRTInfo.IsOrdered then for i:= 0 to LocatorList.Count - 2 do begin - OrderNo1 := GetOtherEndController(LocatorList[i]).FOrderno; - OrderNo2 := GetOtherEndController(LocatorList[i + 1]).FOrderno; + OrderNo1 := GetOtherEndController(LocatorList[i]).GetOrderno; + OrderNo2 := GetOtherEndController(LocatorList[i + 1]).GetOrderno; Result := (OrderNo1 <= OrderNo2); if not Result then Exit; @@ -963,19 +1213,14 @@ function TBoldDirectMultiLinkController.CompareOrderNo(Index1, Index2: integer): var OrderNo1, OrderNo2: integer; begin - if OwningObjectList.BoldRoleRTInfo.RoleRTInfoOfOtherEnd.IsSingleRole then + if RoleRTInfo.RoleRTInfoOfOtherEnd.IsSingleRole then begin - OrderNo1 := GetOtherEndController(LocatorList[Index1]).FOrderNo; - OrderNo2 := GetOtherEndController(LocatorList[Index2]).FOrderNo; + OrderNo1 := GetOtherEndController(LocatorList[Index1]).GetOrderNo; + OrderNo2 := GetOtherEndController(LocatorList[Index2]).GetOrderNo; Result := (OrderNo1 - OrderNo2); end else - raise EBold.Create(sOtherEndMustBeSingle); -end; - -procedure TBoldDirectMultiLinkController.Exchange(Index1, Index2: integer); -begin - LocatorList.Exchange(Index1, Index2); + raise EBold.Create('Cannot call compare if OtherEnd is not a single role'); end; procedure TBoldDirectMultiLinkController.ClearNoLongerReferring(NewList: TBoldObjectIdList); @@ -991,14 +1236,18 @@ procedure TBoldDirectMultiLinkController.ClearNoLongerReferring(NewList: TBoldOb OtherEndController: TBoldDirectSingleLinkController; Locator: TBoldObjectLocator; OwnLocator: TBoldObjectLocator; + BoldSystem: TBoldSystem; + TopSortedClasses: TBoldClassTypeInfoList; begin G := TBoldGuard.Create(Traverser); + BoldSystem := self.BoldSystem; Traverser := BoldSystem.Locators.CreateTraverser; - OwnLocator := OwningMember.OwningObject.BoldObjectLocator; - while not Traverser.EndOfList do + OwnLocator := OwningList.OwningObject.BoldObjectLocator; + TopSortedClasses := BoldSystem.BoldSystemTypeInfo.TopSortedClasses; + while Traverser.MoveNext do begin Locator := Traverser.Locator; - if BoldSystem.BoldSystemTypeInfo.TopSortedClasses[Locator.BoldObjectId.TopSortedIndex].BoldIsA(BoldClassTypeInfoOfOtherEnd) then // + if Locator.BoldClassTypeInfo.BoldIsA(BoldClassTypeInfoOfOtherEnd) then begin if assigned(Locator.BoldObject) then begin @@ -1015,7 +1264,6 @@ procedure TBoldDirectMultiLinkController.ClearNoLongerReferring(NewList: TBoldOb else if (EmbeddedIndex <> -1) and (Locator.EmbeddedSingleLinks[EmbeddedIndex] = OwnLocator) then ObjectList.AddLocator(Locator); end; - Traverser.Next; end; end; @@ -1026,9 +1274,9 @@ procedure TBoldDirectMultiLinkController.ClearNoLongerReferring(NewList: TBoldOb OtherEndController: TBoldDirectSingleLinkController; begin Assert(Assigned(NewList)); - EmbeddedIndex := OwningObjectList.BoldRoleRtInfo.RoleRTInfoOfOtherEnd.EmbeddedLinkIndex; - IndexOfOtherEnd := OwningObjectList.BoldRoleRtInfo.IndexOfOtherEnd; - BoldClassTypeInfoOfOtherEnd := OwningObjectList.BoldRoleRtInfo.ClassTypeInfoOfOtherEnd; + EmbeddedIndex := RoleRTInfo.RoleRTInfoOfOtherEnd.EmbeddedLinkIndex; + IndexOfOtherEnd := RoleRTInfo.IndexOfOtherEnd; + BoldClassTypeInfoOfOtherEnd := RoleRTInfo.ClassTypeInfoOfOtherEnd; if (OwningList.BoldPersistenceState = bvpsCurrent) then ListOfReferring := OwningObjectList else @@ -1049,21 +1297,21 @@ procedure TBoldDirectMultiLinkController.ClearNoLongerReferring(NewList: TBoldOb OtherEndController := GetOtherEndController(aLocator); if Assigned(OtherEndController) then begin - Assert(OtherEndController.OwningMember.BoldPersistenceState in [bvpsCurrent, bvpsInvalid]); + Assert(OtherEndController.OwningReference.BoldPersistenceState in [bvpsCurrent, bvpsInvalid]); OtherEndController.FLocator := nil; - if OtherEndController.OwningMember.BoldPersistenceState <> bvpsInvalid then + if OtherEndController.OwningReference.BoldPersistenceState <> bvpsInvalid then begin - OtherEndController.OwningMember.BoldPersistenceState := bvpsInvalid; - OtherEndController.OwningMember.SendEvent(beValueInvalid); + OtherEndController.OwningReference.BoldPersistenceState := bvpsInvalid; + OtherEndController.OwningReference.SendEvent(beValueInvalid); end; OtherEndController.OwningReference.HasOldValues := false; end - else // member for other end not instantiated. + else begin - EmbeddedIndex := OwningObjectList.BoldRoleRtInfo.RoleRTInfoOfOtherEnd.EmbeddedLinkIndex; + EmbeddedIndex := RoleRTInfo.RoleRTInfoOfOtherEnd.EmbeddedLinkIndex; if (EmbeddedIndex <> -1) and (aLocator.EmbeddedSingleLinks[EmbeddedIndex] <> nil) then begin - Assert(aLocator.EmbeddedSingleLinks[EmbeddedIndex] = OwningMember.OwningObject.BoldObjectLocator); + Assert(aLocator.EmbeddedSingleLinks[EmbeddedIndex] = OwningObjectList.OwningObject.BoldObjectLocator); aLocator.EmbeddedSingleLinks[EmbeddedIndex] := nil; end; end; @@ -1082,7 +1330,7 @@ procedure TBoldDirectMultiLinkController.Clear; try BoldClearLastFailure; if not StartModify then - BoldRaiseLastFailure(OwningList, 'Clear', ''); // do not localize + BoldRaiseLastFailure(OwningList, 'Clear', ''); PreChange; while count > 0 do @@ -1109,17 +1357,21 @@ procedure TBoldDirectSingleLinkController.AddToOtherEnd(Mode: TBoldLinkUnlinkMod OtherEndController: TBoldAbstractController; begin OtherEndController := GetOtherEndController(fLocator, Mode <> blulMarkAdjusted); - if Assigned(OtherEndController) and ((Mode <> blulMarkAdjusted) or (OtherEndController.OwningMember.BoldPersistenceState = bvpsCurrent)) then + if Assigned(OtherEndController) and ((Mode <> blulMarkAdjusted) or (OtherEndController.OwningMember.BoldPersistenceState = bvpsCurrent)) then OtherEndController.linkto(OwningReference.OwningObject.BoldObjectLocator, Mode <> blulMarkAdjusted, Mode); end; -procedure TBoldDirectSingleLinkController.SetAndModifyOrderNo(index: Integer); +function TBoldOrderedDirectSingleLinkController.GetOrderNo: Integer; +begin + Result := fOrderNo; +end; + +procedure TBoldOrderedDirectSingleLinkController.SetAndModifyOrderNo(index: Integer); begin - // Note: Setting Orderno does not send a message, but does make member modified. if index <> FOrderno then begin if not StartModify then - BoldRaiseLastFailure(OwningReference, 'SetAndModifyOrderNo', ''); // do not localize + BoldRaiseLastFailure(OwningReference, 'SetAndModifyOrderNo', ''); PreChange; fOrderNo := Index; EndModify; @@ -1138,19 +1390,19 @@ function TBoldDirectSingleLinkController.GetOtherEndController(aLocator: TBoldOb result := nil; if not assigned(aLocator) then exit; - if OwningReference.BoldRoleRtInfo.IndexOfOtherEnd = -1 then + if RoleRTInfo.IndexOfOtherEnd = -1 then exit; - if AllowForceOtherEnd and OwningReference.BoldRoleRtInfo.ForceOtherEnd then + if AllowForceOtherEnd and RoleRTInfo.ForceOtherEnd then begin aLocator.EnsureBoldObject; - aLocator.BoldObject.BoldMembers[OwningReference.BoldRoleRtInfo.IndexOfOtherEnd].EnsureContentsCurrent; + aLocator.BoldObject.BoldMembers[RoleRTInfo.IndexOfOtherEnd].EnsureContentsCurrent; end; if not assigned(aLocator.BoldObject) then exit; - aMember := aLocator.BoldObject.BoldMembers[OwningReference.BoldRoleRtInfo.IndexOfOtherEnd]; + aMember := aLocator.BoldObject.BoldMembers[RoleRTInfo.IndexOfOtherEnd]; if aMember.BoldPersistenceState = bvpsInvalid then exit; @@ -1163,12 +1415,12 @@ procedure TBoldDirectSingleLinkController.LinkTo(NewLocator: TBoldObjectLocator; BoldClearLastFailure; if Mode = blulMarkModified then if not StartModify then - BoldRaiseLastFailure(OwningReference, 'linkto', ''); // do not localize + BoldRaiseLastFailure(OwningReference, 'linkto', ''); if fLocator <> NewLocator then begin RemoveFromOtherEnd(Mode); InternalSetLocator(NewLocator); - if OwningMember.BoldPersistenceState = bvpsInvalid then + if OwningReference.BoldPersistenceState = bvpsInvalid then OwningReference.HasOldValues := True; end; if Mode = blulMarkModified then @@ -1180,7 +1432,7 @@ procedure TBoldDirectSingleLinkController.RemoveFromOtherEnd(Mode: TBoldLinkUnli OtherEndController: TBoldAbstractController; OldLocatorRelevant: Boolean; begin - OldLocatorRelevant := ((OwningMember.BoldPersistenceState <> bvpsInvalid) or OwningReference.HasOldValues); + OldLocatorRelevant := ((OwningReference.BoldPersistenceState <> bvpsInvalid) or OwningReference.HasOldValues); if OldLocatorRelevant then begin OtherEndController := GetOtherEndController(fLocator, Mode <> blulMarkAdjusted); @@ -1191,6 +1443,7 @@ procedure TBoldDirectSingleLinkController.RemoveFromOtherEnd(Mode: TBoldLinkUnli procedure TBoldDirectSingleLinkController.SetFromId(Id: TBoldObjectId; Mode: TBoldDomainElementProxyMode); var + BoldSystem: TBoldSystem; NewLocator: TBoldObjectLocator; procedure SafeCopyOptimisticValues; @@ -1199,20 +1452,19 @@ procedure TBoldDirectSingleLinkController.SetFromId(Id: TBoldObjectId; Mode: TBo begin Value := NewValueInOptimisticLocking as IBoldObjectIdRef; if Assigned(Value) then - Value.SetFromId(Id); + Value.SetFromId(Id, false); end; - // Adjust Newlocator procedure AdjustNewLocator; var i: integer; obj: TBoldObject; OtherEndController: TBoldAbstractController; begin - // check if link modified at other (embedded) end - for i := 0 to OwningMember.BoldSystem.DirtyObjects.Count - 1 do + BoldSystem := self.BoldSystem; + for i := 0 to BoldSystem.DirtyObjects.Count - 1 do begin - Obj := TBoldObject(OwningMember.BoldSystem.DirtyObjects[i]); - if Obj.BoldClassTypeInfo.Conformsto(OwningReference.BoldRoleRTInfo.ClassTypeInfoOfOtherEnd) then + Obj := TBoldObject(BoldSystem.DirtyObjects[i]); + if Obj.BoldClassTypeInfo.Conformsto(RoleRTInfo.ClassTypeInfoOfOtherEnd) then begin OtherEndController := GetOtherEndController(Obj.BoldObjectLocator, false); if (OtherEndController is TBoldDirectSingleLinkController) and @@ -1229,19 +1481,22 @@ procedure TBoldDirectSingleLinkController.SetFromId(Id: TBoldObjectId; Mode: TBo var LinkUnlinkMode: TBoldLinkUnlinkMode; begin - if (mode = bdepPMIn) and (OwningMember.OwningObject.BoldObjectLocator.BoldObjectId.TimeStamp <> BOLDMAXTIMESTAMP) then // fetching old temporal versi + if (mode = bdepPMIn) and (OwningReference.OwningObject.IsHistoricVersion) then mode := bdepContents; NewLocator := LocatorForId(Id); - if (mode = bdepPMIn) and not OwningReference.BoldRoleRTInfo.IsStoredInObject then // non-embedded end of 1-1 + if (mode = bdepPMIn) and not RoleRTInfo.IsStoredInObject then AdjustNewLocator; if Mode = bdepPmIn then LinkUnlinkMode := blulMarkAdjusted else LinkUnlinkMode := blulNone; - if ((OwningMember.BoldPersistenceState = bvpsInvalid) and not OwningReference.HasOldValues) or (fLocator <> NewLocator) then + if ((OwningReference.BoldPersistenceState = bvpsInvalid) and not OwningReference.HasOldValues) or (fLocator <> NewLocator) then begin + if Assigned(NewLocator) then + if not VerifyLocatorType(NewLocator, OwningReference.BoldRoleRTInfo.ClassTypeInfoOfOtherEnd, false) then + raise EBold.CreateFmt('%s.SetFromId: Object %s is incorrect type %s in %s. Expected type: %s', [ClassName, NewLocator.AsString, NewLocator.BoldClassTypeInfo.ExpressionName, OwningReference.debuginfo, OwningReference.BoldRoleRTInfo.ClassTypeInfoOfOtherEnd.ExpressionName]); if mode <> bdepInternalInitialize then PreChange; if mode in [bdepPMIn, bdepUndo] then @@ -1255,22 +1510,22 @@ procedure TBoldDirectSingleLinkController.SetFromId(Id: TBoldObjectId; Mode: TBo procedure TBoldDirectSingleLinkController.SetLocator(NewLocator: TBoldObjectLocator); begin - OwningMember.BoldSystem.StartTransaction; + BoldSystem.StartTransaction; try BoldClearLastFailure; if not StartModify then - BoldRaiseLastFailure(OwningReference, 'SetLocator', ''); // do not localize + BoldRaiseLastFailure(OwningReference, 'SetLocator', ''); - GetOtherEndController(NewLocator, True); // Makes sure other end is fetched if needed before changing this end + GetOtherEndController(NewLocator, True); RemoveFromOtherEnd(blulMarkModified); InternalSetLocator(NewLocator); AddToOtherEnd(blulMarkModified); - if not Assigned(fLocator) then + if not Assigned(fLocator) and RoleRTInfo.IsOrdered then SetAndModifyOrderNo(-1); EndModify; - OwningReference.BoldSystem.CommitTransaction; + BoldSystem.CommitTransaction; except - OwningReference.BoldSystem.RollbackTransaction; + BoldSystem.RollbackTransaction; raise; end; end; @@ -1279,6 +1534,9 @@ procedure TBoldDirectSingleLinkController.InternalSetLocator(NewLocator: TBoldOb begin if fLocator <> NewLocator then begin + if Assigned(NewLocator) then + if not VerifyLocatorType(NewLocator, OwningReference.BoldRoleRTInfo.ClassTypeInfoOfOtherEnd, false) then + raise EBold.CreateFmt('%s.InternalSetLocator: Object %s is incorrect type %s in %s. Expected type: %s', [ClassName, NewLocator.AsString, NewLocator.BoldClassTypeInfo.ExpressionName, OwningReference.debuginfo, OwningReference.BoldRoleRTInfo.ClassTypeInfoOfOtherEnd.ExpressionName]); PreChange; fLocator := NewLocator; Changed(beValueChanged, [NewLocator]); @@ -1290,19 +1548,52 @@ function TBoldDirectSingleLinkController.GetStreamName: String; Result := BoldContentName_ObjectIdRef; end; +function TBoldDirectSingleLinkController.GetFreeStandingClass: TBoldFreeStandingElementClass; +begin + result := TBFSObjectIdRef; +end; + procedure TBoldDirectSingleLinkController.Unlink(OldLocator: TBoldObjectLocator; Mode: TBoldLinkUnlinkMode); begin - Assert((Mode <> blulMarkAdjusted) or (Owningmember.BoldPersistenceState = bvpsCurrent)); - Assert(Not assigned(fLocator) or (fLocator = OldLocator)); +// Assert removed, remains to be verified if it causes other problems, so we log instead +// Assert((Mode <> blulMarkAdjusted) or (Owningmember.BoldPersistenceState = bvpsCurrent), OwningMember.DisplayName); + if not ((Mode <> blulMarkAdjusted) or (OwningReference.BoldPersistenceState = bvpsCurrent)) then + begin + BoldLog.LogFmt('TBoldDirectSingleLinkController.Unlink: BoldObjectId: %s, Mode: %s Member: %s, MemberPersistenceState: %s. OldLocator: %s; HasOldValues = %s', + [ + OwningMember.OwningObject.BoldObjectLocator.AsString, + TypInfo.GetEnumName(TypeInfo(TBoldLinkUnlinkMode), Ord(Mode)), + OwningMember.DisplayName, + TypInfo.GetEnumName(TypeInfo(TBoldValuePersistenceState), Ord(Owningmember.BoldPersistenceState)), + OldLocator.AsString, + BoolToStr(OwningReference.HasOldValues,True)]); + end; + if (Mode=blulMarkAdjusted) and (fLocator<>OldLocator) then //PATCH + begin + exit; //PATCH + end; + //The prevoius assert prevents unlink to work when controller is bvpsInvalid + //Current implementation of GetOtherEndController never return Invaild Members so this it not a problem + //But if the other end has fetched a new value from db and is current GetOtherEndController will return it + //This will lead to data corruption - Unlink will set correct value to nil! + +// Assert(Not assigned(fLocator) or (fLocator = OldLocator)); BoldClearLastFailure; if Mode = blulMarkModified then if not StartModify then - BoldRaiseLastFailure(OwningReference, 'Unlink', ''); // do not localize + BoldRaiseLastFailure(OwningReference, 'Unlink', ''); InternalSetLocator(nil); OwningReference.HasOldValues := False; - SetAndModifyOrderNo(-1); + + if RoleRTInfo.IsOrdered then + begin + if Mode = blulMarkModified then //PATCH + SetAndModifyOrderNo(-1) + else //PATCH + SetOrderNo(-1, bdepPMIn); //PATCH Do not call SetAndModifyOrderNo when Mode is bluMarkAdjustd - this creates an unwanted save + end; if Mode = blulMarkModified then EndModify; end; @@ -1316,15 +1607,10 @@ procedure TBoldDirectSingleLinkController.PreDiscard; begin OtherEndController := GetOtherEndController(Locator, false); if assigned(OtherEndController) and - not OtherEndController.OwningMember.BoldMemberRTInfo.IsStoredInObject and - not OtherEndController.OwningMember.OwningObject.BoldObjectIsNew then + not OtherEndController.RoleRTInfo.IsStoredInObject and + not OtherEndController.OwningObject.BoldObjectIsNew then begin - // normally, the other end will be a multilink, and not dirty, but if the - // other end is either a singlelink (single-single) or a multilink and the - // system is using an XML-Persistence (MultilinksAreStoredInObject) then we - // hope that the other end will be discarded separately. - if not OtherEndController.OwningMember.BoldDirty then - OtherEndController.OwningMember.Invalidate; + OtherEndController.OwningMember.Invalidate; end; end; end; @@ -1333,32 +1619,29 @@ procedure TBoldDirectSingleLinkController.PreDiscard; OldRef: IBoldValue; OldIdRef: IBoldObjectIdRef; begin - // remove the owningobject from the other end RemoveFromOtherEnd(blulNone); - - // Invalidate the old other end if it exists and is loaded OldRef := OwningReference.OldValue; if assigned(OldRef) then begin - // The OldValue must be an ObjectIdRef since this is a direct singlelink controller OldRef.QueryInterface(IBoldObjectIdRef, OldIdRef); if assigned(OldIdRef.Id) then - InvalidateNonembeddedOtherEnd(OwningReference.BoldSystem.EnsuredLocatorByID[OldIdRef.Id]); + InvalidateNonembeddedOtherEnd(BoldSystem.EnsuredLocatorByID[OldIdRef.Id]); end; + fLocator := nil; end; -function TBoldDirectSingleLinkController.ProxyClass: TBoldMember_ProxyClass; +function TBoldDirectSingleLinkController.GetProxy(Member: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin - result := TBoldDirectSingleLinkController_Proxy; + result := TBoldDirectSingleLinkController_Proxy.MakeProxy(Member ,Mode); end; function TBoldDirectSingleLinkController.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; begin if IsEqualGuid(IID, IBoldObjectIdRef) then begin - result := ProxyClass.create(self.OwningReference, Mode).GetInterface(IID, obj); + result := GetProxy(self.OwningReference, Mode).GetInterface(IID, obj); if not result then - raise EBoldInternal.CreateFmt('ProxyClass for %s did not implement IBoldObjectIdRef', [ClassName]); // do not localize + raise EBoldInternal.CreateFmt('ProxyClass for %s did not implement IBoldObjectIdRef', [ClassName]); end else result := inherited ProxyInterface(IID, Mode, Obj); @@ -1366,16 +1649,81 @@ function TBoldDirectSingleLinkController.ProxyInterface(const IId: TGUID; Mode: function TBoldDirectSingleLinkController.MayUpdate: Boolean; begin - result := not OwningReference.BoldRoleRTInfo.IsStoredInObject or + result := not RoleRTInfo.IsStoredInObject or not assigned(fLocator) or fLocator.ObjectIsPersistent; end; procedure TBoldDirectSingleLinkController.MakeDbCurrent; +{$IFDEF FetchFromClassList} + procedure FetchFromClassList; + var + BoldRoleRTInfo: TBoldRoleRTInfo; + OtherEndBoldClassTypeInfo: TBoldClassTypeInfo; + ClassList: TBoldObjectList; + BoldObjectId: TBoldObjectId; + BoldObject: TBoldObject; + IndexOfOtherEnd: Integer; + BoldObjectReference: TBoldObjectReference; + BoldMember: TBoldMember; + i: integer; + Locator: TBoldObjectLocator; + CheckType: boolean; + lTopSortedIndex: Integer; + lTopSortedClasses: TBoldClassTypeInfoList; + AllMembersLoaded: boolean; + begin + OtherEndBoldClassTypeInfo := RoleRTInfo.ClassTypeInfoOfOtherEnd; + IndexOfOtherEnd := RoleRTInfo.IndexOfOtherEnd; + lTopSortedIndex := RoleRTInfo.ClassTypeInfoOfOtherEnd.TopSortedIndex; + ClassList := BoldSystem.Classes[lTopSortedIndex]; + lTopSortedClasses := BoldSystem.BoldSystemTypeInfo.TopSortedClasses; + Locator := OwningReference.OwningObject.BoldObjectLocator; + BoldObjectId := nil; + CheckType := ClassList.BoldPersistenceState <> bvpsCurrent; + AllMembersLoaded := true; + if CheckType then + ClassList := TBoldClassListController(GetControllerForMember(ClassList)).ClosestLoadedClassList; + for i := ClassList.Count - 1 downto 0 do + begin + if CheckType and ((ClassList.Locators[i].BoldObjectID.TopSortedIndex < lTopSortedIndex) or + not ClassList.Locators[i].BoldClassTypeInfo.BoldIsA(OtherEndBoldClassTypeInfo)) then + Continue; + BoldMember := ClassList[i].BoldMemberIfAssigned[IndexOfOtherEnd]; + if Assigned(BoldMember) then + begin + if ((BoldMember as TBoldObjectReference).Locator = Locator) then + begin + BoldObjectId := ClassList[i].BoldObjectLocator.BoldObjectId; + break; + end; + end + else + AllMembersLoaded := false; + end; + if Assigned(BoldObjectId) or AllMembersLoaded then + begin + SetFromId(BoldObjectId, bdepContents); + OwningReference.BoldPersistenceState := bvpsCurrent; + end + else + begin + DbFetchOwningMember; + end; + end; +{$ENDIF} begin - DbFetchOwningMember; +{$IFDEF FetchFromClassList} + if RoleRTInfo.RoleRTInfoOfOtherEnd.IsSingleRole and + TBoldClassListController(GetControllerForMember(BoldSystem.Classes[RoleRTInfo.ClassTypeInfoOfOtherEnd.TopSortedIndex])).IsCurrentOrSuperClassIsCurrent then + begin + FetchFromClassList; + exit; + end; +{$ENDIF} + DbFetchOwningMember; end; -procedure TBoldDirectSingleLinkController.SetOrderNo(NewOrderNo: Integer; +procedure TBoldOrderedDirectSingleLinkController.SetOrderNo(NewOrderNo: Integer; Mode: TBoldDomainElementProxyMode); var OtherEndController: TBoldAbstractController; @@ -1391,6 +1739,22 @@ procedure TBoldDirectSingleLinkController.SetOrderNo(NewOrderNo: Integer; { TBoldIndirectSingleLinkController } +function TBoldIndirectSingleLinkController.GetLinkObjectOwnLinkController(LinkObject: TBoldObject): TBoldLinkObjectSingleLinkController; +begin + result := GetControllerForMember(LinkObject.BoldMembers[RoleRTInfo.OwnIndexInLinkClass]) as TBoldLinkObjectSingleLinkController; +end; + +function TBoldIndirectSingleLinkController.GetLinkObjectOtherLinkController( + LinkObject: TBoldObject): TBoldLinkObjectSingleLinkController; +begin + result := GetControllerForMember(LinkObject.BoldMembers[RoleRTInfo.OtherIndexInLinkClass]) as TBoldLinkObjectSingleLinkController; +end; + +function TBoldIndirectSingleLinkController.GetLinkObjectRoleController: TBoldLinkObjectReferenceController; +begin + result := ControllerForLinkRole as TBoldLinkObjectReferenceController; +end; + procedure TBoldIndirectSingleLinkController.DeleteLink(Mode: TBoldLinkUnlinkMode); var OldLinkObject: TBoldObject; @@ -1407,11 +1771,6 @@ procedure TBoldIndirectSingleLinkController.DeleteLink(Mode: TBoldLinkUnlinkMode end; end; -function TBoldIndirectSingleLinkController.GetLinkObjectOwnLinkController(LinkObject: TBoldObject): TBoldLinkObjectSingleLinkController; -begin - result := GetControllerForMember(LinkObject.BoldMembers[OwningReference.BoldRoleRtInfo.OwnIndexInLinkClass]) as TBoldLinkObjectSingleLinkController; -end; - function TBoldIndirectSingleLinkController.GetLocator: TBoldObjectLocator; begin result := fOtherEndLocator; @@ -1419,11 +1778,11 @@ function TBoldIndirectSingleLinkController.GetLocator: TBoldObjectLocator; procedure TBoldIndirectSingleLinkController.linkto(NewLocator: TBoldObjectLocator; updateOrderNo: Boolean; Mode: TBoldLinkUnlinkMode); begin - Assert((Mode <> blulMarkAdjusted) or (Owningmember.BoldPersistenceState = bvpsCurrent)); + Assert((Mode <> blulMarkAdjusted) or (OwningReference.BoldPersistenceState = bvpsCurrent), OwningMember.DisplayName); BoldClearLastFailure; if Mode = blulMarkModified then if not StartModify then - BoldRaiseLastFailure(OwningReference, 'Linkto', ''); // do not localize + BoldRaiseLastFailure(OwningReference, 'Linkto', ''); if fLinkObjectLocator <> NewLocator then begin @@ -1432,6 +1791,8 @@ procedure TBoldIndirectSingleLinkController.linkto(NewLocator: TBoldObjectLocato PreChange; fLinkObjectLocator := NewLocator; fOtherEndLocator := GetLinkObjectOtherLinkController(NewLocator.EnsuredBoldObject).fLocator; + if not VerifyLocatorType(fOtherEndLocator, OwningReference.BoldRoleRTInfo.ClassTypeInfoOfOtherEnd, false) then + raise EBold.CreateFmt('%s.linkto: Object %s is incorrect type %s in %s. Expected type: %s', [ClassName, fOtherEndLocator.AsString, fOtherEndLocator.BoldClassTypeInfo.ExpressionName, OwningReference.debuginfo, OwningReference.BoldRoleRTInfo.ClassTypeInfoOfOtherEnd.ExpressionName]); end; Changed(beValueChanged, [fOtherEndLocator]); GetLinkObjectRoleController.Changed(beValueChanged, [fLinkObjectLocator]); @@ -1440,15 +1801,35 @@ procedure TBoldIndirectSingleLinkController.linkto(NewLocator: TBoldObjectLocato end; function TBoldIndirectSingleLinkController.NewLink(OtherLocator: TBoldObjectLocator; Mode: TBoldLinkUnlinkMode): TBoldObject; +{$IFDEF ReuseDeletedLinkObjectOnRelink} + function FindLinkInOldValues: TBoldObject; + var + s: IBoldObjectIdRefPair; + begin + result := nil; + if Supports(OwningReference.OldValue, IBoldObjectIdRefPair, s) and Assigned(s.Id2) then + if s.Id2.IsEqual[OtherLocator.BoldObjectID] then + begin + result := BoldSystem.Locators.ObjectByID[s.Id1]; + Assert(result is RoleRTInfo.LinkClassTypeInfo.ObjectClass); + result.AsIBoldObjectContents[bdepContents].BoldExistenceState := besExisting; + result.AsIBoldObjectContents[bdepContents].BoldPersistenceState := bvpsCurrent; + end; + end; +{$ENDIF} var LinkObject: TBoldObject; LinkClassTypeInfo: TBoldClassTypeinfo; OtherEndController: TBoldAbstractController; begin - LinkClassTypeInfo := OwningReference.BoldRoleRTInfo.LinkClassTypeInfo; - LinkObject := TBoldObjectClass(LinkClassTypeInfo.ObjectClass).InternalCreateNewWithClassAndSystem(LinkClassTypeInfo, OwningReference.BoldSystem, + LinkClassTypeInfo := RoleRTInfo.LinkClassTypeInfo; +{$IFDEF ReuseDeletedLinkObjectOnRelink} + LinkObject := FindLinkInOldValues; + if not Assigned(LinkObject) then +{$ENDIF} + LinkObject := TBoldObjectClass(LinkClassTypeInfo.ObjectClass).InternalCreateNewWithClassAndSystem(LinkClassTypeInfo, BoldSystem, OtherLocator.ObjectIsPersistent and OwningReference.OwningObject.BoldPersistent); - OtherEndController := GetLinkObjectOtherLinkController(LinkObject).GetOtherEndController(OtherLocator, true); // Ensure other end fetched if forced + OtherEndController := GetLinkObjectOtherLinkController(LinkObject).GetOtherEndController(OtherLocator, true); GetLinkObjectOwnLinkController(LinkObject).LinkTo(OwningReference.OwningObject.BoldObjectLocator, true, Mode); GetLinkObjectOtherLinkController(LinkObject).LinkTo(OtherLocator, true, Mode); if Assigned(OtherEndController) then @@ -1468,17 +1849,16 @@ procedure TBoldIndirectSingleLinkController.SetFromIds(Id1, Id2: TBoldObjectId; if Assigned(Value) then Value.SetFromIds(Id1, Id2); end; - - // Adjust NewLinkLocator and NewOtherEndLocator procedure AdjustLocators; var BoldObject: TBoldObject; i: integer; BoldLinkClassTypeInfo: TBoldClassTypeInfo; IndexOfOwnEnd, IndexOfOtherEnd, EmbeddedIndexOfOwnEnd, EmbeddedIndexOfOtherEnd: integer; + BoldSystem: TBoldSystem; begin - IndexOfOwnEnd := OwningReference.BoldRoleRTInfo.OwnIndexInLinkClass; - IndexOfOtherEnd := OwningReference.BoldRoleRTInfo.OtherIndexInLinkClass; + IndexOfOwnEnd := RoleRTInfo.OwnIndexInLinkClass; + IndexOfOtherEnd := RoleRTInfo.OtherIndexInLinkClass; if Assigned(NewLinkLocator) then begin BoldObject := NewLinkLocator.BoldObject; @@ -1491,25 +1871,26 @@ procedure TBoldIndirectSingleLinkController.SetFromIds(Id1, Id2: TBoldObjectId; NewOtherEndLocator := nil; end end - else {object not loaded, set embedded links} { TODO : Is this really related to adjust? } + else {object not loaded, set embedded links} begin if Assigned(NewLinkLocator) then begin - EmbeddedIndexOfOwnEnd := OwningReference.BoldRoleRTInfo.LinkClassTypeInfo.AllMembers[IndexOfOwnEnd].EmbeddedLinkIndex; - EmbeddedIndexOfOtherEnd := OwningReference.BoldRoleRTInfo.LinkClassTypeInfo.AllMembers[IndexOfOtherEnd].EmbeddedLinkIndex; + EmbeddedIndexOfOwnEnd := RoleRTInfo.LinkClassTypeInfo.AllMembers[IndexOfOwnEnd].EmbeddedLinkIndex; + EmbeddedIndexOfOtherEnd := RoleRTInfo.LinkClassTypeInfo.AllMembers[IndexOfOtherEnd].EmbeddedLinkIndex; if (EmbeddedIndexOfOwnEnd <> -1) then - NewLinkLocator.EmbeddedSingleLinks[EmbeddedIndexOfOwnEnd] := OwningMember.OwningObject.BoldObjectLocator; + NewLinkLocator.EmbeddedSingleLinks[EmbeddedIndexOfOwnEnd] := OwningReference.OwningObject.BoldObjectLocator; if (EmbeddedIndexOfOtherEnd <> -1) then NewLinkLocator.EmbeddedSingleLinks[EmbeddedIndexOfOtherEnd] := NewOtherEndLocator; end; end; end; - for I := 0 to OwningMember.BoldSystem.DirtyObjects.Count - 1 do + BoldSystem := self.BoldSystem; + for I := 0 to BoldSystem.DirtyObjects.Count - 1 do begin - BoldLinkClassTypeInfo := OwningReference.BoldRoleRtInfo.LinkClassTypeInfo; - BoldObject := OwningMember.BoldSystem.DirtyObjects[I]; + BoldLinkClassTypeInfo := RoleRTInfo.LinkClassTypeInfo; + BoldObject := BoldSystem.DirtyObjects[I]; if (BoldObject.BoldClassTypeInfo.BoldIsA(BoldLinkClassTypeInfo)) and (BoldObject.BoldExistenceState = besExisting) and - (((BoldObject.BoldMembers[IndexOfOwnEnd]) as TBoldObjectReference).BoldObject = OwningMember.OwningObject) then + (((BoldObject.BoldMembers[IndexOfOwnEnd]) as TBoldObjectReference).BoldObject = OwningReference.OwningObject) then begin SafeCopyOptimisticValues; NewLinkLocator := BoldObject.BoldObjectLocator; @@ -1519,7 +1900,7 @@ procedure TBoldIndirectSingleLinkController.SetFromIds(Id1, Id2: TBoldObjectId; end; begin - if (mode = bdepPMIn) and (OwningMember.OwningObject.BoldObjectLocator.BoldObjectId.TimeStamp <> BOLDMAXTIMESTAMP) then // fetching old temporal versi + if (mode = bdepPMIn) and (OwningReference.OwningObject.IsHistoricVersion) then mode := bdepContents; NewLinkLocator := LocatorForId(Id1); NewOtherEndLocator := LocatorForId(Id2); @@ -1528,6 +1909,9 @@ procedure TBoldIndirectSingleLinkController.SetFromIds(Id1, Id2: TBoldObjectId; if fLinkObjectLocator <> NewLinkLocator then begin + if Assigned(NewOtherEndLocator) then + if not VerifyLocatorType(NewOtherEndLocator, OwningReference.BoldRoleRTInfo.ClassTypeInfoOfOtherEnd, false) then + raise EBold.CreateFmt('%s.SetFromIds: Object %s is incorrect type %s in %s. Expected type: %s', [ClassName, NewOtherEndLocator.AsString, NewOtherEndLocator.BoldClassTypeInfo.ExpressionName, OwningReference.debuginfo, OwningReference.BoldRoleRTInfo.ClassTypeInfoOfOtherEnd.ExpressionName]); PreChange; fLinkObjectLocator := NewLinkLocator; fOtherEndLocator := NewOtherEndLocator; @@ -1540,12 +1924,15 @@ procedure TBoldIndirectSingleLinkController.SetLocator(NewLocator: TBoldObjectLo begin if NewLocator = fLinkObjectLocator then exit; - - OwningReference.BoldSystem.StartTransaction; + BoldSystem.StartTransaction; try BoldClearLastFailure; if not StartModify then - BoldRaiseLastFailure(OwningReference, 'SetLocator', ''); // do not localize + BoldRaiseLastFailure(OwningReference, 'SetLocator', ''); + + if Assigned(NewLocator) then + if not VerifyLocatorType(NewLocator, OwningReference.BoldRoleRTInfo.ClassTypeInfoOfOtherEnd, false) then + raise EBold.CreateFmt('%s.SetLocator: Object %s is incorrect type %s in %s. Expected type: %s', [ClassName, NewLocator.AsString, NewLocator.BoldClassTypeInfo.ExpressionName, OwningReference.debuginfo, OwningReference.BoldRoleRTInfo.ClassTypeInfoOfOtherEnd.ExpressionName]); DeleteLink(blulMarkModified); PreChange; @@ -1555,11 +1942,11 @@ procedure TBoldIndirectSingleLinkController.SetLocator(NewLocator: TBoldObjectLo else fLinkObjectLocator := nil; Changed(beValueChanged, [NewLocator]); - GetLinkObjectRoleController. Changed(beValueChanged, [fLinkObjectLocator]); + GetLinkObjectRoleController.Changed(beValueChanged, [fLinkObjectLocator]); EndModify; - OwningReference.BoldSystem.CommitTransaction; + BoldSystem.CommitTransaction; except - OwningReference.BoldSystem.RollbackTransaction; + BoldSystem.RollbackTransaction; raise; end; end; @@ -1569,14 +1956,19 @@ function TBoldIndirectSingleLinkController.GetStreamName: String; Result := BoldContentName_ObjectIdRefPair; end; +function TBoldIndirectSingleLinkController.GetFreeStandingClass: TBoldFreeStandingElementClass; +begin + result := TBFSObjectIdRefPair; +end; + procedure TBoldIndirectSingleLinkController.Unlink(OldLocator: TBoldObjectLocator; Mode: TBoldLinkUnlinkMode); begin - Assert((Mode <> blulMarkAdjusted) or (Owningmember.BoldPersistenceState = bvpsCurrent)); + Assert((Mode <> blulMarkAdjusted) or (OwningReference.BoldPersistenceState = bvpsCurrent), OwningMember.DisplayName); Assert(fLinkObjectLocator = OldLocator); BoldClearLastFailure; if Mode = blulMarkModified then if not StartModify then - BoldRaiseLastFailure(OwningReference, 'Unlink', ''); // do not localize + BoldRaiseLastFailure(OwningReference, 'Unlink', ''); PreChange; fLinkObjectLocator := nil; @@ -1587,23 +1979,18 @@ procedure TBoldIndirectSingleLinkController.Unlink(OldLocator: TBoldObjectLocato EndModify; end; -function TBoldIndirectSingleLinkController.GetLinkObjectRoleController: TBoldLinkObjectReferenceController; -begin - result := ControllerForLinkRole as TBoldLinkObjectReferenceController; -end; - -function TBoldIndirectSingleLinkController.ProxyClass: TBoldMember_ProxyClass; +function TBoldIndirectSingleLinkController.GetProxy(Member: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin - result := TBoldIndirectSingleLinkController_Proxy; + result := TBoldIndirectSingleLinkController_Proxy.MakeProxy(Member ,Mode); end; function TBoldIndirectSingleLinkController.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; begin if IsEqualGuid(IID, IBoldObjectIdRefPair) then begin - result := ProxyClass.create(self.OwningReference, Mode).GetInterface(IID, obj); + result := GetProxy(self.OwningReference, Mode).GetInterface(IID, obj); if not result then - raise EBoldInternal.CreateFmt('ProxyClass for %s did not implement IBoldObjectIdRefPair', [ClassName]); // do not localize + raise EBoldInternal.CreateFmt('ProxyClass for %s did not implement IBoldObjectIdRefPair', [ClassName]); end else result := inherited ProxyInterface(IID, Mode, Obj); @@ -1611,16 +1998,10 @@ function TBoldIndirectSingleLinkController.ProxyInterface(const IId: TGUID; Mode function TBoldIndirectSingleLinkController.MayUpdate: Boolean; begin - result := not OwningReference.BoldRoleRTInfo.IsStoredInObject or + result := not RoleRTInfo.IsStoredInObject or not assigned(fLinkObjectLocator) or fLinkObjectLocator.ObjectIsPersistent; end; -function TBoldIndirectSingleLinkController.GetLinkObjectOtherLinkController( - LinkObject: TBoldObject): TBoldLinkObjectSingleLinkController; -begin - result := GetControllerForMember(LinkObject.BoldMembers[OwningReference.BoldRoleRtInfo.OtherIndexInLinkClass]) as TBoldLinkObjectSingleLinkController; -end; - function TBoldIndirectSingleLinkController.AssertIntegrity: Boolean; begin if fLinkObjectLocator = nil then @@ -1631,14 +2012,11 @@ function TBoldIndirectSingleLinkController.AssertIntegrity: Boolean; if Assigned(fLinkObjectLocator.BoldObject) then begin Assert(fLinkObjectLocator.BoldObject.BoldExistenceState = besExisting); - Assert(GetLinkObjectOwnLinkController(fLinkObjectLocator.BoldObject).fLocator = OwningMember.OwningObject.BoldObjectLocator); + Assert(GetLinkObjectOwnLinkController(fLinkObjectLocator.BoldObject).fLocator = OwningReference.OwningObject.BoldObjectLocator); Assert(GetLinkObjectOtherLinkController(fLinkObjectLocator.BoldObject).fLocator = fOtherEndLocator); - { TODO : Check included in other end, if loaded. } end - else // link object no loaded + else begin - { TODO : Check values in locator itself } - { TODO : Check included in other end, if loaded. } end; end; Result := True; @@ -1651,6 +2029,16 @@ procedure TBoldIndirectSingleLinkController.MakeDbCurrent; { TBoldIndirectMultiLinkController } +function TBoldIndirectMultiLinkController.GetLinkObjectOwnLinkController(LinkObject: TBoldObject): TBoldLinkObjectSingleLinkController; +begin + result := GetControllerForMember(LinkObject.BoldMembers[RoleRTInfo.OwnIndexInLinkClass]) as TBoldLinkObjectSingleLinkController; +end; + +function TBoldIndirectMultiLinkController.GetLinkObjectListController: TBoldLinkObjectListController; +begin + result := ControllerForLinkMember as TBoldLinkObjectListController; +end; + procedure TBoldIndirectMultiLinkController.AddLocator(Locator: TBoldObjectLocator); var LinkObject: TBoldObject; @@ -1660,15 +2048,15 @@ procedure TBoldIndirectMultiLinkController.AddLocator(Locator: TBoldObjectLocato try BoldClearLastFailure; if not StartModify then - BoldRaiseLastFailure(OwningList, 'AddLocator', ''); // do not localize + BoldRaiseLastFailure(OwningList, 'AddLocator', ''); PreChange; LinkObject := NewLink(Locator, blulMarkModified); LinkLocatorList.Add(LinkObject.BoldObjectLocator); ReferredLocatorList.Add(Locator); Assert(ReferredLocatorList.Count = LinkLocatorList.Count); - if OwningObjectList.BoldRoleRtInfo.IsOrdered then - GetLinkObjectOwnLinkController(LinkObject).SetAndModifyOrderNo(LinkLocatorList.IndexOf(LinkObject.BoldObjectLocator)); // Complexity warning: A loop of adds will take O(n^2) + if RoleRTInfo.IsOrdered then + GetLinkObjectOwnLinkController(LinkObject).SetAndModifyOrderNo(LinkLocatorList.IndexOf(LinkObject.BoldObjectLocator)); Changed(beItemAdded, [Locator]); GetLinkObjectListController.Changed(beItemAdded, [LinkObject.BoldObjectLocator]); EndModify; @@ -1686,6 +2074,12 @@ constructor TBoldIndirectMultiLinkController.Create(OwningList: TBoldObjectList) FReferredList := TBoldObjectLocatorList.Create; end; +function TBoldIndirectMultiLinkController.GetLinkObjectOtherLinkController( + LinkObject: TBoldObject): TBoldLinkObjectSingleLinkController; +begin + result := GetControllerForMember(LinkObject.BoldMembers[RoleRTInfo.OtherIndexInLinkClass]) as TBoldLinkObjectSingleLinkController; +end; + procedure TBoldIndirectMultiLinkController.DeleteLink(LinkObjectLocator: TBoldObjectLocator; Mode: TBoldLinkUnlinkMode); var OldLinkObject: TBoldObject; @@ -1693,8 +2087,8 @@ procedure TBoldIndirectMultiLinkController.DeleteLink(LinkObjectLocator: TBoldOb OldLinkObject := LinkObjectLocator.EnsuredBoldObject; GetLinkObjectOtherLinkController(OldLinkObject).RemoveFromOtherEnd(Mode); GetLinkObjectOtherLinkController(OldLinkObject).Unlink(GetLinkObjectOtherLinkController(OldLinkObject).fLocator, Mode); - GetLinkObjectOwnLinkController(OldLinkObject).PreChange; - GetLinkObjectOwnLinkController(OldLinkObject).Unlink(OwningMember.OwningObject.BoldObjectLocator, Mode); + GetLinkObjectOwnLinkController(OldLinkObject).PreChange; + GetLinkObjectOwnLinkController(OldLinkObject).Unlink(OwningObjectList.OwningObject.BoldObjectLocator, Mode); OldLinkObject.Delete; end; @@ -1706,9 +2100,107 @@ destructor TBoldIndirectMultiLinkController.Destroy; end; procedure TBoldIndirectMultiLinkController.MakeDbCurrent; +{$IFDEF FetchFromClassList} + procedure FetchFromClassList; + var + ClassList: TBoldObjectList; + lBoldGuard: IBoldGuard; + lBoldObject: TBoldObject; + lOtherIndexInLinkClass: Integer; + lOwnBoldObjectLocator: TBoldObjectLocator; + lLinkClassTypeInfo: TBoldClassTypeInfo; + lOwnIndexInLinkClass: integer; + lListOfLinkObjects: TBoldObjectIdList; + lListOfOtherEnd: TBoldObjectIdList; + lThisEndInLinkClass: TBoldObjectReference; + lOtherEndInLinkClass: TBoldObjectReference; + lTopSortedIndex: Integer; + lMultiLinkItem: TIndirectMultiLinkItem; + lSortList: TList; + i: integer; + lIsOrdered: boolean; + CheckType: boolean; + lTopSortedClasses: TBoldClassTypeInfoList; + begin + lBoldGuard := TBoldGuard.Create(lListOfLinkObjects, lListOfOtherEnd, lSortList); + lLinkClassTypeInfo := RoleRTInfo.LinkClassTypeInfo; + ClassList := BoldSystem.Classes[lLinkClassTypeInfo.TopSortedIndex]; + lTopSortedIndex := RoleRTInfo.ClassTypeInfoOfOtherEnd.TopSortedIndex; + lOtherIndexInLinkClass := RoleRTInfo.OtherIndexInLinkClass; + lOwnIndexInLinkClass := RoleRTInfo.OwnIndexInLinkClass ; + lTopSortedClasses := BoldSystem.BoldSystemTypeInfo.TopSortedClasses; + lListOfLinkObjects := TBoldObjectIdList.Create; + lListOfOtherEnd:= TBoldObjectIdList.Create; + lIsOrdered := RoleRTInfo.IsOrdered; + if lIsOrdered then + lSortList := TList.Create; + lOwnBoldObjectLocator := OwningObjectList.OwningObject.BoldObjectLocator; + CheckType := ClassList.BoldPersistenceState <> bvpsCurrent; + if CheckType then + ClassList := TBoldClassListController(GetControllerForMember(ClassList)).ClosestLoadedClassList; + Assert(Assigned(ClassList)); + for i := 0 to ClassList.Count - 1 do + begin + if CheckType and not ClassList.Locators[i].BoldClassTypeInfo.BoldIsA(lLinkClassTypeInfo) then + Continue; + lBoldObject := ClassList[i]; + lThisEndInLinkClass := lBoldObject.BoldMembers{IfAssigned}[lOwnIndexInLinkClass] as TBoldObjectReference; + if Assigned(lThisEndInLinkClass) and (lThisEndInLinkClass.Locator = lOwnBoldObjectLocator) then + begin + lOtherEndInLinkClass := lBoldObject.BoldMembers[lOtherIndexInLinkClass] as TBoldObjectReference; + Assert(Assigned(lOtherEndInLinkClass.Locator)); +{ + if not Assigned(lOtherEndInLinkClass.Locator) then + begin + if lOtherEndInLinkClass.BoldDirty then + lOtherEndInLinkClass.Discard; + Assert(Assigned(lOtherEndInLinkClass.Locator)); + end; +} + if lIsOrdered then + begin + lMultiLinkItem := TIndirectMultiLinkItem.Create; + lMultiLinkItem.ObjectId := lBoldObject.BoldObjectLocator.BoldObjectId; + lMultiLinkItem.OtherObjectId := lOtherEndInLinkClass.Locator.BoldObjectId; + lMultiLinkItem.OrderNo := (GetControllerForMember(lThisEndInLinkClass) as TBoldDirectSingleLinkController).OrderNo; + lSortList.Add(lMultiLinkItem); + end + else + begin + lListOfLinkObjects.Add(lBoldObject.BoldObjectLocator.BoldObjectId); + lListOfOtherEnd.Add(lOtherEndInLinkClass.Locator.BoldObjectId); + end; + end; + end; + if lIsOrdered then + begin + lSortList.Sort(_CompareOrderNo); + for i := 0 to lSortList.Count - 1 do + begin + lMultiLinkItem := TIndirectMultiLinkItem(lSortList[i]); + lListOfLinkObjects.Add(lMultiLinkItem.ObjectId); + lListOfOtherEnd.Add(lMultiLinkItem.OtherObjectId); + lMultiLinkItem.free; + end; + end; + +// DbFetchOwningMember; +// Assert(lListOfOtherEnd.count = OwningObjectList.Count); + SetFromIDLists(lListOfLinkObjects, lListOfOtherEnd, bdepContents); + OwningObjectList.BoldPersistenceState := bvpsCurrent; + end; +{$ENDIF} begin - EnsureOrder; - DbFetchOwningMember; + if OwningObjectList.BoldPersistenceState <> bvpsCurrent then + begin + EnsureOrder; +{$IFDEF FetchFromClassList} + if TBoldClassListController(GetControllerForMember(BoldSystem.Classes[RoleRTInfo.LinkClassTypeInfo.TopSortedIndex])).IsCurrentOrSuperClassIsCurrent then + FetchFromClassList + else +{$ENDIF} + DbFetchOwningMember; + end; end; function TBoldIndirectMultiLinkController.GetCount: Integer; @@ -1716,11 +2208,6 @@ function TBoldIndirectMultiLinkController.GetCount: Integer; Result := LinkLocatorList.Count; end; -function TBoldIndirectMultiLinkController.GetLinkObjectOwnLinkController(LinkObject: TBoldObject): TBoldLinkObjectSingleLinkController; -begin - result := GetControllerForMember(LinkObject.BoldMembers[OwningObjectList.BoldRoleRtInfo.OwnIndexInLinkClass]) as TBoldLinkObjectSingleLinkController; -end; - function TBoldIndirectMultiLinkController.GetLocator(index: Integer): TBoldObjectLocator; begin EnsureOrder; @@ -1732,13 +2219,13 @@ function TBoldIndirectMultiLinkController.GetLocatorByQualifiersAndSubscribe(Mem EnsureOrder; if not ReferredLocatorList.HasMembersIndex then begin - if assigned(OwningObjectList.BoldRoleRTInfo) and OwningObjectList.BoldRoleRTInfo.isQualified then + if assigned(RoleRTInfo) and RoleRTInfo.isQualified then begin OwningObjectList.EnsureObjects; - ReferredLocatorList.InitMembersIndex(OwningObjectList, OwningObjectList.BoldRoleRTInfo.Qualifiers) + ReferredLocatorList.InitMembersIndex(OwningObjectList, RoleRTInfo.Qualifiers) end else - raise EBold.CreateFmt(sRolenotQualified, [ClassName]); + raise EBold.CreateFmt('%s.GetLocatorByQualifiers: Object list does not have a member index or role is not qualified', [ClassName]); end; result := ReferredLocatorList.GetLocatorByAttributesAndSubscribe(MemberList, Subscriber); end; @@ -1763,7 +2250,7 @@ procedure TBoldIndirectMultiLinkController.InsertLocator(index: Integer; Locator try BoldClearLastFailure; if not StartModify then - BoldRaiseLastFailure(OwningList, 'InsertLocator', ''); // do not localize + BoldRaiseLastFailure(OwningList, 'InsertLocator', ''); PreChange; NewLinkLocator := NewLink(Locator, blulMarkModified).BoldObjectLocator; @@ -1784,19 +2271,22 @@ procedure TBoldIndirectMultiLinkController.linkto(NewLocator: TBoldObjectLocator var NewReferredLocator: TBoldObjectLocator; begin - Assert((Mode <> blulMarkAdjusted) or (OwningList.BoldPersistenceState = bvpsCurrent)); - Assert(not LinkLocatorList.LocatorInList[NewLocator], 'locator already in list'); + Assert((Mode <> blulMarkAdjusted) or (OwningList.BoldPersistenceState = bvpsCurrent), OwningMember.DisplayName); + if LinkLocatorList.LocatorInList[NewLocator] then // locator already in list so just exit, this used to be an assert - Daniel + begin + exit; + end; BoldClearLastFailure; if Mode = blulMarkModified then if not StartModify then - BoldRaiseLastFailure(OwningList, 'Linkto', ''); // do not localize + BoldRaiseLastFailure(OwningList, 'Linkto', ''); PreChange; NewReferredLocator := GetLinkObjectOtherLinkController(NewLocator.EnsuredBoldObject).fLocator; LinkLocatorList.Add(NewLocator); ReferredLocatorList.Add(NewReferredLocator); - if updateOrderNo and OwningObjectList.BoldRoleRtInfo.IsOrdered then - GetLinkObjectOwnLinkController(NewLocator.BoldObject).SetAndModifyOrderNo(LinkLocatorList.IndexOf(NewLocator)); // Complexity warning: A loop of adds will take O(n^2) + if updateOrderNo and RoleRTInfo.IsOrdered then + GetLinkObjectOwnLinkController(NewLocator.BoldObject).SetAndModifyOrderNo(LinkLocatorList.IndexOf(NewLocator)); //TODO - This could have side effect when mode is blulMarkAdjusted if Mode = blulMarkAdjusted then OwningObjectList.Adjusted := True; Changed(beItemAdded, [NewReferredLocator]); @@ -1808,14 +2298,14 @@ procedure TBoldIndirectMultiLinkController.linkto(NewLocator: TBoldObjectLocator procedure TBoldIndirectMultiLinkController.Move(CurrentIndex, NewIndex: Integer); begin EnsureOrder; - if not OwningObjectList.BoldRoleRtInfo.IsOrdered then + if not RoleRTInfo.IsOrdered then exit; BoldSystem.StartTransaction; try BoldClearLastFailure; if not StartModify then - BoldRaiseLastFailure(OwningList, 'Move', ''); // do not localize + BoldRaiseLastFailure(OwningList, 'Move', ''); PreChange; LinkLocatorList.Move(CurrentIndex, NewIndex); @@ -1832,16 +2322,41 @@ procedure TBoldIndirectMultiLinkController.Move(CurrentIndex, NewIndex: Integer) end; function TBoldIndirectMultiLinkController.NewLink(OtherLocator: TBoldObjectLocator; Mode: TBoldLinkUnlinkMode): TBoldObject; +{$IFDEF ReuseDeletedLinkObjectOnRelink} + function FindLinkInOldValues: TBoldObject; + var + s: IBoldObjectIdListRefPair; + i: integer; + begin + result := nil; + if Supports(OwningObjectList.OldValue, IBoldObjectIdListRefPair, s) then + for i := 0 to s.Count-1 do + begin + if s.IdList2[i].IsEqual[OtherLocator.BoldObjectID] then + begin + result := BoldSystem.Locators.ObjectByID[s.IdList1[i]]; + Assert(result is RoleRTInfo.LinkClassTypeInfo.ObjectClass); + result.AsIBoldObjectContents[bdepContents].BoldExistenceState := besExisting; + result.AsIBoldObjectContents[bdepContents].BoldPersistenceState := bvpsCurrent; + exit; + end; + end; + end; +{$ENDIF} var LinkObject: TBoldObject; LinkClassTypeInfo: TBoldClassTypeInfo; OtherEndController: TBoldAbstractController; begin - LinkClassTypeInfo := OwningObjectList.BoldRoleRTInfo.LinkClassTypeInfo; - LinkObject := TBoldObjectClass(LinkClassTypeInfo.ObjectClass).InternalCreateNewWithClassAndSystem(LinkClassTypeInfo, OwningMember.BoldSystem, - OtherLocator.ObjectIsPersistent and OwningMember.OwningObject.BoldPersistent); - OtherEndController := GetLinkObjectOtherLinkController(LinkObject).GetOtherEndController(OtherLocator, true); // Ensure other end fetched if forced - GetLinkObjectOwnLinkController(LinkObject).LinkTo(OwningMember.OwningObject.BoldObjectLocator, true, Mode); + LinkClassTypeInfo := RoleRTInfo.LinkClassTypeInfo; +{$IFDEF ReuseDeletedLinkObjectOnRelink} + LinkObject := FindLinkInOldValues; + if not Assigned(LinkObject) then +{$ENDIF} + LinkObject := TBoldObjectClass(LinkClassTypeInfo.ObjectClass).InternalCreateNewWithClassAndSystem(LinkClassTypeInfo, BoldSystem, + OtherLocator.ObjectIsPersistent and OwningObjectList.OwningObject.BoldPersistent); + OtherEndController := GetLinkObjectOtherLinkController(LinkObject).GetOtherEndController(OtherLocator, true); + GetLinkObjectOwnLinkController(LinkObject).LinkTo(OwningObjectList.OwningObject.BoldObjectLocator, true, Mode); GetLinkObjectOtherLinkController(LinkObject).LinkTo(OtherLocator, true, Mode); if Assigned(OtherEndController) then OtherEndController.LinkTo(LinkObject.BoldObjectLocator, false, Mode); @@ -1858,14 +2373,14 @@ procedure TBoldIndirectMultiLinkController.RemoveByIndex(index: Integer); try BoldClearLastFailure; if not StartModify then - BoldRaiseLastFailure(OwningList, 'RemoveByIndex', ''); // do not localize + BoldRaiseLastFailure(OwningList, 'RemoveByIndex', ''); PreChange; Locator := ReferredLocatorList[index]; LinkLocator := LinkLocatorList[index]; BoldSystem.DelayObjectDestruction; try - DeleteLink(LinkLocator, blulMarkModified); // This will remove from other end but not from own + DeleteLink(LinkLocator, blulMarkModified); LinkLocatorList.RemoveByIndex(index); ReferredLocatorList.RemoveByIndex(index); finally @@ -1884,22 +2399,22 @@ procedure TBoldIndirectMultiLinkController.RemoveByIndex(index: Integer); procedure TBoldIndirectMultiLinkController.ReOrder; var -{$IFOPT C+} // if Assertions on +{$IFOPT C+} index: Integer; {$ENDIF} I: Integer; Locator: TBoldObjectLocator; begin - if OwningObjectList.BoldRoleRtInfo.IsOrdered then + if RoleRTInfo.IsOrdered then begin -{$IFOPT C+} // if Assertions on - index := OwningObjectList.BoldRoleRtInfo.IndexOfOtherEnd; +{$IFOPT C+} + index := RoleRTInfo.IndexOfOtherEnd; Assert(index <> -1); {$ENDIF} for I := 0 to LinkLocatorList.Count - 1 do begin Locator := LinkLocatorList.Locators[I]; - Locator.EnsureBoldObject; // Note, can give fetch during fetch, save till all fetched + Locator.EnsureBoldObject; end; for I := 0 to LinkLocatorList.Count - 1 do begin @@ -1921,8 +2436,6 @@ procedure TBoldIndirectMultiLinkController.SetFromIDLists(ListOfLinkObjects, Lis if Assigned(Value) then Value.SetFromIdLists(ListOfLInkObjects, ListOfOtherEnd); end; - - // Adjust NewListOfLinkObjects,NewListOfOtherEnd. Return True if adjusted function AdjustLists: Boolean; var I: integer; @@ -1931,11 +2444,13 @@ procedure TBoldIndirectMultiLinkController.SetFromIDLists(ListOfLinkObjects, Lis IndexOfOtherEnd, IndexOfOwnEnd, EmbeddedIndexOfOtherEnd, EmbeddedIndexOfOwnEnd: Integer; LinkObjectLocator: TBoldObjectLocator; + BoldSystem: TBoldSystem; begin Result := False; - BoldLinkClassTypeInfo := OwningObjectList.BoldRoleRtInfo.LinkClassTypeInfo; - IndexOfOwnEnd := OwningObjectList.BoldRoleRTInfo.OwnIndexInLinkClass; - IndexOfOtherEnd := OwningObjectList.BoldRoleRTInfo.OtherIndexInLinkClass; + BoldLinkClassTypeInfo := RoleRTInfo.LinkClassTypeInfo; + IndexOfOwnEnd := RoleRTInfo.OwnIndexInLinkClass; + IndexOfOtherEnd := RoleRTInfo.OtherIndexInLinkClass; + BoldSystem := self.BoldSystem; {Adjust list} for I := NewListOfLinkObjects.Count - 1 downto 0 do begin @@ -1953,11 +2468,11 @@ procedure TBoldIndirectMultiLinkController.SetFromIDLists(ListOfLinkObjects, Lis NewListOfOtherEnd.RemoveByIndex(I); end; end - else {object not loaded, set embedded links} { TODO : Is this really related to adjust? } + else {object not loaded, set embedded links} begin LinkObjectLocator := AssertedLocatorForId(NewListOfLinkObjects[i]); - EmbeddedIndexOfOwnEnd := OwningObjectList.BoldRoleRTInfo.LinkClassTypeInfo.AllMembers[IndexOfOwnEnd].EmbeddedLinkIndex; - EmbeddedIndexOfOtherEnd := OwningObjectList.BoldRoleRTInfo.LinkClassTypeInfo.AllMembers[IndexOfOtherEnd].EmbeddedLinkIndex; + EmbeddedIndexOfOwnEnd := RoleRTInfo.LinkClassTypeInfo.AllMembers[IndexOfOwnEnd].EmbeddedLinkIndex; + EmbeddedIndexOfOtherEnd := RoleRTInfo.LinkClassTypeInfo.AllMembers[IndexOfOtherEnd].EmbeddedLinkIndex; if (EmbeddedIndexOfOwnEnd <> -1) then LinkObjectLocator.EmbeddedSingleLinks[EmbeddedIndexOfOwnEnd] := OwningList.OwningObject.BoldObjectLocator; if (EmbeddedIndexOfOtherEnd <> -1) then @@ -1989,7 +2504,6 @@ procedure TBoldIndirectMultiLinkController.SetFromIDLists(ListOfLinkObjects, Lis if not PreChangeCalled then begin PreChange; -// GetLinkObjectListController.PreChange; No need to save? PreChangeCalled := True; end; end; @@ -2003,7 +2517,7 @@ procedure TBoldIndirectMultiLinkController.SetFromIDLists(ListOfLinkObjects, Lis G: IBoldGuard; begin G := TBoldGuard.Create(NewListOfLinkObjects, NewListOfOtherEnd); - if (mode = bdepPMIn) and (OwningMember.OwningObject.BoldObjectLocator.BoldObjectId.TimeStamp <> BOLDMAXTIMESTAMP) then // fetching old temporal versi + if (mode = bdepPMIn) and (OwningObjectList.OwningObject.IsHistoricVersion) then mode := bdepContents; if assigned(ListOfLinkObjects) then begin @@ -2022,7 +2536,7 @@ procedure TBoldIndirectMultiLinkController.SetFromIDLists(ListOfLinkObjects, Lis WasAdjusted := False; if Mode = bdepPMIn then ClearNoLongerReferring(newListOfOtherEnd); - PreserveOrder := (mode = bdepContents) or ((mode = bdepPMIn) and OwningObjectList.BoldRoleRTInfo.IsOrdered and not WasAdjusted); + PreserveOrder := (mode = bdepContents) or ((mode = bdepPMIn) and RoleRTInfo.IsOrdered and not WasAdjusted); {we now have a list with the right objects} @@ -2053,8 +2567,7 @@ procedure TBoldIndirectMultiLinkController.SetFromIDLists(ListOfLinkObjects, Lis GetLinkObjectListController.Changed(beItemDeleted, [ObjectLocator]); end else if ObjectLocator = ReferredLocatorList[i] then - // All in order, do nothing - else if ReferredLocatorList.IndexOf(ObjectLocator) <> -1 then // locator in list, but at wrong place + else if ReferredLocatorList.IndexOf(ObjectLocator) <> -1 then begin PreChangeIfNeeded; LinkLocatorList.Move(ReferredLocatorList.IndexOf(ObjectLocator), I); @@ -2063,7 +2576,7 @@ procedure TBoldIndirectMultiLinkController.SetFromIDLists(ListOfLinkObjects, Lis GetLinkObjectListController.Changed(beOrderChanged, []); end else - begin // locator not in list, insert it, + begin PreChangeIfNeeded; NewLocator := AssertedLocatorForId(NewListOfLinkObjects[I]); LinkLocatorList.Insert(I, NewLocator); @@ -2077,8 +2590,7 @@ procedure TBoldIndirectMultiLinkController.SetFromIDLists(ListOfLinkObjects, Lis for I := 0 to NewListOfLinkObjects.Count - 1 do begin ObjectLocator := AssertedLocatorForId(NewListOfOtherEnd[i]); - // if the database contains linkobject duplicates, the lists could get out of sync, we must avoid - // adding two linkobjects for the same object + if not ReferredLocatorList.LocatorInList[ObjectLocator] then begin PreChangeIfNeeded; @@ -2101,7 +2613,7 @@ procedure TBoldIndirectMultiLinkController.SetLocator(index: Integer; Locator: T try BoldClearLastFailure; if not StartModify then - BoldRaiseLastFailure(OwningList, 'SetLocator', ''); // do not localize + BoldRaiseLastFailure(OwningList, 'SetLocator', ''); OldLinkLocator := LinkLocatorList[index]; PreChange; LinkLocatorList[index] := NewLink(Locator, blulMarkModified).BoldObjectLocator; @@ -2122,17 +2634,29 @@ function TBoldIndirectMultiLinkController.GetStreamName: String; result := BoldContentName_ObjectIdListRefPair; end; +function TBoldIndirectMultiLinkController.GetFreeStandingClass: TBoldFreeStandingElementClass; +begin + result := TBFSObjectIdListRefPair; +end; + procedure TBoldIndirectMultiLinkController.Unlink(OldLocator: TBoldObjectLocator; Mode: TBoldLinkUnlinkMode); var OldIndex: Integer; OldLinkLocator: TBoldObjectLocator; begin - Assert((Mode <> blulMarkAdjusted) or (OwningList.BoldPersistenceState = bvpsCurrent)); + Assert((Mode <> blulMarkAdjusted) or (OwningList.BoldPersistenceState = bvpsCurrent), OwningMember.DisplayName); + if not LinkLocatorList.LocatorInList[OldLocator] then + begin + BoldLog.LogFmt('TBoldIndirectMultiLinkController.Unlink: Locator %s (%s) not found in %s (%s) ', + [OldLocator.AsString, OldLocator.EnsuredBoldObject.DisplayName, + OwningMember.OwningObject.BoldObjectLocator.AsString, OwningObjectList.DisplayName]); + exit; + end; Assert(LinkLocatorList.LocatorInList[OldLocator]); BoldClearLastFailure; if Mode = blulMarkModified then if not StartModify then - BoldRaiseLastFailure(OwningList, 'Unlink', ''); // do not localize + BoldRaiseLastFailure(OwningList, 'Unlink', ''); PreChange; OldIndex := LinkLocatorList.IndexOf(OldLocator); @@ -2147,16 +2671,11 @@ procedure TBoldIndirectMultiLinkController.Unlink(OldLocator: TBoldObjectLocator EndModify; end; -function TBoldIndirectMultiLinkController.GetLinkObjectListController: TBoldLinkObjectListController; -begin - result := ControllerForLinkMember as TBoldLinkObjectListController; -end; - function TBoldIndirectMultiLinkController.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; begin if IsEqualGuid(IID, IBoldObjectIdListRefPair) then begin - result := ProxyClass.create(self.OwningList, Mode).GetInterface(IID, obj); + result := GetProxy(self.OwningList, Mode).GetInterface(IID, obj); if not result then raise EBoldInternal.CreateFmt('ProxyClass for %s did not implement IBoldObjectIdListRefPair', [ClassName]); end @@ -2164,9 +2683,9 @@ function TBoldIndirectMultiLinkController.ProxyInterface(const IId: TGUID; Mode: result := inherited ProxyInterface(IID, Mode, Obj); end; -function TBoldIndirectMultiLinkController.ProxyClass: TBoldMember_ProxyClass; +function TBoldIndirectMultiLinkController.GetProxy(Member: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin - result := TBoldIndirectMultiLinkController_Proxy; + result := TBoldIndirectMultiLinkController_Proxy.MakeProxy(Member, Mode); end; procedure TBoldIndirectMultiLinkController.FreeContent; @@ -2179,10 +2698,16 @@ procedure TBoldIndirectMultiLinkController.PrepareClear; var LinkList: TBoldObjectList; begin - LinkList := OwningList.OwningObject.BoldMembers[OwningObjectList.BoldRoleRtInfo.IndexOfLinkObjectRole] as TBoldObjectLIst; + LinkList := OwningList.OwningObject.BoldMembers[RoleRTInfo.IndexOfLinkObjectRole] as TBoldObjectLIst; LinkLIst.EnsureObjects; end; +procedure TBoldIndirectMultiLinkController.Exchange(Index1, Index2: integer); +begin + LinkLocatorList.Exchange(Index1, Index2); + ReferredLocatorList.Exchange(Index1, Index2); +end; + procedure TBoldIndirectMultiLinkController.Resort; begin BoldSort(0, LinkLocatorList.Count - 1, CompareOrderNo, Exchange); @@ -2196,11 +2721,10 @@ function TBoldIndirectMultiLinkController.IsInOrder: Boolean; CurrentObj, PreviousObj: TBoldObject; begin Result := True; - if OwningObjectList.BoldRoleRTInfo.IsOrdered then + if RoleRTInfo.IsOrdered then begin i := 0; CurrentObj := nil; - // Only compare those objects that are loaded. while result and (i < LinkLocatorList.Count - 1) do begin if Assigned(LinkLocatorList[i].BoldObject) then @@ -2209,7 +2733,7 @@ function TBoldIndirectMultiLinkController.IsInOrder: Boolean; CurrentObj := LinkLocatorList[i].BoldObject; if Assigned(PreviousObj) then - Result := GetLinkObjectOwnLinkController(PreviousObj).FOrderNo <= GetLinkObjectOwnLinkController(CurrentObj).FOrderNo; + Result := GetLinkObjectOwnLinkController(PreviousObj).GetOrderNo <= GetLinkObjectOwnLinkController(CurrentObj).GetOrderNo; end; Inc(i); end; @@ -2220,26 +2744,14 @@ function TBoldIndirectMultiLinkController.CompareOrderNo(Index1, Index2: integer var OrderNo1, OrderNo2: integer; begin - if OwningObjectList.BoldRoleRTInfo.RoleRTInfoOfOtherEnd.IsSingleRole then + if RoleRTInfo.RoleRTInfoOfOtherEnd.IsSingleRole then begin - OrderNo1 := GetLinkObjectOwnLinkController(LinkLocatorList[Index1].BoldObject).FOrderNo; - OrderNo2 := GetLinkObjectOwnLinkController(LinkLocatorList[Index2].BoldObject).FOrderNo; + OrderNo1 := GetLinkObjectOwnLinkController(LinkLocatorList[Index1].BoldObject).GetOrderNo; + OrderNo2 := GetLinkObjectOwnLinkController(LinkLocatorList[Index2].BoldObject).GetOrderNo; Result := (OrderNo1 - OrderNo2); end else - raise EBold.Create(sOtherEndMustBeSingle); -end; - -procedure TBoldIndirectMultiLinkController.Exchange(Index1, Index2: integer); -begin - LinkLocatorList.Exchange(Index1, Index2); - ReferredLocatorList.Exchange(Index1, Index2); -end; - -function TBoldIndirectMultiLinkController.GetLinkObjectOtherLinkController( - LinkObject: TBoldObject): TBoldLinkObjectSingleLinkController; -begin - result := GetControllerForMember(LinkObject.BoldMembers[OwningObjectList.BoldRoleRtInfo.OtherIndexInLinkClass]) as TBoldLinkObjectSingleLinkController; + raise EBold.Create('Cannot call compare if OtherEnd is not a single role'); end; function TBoldIndirectMultiLinkController.AssertIntegrity: Boolean; @@ -2256,12 +2768,9 @@ function TBoldIndirectMultiLinkController.AssertIntegrity: Boolean; Assert(LinkLocatorList[i].BoldObject.BoldExistenceState = besExisting); Assert(GetLinkObjectOwnLinkController(LinkLocatorList[i].BoldObject).fLocator = OwningObjectList.OwningObject.BoldObjectLocator); Assert(GetLinkObjectOtherLinkController(LinkLocatorList[i].BoldObject).fLocator = ReferredLocatorList[i]); - { TODO : Check included in other end, if loaded. } end - else // link object no loaded + else begin - { TODO : Check values in locator itself } - { TODO : Check included in other end, if loaded. } end; end; Result := True; @@ -2270,7 +2779,6 @@ function TBoldIndirectMultiLinkController.AssertIntegrity: Boolean; procedure TBoldIndirectMultiLinkController.ClearNoLongerReferring( NewList: TBoldObjectIdList); begin -{ TODO : What do we want to do here. Free actual link objects that are pointing at us? } end; procedure TBoldIndirectMultiLinkController.Clear; @@ -2283,7 +2791,7 @@ procedure TBoldIndirectMultiLinkController.Clear; try BoldClearLastFailure; if not StartModify then - BoldRaiseLastFailure(OwningList, 'RemoveByIndex', ''); // do not localize + BoldRaiseLastFailure(OwningList, 'RemoveByIndex', ''); PreChange; BoldSystem.DelayObjectDestruction; @@ -2293,7 +2801,7 @@ procedure TBoldIndirectMultiLinkController.Clear; ix := Count-1; Locator := ReferredLocatorList[ix]; LinkLocator := LinkLocatorList[ix]; - DeleteLink(LinkLocator, blulMarkModified); // This will remove from other end but not from own + DeleteLink(LinkLocator, blulMarkModified); LinkLocatorList.RemoveByIndex(ix); ReferredLocatorList.RemoveByIndex(ix); Changed(beItemDeleted, [Locator]); @@ -2316,28 +2824,18 @@ function TBoldIndirectMultiLinkController.ControllerForLinkMember: TBoldAbstract var LinkMember: TBoldMember; begin - LinkMember := OwningList.OwningObject.BoldMembers[OwningObjectList.BoldRoleRtInfo.Index+1]; + LinkMember := OwningList.OwningObject.BoldMembers[RoleRTInfo.Index+1]; result := GetControllerForMember(LinkMember) as TBoldAbstractObjectListController; end; function TBoldMultiLinkController.CreateNew: TBoldElement; begin - result := OwningList.BoldSystem.CreateNewObjectByExpressionName(OwningObjectList.BoldRoleRTInfo.ClassTypeInfoOfOtherEnd.ExpressionName); -end; - -procedure TBoldMultiLinkController.EnsureOrder; -begin - if (fMayBeOutOfOrder) then - begin - if not IsInOrder then - Resort; - fMayBeOutOfOrder := false; - end; + result := BoldSystem.CreateNewObjectFromClassTypeInfo(RoleRTInfo.ClassTypeInfoOfOtherEnd); end; function TBoldMultiLinkController.GetCanCreateNew: Boolean; begin - result := not OwningObjectList.BoldRoleRTInfo.ClassTypeInfoOfOtherEnd.IsAbstract; + result := not RoleRTInfo.ClassTypeInfoOfOtherEnd.IsAbstract; end; procedure TBoldDirectMultiLinkController.SingleLinkUnlink( @@ -2350,9 +2848,9 @@ procedure TBoldDirectMultiLinkController.SingleLinkUnlink( aObject := Locator.BoldObject; if Assigned(AObject) then GetOtherEndController(Locator).Unlink(OldLocator, Mode) - else // member for other end not instantiated. + else begin - EmbeddedIndex := OwningObjectList.BoldRoleRtInfo.RoleRTInfoOfOtherEnd.EmbeddedLinkIndex; + EmbeddedIndex := RoleRTInfo.RoleRTInfoOfOtherEnd.EmbeddedLinkIndex; if (EmbeddedIndex <> -1) then if Locator.EmbeddedSingleLinks[EmbeddedIndex] <> nil then begin @@ -2362,13 +2860,8 @@ procedure TBoldDirectMultiLinkController.SingleLinkUnlink( end; end; -function TBoldDirectMultiLinkController.GetOtherEndController(Locator: TBoldObjectLocator): TBoldDirectSingleLinkController; -begin - result := GetControllerForMember(Locator.EnsuredBoldObject.BoldMembers[OwningObjectList.BoldRoleRtInfo.IndexOfOtherEnd]) as TBoldDirectSingleLinkController; -end; - procedure TBoldDirectMultiLinkController.SingleLinkLinkTo(Locator, - NewLocator: TBoldObjectLocator; updateOrderNo: Boolean; Mode: TBoldLinkUnlinkMode); + NewLocator: TBoldObjectLocator; updateOrderNo: Boolean; Mode: TBoldLinkUnlinkMode; aOrderNo: integer); var aObject: TBoldObject; EmbeddedIndex: integer; @@ -2376,18 +2869,18 @@ procedure TBoldDirectMultiLinkController.SingleLinkLinkTo(Locator, aObject := Locator.BoldObject; if Assigned(AObject) then GetOtherEndController(Locator).LinkTo(NewLocator, UpdateOrderNo, Mode) - else // member for other end not instantiated. + else begin - EmbeddedIndex := OwningObjectList.BoldRoleRtInfo.RoleRTInfoOfOtherEnd.EmbeddedLinkIndex; + EmbeddedIndex := RoleRTInfo.RoleRTInfoOfOtherEnd.EmbeddedLinkIndex; Assert(EmbeddedIndex <> -1); - Assert((Locator.EmbeddedSingleLinks[EmbeddedIndex] = nil) or (Locator.EmbeddedSingleLinks[EmbeddedIndex] = NewLocator)); + //Assert(Locator.EmbeddedSingleLinks[EmbeddedIndex] = nil); Locator.EmbeddedSingleLinks[EmbeddedIndex] := NewLocator; end; end; procedure TBoldMultiLinkController.MarkPossiblyOutOfOrder; begin - if OwningObjectList.BoldRoleRTInfo.IsOrdered then + if RoleRTInfo.IsOrdered then fMayBeOutOfOrder := True; end; @@ -2396,7 +2889,7 @@ procedure TBoldMultiLinkController.MarkPossiblyOutOfOrder; function TBoldLinkObjectSingleLinkController.OtherInnerLinkController: TBoldLinkObjectSingleLinkController; begin result := GetControllerForMember(OwningReference.OwningObject.BoldMembers[ - OwningReference.BoldRoleRTInfo.RoleRTInfoOfOtherEnd.OtherIndexInLinkClass]) as TBoldLinkObjectSingleLinkController; + RoleRTInfo.RoleRTInfoOfOtherEnd.OtherIndexInLinkClass]) as TBoldLinkObjectSingleLinkController; end; procedure TBoldLinkObjectSingleLinkController.SetFromId(Id: TBoldObjectId; Mode: TBoldDomainElementProxyMode); @@ -2408,19 +2901,16 @@ procedure TBoldLinkObjectSingleLinkController.SetFromId(Id: TBoldObjectId; Mode: index: Integer; begin inherited; - // Note! This code adjust for a possible previous "flaw". When fetching the - // first of the two inner single links, its "other end" cannot be set up correctly - // since the value of other inner single link is not known. This code adjust - // that when the other inner single link is fetched. Note that this requires - // that both inner single links are fetched in the same operation. + + + + OtherInnerLink := OtherInnerLinkController; if assigned(OtherInnerLink.fLocator) then begin OtherOuterLink := OtherInnerLink.GetOtherEndController(OtherInnerLink.fLocator, false); - // will not be assigned if outerlink is bvpsInvalid if assigned(OtherOuterLink) then begin - // they have no suitable common superclass... if OtherOuterLink is TBoldIndirectMultiLinkController then begin OuterMulti := OtherOuterLink as TBoldIndirectMultiLinkController; @@ -2435,7 +2925,7 @@ procedure TBoldLinkObjectSingleLinkController.SetFromId(Id: TBoldObjectId; Mode: (OuterSingle.fOtherEndLocator = nil) then OuterSingle.fOtherEndLocator := fLocator; end else - raise EBold.CreateFmt(sUnexpectedControllerType, [classname, OtherOuterLink.classname]); + raise EBold.CreateFmt('%s.SetFromId: Unexpected type of controller: %s', [classname, OtherOuterLink.classname]); end; end; end; @@ -2443,7 +2933,7 @@ procedure TBoldLinkObjectSingleLinkController.SetFromId(Id: TBoldObjectId; Mode: procedure TBoldLinkObjectSingleLinkController.SetLocator(NewLocator: TBoldObjectLocator); begin if assigned(NewLocator) then - raise EBold.CreateFmt(sCannotChangeLinkObjectSingleLink, [ClassName]); + raise EBold.CreateFmt('%s.SetLocator: Cannot change a Link Object Single Link', [ClassName]); inherited; end; @@ -2451,7 +2941,7 @@ procedure TBoldLinkObjectSingleLinkController.SetLocator(NewLocator: TBoldObject procedure TBoldLinkObjectListController.AddLocator(Locator: TBoldObjectLocator); begin - raise EBold.CreateFmt(sInvalidForListOfLinkObjects, [ClassName, 'AddLocator']); // do not localize + raise EBold.CreateFmt('%s.AddLocator: Cannot add directly to a list of link objects', [ClassName]); end; procedure TBoldLinkObjectListController.MakeDbCurrent; @@ -2472,22 +2962,23 @@ function TBoldLinkObjectListController.GetLocator(index: Integer): TBoldObjectLo function TBoldLinkObjectListController.GetLocatorByQualifiersAndSubscribe(MemberList: TBoldMemberList; Subscriber: TBoldSubscriber): TBoldObjectLocator; begin - raise EBoldFeatureNotImplementedYet.CreateFmt('%s.GetLocatorByQualifiersAndSubscribe', [ClassName]); // do not localize -end; - -function TBoldLinkObjectListController.GetLocatorList: TBoldObjectLocatorList; -begin - result := GetMainListController.LinkLocatorList; + raise EBoldFeatureNotImplementedYet.CreateFmt('%s.GetLocatorByQualifiersAndSubscribe', [ClassName]); end; function TBoldLinkObjectListController.GetMainListController: TBOldIndirectMultiLinkController; var MainMember: TBoldMember; begin - MainMember := OwningList.OwningObject.BoldMembers[OwningObjectList.BoldRoleRtInfo.IndexOfMainRole]; + MainMember := OwningList.OwningObject.BoldMembers[RoleRTInfo.IndexOfMainRole]; result := GetControllerForMember(MainMember) as TBOldIndirectMultiLinkController; end; +function TBoldLinkObjectListController.GetLocatorList: TBoldObjectLocatorList; +begin + MakeDbCurrent; //PATCH This solves problem with invalidation of main role not propagating to link role + result := GetMainListController.LinkLocatorList; +end; + function TBoldLinkObjectListController.IncludesLocator(Locator: TBoldObjectLocator): Boolean; begin result := (LocatorList.IndexOf(Locator) <> -1) @@ -2500,32 +2991,37 @@ function TBoldLinkObjectListController.IndexOfLocator(Locator: TBoldObjectLocato procedure TBoldLinkObjectListController.InsertLocator(index: Integer; Locator: TBoldObjectLocator); begin - raise EBold.CreateFmt(sInvalidForListOfLinkObjects, [ClassName, 'InsertLocator']); // do not localize + raise EBold.CreateFmt('%s.InsertLocator: cannot insert into a list of link objects', [ClassName]); end; procedure TBoldLinkObjectListController.Move(CurrentIndex, NewIndex: Integer); begin - raise EBold.CreateFmt(sInvalidForListOfLinkObjects, [ClassName, 'Move']); // do not localize + raise EBold.CreateFmt('%s.Move: Cannot move items in a list of link objects', [ClassName]); end; procedure TBoldLinkObjectListController.RemoveByIndex(index: Integer); begin - raise EBold.CreateFmt(sInvalidForListOfLinkObjects, [ClassName, 'RemoveByIndex']); // do not localize + raise EBold.CreateFmt('%s.RemoveByIndex: Cannot remove from a list of link objects', [ClassName]); end; procedure TBoldLinkObjectListController.SetLocator(index: Integer; Locator: TBoldObjectLocator); begin - raise EBold.CreateFmt(sInvalidForListOfLinkObjects, [ClassName, 'SetLocator']); // do not localize + raise EBold.CreateFmt('%s.SetLocator: Cannot modify a list of link objects directly', [ClassName]); end; function TBoldLinkObjectListController.GetStreamName: string; begin - raise EBold.CreateFmt(sLocatedAbstractError, [Classname, 'GetStreamName']); // do not localize + raise EBold.CreateFmt('%s.GetStreamName: Abstract error', [Classname]); +end; + +function TBoldLinkObjectListController.GetFreeStandingClass: TBoldFreeStandingElementClass; +begin + raise EBold.CreateFmt('%s.GetFreeStandingClass: Abstract error', [Classname]); end; function TBoldLinkObjectListController.GetMainList: TBoldObjectList; begin - result := OwningList.OwningObject.BoldMembers[OwningObjectList.BoldRoleRtInfo.IndexOfMainRole] as TBoldObjectList; + result := OwningList.OwningObject.BoldMembers[RoleRTInfo.IndexOfMainRole] as TBoldObjectList; end; function TBoldLinkObjectListController.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; @@ -2539,21 +3035,28 @@ function TBoldLinkObjectListController.ProxyInterface(const IId: TGUID; Mode: TB result := false; end; -function TBoldLinkObjectListController.ProxyClass: TBoldMember_ProxyClass; +function TBoldLinkObjectListController.GetProxy(Member: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin raise EBoldInternal.Create('Can''t access Link Object List directly'); end; { TBoldLinkObjectReferenceController } + function TBoldLinkObjectReferenceController.GetLocator: TBoldObjectLocator; begin + MakeDbCurrent; //PATCH This solves problem with invalidation of main role not propagating to link role result := (ControllerForMainRole as TBoldIndirectSingleLinkController).fLinkObjectLocator; end; function TBoldLinkObjectReferenceController.GetStreamName: string; begin - raise EBold.CreateFmt(sLocatedAbstractError, [Classname, 'GetStreamName']); // do not localize + raise EBold.CreateFmt('%s.GetStreamName: Abstract error', [Classname]); +end; + +function TBoldLinkObjectReferenceController.GetFreeStandingClass: TBoldFreeStandingElementClass; +begin + raise EBold.CreateFmt('%s.GetFreeStandingClass: Abstract error', [Classname]); end; procedure TBoldLinkObjectReferenceController.MakeDbCurrent; @@ -2562,7 +3065,7 @@ procedure TBoldLinkObjectReferenceController.MakeDbCurrent; OwningReference.BoldPersistenceState := bvpsCurrent; end; -function TBoldLinkObjectReferenceController.ProxyClass: TBoldMember_ProxyClass; +function TBoldLinkObjectReferenceController.GetProxy(Member: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin raise EBoldInternal.Create('Can''t access objectreference directly'); end; @@ -2581,7 +3084,31 @@ function TBoldLinkObjectReferenceController.ProxyInterface( procedure TBoldLinkObjectReferenceController.SetLocator(NewLocator: TBoldObjectLocator); begin - raise EBold.CreateFmt(sCannotSetLinkObjectReference, [Classname]); + raise EBold.CreateFmt('%s.SetLocator: Cannot set a link object reference directy', [Classname]); +end; + +{ TBoldUnOrderedDirectSingleLinkController } + +function TBoldUnOrderedDirectSingleLinkController.GetOrderNo: Integer; +begin + Result := -1; +end; + +procedure TBoldUnOrderedDirectSingleLinkController.SetAndModifyOrderNo( + index: Integer); +begin + if OrderNo <> -1 then + raise EBoldInternal.Create('Orderno must -1 on an unordered role'); end; +procedure TBoldUnOrderedDirectSingleLinkController.SetOrderNo( + NewOrderNo: Integer; Mode: TBoldDomainElementProxyMode); +begin + if OrderNo <> -1 then + raise EBoldInternal.Create('Orderno must -1 on an unordered role'); +end; + +initialization + end. + diff --git a/Source/ObjectSpace/BORepresentation/BoldMLAttributes.pas b/Source/ObjectSpace/BORepresentation/BoldMLAttributes.pas index 7d061bae..b5e03ad5 100644 --- a/Source/ObjectSpace/BORepresentation/BoldMLAttributes.pas +++ b/Source/ObjectSpace/BORepresentation/BoldMLAttributes.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldMLAttributes; interface @@ -34,7 +37,7 @@ TBAMLValueSetValue = class(TBAValueSetValue) protected function GetStringRepresentationCount: Integer; override; function GetStringRepresentation(Representation: TBoldRepresentation): string; override; - procedure SetStringRepresentation(Representation: TBoldRepresentation; Value: string); override; + procedure SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); override; procedure AddMLString(Value: TBAMLString); function GetMLString(Representation: integer): TBAMLString; public @@ -47,7 +50,7 @@ TBAMLValueSetValue = class(TBAValueSetValue) TBAMLValueSetValueList = class(TBADerivedValueSetValueList) protected function FindByStringAndLanguage(Representation: integer; Value, Language: String): TBAValueSetValue; - procedure AddMembers(Int: Integer; Members: Array of TBoldMember); override; + procedure Addmembers(Int: Integer; Members: Array of TBoldMember); override; public end; @@ -57,8 +60,9 @@ TBAMLValueSet = class(TBAValueSet) function GetStringRepresentationByLanguage(Representation: integer; Languagename: String): String; procedure SetStringRepresentationByLanguage(Representation: integer; Languagename: String; NewValue: String); function GetStringBylanguage(representation: integer; LanguageName: String): TBAString; - procedure InitializeMember(OwningElement: TBoldDomainElement; ElementTypeInfo: TBoldElementTypeInfo); override; + procedure Initialize; override; public +// class function Getvalues: TBAValueSetValueList; override; procedure DefaultSubscribe(Subscriber: TBoldSubscriber; requestedEvent: TBoldEvent = breReEvaluate); override; procedure SubscribeToStringRepresentation(Representation: TBoldRepresentation; Subscriber: TBoldSubscriber; RequestedEvent: TBoldEvent = breReEvaluate); override; procedure SubscribeToLanguage(representation: integer; Language: String; Subscriber: TBoldSubscriber; requestedEvent: TBoldEvent); @@ -69,8 +73,8 @@ TBAMLValueSet = class(TBAValueSet) {--- TBALanguage ---} TBALanguage = class(TBAValueSet) protected - function GetValues: TBAValueSetValueList; override; - procedure InitializeMember(OwningElement: TBoldDomainElement; ElementTypeInfo: TBoldElementTypeInfo); override; + class function Getvalues: TBAValueSetValueList; override; + procedure Initialize; override; end; {--- TBAMLString ---} @@ -78,22 +82,23 @@ TBAMLString = class(TBAString) private fMLStrings: TStringList; procedure InternalSetDataValue(Representation:TBoldRepresentation; Value: String); - function GetContentAsBlob: String; - procedure SetContentAsBlob(const NewValue: String); + function GetContentAsBlob: TBoldAnsiString; + procedure SetContentAsBlob(const NewValue: TBoldAnsiString); function GetStringBylanguage(LanguageName: String): TBAString; protected - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; function GetStringRepresentation(Representation: TBoldRepresentation): string; override; - procedure SetStringRepresentation(Representation: TBoldRepresentation; Value: string); override; - procedure ReceiveEventFromOwned(originator: TObject; originalEvent: TBoldEvent); override; + procedure SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); override; + procedure ReceiveEventFromOwned(originator: TObject; originalEvent: TBoldEvent; const Args: array of const); override; +{$IFNDEF BOLD_NO_QUERIES} function ReceiveQueryFromOwned(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; override; +{$ENDIF} function StringClass: TBAStringClass; virtual; - procedure InitializeMember(OwningElement: TBoldDomainElement; ElementTypeInfo: TBoldElementTypeInfo); override; - function ProxyClass: TBoldMember_ProxyClass; override; + procedure Initialize; override; public - destructor Destroy; override; + destructor destroy; override; function GetStreamName: string; override; - function ValidateString(Value: string; Representation: TBoldRepresentation): Boolean; override; + function ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; override; function ValidateCharacter(C: Char; Representation: TBoldRepresentation): Boolean; override; procedure Assign(Source: TBoldElement); override; procedure DefaultSubscribe(Subscriber: TBoldSubscriber; requestedEvent: TBoldEvent = breReEvaluate); override; @@ -128,9 +133,9 @@ function BoldLanguageList: TBAValueSetValueList; BoldMLStringSecondaryFallBack: string = '< %s: %s >'; BoldMLStringUnknownFallback: string = '<< %s: %s >>'; - BoldMLLanguageClassName: String = 'LanguageClass'; // do not localize - BoldMLLanguageNameAttributeName: String = 'LanguageName'; // do not localize - BoldMLLanguageNumberAttributeName: String = 'LanguageNumber'; // do not localize + BoldMLLanguageClassName: String = 'LanguageClass'; + BoldMLLanguageNameAttributeName: String = 'LanguageName'; + BoldMLLanguageNumberAttributeName: String = 'LanguageNumber'; implementation @@ -141,8 +146,7 @@ implementation BoldTaggedValueSupport, BoldSystemRT, BoldMemberTypeDictionary, - BoldDefaultStreamNames, - BoldCoreConsts; + BoldDefaultStreamNames; var _BoldLanguageList: TBADerivedValueSetValueList; @@ -160,24 +164,24 @@ procedure EnsureLanguageList; MemberRTInfo: TBoldMemberRTInfo; begin if loadingOfLanguages then - raise EBold.create(sBootStrapProblem); + raise EBold.create('BootStrap-problem, Probably the Languagename is an MLString... Not allowed, sorry'); if not assigned(_BoldLanguageList) then begin LoadingOfLanguages := true; LanguageTypeInfo := TBoldSystem.DefaultSystem.BoldSystemTypeInfo.ClassTypeInfoByExpressionName[BoldMLLanguageClassName]; if not assigned(LanguageTypeInfo) then - raise EBold.CreateFmt(sNeedClassCalledX, [BoldMLLanguageClassName]); + raise EBold.CreateFmt('For MultiLanguage to work, you need a class called "%s"', [BoldMLLanguageClassName]); MemberRTinfo := LanguageTypeInfo.MemberRTInfoByExpressionName[BoldMLLanguageNameAttributeName]; if not assigned(memberRTInfo) then - raise EBold.CreateFmt(sNeedMemberCalledX, [BoldMLLanguageClassName, BoldMLLanguageNameAttributeName]); + raise EBold.CreateFmt('For MultiLanguage to work, Class %s needs a member (string) called "%s"', [BoldMLLanguageClassName, BoldMLLanguageNameAttributeName]); if not memberRTInfo.MemberClass.InheritsFrom(TBAString) then - raise EBold.CreateFmt(sMustBeTBAString, [BoldMLLanguageNameAttributeName, memberRTInfo.MemberClass.ClassName]); + raise EBold.CreateFmt('For MultiLanguage to work, %s must be a TBAString, now it is a %s', [BoldMLLanguageNameAttributeName, memberRTInfo.MemberClass.ClassName]); memberRTInfo := LanguageTypeInfo.MemberRTInfoByExpressionName[BoldMLLanguageNumberAttributeName]; if not assigned(memberRTInfo) then - raise EBold.CreateFmt(sNeedIntegerMemberX, [BoldMLLanguageClassName, BoldMLLanguageNumberAttributeName]); + raise EBold.CreateFmt('For MultiLanguage to work, Class %s needs a member (integer) called "%s"', [BoldMLLanguageClassName, BoldMLLanguageNumberAttributeName]); if not memberRTInfo.MemberClass.InheritsFrom(TBAInteger) then - raise EBold.CreateFmt(sMemberXMustBeInteger, [BoldMLLanguageNumberAttributeName, memberRTInfo.MemberClass.ClassName]); + raise EBold.CreateFmt('For MultiLanguage to work, %s must be a TBAInteger, now it is a %s', [BoldMLLanguageNumberAttributeName, memberRTInfo.MemberClass.ClassName]); _BoldLanguageList := TBADerivedValueSetValueList.Create(TBoldSystem.DefaultSystem, BoldMLLanguageClassName, BoldMLLanguageNumberAttributeName, [BoldMLLanguageNameAttributeName]); LoadingOfLanguages := false; @@ -196,7 +200,7 @@ procedure ValidateLanguage(LanguageName, Location: String); if (Languagename <> '') and not loadingOfLanguages and not assigned(_BoldLanguageList.FindByText(brDefault, LanguageName)) then - raise EBold.CreateFmt(sInvalidLanguageName, [Location, languagename]) + raise EBold.CreateFmt('%s: Invalid languagename %s', [Location, languagename]) end; function EnsureValuesForElement(BoldSystem: TBoldSystem): TBoldSystem; @@ -215,32 +219,32 @@ function EnsureValuesForElement(BoldSystem: TBoldSystem): TBoldSystem; if _Systems.IndexOf(Result) = -1 then begin _Systems.Add(result); - _PrimaryLanguages.Add(TBoldMemberfactory.CreateMemberFromBoldType(result.BoldSystemTypeInfo.AttributeTypeInfoByDelphiName['TBALanguage'])); // do not localize - _SecondaryLanguages.Add(TBoldMemberfactory.CreateMemberFromBoldType(result.BoldSystemTypeInfo.AttributeTypeInfoByDelphiName['TBALanguage'])); // do not localize + _PrimaryLanguages.Add(TBoldMemberfactory.CreateMemberFromBoldType(result.BoldSystemTypeInfo.AttributeTypeInfoByDelphiName['TBALanguage'])); + _SecondaryLanguages.Add(TBoldMemberfactory.CreateMemberFromBoldType(result.BoldSystemTypeInfo.AttributeTypeInfoByDelphiName['TBALanguage'])); end; end; function BoldPrimaryLanguage(BoldSystem: tBoldSystem): TBALanguage; begin - Boldsystem := EnsureValuesForElement(BoldSystem); // a nil-parameter will be translated to DefaultSsytem + Boldsystem := EnsureValuesForElement(BoldSystem); result := TBALanguage(_PrimaryLanguages[_Systems.IndexOf(BoldSystem)]) end; function BoldSecondaryLanguage(BoldSystem: TBoldSystem): TBALanguage; begin - Boldsystem := EnsureValuesForElement(BoldSystem); // a nil-parameter will be translated to DefaultSsytem + Boldsystem := EnsureValuesForElement(BoldSystem); result := TBALanguage(_SecondaryLanguages[_Systems.IndexOf(BoldSystem)]) end; procedure BoldSetPrimaryLanguageByName(BoldSystem: TBoldSystem; LanguageName: String); begin - ValidateLanguage(LanguageName, 'BoldSetPrimaryLanguageByName'); // do not localize + ValidateLanguage(LanguageName, 'BoldSetPrimaryLanguageByName'); BoldPrimaryLanguage(BoldSystem).AsString := LanguageName; end; procedure BoldSetSecondaryLanguageByName(BoldSystem: TBoldSystem; LanguageName: String); begin - ValidateLanguage(LanguageName, 'BoldSetSecondaryLanguageByName'); // do not localize + ValidateLanguage(LanguageName, 'BoldSetSecondaryLanguageByName'); BoldSecondaryLanguage(BoldSystem).AsString := LanguageName; end; @@ -269,15 +273,15 @@ function TBAMLValueSetValue.GetStringRepresentation(Representation: TBoldReprese if representation in [1..StringRepresentationCount] then result := fStringRepresentations[Representation - 1].AsString else - raise EBold.CreateFmt(sRepresentationNotSupported, [ClassName, representation]); + raise EBold.CreateFmt('%s: representation not supported %d', [ClassName, representation]); end; -procedure TBAMLValueSetValue.SetStringRepresentation(Representation: TBoldRepresentation; Value: string); +procedure TBAMLValueSetValue.SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); begin if representation in [1..StringRepresentationCount] then fStringRepresentations[Representation - 1].AsString := Value else - raise EBold.CreateFmt(sRepresentationNotSupported, [ClassName, representation]); + raise EBold.CreateFmt('%s: Representation not supported %d', [ClassName, representation]); end; function TBAMLValueSetValue.GetMLString(Representation: integer): TBAMLString; @@ -285,7 +289,7 @@ function TBAMLValueSetValue.GetMLString(Representation: integer): TBAMLString; if representation in [1..StringRepresentationCount] then result := FStringRepresentations[Representation - 1] as TBAMLString else - raise EBold.CreateFmt(sRepresentationNotSupported, [ClassName, representation]); + raise EBold.CreateFmt('%s: Representation not supported %d', [ClassName, representation]); end; procedure TBAMLValueSetValue.AddMLString(Value: TBAMLString); @@ -305,7 +309,7 @@ procedure TBAMLValueSetValueList.Addmembers(Int: Integer; Members: Array of TBol for i := 0 to High(Members) do begin if not (members[i] is TBAMLString) then - raise EBold.CreateFmt(sMLValueSetsRequireMLStrings, [Members[i].Classname]); + raise EBold.CreateFmt('TBAMLValueSets can only use TBAMLStrings, not %s', [Members[i].Classname]); AddMLString(Members[i] as TBAMLString); end; end; @@ -336,7 +340,7 @@ procedure TBAMLValueSet.DefaultSubscribe(Subscriber: TBoldSubscriber; requestedE procedure TBAMLValueSet.SubscribeToLanguage(representation: integer; Language: String; Subscriber: TBoldSubscriber; requestedEvent: TBoldEvent); begin - ValidateLanguage(Language, ClassName + '.SubscribeToLanguage'); // do not localize + ValidateLanguage(Language, ClassName + '.SubscribeToLanguage'); GetStringBylanguage(Representation, Language).DefaultSubscribe(Subscriber, requestedEvent); end; @@ -346,7 +350,7 @@ function TBAMLValueSet.GetStringBylanguage(representation: integer; LanguageName TempML: TBAMLString; begin Result := nil; - ValidateLanguage(LanguageName, ClassName + '.GetStringByLanguage'); // do not localize + ValidateLanguage(LanguageName, ClassName + '.GetStringByLanguage'); temp := Values.FindByInteger(AsInteger); if temp is TBAMLValueSetValue then @@ -356,8 +360,7 @@ function TBAMLValueSet.GetStringBylanguage(representation: integer; LanguageName end; end; -procedure TBAMLValueSet.InitializeMember(OwningElement: TBoldDomainElement; - ElementTypeInfo: TBoldElementTypeInfo); +procedure TBAMLValueSet.Initialize; var x: TBAvalueSetValue; begin @@ -378,7 +381,7 @@ procedure TBAMLValueSet.InitializeMember(OwningElement: TBoldDomainElement; function TBAMLValueSet.GetStringRepresentationByLanguage(Representation: integer; LAnguagename: String): String; begin if IsNull then {IsNull ensures current} - Result := '' //FIXME: raise Exception? + Result := '' else Result := GetStringbylanguage(Representation, LanguageName).AsString; end; @@ -393,19 +396,23 @@ procedure TBAMLValueSet.SetStringRepresentationByLanguage(Representation: intege if assigned(MLValue) then AsInteger := MLValue.AsInteger else - raise EBold.Create(sInvalidValue); + raise EBold.CreateFmt('%s: Invalid value %s', [ClassName, NewValue]); end; {--- TBALanguage ---} -function TBALanguage.GetValues: TBAValueSetValueList; +class function TBALanguage.GetValues: TBAValueSetValueList; begin - EnsureLanguageList; - result := _BoldLanguageList; + result := nil; + if TBoldSystem.DefaultSystem.BoldSystemTypeInfo.ClassTypeInfoByExpressionName[BoldMLLanguageClassName] <> nil then + begin + EnsureLanguageList; + result := _BoldLanguageList; + end; end; {--- TBAMLString ---} -destructor TBAMLString.Destroy; +destructor TBAMLString.destroy; begin PrepareToDestroy; inherited; @@ -425,17 +432,18 @@ procedure TBAMLString.Assign(Source: TBoldElement); AsString := Source.AsString; end; -function TBAMLString.GetContentAsBlob: String; +function TBAMLString.GetContentAsBlob: TBoldAnsiString; begin - result := StringRepresentation[brMLString]; + result := TBoldAnsiString(StringRepresentation[brMLString]); end; -procedure TBAMLString.SetContentAsBlob(const NewValue: String); +procedure TBAMLString.SetContentAsBlob(const NewValue: TBoldAnsiString); begin - StringRepresentation[brMLString] := NewValue; + StringRepresentation[brMLString] := String(NewValue); end; -procedure TBAMLString.ReceiveEventFromOwned(originator: TObject; originalEvent: TBoldEvent); + +procedure TBAMLString.ReceiveEventFromOwned(originator: TObject; originalEvent: TBoldEvent; const Args: array of const); begin if originalEvent in beValueEvents then SendEvent(OriginalEvent); @@ -455,13 +463,13 @@ function TBAMLString.GetStringBylanguage(LanguageName: String): TBAString; StrPos: integer; BoldString: TBAString; begin - ValidateLanguage(LanguageName, ClassName + '.GetStringByLanguage'); // do not localize + ValidateLanguage(LanguageName, ClassName + '.GetStringByLanguage'); if LanguageName = '' then LanguageName := BoldPrimaryLanguage(BoldSystem).AsString; StrPos := fMLStrings.IndexOf(LanguageName); if StrPos = -1 then begin - BoldString := TBoldDomainElementClass(StringClass).Create(self) as TBAString; + BoldString := TBoldDomainElementClass(StringClass).CreateWithOwner(self) as TBAString; StrPos := fMLStrings.AddObject(languagename, BoldString); end; Result := TBAString(fMLStrings.Objects[StrPos]) @@ -484,19 +492,16 @@ function TBAMLString.GetStringRepresentation(Representation: TBoldRepresentation result := '' else begin - // check the current language DisplayLanguage := BoldPrimaryLanguage(BoldSystem); result := GetStringByLanguage(DisplayLanguage.AsString).AsString; if result = '' then begin - // check the default language DisplayLanguage := BoldSecondaryLanguage(BoldSystem); result := GetStringByLanguage(DisplayLanguage.AsString).AsString; if result <> '' then result := format(BoldMLStringSecondaryFallBack, [DisplayLanguage.AsString, Result]) else begin - // check any language for i := 0 to BoldLanguageList.count - 1 do begin result := GetStringByLAnguage(BoldLanguageList[i].AsString).AsString; @@ -539,7 +544,6 @@ procedure TBAMLString.InternalSetDataValue(Representation:TBoldRepresentation; V Delete(Value, 1, Pos(#255, Value)); LangValue := copy(Value, 1, pos(#255, Value) - 1); Delete(Value, 1, Pos(#255, Value)); - // make sure not to send any events GetStringBylanguage(Lang).ProxyInterface(IBoldStringContent, bdepContents, StringContent); StringContent.asString := LangValue; end; @@ -550,7 +554,7 @@ procedure TBAMLString.InternalSetDataValue(Representation:TBoldRepresentation; V end; end; -procedure TBAMLString.SetStringRepresentation(Representation: TBoldRepresentation; Value: string); +procedure TBAMLString.SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); begin if representation in [brMLString, brDefault] then InternalSetDataValue(representation, Value) @@ -567,7 +571,7 @@ procedure TBAMLString.DefaultSubscribe(Subscriber: TBoldSubscriber; requestedEve procedure TBAMLString.SubscribeToLanguage(Language: String; Subscriber: TBoldSubscriber; requestedEvent: TBoldEvent); begin - ValidateLanguage(Language, ClassName + '.SubscribeToLanguage'); // do not localize + ValidateLanguage(Language, ClassName + '.SubscribeToLanguage'); GetStringBylanguage(Language).DefaultSubscribe(Subscriber, requestedEvent); end; @@ -603,7 +607,6 @@ function SubscribeAndTestEmpty: Boolean; begin Language := BoldSecondaryLanguage(self.BoldSystem); SubscribeAndTestEmpty; - // if empty, stringrep will fall back to a constant string, no need to subscribe end; end else @@ -624,7 +627,7 @@ function TBAMLString.ValidateCharacter(C: Char; Representation: TBoldRepresentat result := inherited ValidateCharacter(c, representation); end; -function TBAMLString.ValidateString(Value: string; +function TBAMLString.ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; begin if fMLStrings.count > 0 then @@ -633,8 +636,7 @@ function TBAMLString.ValidateString(Value: string; result := inherited ValidateString(value, representation); end; -procedure TBALanguage.InitializeMember(OwningElement: TBoldDomainElement; - ElementTypeInfo: TBoldElementTypeInfo); +procedure TBALanguage.Initialize; var y: TBAvalueSetValueList; x: TBAvalueSetValue; @@ -644,9 +646,7 @@ procedure TBALanguage.InitializeMember(OwningElement: TBoldDomainElement; if assigned(y) then begin - // first, check if there is a language with the value 0 x := y.FindByInteger(0); - // if not, try any language if not assigned(x) then x := y.GetFirstvalue; if assigned(x) then @@ -657,8 +657,7 @@ procedure TBALanguage.InitializeMember(OwningElement: TBoldDomainElement; SetContentToNull; end; -procedure TBAMLString.InitializeMember(OwningElement: TBoldDomainElement; - ElementTypeInfo: TBoldElementTypeInfo); +procedure TBAMLString.Initialize; begin inherited; fMlStrings := TStringList.create; @@ -671,7 +670,7 @@ procedure TBAMLValueSetValue.SubscribeToStringRepresentation( if representation in [1..StringRepresentationCount] then fStringRepresentations[Representation - 1].SubscribeToStringRepresentation(brDefault, subscriber, requestedEvent) else - raise EBold.CreateFmt(sRepresentationNotSupported, [ClassName]); + raise EBold.CreateFmt('%s: Representation not supported %d', [ClassName]); end; procedure TBAMLValueSet.SubscribeToStringRepresentation( @@ -680,7 +679,7 @@ procedure TBAMLValueSet.SubscribeToStringRepresentation( begin Values[AsInteger].SubscribeToStringRepresentation(Representation, subscriber, requestedEvent); end; - +{$IFNDEF BOLD_NO_QUERIES} function TBAMLString.ReceiveQueryFromOwned(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; @@ -689,8 +688,8 @@ function TBAMLString.ReceiveQueryFromOwned(Originator: TObject; if OriginalEvent = bqMayModify then result := CanModify; end; - -procedure TBAMLString.AssignContentValue(Source: IBoldValue); +{$ENDIF} +procedure TBAMLString.AssignContentValue(const Source: IBoldValue); var s: IBoldBlobContent; begin @@ -699,31 +698,26 @@ procedure TBAMLString.AssignContentValue(Source: IBoldValue); if s.IsNull then SetContentToNull else - StringRepresentation[brMLString] := s.asBlob; + StringRepresentation[brMLString] := String(s.asBlob); end else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, 'AssignContentValue']); // do not localize + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); end; { TBoldMLString_Proxy } function TBAMLString_Proxy.GetProxedMLString: TBAMLString; begin - result := ProxedElement as TBAMLString; -end; - -function TBAMLString.ProxyClass: TBoldMember_ProxyClass; -begin - result := TBAMLString_Proxy; + result := ProxedMember as TBAMLString; end; function TBAMLString.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; begin if IsEqualGuid(IID, IBoldBlobContent) then begin - result := ProxyClass.create(self, Mode).GetInterface(IID, obj); + result := TBAString_Proxy.MakeProxy(self, Mode).GetInterface(IID, obj); if not result then - raise EBoldInternal.CreateFmt(sProxyClassDidntImplementInterface, [ClassName]); + raise EBoldInternal.CreateFmt('ProxyClass for %s did not implement IBoldBlobContent', [ClassName]); end else result := inherited ProxyInterface(IID, Mode, Obj); @@ -738,7 +732,7 @@ function TBAMLSubString.StartModify: Boolean; if (OwningElement is TBoldMember) then begin if not (BoldPersistenceState in [bvpsCurrent, bvpsModified, bvpsTransient, bvpsInvalid]) then - StateError('StartModify'); // do not localize + StateError('StartModify'); result := CanModify; OwningMember := (OwningElement as TBoldMember); if result and assigned(OwningMember.BoldSystem) and assigned(OwningMember.OwningObject) and @@ -747,7 +741,7 @@ function TBAMLSubString.StartModify: Boolean; result := OwningMember.BoldSystem.PessimisticLockHandler.LockElement(OwningMember); if result then begin - if assigned(OwningMember.OwningObject) and not OwningMember.BoldSystem.InTransaction and StoreInUndo then // Object always has system + if assigned(OwningMember.OwningObject) and not OwningMember.BoldSystem.InTransaction and StoreInUndo then OwningMember.BoldSystem.UndoHandler.HandleMember(OwningMember.OwningObject.AsIBoldObjectContents[bdepContents], OwningMember.BoldMemberRTInfo.Index, OwningMember.AsIBoldValue[bdepContents]); DoStartModify; @@ -755,6 +749,7 @@ function TBAMLSubString.StartModify: Boolean; end else result := inherited StartModify; + end; function TBAMLValueSet.CompareToEnumLiteral(const str: String): Boolean; diff --git a/Source/ObjectSpace/BORepresentation/BoldOSSMessage.pas b/Source/ObjectSpace/BORepresentation/BoldOSSMessage.pas new file mode 100644 index 00000000..c61b044b --- /dev/null +++ b/Source/ObjectSpace/BORepresentation/BoldOSSMessage.pas @@ -0,0 +1,171 @@ + +{ Global compiler directives } +{$include bold.inc} +unit BoldOSSMessage; + +interface + +uses + Classes; // for TPersistent +// BoldDefs; // for TBoldTimeStampType + +const + cOSSMessageSync = 'SYNC'; + cOSSMessageFail = 'FAIL'; + +type + TSessionId = Int64; + TBoldTimeStampType = integer; // copy from BoldDefs + TBoldOSSMessageType = (mtSync, mtFail); + TDateTimeMS = TDateTime; + + TBoldOSSMessage = class(TInterfacedPersistent) + private + fMessageType: TBoldOSSMessageType; + fEvents: string; + fBoldTimeStamp: TBoldTimeStampType; + fTimeOfTimeStamp: TDateTimeMS; + fClientSendTime: TDateTimeMS; + fUser: string; + fApplication: string; + fComputer: string; + function GetAsString: string; + procedure SetAsString(const Value: string); + protected + procedure AssignTo(Dest: TPersistent); override; + public + constructor Create; overload; + constructor Create( + AMessageType: TBoldOSSMessageType; + AEvents: string; + ABoldTimeStamp: TBoldTimeStampType; + ATimeOfTimeStamp: TDateTimeMS; + AClientSendTime: TDateTimeMS; + AUser: string = ''; + AComputer: string = ''; + AApplication: string = ''); overload; + destructor Destroy; override; + function Clone: TBoldOSSMessage; + property AsString: string read GetAsString write SetAsString; + published + property MessageType: TBoldOSSMessageType read fMessageType; + property Events: string read fEvents; + property BoldTimeStamp: TBoldTimeStampType read fBoldTimeStamp; + property TimeOfTimeStamp: TDateTimeMS read fTimeOfTimeStamp; + property ClientSendTime: TDateTimeMS read fClientSendTime; + // writeable properties, can be sent blank and filled in by service + property Computer: string read fComputer write fComputer; + property Application: string read fApplication write fApplication; + property User: string read fUser write fUser; + end; + +implementation + +uses + System.SysUtils, + BoldIsoDateTime, + System.JSON, + System.JSON.Writers, + System.JSON.Readers, + TypInfo; + +{ TBoldOSSMessage } + +constructor TBoldOSSMessage.Create; +begin + inherited; +end; + +destructor TBoldOSSMessage.Destroy; +begin + inherited; +end; + +function TBoldOSSMessage.GetAsString: string; +var + JSONObject,t1: TJSONObject; +begin + JSONObject := TJSONObject.Create; + try + JSONObject.AddPair('MessageType', String((GetEnumName(TypeInfo(TBoldOSSMessageType), Ord(MessageType))))); + JSONObject.AddPair('BoldTimeStamp', IntToStr(BoldTimeStamp)); + JSONObject.AddPair('BoldTimeOfTimeStamp', AsISODateTimeMS(TimeOfTimeStamp)); + JSONObject.AddPair('SendTime', AsISODateTimeMS(ClientSendTime)); + JSONObject.AddPair('User', User); + JSONObject.AddPair('Computer', Computer); + JSONObject.AddPair('Application', Application); + JSONObject.AddPair('Events', Events); + result := JSONObject.ToString; + finally + JSONObject.free; + end; +end; + +procedure TBoldOSSMessage.SetAsString(const Value: string); +var + JSONObject: TJSONObject; + s: string; +begin + JSONObject:= TJSONObject.ParseJSONValue(Value) as TJSONObject; + try + s := JSONObject.GetValue('MessageType').Value; + if s = 'mtSync' then + fMessageType := mtSync + else + if s = 'mtFail' then + fMessageType := mtFail + else + raise Exception.Create('Unknown MessageType'); + fBoldTimeStamp := StrToInt(JSONObject.GetValue('BoldTimeStamp').Value); + fTimeOfTimeStamp := ParseISODateTime(JSONObject.GetValue('BoldTimeOfTimeStamp').Value); + fClientSendTime := ParseISODateTime(JSONObject.GetValue('SendTime').Value); + fUser := JSONObject.GetValue('User').Value; + fComputer := JSONObject.GetValue('Computer').Value; + fApplication := JSONObject.GetValue('Application').Value; + fEvents := JSONObject.GetValue('Events').Value; + finally + JSONObject.Free; + end; +end; + +constructor TBoldOSSMessage.Create(AMessageType: TBoldOSSMessageType; AEvents: string; + ABoldTimeStamp: TBoldTimeStampType; ATimeOfTimeStamp, + AClientSendTime: TDateTimeMS; + AUser: string; AComputer: string; AApplication: string); +begin + fMessageType := AMessageType; + fEvents := AEvents; + fBoldTimeStamp := ABoldTimeStamp; + fTimeOfTimeStamp := ATimeOfTimeStamp; + fClientSendTime := AClientSendTime; + fUser := AUser; + fComputer := AComputer; + fApplication := AApplication; +end; + +procedure TBoldOSSMessage.AssignTo(Dest: TPersistent); +begin + if Dest is TBoldOSSMessage then + with Dest as TBoldOSSMessage do + begin + fMessageType := self.fMessageType; + fEvents := self.fEvents; + fBoldTimeStamp := self.fBoldTimeStamp; + fTimeOfTimeStamp := self.fTimeOfTimeStamp; + fClientSendTime := self.fClientSendTime; + fApplication := self.fApplication; + fUser := self.fUser; + fComputer := self.fComputer; + end + else + inherited; +end; + +function TBoldOSSMessage.Clone: TBoldOSSMessage; +begin + result := TBoldOSSMessage.Create; + self.AssignTo(result); +end; + +end. + diff --git a/Source/ObjectSpace/BORepresentation/BoldObjectListControllers.pas b/Source/ObjectSpace/BORepresentation/BoldObjectListControllers.pas index 0da5e821..76b4f7c7 100644 --- a/Source/ObjectSpace/BORepresentation/BoldObjectListControllers.pas +++ b/Source/ObjectSpace/BORepresentation/BoldObjectListControllers.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldObjectListControllers; interface @@ -5,7 +8,7 @@ interface uses Classes, BoldSystem, - BoldObjectSpaceLists, + BoldObjectSpaceLists, BoldDomainElement, BoldValueInterfaces, BoldId, @@ -25,21 +28,23 @@ TBoldObjectList_Proxy = class; TBoldObjectListController = class(TBoldAbstractObjectListController) private FList: TBoldObjectAttributeIndexList; - FSubscriber: TBoldPassthroughSubscriber; + FSubscriber: TBoldExtendedPassthroughSubscriber; procedure _ReceiveObjectDeleted(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const); - function GetLocatorList: TBoldObjectLocatorList; + function GetLocatorList: TBoldObjectLocatorList; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure InternalRemoveByIndex(index: Integer); protected function CreateNew: TBoldElement; override; function GetStreamName: string; override; - function ProxyClass: TBoldMember_ProxyClass; override; + function GetProxy(Member: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; procedure SubscribeToObjectDeleted(Locator: TBoldObjectLocator); virtual; + function GetCapacity: integer; override; + procedure SetCapacity(const Value: integer); override; public - constructor Create(OwningList: TBoldObjectList); + constructor Create(OwningList: TBoldObjectList); reintroduce; destructor Destroy; override; procedure AddLocator(Locator: TBoldObjectLocator); override; procedure AssignContentValue(Source: IBoldValue); - procedure DropSubscriptions; + procedure DropSubscriptions; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure Resubscribe; function GetCount: Integer; override; function GetLocator(index: Integer): TBoldObjectLocator; override; @@ -52,76 +57,123 @@ TBoldObjectListController = class(TBoldAbstractObjectListController) procedure RemoveByIndex(index: Integer); override; procedure SetLocator(index: Integer; Locator: TBoldObjectLocator); override; procedure FreeContent; override; + procedure Clear; override; property LocatorList: TBoldObjectLocatorList read GetLocatorList; end; +{ BoldPersistenceState: + bvpsInvalid: List contains just objcets that have been loaded or allloadedobjects + bvpsTransient: Means that all IDs are loaded + bvpsCurrent: Means all IDs and all Objects are loaded. +} { TBoldClassListController } TBoldClassListController = class(TBoldObjectListController) private fTimestamp: TBoldTimestampType; fAtTimeList: TList; + fClassTypeInfo: TBoldClassTypeInfo; + fSuperclasslist: TBoldObjectList; + fSuperClassController: TBoldClassListController; + fLoadedObjectCount: Integer; function GetAtTimeList: TList; procedure FillFromClassList(ObjectList: TBoldObjectList); procedure FillFromSystem; - function ClosestLoadedClassList: TBoldObjectList; property AtTimeList: TList read GetAtTimeList; - function GetIdList(Index: Integer): TBoldObjectID; + function GetIdList(Index: Integer): TBoldObjectID; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetFromIdList(List: TBoldObjectIdList; Mode: TBoldDomainElementProxyMode); + procedure MarkAsAllIDsLoaded; + procedure MarkListCurrent; + procedure CheckStillCurrent; + procedure SetPersistenceState(APersistenceState: TBoldValuePersistenceState); protected function GetCanCreateNew: Boolean; override; - function GetClassTypeInfo: TBoldClassTypeInfo; function GetStringrepresentation: String; override; procedure SubscribeToObjectDeleted(Locator: TBoldObjectLocator); override; - property ClassTypeInfo: TBoldClassTypeInfo read GetClassTypeInfo; - function ProxyClass: TBoldMember_ProxyClass; override; + property ClassTypeInfo: TBoldClassTypeInfo read fClassTypeInfo; + function GetProxy(Member: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; public constructor Create(OwningList: TBoldObjectList); destructor Destroy; override; - procedure ReceiveClassEvent(BoldObject: TBoldObject; EVENT: TBoldEvent); + procedure ReceiveClassEvent(BoldObject: TBoldObject; Event: TBoldEvent); function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; override; function AtTime(Time: TBoldTimeStampType): TBoldMember; override; function HandlesAtTime: Boolean; override; procedure MakeDbCurrent; override; + procedure AddLocator(Locator: TBoldObjectLocator); override; procedure RemoveByIndex(index: Integer); override; + property LoadedObjectCount: Integer read fLoadedObjectCount; + function HasLoadedSuperClass: boolean; + function ClosestLoadedClassList: TBoldObjectList; + function IsCurrentOrSuperClassIsCurrent: boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} end; { TBoldObjectList_Proxy } TBoldObjectList_Proxy = class(TBoldMember_Proxy) private - function GetObjectListController: TBoldObjectListController; + function GetObjectListController: TBoldObjectListController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; property ObjectListController: TBoldObjectListController read GetObjectListController; end; { TBoldClassList_Proxy } TBoldClassList_Proxy = class(TBoldMember_Proxy, IBoldObjectIdListRef) private - function GetClassListController: TBoldClassListController; - // IBoldObjectIdListRef + function GetClassListController: TBoldClassListController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetFromIdList(IdLIst: TBoldObjectIdList); - function GetIdList(Index: Integer): TBoldObjectID; - function GetCount: integer; + procedure SetList(IdList: TBoldObjectIdList); + function GetIdList(Index: Integer): TBoldObjectID; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetCount: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected property ClassListController: TBoldClassListController read GetClassListController; - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; end; +const + beClassListStateChanged = 31; // this is used so that we can subscribe to BoldPersistenceState of a class list + implementation uses SysUtils, BoldIndexableList, - BoldDefaultStreamNames, - BoldValueSpaceInterfaces, - BoldCoreConsts; + BoldDefaultStreamNames, + BoldValueSpaceInterfaces; { TBoldObjectListController } +constructor TBoldObjectListController.Create(OwningList: TBoldObjectList); +begin + inherited Create(OwningList); + FList := TBoldObjectLocatorList.Create; +end; + +destructor TBoldObjectListController.Destroy; +begin + FreeAndNil(FList); + FreeAndNil(FSubscriber); + inherited; +end; + +function TBoldObjectListController.GetLocatorList: TBoldObjectLocatorList; +begin + result := TBoldObjectLocatorList(FList); +end; + procedure TBoldObjectListController.AddLocator(Locator: TBoldObjectLocator); begin if not StartModify then - BoldRaiseLastFailure(OwningList, 'AddLocator', ''); // do not localize + BoldRaiseLastFailure(OwningList, 'AddLocator', ''); + +{$IFNDEF AllowCrossSystemLists} + if (BoldSystemCount > 1) and Assigned(BoldSystem) then + begin + Assert(Assigned(Locator), 'Locator not Assigned'); + Assert(Assigned(Locator.BoldSystem), 'Locator.BoldSystem not Assigned'); + if Locator.BoldSystem <> BoldSystem then + SetBoldLastFailureReason(TBoldFailureReason.CreateFmt('TBoldObjectListController.AddLocator: Locator from another system not allowed to be added to %s, Define conditional AllowCrossSystemLists if you want to allow this.', [OwningMember.DisplayName], OwningList)); + end; +{$ENDIF} LocatorList.Add(Locator); SubscribeToObjectDeleted(Locator); @@ -130,18 +182,9 @@ procedure TBoldObjectListController.AddLocator(Locator: TBoldObjectLocator); EndModify; end; -constructor TBoldObjectListController.Create(OwningList: TBoldObjectList); +function TBoldObjectListController.GetCapacity: integer; begin - inherited Create(OwningList); - FList := TBoldObjectLocatorList.Create; - FSubscriber := TBoldPassthroughSubscriber.CreateWithExtendedReceive(_ReceiveObjectDeleted); -end; - -destructor TBoldObjectListController.Destroy; -begin - FreeAndNil(FList); - FreeAndNil(FSubscriber); - inherited; + result := LocatorList.Capacity; end; function TBoldObjectListController.GetCount: Integer; @@ -163,21 +206,15 @@ function TBoldObjectListController.GetLocatorByQualifiersAndSubscribe(MemberList begin if assigned(OwningObjectList.BoldRoleRTInfo) and OwningObjectList.BoldRoleRTInfo.IsQualified then begin - // this handles qualified derived associations OwningObjectList.EnsureContentsCurrent; LocatorList.InitMembersIndex(OwningObjectList, OwningObjectList.BoldRoleRTInfo.Qualifiers); end else - raise EBold.CreateFmt(sRolenotQualified, [ClassName]); + raise EBold.CreateFmt('%s.GetLocatorByQualifiersAndSubscribe: Object list does not have a member index or role is not qualified', [ClassName]); end; result := List.GetLocatorByAttributesAndSubscribe(MemberList, Subscriber); end; -function TBoldObjectListController.GetLocatorList: TBoldObjectLocatorList; -begin - result := TBoldObjectLocatorList(FList); -end; - function TBoldObjectListController.IncludesLocator(Locator: TBoldObjectLocator): Boolean; begin Result := LocatorList.LocatorInList[Locator]; @@ -191,8 +228,16 @@ function TBoldObjectListController.IndexOfLocator(Locator: TBoldObjectLocator): procedure TBoldObjectListController.InsertLocator(index: Integer; Locator: TBoldObjectLocator); begin if not StartModify then - BoldRaiseLastFailure(OwningList, 'InsertLocator', ''); // do not localize - + BoldRaiseLastFailure(OwningList, 'InsertLocator', ''); +{$IFNDEF AllowCrossSystemLists} + if (BoldSystemCount > 1) and Assigned(BoldSystem) then + begin + Assert(Assigned(Locator), 'Locator not Assigned'); + Assert(Assigned(Locator.BoldSystem), 'Locator.BoldSystem not Assigned'); + if Locator.BoldSystem <> BoldSystem then + SetBoldLastFailureReason(TBoldFailureReason.CreateFmt('TBoldObjectListController.InsertLocator: Locator from another system not allowed to be inserted in %s, Define conditional AllowCrossSystemLists if you want to allow this.', [OwningMember.DisplayName], OwningList)); + end; +{$ENDIF} LocatorList.Insert(index, Locator); SubscribeToObjectDeleted(Locator); Changed(beItemAdded, [Locator]); @@ -203,7 +248,7 @@ procedure TBoldObjectListController.InsertLocator(index: Integer; Locator: TBold procedure TBoldObjectListController.Move(CurrentIndex, NewIndex: Integer); begin if not StartModify then - BoldRaiseLastFailure(OwningList, 'Move', ''); // do not localize + BoldRaiseLastFailure(OwningList, 'Move', ''); LocatorList.Move(CurrentIndex, NewIndex); Changed(beOrderChanged, []); @@ -223,20 +268,34 @@ procedure TBoldObjectListController.InternalRemoveByIndex(index: Integer); procedure TBoldObjectListController.RemoveByIndex(index: Integer); begin if not StartModify then - BoldRaiseLastFailure(OwningList, 'RemoveByIndex', ''); // do not localize + BoldRaiseLastFailure(OwningList, 'RemoveByIndex', ''); InternalRemoveByIndex(index); EndModify; end; +procedure TBoldObjectListController.SetCapacity(const Value: integer); +begin + LocatorList.Capacity := Value; +end; + procedure TBoldObjectListController.SetLocator(index: Integer; Locator: TBoldObjectLocator); begin if not StartModify then - BoldRaiseLastFailure(OwningList, 'SetLocator', ''); // do not localize + BoldRaiseLastFailure(OwningList, 'SetLocator', ''); if Locator = nil then RemoveByIndex(index) else begin +{$IFNDEF AllowCrossSystemLists} + if (BoldSystemCount > 1) and Assigned(BoldSystem) then + begin + Assert(Assigned(Locator), 'Locator not Assigned'); + Assert(Assigned(Locator.BoldSystem), 'Locator.BoldSystem not Assigned'); + if Locator.BoldSystem <> BoldSystem then + SetBoldLastFailureReason(TBoldFailureReason.CreateFmt('TBoldObjectListController.SetLocator: Locator from another system not allowed to be inserted in %s, Define conditional AllowCrossSystemLists if you want to allow this.', [OwningMember.DisplayName], OwningList)); + end; +{$ENDIF} LocatorList[index] := Locator; SubscribeToObjectDeleted(Locator); Changed(beItemReplaced, [Locator, Index]); @@ -252,7 +311,6 @@ function TBoldObjectListController.GetStreamname: string; procedure TBoldObjectListController.MakeDbCurrent; begin - // do nothing. Object lists are not persistent and therefore always current. end; procedure TBoldObjectListController._ReceiveObjectDeleted( @@ -263,53 +321,82 @@ procedure TBoldObjectListController._ReceiveObjectDeleted( var i: Integer; begin + {$IFDEF AllowCrossSystemLists} for i := Count - 1 downto 0 do if LocatorList[i].BoldSystem = System then InternalRemoveByIndex(i); + {$ELSE} + LocatorList.Clear; + {$ENDIF} + end; + + procedure RemoveLocator(Locator: TBoldObjectLocator); + begin + if LocatorList.LocatorInList[Locator] then + begin + LocatorList.Remove(Locator); + Changed(beItemDeleted, [Locator]); + end; end; var DeletedLocator: TBoldObjectLocator; begin - assert(originator is TBoldSystem); - case RequestedEvent of + assert(originator is TBoldObjectList); + case OriginalEvent of beLocatorDestroying, beObjectDeleted: begin assert(High(Args) = 0); assert(Args[0].vType = vtObject); - DeletedLocator := TBoldObject(Args[0].VObject).BoldObjectLocator; - if LocatorList.LocatorInList[DeletedLocator] then - begin - LocatorList.Remove(DeletedLocator); - Changed(beItemDeleted, [DeletedLocator]); - end; + Assert(Args[0].VObject is TBoldObjectLocator); + DeletedLocator := TBoldObjectLocator(Args[0].VObject); +// Assert(not Assigned(OwningList.Boldtype) or DeletedLocator.BoldObject.BoldClassTypeInfo.BoldIsA(TBoldListTypeInfo(OwningList.Boldtype).ListElementTypeInfo)); + RemoveLocator(DeletedLocator); end; beDestroying: begin - RemoveAllObjectsFromSystem(TBoldSystem(Originator)); + RemoveAllObjectsFromSystem(TBoldSystem(TBoldObjectList(Originator).OwningElement)); end; else - raise EBoldInternal.CreateFmt(sUnknownEvent, [classname]); + raise EBoldInternal.CreateFmt('%s._ReceiveObjectDeleted: Unknown event', [classname]); end; end; procedure TBoldObjectListController.SubscribeToObjectDeleted(Locator: TBoldObjectLocator); +var + ClassList: TBoldObjectList; begin - if OwningObjectList.SubscribeToObjectsInList then + with OwningObjectList do begin - // Object deleted - Locator.BoldSystem.AddSmallSubscription(FSubscriber, [beObjectDeleted], beObjectDeleted); - // System Destroyed - Locator.BoldSystem.AddSmallSubscription(FSubscriber, [beDestroying], beDestroying); + if not (SubscribeToLocatorsInList or SubscribeToObjectsInList) then + exit; + if Assigned(FSubscriber) then + exit + else + FSubscriber := TBoldExtendedPassthroughSubscriber.CreateWithExtendedReceive(_ReceiveObjectDeleted); + + if Assigned(OwningObjectList.BoldType) then + ClassList := Locator.BoldSystem.Classes[TBoldClassTypeInfo(TBoldListTypeInfo(OwningObjectList.BoldType).ListElementTypeInfo).TopSortedIndex] + else + ClassList := Locator.BoldSystem.Classes[0]; + + if SubscribeToLocatorsInList then + begin + if SubscribeToObjectsInList then + ClassList.AddSmallSubscription(FSubscriber, [beLocatorDestroying, beDestroying, beObjectDeleted], beLocatorDestroying) + else + ClassList.AddSmallSubscription(fSubscriber, [beLocatorDestroying], beLocatorDestroying); + end + else + if SubscribeToObjectsInList then + ClassList.AddSmallSubscription(FSubscriber, [beDestroying, beObjectDeleted], beLocatorDestroying); end; - if OwningObjectList.SubscribeToLocatorsInList then - Locator.BoldSystem.AddSmallSubscription(fSubscriber, [beLocatorDestroying], beLocatorDestroying); end; procedure TBoldObjectListController.DropSubscriptions; begin - FSubscriber.CancelAllSubscriptions; + FreeAndNil(FSubscriber); end; procedure TBoldObjectListController.Resubscribe; @@ -318,17 +405,36 @@ procedure TBoldObjectListController.Resubscribe; LastSystem: TBoldSystem; Locator: TBoldObjectLocator; begin - LastSystem := nil; - for i := 0 to Count - 1 do + Locator := (LocatorList.Any) as TBoldObjectLocator; + if Assigned(Locator) then begin - // only add subscriptions once per system for performance. - Locator := Locatorlist[i]; - if Locator.BoldSystem <> LastSystem then + SubscribeToObjectDeleted(Locator); + if BoldSystemCount > 1 then begin - SubscribeToObjectDeleted(LocatorList[i]); LastSystem := Locator.BoldSystem; + for i := 0 to Count - 1 do + begin + Locator := Locatorlist[i]; + if Locator.BoldSystem <> LastSystem then + begin + SubscribeToObjectDeleted(LocatorList[i]); + LastSystem := Locator.BoldSystem; + end; + end; end; - end; + end +end; + +procedure TBoldObjectListController.Clear; +var + i: integer; +begin + with OwningObjectList do + if MemberHasSubscribers or IsPartOfSystem then + inherited + else + LocatorList.Clear; + DropSubscriptions; end; procedure TBoldObjectListController.AssignContentValue(Source: IBoldValue); @@ -347,7 +453,7 @@ procedure TBoldObjectListController.AssignContentValue(Source: IBoldValue); Changed(beValueChanged, []); end else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, 'AssignContentValue']); // do not localize + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); end; procedure TBoldObjectListController.FreeContent; @@ -355,29 +461,19 @@ procedure TBoldObjectListController.FreeContent; Locatorlist.Clear; end; -function TBoldObjectListController.ProxyClass: TBoldMember_ProxyClass; +function TBoldObjectListController.GetProxy(Member: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin - Result := TBoldObjectList_Proxy; + Result := TBoldObjectList_Proxy.Create(Member, Mode); end; { TBoldClassListController } function TBoldObjectListController.CreateNew: TBoldElement; var - ListtypeInfo: TBoldListTypeInfo; ClassTypeInfo: TBoldClassTypeInfo; begin - ListTypeInfo := TBoldListTypeInfo(OwningList.Boldtype); - ClassTypeInfo := TBoldClassTypeInfo(ListTypeInfo.ListElementTypeInfo); - result := TBoldObjectClass(ClassTypeInfo.ObjectClass).InternalCreateNewWithClassAndSystem(ClassTypeInfo, owningList.BoldSystem, True); -end; - -function TBoldClassListController.GetClassTypeInfo: TBoldClassTypeInfo; -var - listtypeInfo: TBoldLIstTypeInfo; -begin - ListTypeInfo := TBoldListTypeInfo(OwningList.Boldtype); - result := TBoldClassTypeInfo(ListTypeInfo.ListElementTypeInfo); + ClassTypeInfo := TBoldClassTypeInfo(TBoldListTypeInfo(OwningList.Boldtype).ListElementTypeInfo); + result := TBoldObjectClass(ClassTypeInfo.ObjectClass).InternalCreateNewWithClassAndSystem(ClassTypeInfo, BoldSystem, True); end; function TBoldClassListController.GetCanCreateNew: Boolean; @@ -385,12 +481,12 @@ function TBoldClassListController.GetCanCreateNew: Boolean; result := true; if result and ClassTypeInfo.IsAbstract then begin - SetBoldLastFailureReason(TBoldFailureReason.CreateFmt(sClassIsAbstract, [ClassTypeInfo.ExpressionName], OwningList)); + SetBoldLastFailureReason(TBoldFailureReason.CreateFmt('%s is an abstract class', [ClassTypeInfo.ExpressionName], OwningList)); result := false; end; if result and ClassTypeInfo.IsLinkClass then begin - SetBoldLastFailureReason(TBoldFailureReason.CreateFmt(sClassIsLinkClass, [ClassTypeInfo.ExpressionName], OwningList)); + SetBoldLastFailureReason(TBoldFailureReason.CreateFmt('%s is a LinkClass', [ClassTypeInfo.ExpressionName], OwningList)); result := false; end; end; @@ -402,11 +498,33 @@ function TBoldClassListController.GetStringrepresentation: String; procedure TBoldClassListController.FillFromClassList(ObjectList: TBoldObjectList); var - i: integer; + I: Integer; + iTopSortedIndex: Integer; + DestinationList: TBoldObjectList; + Locator: TBoldObjectLocator; begin - for i := 0 to ObjectList.Count - 1 do - if ObjectList[i].BoldClassTypeInfo.BoldIsA(ClassTypeinfo) then - OwningList.Add(ObjectList[i]); + iTopSortedIndex := ClassTypeinfo.TopSortedIndex; + DestinationList := OwningObjectList; + for I := 0 to ObjectList.Count - 1 do + begin + Locator := ObjectList.Locators[I]; + if Assigned(Locator.BoldObject) then + begin + if Locator.BoldObject.BoldClassTypeInfo.BoldIsA(ClassTypeInfo) then + DestinationList.AddLocator(Locator); + end + else + if Locator.BoldObjectID.TopSortedIndexExact and + ((Locator.BoldObjectID.TopSortedIndex = iTopSortedIndex) or + (Locator.BoldClassTypeInfo.BoldIsA(ClassTypeinfo))) then + begin + DestinationList.AddLocator(Locator); + iTopSortedIndex := Locator.BoldObjectID.TopSortedIndex; + end + else + if Locator.EnsuredBoldObject.BoldClassTypeInfo.BoldIsA(ClassTypeInfo) then + DestinationList.AddLocator(Locator); + end; end; procedure TBoldClassListController.FillFromSystem; @@ -414,8 +532,8 @@ procedure TBoldClassListController.FillFromSystem; Traverser: TBoldLocatorListTraverser; Locator: TBoldObjectLocator; begin - Traverser := OwningList.BoldSystem.Locators.CreateTraverser; - while not Traverser.EndOfList do + Traverser := BoldSystem.Locators.CreateTraverser; + while Traverser.MoveNext do begin Locator := Traverser.Locator; if assigned(Locator.BoldObject) and not Locator.BoldObject.BoldPersistent @@ -424,7 +542,6 @@ procedure TBoldClassListController.FillFromSystem; begin LocatorList.Add(Locator); end; - Traverser.Next; end; Traverser.Free; end; @@ -432,6 +549,7 @@ procedure TBoldClassListController.FillFromSystem; function TBoldClassListController.ClosestLoadedClassList: TBoldObjectList; var SuperClass: TBoldClassTypeInfo; + SuperClassList: TBoldObjectList; begin if fTimestamp <> BOLDMAXTIMESTAMP then begin @@ -440,11 +558,12 @@ function TBoldClassListController.ClosestLoadedClassList: TBoldObjectList; end; SuperClass := ClassTypeInfo.SuperClassTypeInfo; - while assigned(SuperClass) and (OwningList.BoldSystem.Classes[SuperClass.TopSortedIndex].BoldPersistenceState <> bvpsCurrent) do - SuperClass := SuperClass.SuperClassTypeInfo; + with BoldSystem do + while assigned(SuperClass) and (Classes[SuperClass.TopSortedIndex].BoldPersistenceState <> bvpsCurrent) do + SuperClass := SuperClass.SuperClassTypeInfo; if assigned(SuperClass) then - result := OwningList.BoldSystem.Classes[SuperClass.TopSortedIndex] + result := BoldSystem.Classes[SuperClass.TopSortedIndex] else result := nil; end; @@ -453,7 +572,7 @@ procedure TBoldClassListController.MakeDbCurrent; var SourceList: TBoldObjectList; begin - if ClassTypeinfo.Persistent and OwningList.BoldSystem.BoldPersistent then + if ClassTypeinfo.Persistent and BoldSystem.BoldPersistent then begin SourceList := ClosestLoadedClassList; @@ -464,60 +583,109 @@ procedure TBoldClassListController.MakeDbCurrent; end else FillFromSystem; - OwningList.BoldPersistenceState := bvpsTransient; + MarkAsAllIDsLoaded; end; -procedure TBoldClassListController.ReceiveClassEvent(BoldObject: TBoldObject; Event: TBoldEvent); -var - SuperClassTypeInfo: TBoldClassTypeInfo; - Superclasslist: TBoldObjectList; +procedure TBoldClassListController.MarkAsAllIDsLoaded; begin - SuperClassTypeInfo := ClassTypeInfo.SuperClassTypeInfo; - if Assigned(SuperClassTypeInfo) then + if fLoadedObjectCount = Count then + MarkListCurrent + else + SetPersistenceState(bvpsTransient); +end; + +procedure TBoldClassListController.MarkListCurrent; +begin + if (OwningList.BoldPersistenceState <> bvpsCurrent) and (fLoadedObjectCount = Count) then begin - SuperClassList := BoldSystem.Classes[SuperClassTypeInfo.TopSortedIndex]; - TBoldClassListController(GetControllerForMember(SuperClassList)).ReceiveClassEvent(BoldObject, EVENT); + SetPersistenceState(bvpsCurrent); end; - if Owninglist.BoldPersistenceState <> bvpsInvalid then - begin - case Event of - beObjectCreated: AddLocator(BoldObject.BoldObjectLocator); - beObjectDeleted: +end; + +procedure TBoldClassListController.ReceiveClassEvent(BoldObject: TBoldObject; Event: TBoldEvent); +begin + if Assigned(fSuperClassController) then + fSuperClassController.ReceiveClassEvent(BoldObject, Event); + case Event of + beObjectCreated: begin - // it is a linear operation to delete objects in the classlist - // invalidating it is also linear, but hopefully it does not have to be done as often. - // In the persistent case, invalidating has a different effect, since the classlist must be reloaded from db. - if ClassTypeInfo.Persistent and OwningList.BoldSystem.BoldPersistent then - LocatorList.Remove(BoldObject.BoldObjectLocator) - else - Owninglist.Invalidate; + inc(fLoadedObjectCount); + if Owninglist.BoldPersistenceState <> bvpsInvalid then + begin +// Assert(not LocatorList.Includes(BoldObject.BoldObjectLocator), 'Locator already in list on beObjectCreated.'); + AddLocator(BoldObject.BoldObjectLocator) + end; + Owninglist.Invalidate; end; - beObjectFetched: OwningList.SendEvent(beObjectFetched); - else - raise EBoldInternal.CreateFmt('%s.ReceiveClassEvent: Unknown event', [ClassName]); + beObjectDeleted: + begin + if Owninglist.BoldPersistenceState <> bvpsInvalid then + begin + if ClassTypeInfo.Persistent and BoldSystem.BoldPersistent then + LocatorList.Remove(BoldObject.BoldObjectLocator); + end; + Dec(fLoadedObjectCount); + Owninglist.Invalidate; + OwningList.SendExtendedEvent(Event, [BoldObject.BoldObjectLocator]); end; - end - else - if Event = beObjectFetched then + beObjectFetched: begin - OwningList.SendEvent(beObjectFetched); + inc(fLoadedObjectCount); + if Owninglist.IsCurrent then + begin +// Assert(not LocatorList.Includes(BoldObject.BoldObjectLocator), 'Locator already in list on beObjectFetched.'); + AddLocator(BoldObject.BoldObjectLocator); + OwningList.SendExtendedEvent(beValueInvalid, [BoldObject.BoldObjectLocator]); + end + else + if (Owninglist.BoldPersistenceState = bvpsTransient) and (fLoadedObjectCount = count) then + begin +// Assert(LocatorList.Includes(BoldObject.BoldObjectLocator), 'Locator not already in list on beObjectFetched.'); + MarkListCurrent; + OwningList.SendExtendedEvent(beValueInvalid, [BoldObject.BoldObjectLocator]); + end + else + Owninglist.Invalidate; end; - - + beObjectUnloaded: + begin + if not BoldObject.BoldObjectIsDeleted then + begin + Dec(fLoadedObjectCount); + if Owninglist.BoldPersistenceState = bvpsCurrent then + begin + SetPersistenceState(bvpsTransient); + OwningList.SendEvent(beValueInvalid); + end + else + Owninglist.Invalidate; + end; + end; + end; case event of beObjectCreated: OwningList.SendExtendedEvent(beItemAdded, [BoldObject.BoldObjectLocator]); beObjectDeleted: OwningList.SendExtendedEvent(beItemDeleted, [BoldObject.BoldObjectLocator]); + beObjectFetched: OwningList.SendExtendedEvent(beObjectFetched, [BoldObject.BoldObjectLocator]); + beObjectUnloaded: OwningList.SendExtendedEvent(beObjectUnloaded, [BoldObject.BoldObjectLocator]) + else + raise EBoldInternal.CreateFmt('%s.ReceiveClassEvent: Unknown event: %d', [ClassName, Event]); end; end; procedure TBoldClassListController.RemoveByIndex(index: Integer); begin + Assert(not LocatorList[index].EnsuredBoldObject.BoldObjectIsDeleted); LocatorList[Index].EnsuredBoldObject.Delete; end; procedure TBoldClassListController.SubscribeToObjectDeleted; begin - // remove behaviour from parent +end; + +procedure TBoldClassListController.CheckStillCurrent; +begin + if OwningList.isCurrent and (fLoadedObjectCount <> Count) then + SetPersistenceState(bvpsTransient); end; function TBoldClassListController.HandlesAtTime: Boolean; @@ -525,6 +693,22 @@ function TBoldClassListController.HandlesAtTime: Boolean; result := true; end; +function TBoldClassListController.HasLoadedSuperClass: boolean; +begin + result := ClosestLoadedClassList <> nil; +end; + +function TBoldClassListController.IsCurrentOrSuperClassIsCurrent: boolean; +begin + result := HasLoadedSuperClass or (OwningObjectList.BoldPersistenceState = bvpsCurrent); +end; + +procedure TBoldClassListController.AddLocator(Locator: TBoldObjectLocator); +begin + LocatorList.Add(Locator); + CheckStillCurrent; +end; + function TBoldClassListController.AtTime( Time: TBoldTimeStampType): TBoldMember; var @@ -540,8 +724,8 @@ function TBoldClassListController.AtTime( result := TBoldObjectList(AtTimeList[i]); if not assigned(result) then begin - result := TBoldObjectList.InternalCreateClassList(BoldSystem, OwningList.BoldType as TBoldListTypeInfo); - TBoldClassListController(GetControllerForMember(result)).fTimestamp := Time; + result := TBoldObjectList.InternalCreateClassList(BoldSystem, OwningList.BoldType as TBoldListTypeInfo); + TBoldClassListController(GetControllerForMember(result)).fTimestamp := Time; AtTimeList.Add(result); end; end; @@ -569,98 +753,77 @@ constructor TBoldClassListController.Create(OwningList: TBoldObjectList); begin inherited Create(OwningList); fTimestamp := BOLDMAXTIMESTAMP; + fClassTypeInfo := TBoldClassTypeInfo(TBoldListTypeInfo(OwningList.Boldtype).ListElementTypeInfo); + if Assigned(ClassTypeInfo.SuperClassTypeInfo) then + begin + fSuperClassList := BoldSystem.Classes[ClassTypeInfo.SuperClassTypeInfo.TopSortedIndex]; + fSuperClassController := TBoldClassListController(GetControllerForMember(fSuperClassList)); + end; + OwningList.DuplicateMode := bldmError; end; -function TBoldClassListController.ProxyClass: TBoldMember_ProxyClass; +function TBoldClassListController.GetProxy(Member: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin - Result := TBoldClassList_Proxy; + Result := TBoldClassList_Proxy.Create(Member, Mode); end; function TBoldClassListController.GetIdList(Index: Integer): TBoldObjectID; -var - aLocator: TBoldObjectLocator; begin - aLocator := LocatorList[Index]; - result := aLocator.BoldObjectId + result := LocatorList[Index].BoldObjectId; end; -{ -procedure TBoldClassListController.AddTransientFromSystem; -var - Traverser: TBoldLocatorListTraverser; - Locator: TBoldObjectLocator; -begin - Traverser := OwningList.BoldSystem.Locators.CreateTraverser; - while not Traverser.EndOfList do - begin - Locator := Traverser.Locator; - if assigned(Locator.BoldObject) and not Locator.BoldObject.BoldPersistent and Locator.BoldObject.BoldClassTypeInfo.BoldIsA(ClassTypeinfo) then - LocatorList.Add(Locator); - Traverser.Next; - end; - Traverser.Free; -end; -} - procedure TBoldClassListController.SetFromIdList( List: TBoldObjectIdList; Mode: TBoldDomainElementProxyMode); - procedure InternalAddLocator(NewLocator: TBoldObjectLocator); +var + BoldSystem: TBoldSystem; + + procedure InternalAddId(ID: TBoldObjectId); + var + Locator: TBoldObjectLocator; begin - Assert(Assigned(NewLocator)); - if not IncludesLocator(NewLocator) then + Locator := BoldSystem.EnsuredLocatorByID[ID]; + if not IncludesLocator(Locator) then begin PreChange; - LocatorList.Add(NewLocator); - Changed(beItemAdded, [NewLocator]); + LocatorList.Add(Locator); + Changed(beItemAdded, [Locator]); end; end; - procedure InternalAddId(ID: TBoldObjectId); - begin - InternalAddLocator(BoldSystem.EnsuredLocatorByID[ID]); - end; - +{$IFNDEF NoTransientInstancesOfPersistentClass} procedure AddTransientFromSystem(List:TBoldObjectIdList); var - Traverser: TBoldLocatorListTraverser; Locator: TBoldObjectLocator; begin - Traverser := OwningList.BoldSystem.Locators.CreateTraverser; - while not Traverser.EndOfList do - begin - Locator := Traverser.Locator; + if not BoldSystem.Locators.IsEmpty then + for Locator in BoldSystem.Locators do if assigned(Locator.BoldObject) and not Locator.BoldObject.BoldPersistent and Locator.BoldObject.BoldClassTypeInfo.BoldIsA(ClassTypeinfo) then List.Add(Locator.BoldObjectID); - Traverser.Next; - end; - Traverser.Free; end; +{$ENDIF} - var +var I: Integer; NewList: TBoldObjectIdlist; Locator: TBoldObjectLocator; TheObject: TBoldObject; - begin - + BoldSystem := self.BoldSystem; if assigned(List) then NewList := List.Clone else NewList := TBoldObjectidList.create; - + try if mode = bdepPMIn then begin - // remove objects that have been deleted in memory + if BoldSystem.BoldDirty then // Search for Deleted objects only if system is dirty. for I := NewList.Count - 1 downto 0 do begin Locator := BoldSystem.Locators.LocatorByID[NewList[i]]; if assigned(Locator) and assigned(Locator.BoldObject) and (Locator.BoldObject.BoldExistenceState = besDeleted) then NewList.RemoveByIndex(i); end; - - // Add New Objects for I := 0 to BoldSystem.DirtyObjects.Count - 1 do begin TheObject := TBoldObject(BoldSystem.DirtyObjects[I]); @@ -668,17 +831,28 @@ procedure TBoldClassListController.SetFromIdList( ((TheObject.BoldExistenceState = besExisting) and (TheObject.BoldPersistenceState = bvpsModified)) then NewList.add(TheObject.BoldObjectLocator.BoldObjectID) end; - +{$IFNDEF NoTransientInstancesOfPersistentClass} AddTransientFromSystem(NewList); +{$ENDIF} end; + for I := GetCount - 1 downto 0 do + if not NewList.IdInList[GetLocator(I).BoldObjectID] then + LocatorList.RemoveByIndex(I); + for I := 0 to NewList.Count - 1 do + InternalAddId(NewList[I]); + finally + NewList.Free; + end; +end; - // fix§up locator list with minimum impact - for I := GetCount - 1 downto 0 do - if not NewList.IdInList[GetLocator(I).BoldObjectID] then - LocatorList.RemoveByIndex(I); - for I := 0 to NewList.Count - 1 do - InternalAddId(NewList[I]); - NewList.Free; +procedure TBoldClassListController.SetPersistenceState( + APersistenceState: TBoldValuePersistenceState); +begin + with OwningList do + begin + BoldPersistenceState := APersistenceState; + SendEvent(beClassListStateChanged); + end; end; function TBoldClassListController.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; @@ -686,7 +860,7 @@ function TBoldClassListController.ProxyInterface(const IId: TGUID; Mode: TBoldDo begin if IsEqualGuid(IID, IBoldObjectIdListRef) then begin - result := ProxyClass.create(self.OwningList, Mode).GetInterface(IID, obj); + result := GetProxy(self.OwningList, Mode).GetInterface(IID, obj); if not result then raise EBoldInternal.CreateFmt('ProxyClass for %s did not implement IBoldObjectIdListRef', [ClassName]); end @@ -696,17 +870,17 @@ function TBoldClassListController.ProxyInterface(const IId: TGUID; Mode: TBoldDo { TBoldClassList_Proxy } -procedure TBoldClassList_Proxy.AssignContentValue(Source: IBoldValue); +function TBoldClassList_Proxy.GetClassListController: TBoldClassListController; begin - if Mode = bdepContents then - ClassListController.AssignContentValue(Source) - else - UnsupportedMode(Mode, 'AssignContentValue'); // do not localize + Result := TBoldClassListController(ProxedController); end; -function TBoldClassList_Proxy.GetClassListController: TBoldClassListController; +procedure TBoldClassList_Proxy.AssignContentValue(const Source: IBoldValue); begin - Result := TBoldClassListController(ProxedController); + if Mode = bdepContents then + ClassListController.AssignContentValue(Source) + else + UnsupportedMode(Mode, 'AssignContentValue'); end; function TBoldClassList_Proxy.GetCount: integer; @@ -721,25 +895,36 @@ function TBoldClassList_Proxy.GetIdList(Index: Integer): TBoldObjectID; procedure TBoldClassList_Proxy.SetFromIdList(IdLIst: TBoldObjectIdList); begin - if Mode = bdepPMIn then { TODO : Move in implementation to proxy } + if Mode = bdepPMIn then ClassListController.SetFromIdList(IdLIst, Mode) else - UnsupportedMode(Mode, 'SetFromIdList'); // do not localize + UnsupportedMode(Mode, 'SetFromIdList'); +end; + +procedure TBoldClassList_Proxy.SetList(IdList: TBoldObjectIdList); +var + i: integer; +begin + IdList.Clear; + for I := 0 to ClassListController.Count - 1 do + IdList.Add(ClassListController.GetIdList(i)); end; { TBoldObjectList_Proxy } -procedure TBoldObjectList_Proxy.AssignContentValue(Source: IBoldValue); +function TBoldObjectList_Proxy.GetObjectListController: TBoldObjectListController; +begin + Result := TBoldObjectListController(ProxedController); +end; + +procedure TBoldObjectList_Proxy.AssignContentValue(const Source: IBoldValue); begin if Mode = bdepContents then ObjectListController.AssignContentValue(Source) else - UnsupportedMode(Mode, 'AssignContentValue'); // do not localize + UnsupportedMode(Mode, 'AssignContentValue'); end; -function TBoldObjectList_Proxy.GetObjectListController: TBoldObjectListController; -begin - Result := TBoldObjectListController(ProxedController); -end; +initialization end. diff --git a/Source/ObjectSpace/BORepresentation/BoldObjectSpaceLists.pas b/Source/ObjectSpace/BORepresentation/BoldObjectSpaceLists.pas index 3e0fc38c..492a3d80 100644 --- a/Source/ObjectSpace/BORepresentation/BoldObjectSpaceLists.pas +++ b/Source/ObjectSpace/BORepresentation/BoldObjectSpaceLists.pas @@ -1,14 +1,18 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldObjectSpaceLists; interface uses Classes, - BoldSubscription, + BoldSubscription, BoldSystem, BoldSystemRT, BoldIndex, - BoldIndexableList; + BoldIndexableList, + BoldHashIndexes; type TBoldObjectAttributeIndexList = class; @@ -18,24 +22,26 @@ TBoldMembersHashIndex = class; {---TBoldObjectAttributeIndexList---} TBoldObjectAttributeIndexList = class(TBoldIndexableList) private - function GetHasMembersIndex: Boolean; - function GetMembersIndex: TBoldMembersHashIndex; - function CreateMembersIndex(ObjectList: TBoldObjectList; MemberList: TBoldMemberRTInfoList): TBoldMembersHashIndex; - procedure NotifyMemberIndexBad; virtual; + class var IX_BoldQualifiers: integer; + function GetHasMembersIndex: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetMembersIndex: TBoldMembersHashIndex; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected + procedure NotifyMemberIndexBad; virtual; procedure EnsureLazyCreateIndexes; virtual; + function CreateMembersIndex(ObjectList: TBoldObjectList; MemberList: TBoldMemberRTInfoList): TBoldMembersHashIndex; virtual; public procedure InitMembersIndex(ObjectList: TBoldObjectList; MemberList: TBoldMemberRTInfoList); property HasMembersIndex: Boolean read GetHasMembersIndex; - function GetLocatorByAttributesAndSubscribe(MemberList: TBoldMemberList; Subscriber: TBoldSubscriber): TBoldObjectLocator; + function GetLocatorByAttributesAndSubscribe(MemberList: TBoldMemberList; Subscriber: TBoldSubscriber): TBoldObjectLocator; {$IFDEF BOLD_INLINE} inline; {$ENDIF} end; {---TBoldObjectLocatorList---} TBoldObjectLocatorList = class(TBoldObjectAttributeIndexList) private - function GetLocatorIndex: TBoldLocatorHashIndex; - function GetLocators(index: Integer): TBoldObjectLocator; - procedure SetLocators(index: Integer; Value: TBoldObjectLocator); + class var IX_BoldObjectLocator: integer; + function GetLocatorIndex: TBoldLocatorHashIndex; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetLocators(index: Integer): TBoldObjectLocator; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetLocators(index: Integer; Value: TBoldObjectLocator); {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetLocatorInList(Locator: TBoldObjectLocator): Boolean; property LocatorIndex: TBoldLocatorHashIndex read GetLocatorIndex; protected @@ -43,9 +49,9 @@ TBoldObjectLocatorList = class(TBoldObjectAttributeIndexList) public constructor Create; constructor CreateFromObjectList(BoldObjectList: TBoldObjectList); - procedure Add(NewLocator: TBoldObjectLocator); + procedure Add(NewLocator: TBoldObjectLocator); {$IFDEF BOLD_INLINE} inline; {$ENDIF} function Clone: TBoldObjectLocatorList; - procedure Ensure(NewLocator: TBoldObjectLocator); + procedure Ensure(NewLocator: TBoldObjectLocator); {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure FillObjectList(BoldObjectList: TBoldObjectList); procedure MergeObjectList(BoldObjectList: TBoldObjectList); property Locators[index: Integer]: TBoldObjectLocator read GetLocators write SetLocators; default; @@ -59,15 +65,16 @@ TBoldMembersHashIndex = class(TBoldHashIndex) fMemberSubscriber: TBoldPassThroughSubscriber; fOwner: TBoldObjectAttributeIndexList; fObjectList: TBoldObjectList; - procedure _receiveMemberChanged(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); + fStringCompareMode: TBoldStringCompareMode; protected - constructor Create(Owner: TBoldObjectAttributeIndexList; ObjectList: TBoldObjectList; Members: TBoldMemberRTInfoList); function HashItem(Item: TObject): Cardinal; override; function Match(const Key; Item:TObject):Boolean; override; function Hash(const Key): Cardinal; override; - function LocatorFromItem(Item: TObject): TBoldObjectLocator; - function ObjectFromItem(Item: TObject): TBoldObject; + function LocatorFromItem(Item: TObject): TBoldObjectLocator; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function ObjectFromItem(Item: TObject): TBoldObject; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure _receiveMemberChanged(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); virtual; public + constructor Create(Owner: TBoldObjectAttributeIndexList; ObjectList: TBoldObjectList; Members: TBoldMemberRTInfoList; AStringCompareMode: TBoldStringCompareMode = bscCaseDependent); destructor Destroy; override; procedure Clear(DestroyObjects: Boolean = false); override; procedure Add(Item: TObject); override; @@ -79,11 +86,7 @@ implementation uses SysUtils, BoldId, - BoldHashIndexes; - -var - IX_BoldObjectLocator: integer = -1; - IX_BoldQualifiers: integer = -1; + BoldDefs; type {---TBoldMembersKey---} @@ -92,11 +95,28 @@ TBoldMembersKey = class FAttributeList: TBoldMemberList; FHash: Cardinal; public - constructor Create(Attributes: TBoldMemberList); + constructor Create(Attributes: TBoldMemberList; StringCompareMode: TBoldStringCompareMode); property AttributeList: TBoldMemberList read FAttributeList; function Hash: Cardinal; end; +function TBoldMembersHashIndex.LocatorFromItem(Item: TObject): TBoldObjectLocator; +begin + Assert(not Assigned(Item) or (Item is TBoldObjectLocator)); + result := TBoldObjectLocator(Item); +end; + +function TBoldMembersHashIndex.ObjectFromItem(Item: TObject): TBoldObject; +var + temp: TBoldObjectLocator; +begin + temp := LocatorFromItem(Item); + if assigned(temp) then + result := temp.EnsuredBoldObject + else + result := nil; +end; + procedure TBoldMembersHashIndex.Add(Item: TObject); var i: integer; @@ -114,12 +134,122 @@ procedure TBoldMembersHashIndex.Add(Item: TObject); end; end; + {---TBoldMembersHashIndex---} +constructor TBoldMembersHashIndex.Create(Owner: TBoldObjectAttributeIndexList; ObjectList: TBoldObjectList; Members: TBoldMemberRTInfoList; AStringCompareMode: TBoldStringCompareMode); +var + i: Integer; +begin + inherited Create; + FStringCompareMode := AStringCompareMode; + FMemberIndexList := TList.Create; + FMemberIndexList.Capacity := Members.Count; + for i := 0 to Members.Count - 1 do + FMemberIndexList.Add(TBoldMemberId.create(Members[i].index)); + fMemberSubscriber := TBoldPassThroughSubscriber.Create(_receiveMemberChanged); + fOwner := Owner; + fObjectList := ObjectList; +end; + +destructor TBoldMembersHashIndex.Destroy; +var + i: Integer; +begin + for i := FMemberIndexList.Count-1 downto 0 do { counting down avoids adjusting other pointers in list } + TObject(FMemberIndexList[i]).Free; + FreeAndNil(FMemberIndexList); + FreeAndNil(fMemberSubscriber); + inherited; +end; + +function TBoldMembersHashIndex.HashItem(Item: TObject): Cardinal; +var + i: Integer; + concatval: String; + index: Integer; + member: TBoldMember; + BoldObject: TBoldObject; +begin + concatval := ''; + BoldObject := ObjectFromItem(Item); + for i := 0 to FMemberIndexList.Count - 1 do + begin + Assert(TObject(FMemberIndexList[i]) is TBoldMemberId); + index := TBoldMemberId(FMemberIndexList[i]).MemberIndex; + member := BoldObject.BoldMembers[index]; + concatval := concatval + member.AsString; + end; + result := TBoldStringKey.HashString(concatval, fStringCompareMode); +end; + +function TBoldMembersHashIndex.Match(const Key; Item:TObject):Boolean; +var + MembersKey: TBoldMembersKey; + Member: TBoldMember; + BoldObject: TBoldObject; + i: Integer; +const + cStringType = 'String'; // to avoid using BoldAttributes unit +begin + MembersKey := TBoldMembersKey(Key); + BoldObject := ObjectFromItem(Item); + result := FMemberIndexList.Count = MembersKey.AttributeList.Count; + i := 0; + while result and (i < FMemberIndexList.Count) do + begin + Assert(TObject(FMemberIndexList[i]) is TBoldMemberId); + Member := BoldObject.BoldMembers[TBoldMemberId(FMemberIndexList[i]).MemberIndex]; + if (fStringCompareMode <> bscCaseDependent) and (Member.BoldType.AsString = cStringType) then + result := MembersKey.AttributeList[i].IsEqualAs(ctCaseInsensitive, Member) + else + result := MembersKey.AttributeList[i].IsEqual(Member); + inc(i); + end; +end; + +function TBoldMembersHashIndex.GetLocatorByAttributesAndSubscribe(MemberList: TBoldMemberList; Subscriber: TBoldSubscriber): TBoldObjectLocator; +var + Key: TBoldMembersKey; + i: integer; +begin + Key := TBoldMembersKey.Create(MemberList, fStringCompareMode); + try + result := LocatorFromItem(Find(Key)); + finally + Key.Free; + end; + + if assigned(subscriber) then + begin + if assigned(result) then + begin + for i := 0 to FMemberIndexList.Count - 1 do + result.EnsuredBoldObject.BoldMembers[TBoldMemberId(FMemberIndexList[i]).MemberIndex].DefaultSubscribe(subscriber, breReSubscribe); + end + else if assigned(fObjectList) then + fObjectList.AddSmallSubscription(Subscriber, [beQualifierChanged], breReSubscribe); + end; +end; + procedure TBoldMembersHashIndex._receiveMemberChanged(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); +var + Locator: TBoldObjectLocator; begin + if OriginalEvent = beValueChanged then + begin + Locator := (Originator as TBoldMember).OwningObject.BoldObjectLocator; + if not IsCorrectlyIndexed(Locator) then + begin + AutoResize := false; + RemoveChanged(Locator); + Add(locator); + AutoResize := true; + end; + end; if assigned(fObjectList) then fObjectList.SendEvent(beQualifierChanged); - fOwner.NotifyMemberIndexBad; // this will tell the owning locatorlist to destroy us. + if OriginalEvent <> beValueChanged then + fOwner.NotifyMemberIndexBad; end; procedure TBoldMembersHashIndex.Clear(DestroyObjects: Boolean = false); @@ -159,9 +289,12 @@ function TBoldObjectAttributeIndexList.GetHasMembersIndex: Boolean; procedure TBoldObjectAttributeIndexList.EnsureLazyCreateIndexes; begin - // nothing; end; +function TBoldObjectAttributeIndexList.GetMembersIndex: TBoldMembersHashIndex; +begin + result := TBoldMembersHashIndex(indexes[IX_BoldQualifiers]); +end; procedure TBoldObjectAttributeIndexList.NotifyMemberIndexBad; var @@ -174,13 +307,6 @@ procedure TBoldObjectAttributeIndexList.NotifyMemberIndexBad; end; end; -function TBoldObjectAttributeIndexList.GetMembersIndex: TBoldMembersHashIndex; -begin - result := TBoldMembersHashIndex(indexes[IX_BoldQualifiers]); -end; - - - {---TBoldObjectLocatorList---} constructor TBoldObjectLocatorList.Create; begin @@ -189,20 +315,31 @@ constructor TBoldObjectLocatorList.Create; OwnsEntries := False; end; +function TBoldObjectLocatorList.GetLocators(index: Integer): TBoldObjectLocator; +begin + Result := TBoldObjectLocator(Items[index]); +end; + +procedure TBoldObjectLocatorList.SetLocators(index: Integer; Value: TBoldObjectLocator); +begin + Items[index] := Value; +end; + +procedure TBoldObjectLocatorList.Add(NewLocator: TBoldObjectLocator); +begin + inherited Add(NewLocator); +end; + constructor TBoldObjectLocatorList.CreateFromObjectList(BoldObjectList: TBoldObjectList); var I: Integer; begin Create; + Capacity := BoldObjectList.Count; for I := 0 to BoldObjectList.Count - 1 do Add(BoldObjectList.Locators[I]); end; -function TBoldObjectLocatorList.GetLocators(index: Integer): TBoldObjectLocator; -begin - Result := TBoldObjectLocator(Items[index]); -end; - function TBoldObjectLocatorList.GetLocatorIndex: TBoldLocatorHashIndex; begin if UnorderedIndexCount = 0 then @@ -210,25 +347,28 @@ function TBoldObjectLocatorList.GetLocatorIndex: TBoldLocatorHashIndex; result := TBoldLocatorHashIndex(Indexes[IX_BoldObjectLocator]); end; - function TBoldObjectLocatorList.Clone: TBoldObjectLocatorList; var I: Integer; begin Result := TBoldObjectLocatorList.Create; + Result.Capacity := Capacity; for I := 0 to Count - 1 do Result.Add(Locators[I]); end; function TBoldObjectLocatorList.GetLocatorInList(Locator: TBoldObjectLocator): Boolean; begin - result := assigned(Locator); - if result then + Result := Assigned(Locator); + if Result then begin - if Count > 10 then - Result := Assigned(LocatorIndex.FindLocatorByLocator(Locator)) + case Count of + 0: result := false; + 1: result := Locators[0] = Locator; + 2..10: Result := IndexOf(Locator) <> -1; else - result := IndexOf(Locator) <> -1; + Result := Assigned(LocatorIndex.FindLocatorByLocator(Locator)); + end; end; end; @@ -250,11 +390,6 @@ procedure TBoldObjectLocatorList.FillObjectList(BoldObjectList: TBoldObjectList) BoldObjectList.Add(Locators[I].BoldObject); end; -procedure TBoldObjectLocatorList.Add(NewLocator: TBoldObjectLocator); -begin - inherited Add(NewLocator); -end; - procedure TBoldObjectLocatorList.EnsureLazyCreateIndexes; begin inherited; @@ -267,121 +402,9 @@ procedure TBoldObjectLocatorList.Ensure(NewLocator: TBoldObjectLocator); Add(NewLocator); end; - - -procedure TBoldObjectLocatorList.SetLocators(index: Integer; Value: TBoldObjectLocator); -begin - Items[index] := Value; -end; - - {---TBoldMembersHashIndex---} -constructor TBoldMembersHashIndex.Create(Owner: TBoldObjectAttributeIndexList; ObjectList: TBoldObjectList; Members: TBoldMemberRTInfoList); -var - i: Integer; -begin - inherited Create; - FMemberIndexList := TList.Create; - FMemberIndexList.Capacity := Members.Count; - for i := 0 to Members.Count - 1 do - FMemberIndexList.Add(TBoldMemberId.create(Members[i].index)); - fMemberSubscriber := TBoldPassThroughSubscriber.Create(_receiveMemberChanged); - fOwner := Owner; - fObjectList := ObjectList; -end; - -destructor TBoldMembersHashIndex.Destroy; -var - i: Integer; -begin - for i := 0 to FMemberIndexList.Count - 1 do - TObject(FMemberIndexList[i]).Free; - FreeAndNil(FMemberIndexList); - FreeAndNil(fMemberSubscriber); - inherited; -end; - -function TBoldMembersHashIndex.HashItem(Item: TObject): Cardinal; -var - i: Integer; - concatval: String; - index: Integer; - member: TBoldMember; - BoldObject: TBoldObject; -begin - concatval := ''; - BoldObject := ObjectFromItem(Item); - for i := 0 to FMemberIndexList.Count - 1 do - begin - Assert(TObject(FMemberIndexList[i]) is TBoldMemberId); - index := TBoldMemberId(FMemberIndexList[i]).MemberIndex; - member := BoldObject.BoldMembers[index]; - concatval := concatval + member.AsString; - end; - result := TBoldStringKey.HashString(concatval, bscCaseDependent); -end; - -function TBoldMembersHashIndex.Match(const Key; Item:TObject):Boolean; -var - MembersKey: TBoldMembersKey; - BoldObject: TBoldObject; - i: Integer; -begin - MembersKey := TBoldMembersKey(Key); - BoldObject := ObjectFromItem(Item); - result := FMemberIndexList.Count = MembersKey.AttributeList.Count; - i := 0; - while result and (i < FMemberIndexList.Count) do - begin - Assert(TObject(FMemberIndexList[i]) is TBoldMemberId); - result := MembersKey.AttributeList[i].IsEqual(BoldObject.BoldMembers[TBoldMemberId(FMemberIndexList[i]).MemberIndex]); - inc(i); - end; -end; - -function TBoldMembersHashIndex.ObjectFromItem(Item: TObject): TBoldObject; -var - temp: TBoldObjectLocator; -begin - temp := LocatorFromItem(Item); - if assigned(temp) then - result := temp.EnsuredBoldObject - else - result := nil; -end; - -function TBoldMembersHashIndex.LocatorFromItem(Item: TObject): TBoldObjectLocator; -begin - Assert(not Assigned(Item) or (Item is TBoldObjectLocator)); - result := TBoldObjectLocator(Item); -end; - -function TBoldMembersHashIndex.GetLocatorByAttributesAndSubscribe(MemberList: TBoldMemberList; Subscriber: TBoldSubscriber): TBoldObjectLocator; -var - Key: TBoldMembersKey; - i: integer; -begin - Key := TBoldMembersKey.Create(MemberList); - try - result := LocatorFromItem(Find(Key)); - finally - Key.Free; - end; - - if assigned(subscriber) then - begin - if assigned(result) then - begin - for i := 0 to FMemberIndexList.Count - 1 do - result.EnsuredBoldObject.BoldMembers[TBoldMemberId(FMemberIndexList[i]).MemberIndex].DefaultSubscribe(subscriber, breReSubscribe); - end - else if assigned(fObjectList) then - fObjectList.AddSmallSubscription(Subscriber, [beQualifierChanged], breReSubscribe); - end; -end; - {---TBoldMembersKey---} -constructor TBoldMembersKey.Create(Attributes: TBoldMemberList); +constructor TBoldMembersKey.Create(Attributes: TBoldMemberList; StringCompareMode: TBoldStringCompareMode); var i: Integer; concatval: String; @@ -389,7 +412,7 @@ constructor TBoldMembersKey.Create(Attributes: TBoldMemberList); FAttributeList := Attributes; for i := 0 to FAttributeList.Count - 1 do concatval := concatval + FAttributeList[i].AsString; - FHash := TBoldStringKey.HashString(concatval, bscCaseDependent); + FHash := TBoldStringKey.HashString(concatval, StringCompareMode); end; function TBoldMembersKey.Hash: Cardinal; @@ -402,4 +425,9 @@ function TBoldMembersHashIndex.Hash(const Key): Cardinal; Result := TBoldMembersKey(Key).Hash; end; +initialization + TBoldObjectAttributeIndexList.IX_BoldQualifiers := -1; + TBoldObjectLocatorList.IX_BoldObjectLocator := -1 + end. + diff --git a/Source/ObjectSpace/BORepresentation/BoldOptimisticLockingSupport.pas b/Source/ObjectSpace/BORepresentation/BoldOptimisticLockingSupport.pas index adf15853..65a96d3a 100644 --- a/Source/ObjectSpace/BORepresentation/BoldOptimisticLockingSupport.pas +++ b/Source/ObjectSpace/BORepresentation/BoldOptimisticLockingSupport.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOptimisticLockingSupport; interface @@ -19,7 +22,7 @@ TBoldOptimisticLockHandler = class(TBoldAbstractOptimisticLockHandler) procedure GetRegionsForRemoteMember(OwningId: TBoldObjectId; Regions: TBoldRegionLookup; OwningRoleRTInfo: TBoldRoleRTInfo); procedure GetRegionsForDirtyOtherEnds(ObjectList: TBoldObjectList; Regions: TBoldRegionLookup); - procedure CopyValue(TargetVS: IBoldValueSpace; var TargetObjectContents: IBoldObjectContents; TargetObjectId: TBoldObjectId; MemberIndex: integer; Value: IBoldValue; StreamName: String); + procedure CopyValue(const TargetVS: IBoldValueSpace; var TargetObjectContents: IBoldObjectContents; TargetObjectId: TBoldObjectId; MemberIndex: integer; const Value: IBoldValue; const StreamName: String); procedure RetrieveOptimisticLockingvalues(ObjectList: TBoldObjectlist; PreCondition: TBoldOptimisticLockingPrecondition); procedure GetRegionsForElement(Element: TBoldDomainElement; Regions: TBoldRegionLookup); procedure GetRegionsForDirtyMembersInList(ObjectList: TBoldObjectList; Regions: TBoldRegionLookup); @@ -45,8 +48,7 @@ implementation BoldIndexableList, BoldElements, BoldTaggedValueSupport, - BoldGuard, - BoldCoreConsts; + BoldGuard; { TBoldOptimisticLockHandler } @@ -74,10 +76,10 @@ procedure TBoldOptimisticLockHandler.AddOptimisticRegionLocks(ObjectList: TBoldO GetLockingValuesForRegions(Regions, PreCondition); end; -procedure TBoldOptimisticLockHandler.CopyValue(TargetVS: IBoldValueSpace; +procedure TBoldOptimisticLockHandler.CopyValue(const TargetVS: IBoldValueSpace; var TargetObjectContents: IBoldObjectContents; - TargetObjectId: TBoldObjectId; MemberIndex: integer; Value: IBoldValue; - StreamName: String); + TargetObjectId: TBoldObjectId; MemberIndex: integer; const Value: IBoldValue; + const StreamName: String); var MemberId: TBoldMemberId; NewValue: IBoldValue; @@ -97,33 +99,26 @@ procedure TBoldOptimisticLockHandler.CopyValue(TargetVS: IBoldValueSpace; procedure TBoldOptimisticLockHandler.GetRegionsForDirtyOtherEnds(ObjectList: TBoldObjectList; Regions: TBoldRegionLookup); var - ObjIx, MemberIx: integer; + ObjIx, i: integer; Obj: TBoldObject; ObjRef: TBoldObjectReference; OldRemoteId: TBoldObjectId; - Member: TBoldMember; begin - // must grab objects with "dirty" multilinks refered to by singlelinks in the original objectlist, if they are managed by atleast one region. for ObjIx := 0 to ObjectList.Count-1 do begin Obj := ObjectList[ObjIx]; - for MemberIx := 0 to Obj.BoldMemberCount-1 do + with Obj.BoldClassTypeInfo.AllRoles do + for i := 0 to Count-1 do + if Items[i].IsSingleRole then begin - if Obj.BoldMemberAssigned[MemberIx] then + ObjRef := Obj.BoldMemberIfAssigned[Items[i].index] as TBoldObjectReference; + if Assigned(ObjRef) and ObjRef.BoldDirty then begin - Member := Obj.BoldMembers[MemberIx]; - if member.BoldMemberRTInfo.IsSingleRole then - begin - if Member.BoldDirty and (Member is TBoldObjectReference) then - begin - ObjRef := Member as TBoldObjectReference; - OldRemoteId := GetRemotedfromIdRefValue(Objref.OldValue); - if assigned(OldRemoteId) then - GetRegionsForRemoteMember(OldRemoteId, Regions, ObjRef.BoldRoleRTInfo); - if assigned(ObjRef.Locator) then - GetRegionsForRemoteMember(ObjRef.Locator.BoldobjectId, Regions, ObjRef.BoldRoleRTInfo); - end; - end; + OldRemoteId := GetRemotedfromIdRefValue(Objref.OldValue); + if assigned(OldRemoteId) then + GetRegionsForRemoteMember(OldRemoteId, Regions, ObjRef.BoldRoleRTInfo); + if assigned(ObjRef.Locator) then + GetRegionsForRemoteMember(ObjRef.Locator.BoldobjectId, Regions, ObjRef.BoldRoleRTInfo); end; end; end; @@ -182,10 +177,9 @@ procedure TBoldOptimisticLockHandler.GetLockingValuesForRegions(Regions: TBoldRe Traverser: TBoldIndexableListTraverser; begin Traverser := Regions.CreateTraverser; - while not Traverser.EndOfList do + while Traverser.MoveNext do begin GetLockingValuesForRegion(Traverser.Item as TBoldRegion, PreCondition); - Traverser.Next; end; Traverser.Free; end; @@ -253,30 +247,23 @@ procedure TBoldOptimisticLockHandler.RetrieveOptimisticLockingvalues(ObjectList: BoldObject := ObjectList[ObjIx]; Mode := BoldObject.BoldClassTypeInfo.OptimisticLocking; NewObjectContents := nil; - // skip new objects, and objects with no locking at all if Mode in [bolmTimeStamp, bolmModifiedMembers, bolmAllMembers] then begin ObjectId := BoldObject.BoldObjectLocator.BoldObjectID; ObjectContents := OldValues.ObjectContentsByObjectId[ObjectId]; - - // Copy all members from the optimisticLockingArea, for MemberIx := 0 to BoldObject.BoldMemberCount - 1 do begin MemberRTInfo := BoldObject.BoldClassTypeInfo.AllMembers[MemberIx]; if MemberRTInfo.CanHaveOldValue then begin value := nil; - - // timestamp-mode should take only multiroles, othermodes should take all values in OptimisticLockingarea if assigned(ObjectContents) then begin if (Mode in [bolmModifiedMembers, bolmAllMembers]) or MemberRTInfo.EncouragesOptimisticLockingOnDeletedOnly then Value := ObjectContents.ValueByIndex[MemberIx] end; - // In Mode=Class and the member was not in optimistic locking area, steal it from the object (if it is loaded) - // always steal multiroles that are current - // on a deleted object, all multiroles are current + if not assigned(Value) and BoldObject.BoldMemberAssigned[MemberIx] and @@ -289,16 +276,12 @@ procedure TBoldOptimisticLockHandler.RetrieveOptimisticLockingvalues(ObjectList: Value := BoldObject.BoldMembers[MemberIx].AsIBoldValue[bdepContents]; end; end; - - // We should not optimistically check multilinks except for deleted objects if assigned(value) and MemberRTinfo.EncouragesOptimisticLockingOnDeletedOnly and not BoldObject.BoldObjectIsDeleted then value := nil; - // We should not check the values of innerlinks, they can not change, only the linkobject - // can appear/disappear. However, we must check that the object is not deleted, so we - // ensure the objectID in the valuespace + if assigned(value) and (MemberRTinfo.IsSingleRole) and ((MemberRTInfo as TBoldRoleRTInfo).RoleType = rtInnerLinkRole) then @@ -314,28 +297,23 @@ procedure TBoldOptimisticLockHandler.RetrieveOptimisticLockingvalues(ObjectList: begin RoleRTInfo := MemberRTInfo as TBoldRoleRTInfo; if (RoleRTInfo.RoleType = rtRole) and - BoldObject.BoldMemberAssigned[MemberIx] and BoldObject.BoldMembers[MemberIx].BoldDirty then + RoleRTInfo.RoleRTInfoOfOtherEnd.IsSingleRole and + not RoleRTInfo.RoleRTInfoOfOtherEnd.IsStoredInObject and + BoldObject.BoldMembers[MemberIx].BoldDirty then begin - // ensure existence of related objects unless they are new RelatedObject := (BoldObject.BoldMembers[MemberIx] as TBoldObjectReference).BoldObject; if assigned(relatedObject) and (not relatedObject.BoldObjectIsNew) then begin - RelatedObjectcontents := Precondition.ValueSpace.EnsuredObjectContentsByObjectId[RelatedObject.BoldObjectLocator.BoldObjectId]; - // for embedded singlelinks with nonembedded otherends we must optimistically lock the other end so no one - // else has decided to point to it. - if RoleRTInfo.RoleRTInfoOfOtherEnd.IsSingleRole and - not RoleRTInfo.RoleRTInfoOfOtherEnd.IsStoredInObject then + value := RelatedObject.BoldMembers[RoleRTInfo.IndexOfOtherEnd].OldValue; + if assigned(Value) then begin - value := RelatedObject.BoldMembers[RoleRTInfo.IndexOfOtherEnd].OldValue; - if assigned(Value) then - begin - CopyValue( - Precondition.ValueSpace, - RelatedObjectcontents, - RelatedObject.BoldObjectLocator.BoldObjectId, - RoleRTInfo.IndexOfOtherEnd, Value, - RelatedObject.BoldMembers[RoleRTInfo.IndexOfOtherEnd].AsIBoldValue[bdepContents].ContentName); - end; + RelatedObjectcontents := Precondition.ValueSpace.EnsuredObjectContentsByObjectId[RelatedObject.BoldObjectLocator.BoldObjectId]; + CopyValue( + Precondition.ValueSpace, + RelatedObjectcontents, + RelatedObject.BoldObjectLocator.BoldObjectId, + RoleRTInfo.IndexOfOtherEnd, Value, + RelatedObject.BoldMembers[RoleRTInfo.IndexOfOtherEnd].AsIBoldValue[bdepContents].ContentName); end; end; end; @@ -365,21 +343,20 @@ procedure TBoldOptimisticLockHandler.GetRegionsForRemoteMember(OwningId: TBoldOb if assigned(OwningId) then begin RemoteObj := System.EnsuredLocatorByID[OwningId].BoldObject; - // the remote object should really be there, but if it is not, there is really nothing we can do about it (except throw an exception ;-). if assigned(RemoteObj) then begin OtherEnd := RemoteObj.Boldmembers[OwningRoleRTInfo.IndexOfOtherEnd]; if OtherEnd.BoldPersistenceState = bvpsInvalid then begin if OwningRoleRTInfo.ForceOtherEnd then - raise EBold.CreateFmt(sRelatedRoleNotLoaded, [classname, OwningRoleRTInfo.AsString]); + raise EBold.CreateFmt('%s.GetRegionsForRemoteMember: The related role (of %s) is not loaded. Unable to ensure optimistic locking consistency', [classname, OwningRoleRTInfo.AsString]); end else GetRegionsForElement(OtherEnd, Regions); end else if OwningRoleRTInfo.ForceOtherEnd then - raise EBold.CreateFmt(sRelatedObjectNotLoaded, [classname, OwningRoleRTInfo.AsString]); + raise EBold.CreateFmt('%s.GetRegionsForRemoteMember: The related object (of %s) is not loaded. Unable to ensure optimistic locking consistency', [classname, OwningRoleRTInfo.AsString]); end; end; @@ -471,10 +448,9 @@ procedure TBoldOptimisticLockHandler.AddRegionsObjectsToEnclosure( Traverser: TBoldIndexableListTraverser; begin Traverser := Regions.CreateTraverser; - while not Traverser.EndOfList do + while Traverser.MoveNext do begin AddRegionObjectsToEnclosure(Traverser.Item as TBoldRegion, Enclosure, ValidateOnly, ListIsEnclosure); - Traverser.Next; end; Traverser.Free; end; diff --git a/Source/ObjectSpace/BORepresentation/BoldSystem.pas b/Source/ObjectSpace/BORepresentation/BoldSystem.pas index c2484ac4..d04af321 100644 --- a/Source/ObjectSpace/BORepresentation/BoldSystem.pas +++ b/Source/ObjectSpace/BORepresentation/BoldSystem.pas @@ -1,10 +1,14 @@ + +{ Global compiler directives } +{$include bold.inc} + unit BoldSystem; interface uses Classes, - Db, // Needed for GetAllInClassWithSQL... + Db, BoldBase, BoldStreams, BoldSystemRT, @@ -28,13 +32,17 @@ interface const {Query events} bqBaseSystem = bqMaxSubscription + 1; + {$IFNDEF BOLD_NO_QUERIES} {General} bqMayRead = bqBaseSystem + 0; + + bqMaySetValue = bqBaseSystem + 1; {TBoldAttribute} bqMaySetToNull = bqBaseSystem + 2; {TBoldList and TBoldObjectReference} bqMayClear = bqBaseSystem + 3; + {TBoldList} bqMayInsert = bqBaseSystem + 4; bqMayRemove = bqBaseSystem + 5; @@ -43,7 +51,7 @@ interface {Object creation/deletion (sent by system)} bqMayCreateObject = bqBaseSystem + 8; bqMayDeleteObject = bqBaseSystem + 9; - + {$ENDIF} bqMaxSystem = bqBaseSystem + 9; type @@ -68,24 +76,17 @@ TBoldAbstractPessimisticLockHandler = class; TBoldAbstractOptimisticLockHandler = class; TBoldAbstractUndoHandler = class; TBoldAbstractOldValueHandler = class; - TBoldAbstractTransActionHandler = class; TBoldAbstractSystemPersistenceHandler = class; TBoldAbstractRegionFactory = class; - - // Controllers TBoldAbstractController = class; TBoldListController = class; TBoldAbstractObjectListController = class; TBoldAbstractObjectReferenceController = class; - TBoldObjectReferenceController = class; { TODO : Move out } + TBoldObjectReferenceController = class; TBoldMemberFactory = class; - - // Proxies TBoldMember_Proxy = class; TBoldAttribute_Proxy = class; - - // Meta classes TBoldObjectClass = class of TBoldObject; TBoldAttributeClass = class of TBoldAttribute; TBoldMemberClass = class of TBoldMember; @@ -93,6 +94,7 @@ TBoldListClass = class of TBoldList; TBoldObjectListClass = class of TBoldObjectList; TBoldMember_ProxyClass = class of TBoldMember_Proxy; + TBoldMemberDeriver = class; { exceptions } EBoldOperationFailedForObjectList = class; @@ -110,7 +112,7 @@ EBoldAccessNullValue = class(EBold); TBoldCreateApproximateObjectError = procedure(Obj: TBoldObject) of object; { TBoldSystemExtension } - TBoldSystemExtension = class(TBoldNonRefcountedObject) + TBoldSystemExtension = class(TBoldSubscribableNonRefCountedObject) private fSystem: TBoldSystem; public @@ -129,7 +131,7 @@ TBoldAbstractPessimisticLockHandler = class(TBoldSystemExtension) { TBoldAbstractOptimisticLockHandler } TBoldAbstractOptimisticLockHandler = class(TBoldSystemExtension) private - function GetOldValues: IBoldValueSpace; + function GetOldValues: IBoldValueSpace; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public procedure AddOptimisticLocks(ObjectList: TBoldObjectlist; PreCondition: TBoldOptimisticLockingPrecondition); virtual; abstract; procedure EnsureEnclosure(Obj: TBoldObject; Enclosure: TBoldObjectList; ValidateOnly: Boolean; var ListIsEnclosure: Boolean); virtual; abstract; @@ -139,11 +141,11 @@ TBoldAbstractOptimisticLockHandler = class(TBoldSystemExtension) { TBoldAbstractUndoHandler } TBoldAbstractUndoHandler = class(TBoldSystemExtension) protected - class function GetControllerForMember(Member: TBoldMember): TBoldAbstractController; + class function GetControllerForMember(Member: TBoldMember): TBoldAbstractController; {$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure DeleteObject(BoldObject: TBoldObject); public - procedure HandleMember(ObjectContents: IBoldObjectContents; MemberIndex: integer; MemberValue: IBoldValue); virtual; abstract; - procedure HandleObject(Obj: IBoldObjectContents; RegardAsExisting: Boolean); virtual; abstract; + procedure HandleMember(const ObjectContents: IBoldObjectContents; MemberIndex: integer; const MemberValue: IBoldValue); virtual; abstract; + procedure HandleObject(const Obj: IBoldObjectContents; RegardAsExisting: Boolean); virtual; abstract; procedure PrepareUpdate(const ObjectList: TBoldObjectList); virtual; abstract; procedure ApplytranslationList(IdTranslationList: TBoldIdTranslationList); virtual; abstract; end; @@ -154,9 +156,9 @@ TBoldAbstractOldValueHandler = class(TBoldSystemExtension) function GetOldValues: IBoldValueSpace; virtual; abstract; function GetIsEmpty: Boolean; virtual; abstract; procedure PurgeEqualValues; virtual; abstract; - class function NewValueInValueSpace(BoldMember: TBoldMember; ValueSpace: IBoldValueSpace): IBoldValue; - class procedure CopyMemberToValueSpace(BoldMember: TBoldMember; ValueSpace: IBoldValueSpace); - class procedure CopyObjectToValueSpace(BoldObject: TBoldObject; ValueSpace: IBoldValueSpace); + class function NewValueInValueSpace(BoldMember: TBoldMember; const ValueSpace: IBoldValueSpace): IBoldValue; + class procedure CopyMemberToValueSpace(BoldMember: TBoldMember; const ValueSpace: IBoldValueSpace); + class procedure CopyObjectToValueSpace(BoldObject: TBoldObject; const ValueSpace: IBoldValueSpace); public procedure MemberValuePreChange(BoldMember: TBoldMember); virtual; abstract; procedure MemberPersistenceStatePreChange(BoldMember: TBoldMember; NewState: TBoldValuePersistenceState); virtual; abstract; @@ -166,42 +168,38 @@ TBoldAbstractOldValueHandler = class(TBoldSystemExtension) property IsEmpty: Boolean read GetIsEmpty; end; - { TBoldAbstractTransActionHandler } - TBoldAbstractTransActionHandler = class(TBoldAbstractOldValueHandler) - protected - function GetTransactionMode: TBoldSystemTransactionMode; virtual; abstract; - function GetTransactionState: TBoldTransactionState; virtual; abstract; - public - procedure StartTransaction(MinimalMode: TBoldSystemTransactionMode = stmNormal); virtual; abstract; - procedure CommitTransaction(MinimalMode: TBoldSystemTransactionMode = stmNormal); virtual; abstract; - procedure RollbackTransaction(MinimalMode: TBoldSystemTransactionMode = stmNormal); virtual; abstract; - property TransactionMode: TBoldSystemTransactionMode read GetTransactionMode; - property TransactionState: TBoldTransactionState read GetTransactionState; - end; { TBoldAbstractSystemPersistenceHandler } TBoldAbstractSystemPersistenceHandler = class(TBoldSystemExtension) private fOnPreUpdate: TNotifyEvent; + fOnPostUpdate: TNotifyEvent; protected function GetTimeStampOfLatestUpdate: TBoldTimeStampType; virtual; abstract; + function GetTimeOfLatestUpdate: TDateTime; virtual; abstract; public function EnsureEnclosure(ObjectList: TBoldObjectList; ValidateOnly: Boolean): Boolean; virtual; abstract; - procedure FetchLinksWithObjects(ObjectList: TBoldObjectList; const LinkName: string; FetchedObjects: TBoldObjectList); virtual; abstract; + procedure FetchLinksWithObjects(ObjectList: TBoldObjectList; const LinkName: string;FetchObjectsInLink: Boolean = True{; const FetchedObjectList: TBoldObjectList = nil});virtual; abstract; + procedure FetchMembersWithObjects(aBoldObjectList: TBoldObjectList; aBoldMemberIdList: TBoldMemberIdList); overload; virtual; abstract; + procedure FetchMembersWithObjects(aBoldObjectList: TBoldObjectList; AMemberCommaList: string); overload; virtual; abstract; procedure FetchObjectById(BoldObjectId: TBoldObjectId); virtual; abstract; procedure FetchMember(Member: TBoldMember); virtual; abstract; procedure FetchList(FetchList: TBoldObjectList); virtual; abstract; procedure FetchClass(ClassList: TBoldObjectList; Time: TBoldTimestampType); virtual; abstract; procedure GetAllWithCondition(aList: TBoldObjectList; Condition: TBoldCondition); virtual; abstract; procedure GetAllInClassWithSQL(aList: TBoldObjectList; AClass: TBoldObjectClass; WhereClause, OrderByClause: String; Params: TParams; JoinInheritedTables: Boolean; MaxAnswers: integer; Offset: integer);virtual; abstract; + procedure GetAllInClassWithRawSQL(aList: TBoldObjectList; AClass: TBoldObjectClass; SQL: String; Params: TParams; MaxAnswers: integer; Offset: integer);virtual; abstract; procedure UpdateDatabaseWithList(ObjectList: TBoldObjectList); virtual; abstract; function GetTimeForTimestamp(Timestamp: TBoldTimestampType): TDateTime; virtual; abstract; function GetTimestampForTime(ClockTime: TDateTime): TBoldTimestampType; virtual; abstract; property OnPreUpdate: TNotifyEvent read fOnPreUpdate write fOnPreUpdate; + property OnPostUpdate: TNotifyEvent read fOnPostUpdate write fOnPostUpdate; property TimeStampOfLatestUpdate: TBoldTimeStampType read GetTimeStampOfLatestUpdate; + property TimeOfLatestUpdate: TDateTime read GetTimeOfLatestUpdate; procedure EndFetchForAll(ObjectList: TBoldObjectList; MemberIdList: TBoldMemberIdList); procedure EndUpdateForAll(ObjectList: TBoldObjectList; Translationlist: TBoldIdTranslationlist); function StartUpdateForAll(ObjectList: TBoldObjectList): Boolean; + function CanEvaluateInPS(sOCL: string; aContext: TBoldElementTypeInfo = nil; const aVariableList: TBoldExternalVariableList = nil): Boolean; virtual; abstract; end; { TBoldAbstractRegionFactory } @@ -214,6 +212,10 @@ TBoldAbstractRegionFactory = class(TBoldMemoryManagedObject) procedure GetRegionsForElement(Element: TBoldDomainElement; ResultList: TList); virtual; abstract; end; +{$IFDEF ACCESSSTATISTICS} //// START PATCH ACCESSSTATISTICS //////////////////// + TArrayOfArrayOfIntegers = array of array of Integer; +{$ENDIF} //// END PATCH ACCESSSTATISTICS /////////////////////////////////////// + {---TBoldSystem---} TBoldSystem = class(TBoldDomainElement) private @@ -223,7 +225,8 @@ TBoldSystem = class(TBoldDomainElement) fDelayedDestructionCount: integer; fDelayedDestructionList: TList; fDirtyObjects: TList; {of TBoldObject} - fDirtyObjectsInvalid: Boolean; + FDiscardCount: Integer; + fFetchNesting: Integer; fEvaluator: TBoldEvaluator; fLocators: TBoldSystemLocatorList; FNewDirtyList: TBoldObjectList; @@ -242,78 +245,132 @@ TBoldSystem = class(TBoldDomainElement) fSystemPersistenceHandler: TBoldAbstractSystemPersistenceHandler; fUndoHandler: TBoldAbstractUndoHandler; fOnCreateApproximateObjectError: TBoldCreateApproximateObjectError; - procedure SetIsdefault(Value: boolean); + fDerivedMembers: TList; + fPersistenceControllerSubscriber: TBoldPassthroughSubscriber; + FDeletingObjectsDepth: Integer; +{$IFNDEF NoAutoSubscription} + fMembersReadDuringDerivation: TList; + fMembersReadDuringDerivationIndexArray: array of Integer; +{$ENDIF} + fSystemProxyCache: array[TBoldDomainElementProxyMode] of IBoldvalueSpace; + procedure SetIsDefault(Value: boolean); function GetIsDefault: boolean; - function RollBackAreaAssigned: boolean; + property RollBackAreaAssigned: Boolean index befRollbackAreaAssigned read GetElementFlag write SetElementFlag; procedure CopyMemberToRollBackBuffer(BoldMember: TBoldMember); procedure CopyObjectToRollBackBuffer(BoldObject: TBoldObject); procedure AddToTransaction(DomainElement: TBoldDomainElement); function CanCommit: Boolean; + procedure IncrementDeletingObjectsDepth; + procedure DecrementDeletingObjectsDepth; procedure DestroyObject(BoldObject: TBoldObject); procedure DirtyAsObjectList(ObjectList: TBoldObjectList); function FindClassByExpressionName(const ExpressionName: string): TBoldObjectList; function GetClassByExpressionName(const ExpressionName: string): TBoldObjectList; + function GetClassByObjectClass(AObjectClass: TBoldObjectClass): TBoldObjectList; function GetClassByIndex(index: Integer): TBoldObjectList; function GetDirtyObjects: TList; {of TBoldObject} - function GetEnsuredLocatorByID(ObjectID: TBoldObjectId): TBoldObjectLocator; - function GetTimeForTimestamp(Timestamp: TBoldTimestampType): TDateTime; - function GetTimestampForTime(ClockTime: TDateTime): TBoldTimestampType; + function GetDirtyObjectsAsBoldList(AClassType: TBoldObjectClass): TBoldObjectList; + function GetDirtyObjectsAsBoldListByClassExpressionName(const AClass: string): TBoldObjectList; + function GetAllDirtyObjectsAsBoldList: TBoldObjectList; + function GetEnsuredLocatorByID(ObjectID: TBoldObjectId): TBoldObjectLocator; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetTimeForTimestamp(Timestamp: TBoldTimestampType): TDateTime; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetTimestampForTime(ClockTime: TDateTime): TBoldTimestampType; {$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure MarkObjectClean(BoldObject: TBoldObject); {called by TBoldObject} procedure MarkObjectDirty(BoldObject: TBoldObject); {called by TBoldObject} - procedure MarkObjectPossiblyCleaner(BoldObject: TBoldObject); {called by TBoldObject} - function GetAsIBoldvalueSpace(Mode: TBoldDomainElementProxyMode): IBoldvalueSpace; - procedure SetTransactionMode(const Value: TBoldSystemTransactionMode); + procedure MarkObjectPossiblyCleaner(BoldObject: TBoldObject); {$IFDEF BOLD_INLINE} inline; {$ENDIF} {called by TBoldObject} + function GetAsIBoldvalueSpace(Mode: TBoldDomainElementProxyMode): IBoldvalueSpace; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetTransactionMode(const Value: TBoldSystemTransactionMode);{$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure SetPessimisticLockHandler(const Value: TBoldAbstractPessimisticLockHandler); function GetOnPreUpdate: TNotifyEvent; procedure SetOnPreUpdate(const Value: TNotifyEvent); - function GetTimeStampOfLatestUpdate: TBoldTimeStampType; - function GetUndoHandler: TBoldAbstractUndoHandler; - function GetUndoHandlerInterface: IBoldUndoHandler; - function CanCreateObject(ClassTypeInfo: TBoldClassTypeInfo): boolean; - function CanDeleteObject(anObject: TBoldObject): boolean; - procedure DiscardPersistent; - procedure DiscardTransient; + function GetTimeStampOfLatestUpdate: TBoldTimeStampType; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetTimeOfLatestUpdate: TDateTime; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetUndoHandler: TBoldAbstractUndoHandler; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetUndoHandlerInterface: IBoldUndoHandler; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function CanCreateObject(ClassTypeInfo: TBoldClassTypeInfo): boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function CanDeleteObject(anObject: TBoldObject): boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure MemberDerivationBegin(Member: TBoldMember); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure MemberDerivationEnd(Member: TBoldMember); + function GetIsProcessingTransactionOrUpdatingDatabase: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure ReceiveFromPersistenceController(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); + function GetDiscarding: Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetIsFetching: Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + property DirtyObjectsInvalid: Boolean index befDirtyObjectsInvalid read GetElementFlag write SetElementFlag; + property IsFetching: Boolean read GetIsFetching; protected function GetBoldDirty: Boolean; override; function GetBoldType: TBoldElementTypeInfo; override; - function GetDisplayName: String; override; function GetEvaluator: TBoldEvaluator; override; function GetStringRepresentation(Representation: TBoldRepresentation): string; override; - procedure ReceiveEventFromOwned(originator: TObject; originalEvent: TBoldEvent); override; + procedure ReceiveEventFromOwned(originator: TObject; originalEvent: TBoldEvent; const Args: array of const); override; +{$IFNDEF BOLD_NO_QUERIES} + function ReceiveQueryFromOwned(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; override; +{$ENDIF} property SystemPersistenceHandler: TBoldAbstractSystemPersistenceHandler read fSystemPersistenceHandler; - public - constructor Create(AOwningElement: TBoldDomainElement); override; - constructor CreateWithTypeInfo(AOwningElement: TBoldDomainElement; SystemTypeInfo: TBoldSystemTypeInfo; PersistenceController: TBoldPersistenceController; RegionFactory: TBoldAbstractRegionFactory = nil); + property OldValueHandler: TBoldAbstractOldValueHandler read fOldValueHandler; + public +{$IFDEF ACCESSSTATISTICS} //// START PATCH ACCESSSTATISTICS //////////////////// + fAccessStats: TArrayOfArrayOfIntegers; + fDeriveStats: TArrayOfArrayOfIntegers; + fInvalidateStats: TArrayOfArrayOfIntegers; + fModifyStats: TArrayOfArrayOfIntegers; +{$ENDIF} //// END PATCH ACCESSSTATISTICS /////////////////////////////////////// + constructor CreateWithTypeInfo(AOwningElement: TBoldDomainElement; SystemTypeInfo: TBoldSystemTypeInfo; PersistenceController: TBoldPersistenceController; RegionFactory: TBoldAbstractRegionFactory = nil); reintroduce; destructor Destroy; override; function AssertLinkIntegrity: Boolean; class function DefaultSystem: TBoldSystem; procedure MakeDefault; procedure EnsureCanDestroy; procedure AllowObjectDestruction; + function CanEvaluateInPS(sOCL: string; aContext: TBoldElementTypeInfo = nil; const aVariableList: TBoldExternalVariableList = nil): Boolean; procedure CommitTransaction(MinimalMode: TBoldSystemTransactionMode = stmNormal); function CreateExistingObjectByID(BoldObjectID: TBoldObjectId): TBoldObject; function CreateNewObjectByExpressionName(const ExpressionName: string; Persistent: Boolean = True): TBoldObject; + function CreateNewObjectFromClassTypeInfo(aClassTypeInfo: TBoldClassTypeInfo; Persistent: Boolean = True): TBoldObject; procedure DefaultSubscribe(Subscriber: TBoldSubscriber; RequestedEvent: TBoldEvent = breReEvaluate); override; - procedure DelayObjectDestruction; - procedure Discard; + procedure DelayObjectDestruction; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure Discard; override; + function IsDerivingMembers: boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function CurrentDerivedMember: TBoldMember; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function EnsureEnclosure(ObjectList: TBoldObjectList; ValidateOnly: Boolean): Boolean; - procedure FetchLinksWithObjects(ObjectList: TBoldObjectList; const LinkName: string; FetchedObjects: TBoldObjectList = nil); + procedure FetchLinksWithObjects(ObjectList: TBoldObjectList; const LinkName: string;FetchObjectsInLink: Boolean = True{; const FetchedObjectList: TBoldObjectList = nil}); + procedure FetchMembersWithObjects(aBoldObjectList: TBoldObjectList; aBoldMemberIdList: TBoldMemberIdList); overload; + procedure FetchMembersWithObjects(aBoldObjectList: TBoldObjectList; const AMemberCommaList: string); overload; + procedure FetchMembersWithObject(ABoldObject: TBoldObject; const AMemberCommaList: string); + procedure FetchIdList(FetchIdList: TBoldObjectIdList; AFetchObjects: boolean = true); procedure GetAllInClass(aList: TBoldObjectList; AClass: TBoldObjectClass); procedure GetAllWithCondition(aList: TBoldObjectList; Condition: TBoldCondition); procedure GetAllInClassWithSQL(aList: TBoldObjectList; AClass: TBoldObjectClass; WhereClause, OrderByClause: String; Params: TParams = nil; JoinInheritedTables: Boolean = true; MaxAnswers: integer = -1; Offset: integer = -1); + procedure GetAllInClassWithRawSQL(aList: TBoldObjectList; AClass: TBoldObjectClass; SQL: String; Params: TParams = nil; MaxAnswers: integer = -1; Offset: integer = -1); procedure GetAsList(ResultList: TBoldIndirectElement); override; - function InTransaction: boolean; + function InTransaction: boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure RollbackTransaction(MinimalMode: TBoldSystemTransactionMode = stmNormal); procedure StartTransaction(MinimalMode: TBoldSystemTransactionMode = stmNormal); function TryCommitTransaction(MinimalMode: TBoldSystemTransactionMode = stmNormal): Boolean; procedure UpdateDatabase; procedure UpdateDatabaseWithList(ObjectList: TBoldObjectList); + procedure UpdateDatabaseWithObjects(const aObjects: array of TBoldObject); function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; override; + procedure CheckIntegrity; + procedure DiscardPersistent(ADiscardTransientLinks: boolean = true); + procedure DiscardTransient; + function EnsureLocatorByID(ObjectID: TBoldObjectId; out ACreated: boolean): TBoldObjectLocator; + function ContainsDirtyObjectsOfClass(AClassType: TBoldObjectClass): boolean; + procedure RemoveDeletedObjects(IDList: TBoldObjectIdList); property IsDefault: Boolean read GetIsDefault write SetIsDefault; + property IsDestroying: Boolean index befIsDestroying read GetElementFlag write SetElementFlag; + property IsCommitting: Boolean index befIsCommitting read GetElementFlag write SetElementFlag; + property IsRollingBack: Boolean index befIsRollingBack read GetElementFlag write SetElementFlag; + property IsUpdatingDatabase: Boolean index befIsUpdatingDatabase read GetElementFlag write SetElementFlag; + property IsProcessingTransactionOrUpdatingDatabase: Boolean read GetIsProcessingTransactionOrUpdatingDatabase; property BoldSystemTypeInfo: TBoldSystemTypeInfo read fBoldSystemTypeInfo; property ClassByExpressionName[const ExpressionName: string]: TBoldObjectList read GetClassByExpressionName; + property ClassByObjectClass[ObjectClass: TBoldObjectClass]: TBoldObjectList read GetClassByObjectClass; property Classes[index: Integer]: TBoldObjectList read GetClassByIndex; property DirtyObjects: TList read GetDirtyObjects; + property DirtyObjectsAsBoldListByClass[AClassType: TBoldObjectClass]: TBoldObjectList read GetDirtyObjectsAsBoldList; + property DirtyObjectsAsBoldListByClassExpressionName[const AClass: string]: TBoldObjectList read GetDirtyObjectsAsBoldListByClassExpressionName; + property DirtyObjectsAsBoldList: TBoldObjectList read GetAllDirtyObjectsAsBoldList; property EnsuredLocatorByID[ObjectID: TBoldObjectId]: TBoldObjectLocator read GetEnsuredLocatorByID; property Locators: TBoldSystemLocatorList read fLocators; property PessimisticLockHandler: TBoldAbstractPessimisticLockHandler read fPessimisticLockHandler write SetPessimisticLockHandler; @@ -321,11 +378,13 @@ TBoldSystem = class(TBoldDomainElement) property RegionFactory: TBoldAbstractRegionFactory read fRegionFactory; property NewDirtyList: TBoldObjectList read FNewDirtyList write FNewDirtyList; property NewModifiedList: TBoldObjectList read FNewModifiedList write FNewModifiedList; + property TransactionNesting: Integer read fTransactionNesting; property PersistenceController: TBoldPersistenceController read fPersistenceController; property AsIBoldvalueSpace[Mode: TBoldDomainElementProxyMode]: IBoldvalueSpace read GetAsIBoldValueSpace; property TimeForTimestamp[Timestamp: TBoldTimestampType]: TDateTime read GetTimeForTimestamp; property TimestampForTime[ClockTime: TDateTime]: TBoldTimestampType read GetTimestampForTime; property TimeStampOfLatestUpdate: TBoldTimeStampType read GetTimeStampOfLatestUpdate; + property TimeOfLatestUpdate: TDateTime read GetTimeOfLatestUpdate; property TransactionMode: TBoldSystemTransactionMode read fTransactionMode write SetTransactionMode; property OnPreUpdate: TNotifyEvent read GetOnPreUpdate write SetOnPreUpdate; property OnOptimisticLockingFailed: TBoldOptimisticLockingFailedEvent read fOptimisticLockingFailed write fOptimisticLockingFailed; @@ -334,59 +393,73 @@ TBoldSystem = class(TBoldDomainElement) property OnCreateApproximateObjectError: TBoldCreateApproximateObjectError read fOnCreateApproximateObjectError write fOnCreateApproximateObjectError; end; - { TBoldLocatorListTraverser } + { TBoldLocatorListTraverser } TBoldLocatorListTraverser = class(TBoldIndexableListTraverser) private - function GetLocator: TBoldObjectLocator; + function GetLocator: TBoldObjectLocator; {$IFDEF BOLD_INLINE}inline;{$ENDIF} public - property locator: TBoldObjectLocator read GetLocator; + property Locator: TBoldObjectLocator read GetLocator; + property Current: TBoldObjectLocator read GetLocator; end; {---TBoldSystemLocatorList---} TBoldSystemLocatorList = class(TBoldUnOrderedIndexableList) private - function GetLocatorByID(ObjectID: TBoldObjectId): TBoldObjectLocator; - function GetObjectByID(ObjectID: TBoldObjectId): TBoldObject; + class var IX_BoldObjectId: integer; + function GetLocatorByID(ObjectID: TBoldObjectId): TBoldObjectLocator; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetObjectByID(ObjectID: TBoldObjectId): TBoldObject; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetObjectByIDString(const ID: string): TBoldObject; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetLocatorByIDString(const ID: string): TBoldObjectLocator; {$IFDEF BOLD_INLINE}inline;{$ENDIF} protected function TraverserClass: TBoldIndexableListTraverserClass; override; public constructor Create; + function GetEnumerator: TBoldLocatorListTraverser; procedure UpdateID(Locator: TBoldObjectLocator; NewObjectID: TBoldObjectId; AllowInternal: Boolean = false); function CreateTraverser: TBoldLocatorListTraverser; property LocatorByID[ObjectID: TBoldObjectId]: TBoldObjectLocator read GetLocatorByID; property ObjectByID[ObjectID: TBoldObjectId]: TBoldObject read GetObjectByID; + property LocatorByIdString[const ID: string]: TBoldObjectLocator read GetLocatorByIDString; + property ObjectByIdString[const ID: string]: TBoldObject read GetObjectByIDString; end; + TBoldLocatorArray = array of TBoldObjectLocator; + {---TBoldObjectLocator---} TBoldObjectLocator = class(TBoldMemoryManagedObject) private fBoldSystem: TBoldSystem; fBoldObject: TBoldObject; fBoldObjectID: TBoldObjectId; - fEmbeddedSingleLinks: TBoldObjectArray; + fEmbeddedSingleLinks: TBoldLocatorArray; constructor CreateWithObjectId(BoldSystem: TBoldSystem; BoldObjectID: TBoldObjectId); constructor CreateWithClassID(BoldSystem: TBoldSystem; TopSortedIndex: integer; Exact: Boolean); + procedure AddToLocators; procedure FetchBoldObject; procedure EmbeddedSingleLinksToObject; procedure EmbeddedSingleLinksFromObject; procedure FreeEmbeddedSingleLinksOfOtherEnd; - function GetAsString: string; - function GetEnsuredBoldObject: TBoldObject; - function GetObjectIsPersistent: Boolean; - function GetEmbeddedSingleLinks(EmbeddedIndex: integer): TBoldObjectLocator; + function GetAsString: string; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetEnsuredBoldObject: TBoldObject; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetObjectIsPersistent: Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetEmbeddedSingleLinks(EmbeddedIndex: integer): TBoldObjectLocator; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetEmbeddedSingleLinks(EmbeddedIndex: integer; const Value: TBoldObjectLocator); - //procedure TypeAtLeast(TopSortedIndex: integer; Exact: Boolean); + function GetClassTypeInfo: TBoldClassTypeInfo; + procedure TryShrinkEmbeddedLinks; + protected + function GetDebugInfo: string; override; public destructor Destroy; override; function AtTime(Time: TBoldTimeStampType): TBoldObjectLocator; - procedure DiscardBoldObject; - procedure EnsureBoldObject; - function Hash: Cardinal; + procedure DiscardBoldObject(ADiscardTransientLinks: boolean = true); + procedure EnsureBoldObject; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function Hash: Cardinal; {$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure UnloadBoldObject; property AsString: string read GetAsString; property BoldObject: TBoldObject read FBoldObject; property BoldObjectID: TBoldObjectId read fBoldObjectID; property BoldSystem: TBoldSystem read FBoldSystem; + property BoldClassTypeInfo: TBoldClassTypeInfo read GetClassTypeInfo; property EnsuredBoldObject: TBoldObject read GetEnsuredBoldObject; property ObjectIsPersistent: Boolean read GetObjectIsPersistent; property EmbeddedSingleLinks[EmbeddedIndex: integer]: TBoldObjectLocator read GetEmbeddedSingleLinks write SetEmbeddedSingleLinks; @@ -394,11 +467,12 @@ TBoldObjectLocator = class(TBoldMemoryManagedObject) {---TBoldObject---} TBoldObject = class(TBoldDomainElement) - private fBoldClassTypeInfo: TBoldClassTypeInfo; - fDynamicData: PPointerList; // Defined in Classes for TList + fMemberArray: array of TBoldMember; + fDeriverArray: array of TBoldMemberDeriver; FBoldObjectLocator: TBoldObjectLocator; + fTimeStamp: TBoldTimeStampType; constructor InternalCreateWithClassAndLocator(ClassTypeInfo: TBoldClassTypeInfo; Locator: TBoldObjectLocator); procedure CalculateMemberModified; function CanUnload: Boolean; @@ -412,24 +486,26 @@ TBoldObject = class(TBoldDomainElement) procedure EndUpdate(Translationlist: TBoldIdTranslationlist); procedure EndUpdateMembers(Translationlist: TBoldIdTranslationlist); procedure FailDelete; - function FindBoldMemberByExpressionName(const Name: string): TBoldMember; - function GetBoldExistenceState: TBoldExistenceState; - function GetBoldMemberCount: Integer; + procedure InternalUnLinkAll(AUnlinkPersistent: boolean = true); + procedure InternalDiscard(ADiscardPersistentLinks: boolean = true); + function GetBoldExistenceState: TBoldExistenceState; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetBoldMemberCount: Integer; {inline;} // inline causes a bug function GetBoldMembers(index: Integer): TBoldMember; - function GetBoldPersistenceState: TBoldValuePersistenceState; - function GetBoldSystem: TBoldSystem; - function GetBoldTime: TBoldTimestampType; + function GetBoldMemberDeriver(Member: TBoldMember): TBoldMemberDeriver; + function GetBoldMemberIfAssigned(index: Integer): TBoldMember; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetBoldPersistenceState: TBoldValuePersistenceState; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetBoldSystem: TBoldSystem; reintroduce; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetBoldTime: TBoldTimestampType; {$IFDEF BOLD_INLINE}inline;{$ENDIF} function GetGlobalId: string; - function GetIsModified: Boolean; - function GetIsReadOnly: Boolean; // implements method in IBoldObjectContents - function GetObjectHasSubscribers: Boolean; - function GetTimeStamp: TBoldTimeStampType; + function GetIsModified: Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetObjectHasSubscribers: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetTimeStamp: TBoldTimeStampType; {$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure InitializeObject(System: TBoldSystem; ClassTypeInfo: TBoldClassTypeInfo; Locator: TBoldObjectLocator; Persistent: Boolean); - function CreateMemberByIndex(Index: integer): TBoldMember; procedure InitializeMember(Member: TBoldMember; MemberRTInfo: TBoldMemberRTInfo; IsNewObject: Boolean); function MayUpdateMembers: Boolean; - procedure MemberBecomingClean(BoldMember: TBoldMember); - procedure MemberBecomingModified(BoldMember: TBoldMember); + procedure MemberBecomingClean(BoldMember: TBoldMember); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure MemberBecomingModified(BoldMember: TBoldMember); {inline;} // inline causes a bug + procedure MemberChangingValidity(BoldMemberRtInfo: TBoldMemberRtInfo; NewValue: TBoldValuePersistenceState); {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetBoldExistenceState(Value: TBoldExistenceState); procedure SetBoldPersistenceState(Value: TBoldValuePersistenceState); procedure SetIsReadOnly(NewValue: Boolean); @@ -437,41 +513,52 @@ TBoldObject = class(TBoldDomainElement) procedure SetTimeStamp(NewValue: TBoldTimeStampType); function StartDelete: Boolean; function InternalCanDelete(CheckedObjects: TBoldDomainElementCollection; Cascade: Boolean): Boolean; - function GetAsIBoldObjectContents(Mode: TBoldDomainElementProxyMode): IBoldObjectContents; - function GetBoldMemberAssigned(Index: integer): Boolean; - function GetBoldObjectIsNew: Boolean; - function GetBoldObjectIsDeleted: Boolean; - function GetBoldObjectExists: Boolean; - function GetDynamicDataSize: Integer; + function GetAsIBoldObjectContents(Mode: TBoldDomainElementProxyMode): IBoldObjectContents; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetBoldMemberAssigned(Index: integer): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function SafeGetBoldMemberAssigned(Index: integer): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetBoldObjectIsNew: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetBoldObjectIsDeleted: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetBoldObjectExists: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} property InDirtyList: Boolean index befInDirtyList read GetElementFlag write SetElementFlag; - property IsReadOnly: Boolean read GetIsReadOnly; property MemberModified: Boolean index befMemberModified read GetElementFlag write SetElementFlag; property MemberModifiedKnown: Boolean index befMemberModifiedKnown read GetElementFlag write SetElementFlag; - property BoldStoresTimeStamp: boolean index befStoresTimeStamp read GetElementFlag; + property IsEffectiveInvalid: Boolean index befIsEffectiveInvalid read GetElementFlag write SetElementFlag; + property IsEffectiveInvalidKnown: Boolean index befIsEffectiveInvalidKnown read GetElementFlag write SetElementFlag; + property InDelayDestructionList: Boolean index befInDelayDestructionList read GetElementFlag write SetElementFlag; function GetBoldMemberByExpressionName(const Name: string): TBoldMember; function GetBoldMemberIndexByExpressionName(const Name: string): Integer; - //function GetEffectiveInvalid: Boolean; + function CalculateEffectiveInvalid: Boolean; + function GetEffectiveInvalid: Boolean; + procedure FreeDerivers; protected procedure CompleteCreate; virtual; procedure CompleteUpdate; virtual; + procedure CompleteRecreate; virtual; function GetBoldDirty: Boolean; override; function GetBoldType: TBoldElementTypeInfo; override; function GetDisplayName: String; override; function GetEvaluator: TBoldEvaluator; override; function GetStringRepresentation(Representation: TBoldRepresentation): string; override; - function GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; virtual; - function GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; virtual; + function GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; overload; virtual; + function GetDeriveMethodForMember(MemberIndex: Integer): TBoldDeriveAndResubscribe; overload; virtual; + function GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; overload; virtual; + function GetReverseDeriveMethodForMember(MemberIndex: Integer): TBoldReverseDerive; overload; virtual; function MayDelete: Boolean; virtual; function MayUpdate: Boolean; virtual; + function GetDeletingOrDeletingByDiscard: Boolean; procedure PrepareDelete; virtual; procedure PrepareUpdate; virtual; + procedure PrepareDiscard; virtual; + procedure InternalPrepareDeleteOrDeleteByDiscard; virtual; procedure StateError(S: String); override; function ValidateMember(const ObjectDelphiName, MemberDelphiName: String; GeneratedMemberIndex: integer; MemberClass: TBoldMemberClass): Boolean; procedure ToBeRemovedMemberAccessed(MemberRTInfo: TBoldMemberRTInfo); virtual; procedure ToBeRemovedMemberModified(MemberRTInfo: TBoldMemberRTInfo); virtual; procedure ToBeRemovedClassAccessed; virtual; + function InternalCanDeleteObject: Boolean; virtual; + procedure BeforeDiscard; virtual; + procedure AfterDiscard; virtual; public - // must be public so that links can call it when creating linkclasses constructor Create(AOwningElement: TBoldDomainElement; Persistent: Boolean = True); reintroduce; constructor InternalCreateNewWithClassAndSystem(ClassTypeInfo: TBoldClassTypeInfo; aSystem: TBoldSystem; Persistent: Boolean); destructor Destroy; override; @@ -482,23 +569,32 @@ TBoldObject = class(TBoldDomainElement) function CheckLinks(index: Integer): Boolean; procedure DefaultSubscribe(Subscriber: TBoldSubscriber; RequestedEvent: TBoldEvent = breReEvaluate); override; procedure Delete; - procedure Discard; + procedure Discard; override; + procedure DiscardPersistentMembers; procedure GetAsList(ResultList: TBoldIndirectElement); override; - procedure Invalidate; + procedure Invalidate; override; function IsEqualAs(CompareType: TBoldCompareType; BoldElement: TBoldElement): Boolean; override; - procedure ReceiveEventFromOwned(originator: TObject; originalEvent: TBoldEvent); override; + procedure ReceiveEventFromOwned(originator: TObject; originalEvent: TBoldEvent; const Args: array of const); override; +{$IFNDEF BOLD_NO_QUERIES} + function ReceiveQueryFromOwned(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; override; +{$ENDIF} procedure ReRead; procedure SubscribeToStringRepresentation(Representation: TBoldRepresentation; Subscriber: TBoldSubscriber; RequestedEvent: TBoldEvent = breReEvaluate); override; procedure UnLinkAll; + procedure UnLinkAllPersistent; +{$IFNDEF CompareToOldValues} procedure MarkObjectDirty; +{$ENDIF} procedure ClearTouched; function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; override; + function FindBoldMemberByExpressionName(const Name: string): TBoldMember; property BoldClassTypeInfo: TBoldClassTypeInfo read fBoldClassTypeInfo; property BoldExistenceState: TBoldExistenceState read GetBoldExistenceState; property BoldMemberByExpressionName[const name: string]: TBoldMember read GetBoldMemberByExpressionName; property BoldMemberCount: Integer read GetBoldMemberCount; property BoldMemberIndexByExpressionName[const name: string]: Integer read GetBoldMemberIndexByExpressionName; property BoldMemberAssigned[index: Integer]: Boolean read GetBoldMemberAssigned; + property BoldMemberIfAssigned[index: Integer]: TBoldMember read GetBoldMemberIfAssigned; property BoldMembers[index: Integer]: TBoldMember read GetBoldMembers; property BoldObjectLocator: TBoldObjectLocator read FBoldObjectLocator; property BoldPersistenceState: TBoldValuePersistenceState read GetBoldPersistenceState; @@ -510,6 +606,12 @@ TBoldObject = class(TBoldDomainElement) property BoldObjectIsDeleted: Boolean read GetBoldObjectIsDeleted; property BoldObjectExists: Boolean read GetBoldObjectExists; property Touched: Boolean index befTouched read GetElementFlag; + property Discarding: Boolean index befDiscarding read GetElementFlag write SetElementFlag; + property Deleting: Boolean index befDeleting read GetElementFlag write SetElementFlag; + property DeletingOrDeletingByDiscard: Boolean read GetDeletingOrDeletingByDiscard; + property IsHistoricVersion: Boolean index befIsHistoricVersion read GetElementFlag; + property IsReadOnly: Boolean index befObjectReadOnly read GetElementFlag write SetElementFlag; + property EffectiveInvalid: Boolean read GetEffectiveInvalid; end; { TBoldMember } @@ -517,40 +619,44 @@ TBoldMember = class(TBoldDomainElement) private fBoldMetaType: TBoldMetaElement; procedure AdjustOldValues(Translationlist: TBoldIdTranslationlist); virtual; - procedure CalculateDerivedMemberWithExpression(DerivedObject: TObject; Subscriber: TBoldSubscriber); + procedure CalculateDerivedMemberWithExpression(Subscriber: TBoldSubscriber); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure CalculateDerivedMemberWithDeriveMethod(Subscriber: TBoldSubscriber); + procedure DeriveMember(Subscriber: TBoldSubscriber); + procedure ReverseDeriveMember(); procedure EndUpdate(Translationlist: TBoldIdTranslationlist); - function GetOwningObject: TBoldObject; - function GetBoldSystem: TBoldSystem; - function GetBoldMemberRTInfo: TBoldMemberRTInfo; - procedure _NotifyOutOfDate; + function GetOwningObject: TBoldObject; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetBoldSystem: TBoldSystem; reintroduce; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetBoldMemberRTInfo: TBoldMemberRTInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure _NotifyOutOfDate; {$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure DoSetInitialValue; virtual; - function FindASystem: TBoldSystem; - function GetDeriver: TBoldEventPluggedDeriver; + {$IFDEF LightMemberDeriver} + function GetDeriver: TBoldMemberDeriver; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + {$ENDIF} function GetElementTypeInfoForType: TBoldElementTypeInfo; virtual; - function GetIsPartOfSystem: Boolean; - function GetIsReadOnly(Flag: TBoldElementFlag): Boolean; - procedure InitializeStateToInvalid; - procedure InitializeStateToModified; - procedure InitializeStateToTransient; + function GetIsReadOnly(Flag: TBoldElementFlag): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure InitializeStateToInvalid; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure InitializeStateToModified; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure InitializeStateToTransient; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure InitializeStateToCurrent; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function InternalMayUpdate: Boolean; virtual; - function IsInvalid: Boolean; + function IsInvalid: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetIsCurrent: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure MakeDbCurrent; virtual; procedure ObjectBecomingPersistent; procedure InternalDiscard; - function GetAsIBoldValue(Mode: TBoldDomainElementProxyMode): IBoldValue; + function GetAsIBoldValue(Mode: TBoldDomainElementProxyMode): IBoldValue; {$IFDEF BOLD_INLINE}inline;{$ENDIF} function GetController: TBoldAbstractController; virtual; - procedure MarkMemberDirty; procedure AssignContentValueFromElement(source: TBoldElement); virtual; property HasDeriver: Boolean index befHasDeriver read GetElementFlag write SetElementFlag; - property OwnedByObject: Boolean index befOwnedByObject read GetElementFlag write SetElementFlag; - property IsReadOnly: Boolean index befMemberReadOnly read GetIsReadOnly write SetElementFlag; - function GetDeriverState: TBoldDeriverState; - procedure SetDeriverState(value: TBoldDeriverState); - function GetOldvalue: IBoldvalue; - constructor InternalCreate(OwningObject: TBoldObject; MemberRTInfo: TBoldMemberRTInfo; SetInitialValue: Boolean); + function GetDeriverState: TBoldDeriverState; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetDeriverState(value: TBoldDeriverState); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetOldValue: IBoldvalue; + constructor CreateAsObjectPart(OwningObject: TBoldObject; MemberRTInfo: TBoldMemberRTInfo); + procedure InitializeNonObjectOwned(ElementTypeInfo: TBoldElementTypeInfo); {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure PreDiscard; virtual; property DeriverState: TBoldDeriverState read GetDeriverState write SetDeriverState; protected + function FindASystem: TBoldSystem; procedure DoStartModify; procedure Changed(Event: TBoldEvent; const Args: array of const); procedure CompleteModify; virtual; @@ -558,13 +664,18 @@ TBoldMember = class(TBoldDomainElement) procedure EndModify; procedure FailModify; procedure FreeContent; virtual; + {$IFNDEF LightMemberDeriver} + function GetDeriver: TBoldMemberDeriver; virtual; + {$ENDIF} function GetBoldDirty: Boolean; override; - function GetBoldPersistenceState: TBoldValuePersistenceState; + function GetBoldPersistenceState: TBoldValuePersistenceState; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetPSStateIsInvalid: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetBoldType: TBoldElementTypeInfo; override; function GetDisplayName: String; override; function GetEvaluator: TBoldEvaluator; override; function GetStreamName: string; virtual; - procedure InitializeMember(AOwningElement: TBoldDomainElement; ElementTypeInfo: TBoldElementTypeInfo); virtual; + function GetFreeStandingClass: TBoldFreeStandingElementClass; virtual; + procedure Initialize; virtual; function MayModify: Boolean; virtual; function MayUpdate: Boolean; virtual; procedure PreChange; @@ -574,54 +685,68 @@ TBoldMember = class(TBoldDomainElement) procedure StateError(S: String); override; function StartModify: Boolean; virtual; function RetrieveProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj; const InterfaceName: string): Boolean; - function ProxyClass: TBoldMember_ProxyClass; virtual; abstract; + function GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; virtual; abstract; function CloneIfPossible: TBoldElement; override; + function GetIsPartOfSystem: Boolean; override; public constructor Create; reintroduce; - constructor CreateWithTypeInfo(ElementTypeInfo: TBoldElementTypeInfo); + constructor CreateWithTypeInfo(ElementTypeInfo: TBoldElementTypeInfo); override; destructor Destroy; override; function AtTime(Time: TBoldTimestampType): TBoldMember; virtual; function CanModify: Boolean; function CanUpdate: Boolean; - function MemberHasSubscribers: Boolean; - function Clone: TBoldMember; - function IsEqualToValue(Value: IBoldValue): Boolean; virtual; - function StoreInUndo: Boolean; { TODO : Move to RTInfo } - procedure Discard; - procedure EnsureContentsCurrent; + function MemberHasSubscribers: Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function Clone: TBoldMember; virtual; + function IsEqualToValue(const Value: IBoldValue): Boolean; virtual; + function StoreInUndo: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure Discard; override; + procedure DoEnsureContentsCurrent; + procedure DoMarkTouched; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure EnsureContentsCurrent; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure Refetch; procedure GetAsList(ResultList: TBoldIndirectElement); override; procedure GetAsValue(ResultElement: TBoldIndirectElement); override; - procedure Invalidate; - function CanRead(Subscriber: TBoldSubscriber): Boolean; + procedure Invalidate; override; + procedure MarkMemberDirty; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function CanRead(Subscriber: TBoldSubscriber): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function ObserverMayModify(Observer: TObject): Boolean; override; function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; override; property BoldMemberRTInfo: TBoldMemberRTInfo read GetBoldMemberRTInfo; property BoldSystem: TBoldSystem read GetBoldSystem; property BoldPersistenceState: TBoldValuePersistenceState read GetBoldPersistenceState write SetBoldPersistenceState; + property BoldPersistenceStateIsInvalid: Boolean read GetPSStateIsInvalid; + property IsCurrent: Boolean read GetIsCurrent; property Derived: Boolean index befDerived read GetElementFlag; - property Deriver: TBoldEventPluggedDeriver read GetDeriver; - property IsPartOfSystem: Boolean read GetIsPartOfSystem; + property Deriver: TBoldMemberDeriver read GetDeriver; property OwningObject: TBoldObject read GetOwningObject; property AsIBoldValue[Mode: TBoldDomainElementProxyMode]: IBoldValue read GetAsIBoldValue; property OldValue: IBoldValue read GetOldValue; property Touched: Boolean index befTouched read GetElementFlag; + property IsPreFetched: Boolean index befPreFetched read GetElementFlag write SetElementFlag; + property OwnedByObject: Boolean index befOwnedByObject read GetElementFlag write SetElementFlag; + property IsReadOnly: Boolean index befMemberReadOnly read GetIsReadOnly write SetElementFlag; end; { TBoldMember_Proxy } TBoldMember_Proxy = class(TBoldDomainElement_Proxy, IBoldValue, IBoldStreamable) private - function GetProxedMember: TBoldMember; - function GetProxedController: TBoldAbstractController; + fProxedMember: TBoldMember; + function GetProxedController: TBoldAbstractController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected - property ProxedMember: TBoldMember read GetProxedMember; + property ProxedMember: TBoldMember read fProxedMember; property ProxedController: TBoldAbstractController read GetProxedController; - function GetContentName: String; - function GetStreamName: String; - procedure AssignContent(Source: IBoldValue); - procedure AssignContentValue(Source: IBoldValue); virtual; abstract; - function GetBoldPersistenceState: TBoldValuePersistenceState; - procedure SetBoldPersistenceState(Value: TBoldValuePersistenceState); + function GetContentName: String; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetStreamName: String; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetFreeStandingClass: TBoldFreeStandingElementClass; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetContentType: TBoldValueContentType; + procedure AssignContent(const Source: IBoldValue); + procedure AssignContentValue(const Source: IBoldValue); virtual; abstract; + function GetBoldPersistenceState: TBoldValuePersistenceState; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetBoldPersistenceState(Value: TBoldValuePersistenceState); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + constructor Create(ProxedMember: TBoldMember; Mode: TBoldDomainElementProxyMode); + public + class function MakeProxy(ProxedMember: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; virtual; + procedure Retarget(ProxedMember: TBoldMember; Mode: TBoldDomainElementProxyMode); {$IFDEF BOLD_INLINE} inline; {$ENDIF} end; { TBoldMemberFactory } @@ -634,67 +759,75 @@ TBoldMemberFactory = class(TBoldMemoryManagedObject) {---TBoldAttribute---} TBoldAttribute = class(TBoldMember) private - function GetBoldAttributeRTInfo: TBoldAttributeRTInfo; + function GetBoldAttributeRTInfo: TBoldAttributeRTInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetElementTypeInfoForType: TBoldElementTypeInfo; override; - function GetIsNull: Boolean; + function GetIsNull: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure MakeDbCurrent; override; procedure NullFailure; protected - procedure AssignValue(Source: IBoldValue); virtual; abstract; - procedure AssignContentValue(Source: IBoldValue); virtual; abstract; + procedure AssignValue(const Source: IBoldValue); virtual; abstract; + procedure AssignContentValue(const Source: IBoldValue); virtual; abstract; procedure DoSetInitialValue; override; - function GetContentIsNull: Boolean; + property ContentIsNull: Boolean index befIsNull read GetElementFlag; class function EitherIsNull(Attribute1, Attribute2: TBoldAttribute): Boolean; - procedure EnsureNotNull; + procedure EnsureNotNull; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure FormatFailure(const value, ExpectedDataType: String); + function GetAttributeTypeInfoForType: TBoldElementTypeInfo; virtual; function GetStreamName: string; override; + function StringCompare(CompareType: TBoldCompareType; const s1, s2: string): integer; function NullBiggest(BoldElement: TBoldElement): Integer; function NullSmallest(BoldElement: TBoldElement): Integer; procedure SetContentToNull; - procedure SetToNonNull; - property ContentIsNull: Boolean read GetContentIsNull; + procedure SetToNonNull; {$IFDEF BOLD_INLINE}inline;{$ENDIF} public + function GetAsVariant: Variant; override; + procedure SetAsVariant(const Value: Variant); override; function CompareToAs(CompType: TBoldCompareType; BoldElement: TBoldElement): Integer; override; procedure DefaultSubscribe(Subscriber: TBoldSubscriber; RequestedEvent: TBoldEvent = breReEvaluate); override; function CanSetToNull(Subscriber: TBoldSubscriber): Boolean; - function IsEqualToValue(Value: IBoldValue): Boolean; override; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; procedure RecycleValue; procedure SetToNull; virtual; procedure Assign(Source: TBoldElement); override; function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; override; procedure SubscribeToStringRepresentation(Representation: TBoldRepresentation; Subscriber: TBoldSubscriber; RequestedEvent: TBoldEvent = breReEvaluate); override; procedure SetEmptyValue; virtual; + function ValidateVariant(const Value: Variant; Representation: TBoldRepresentation = brDefault): Boolean; override; + function IsVariantTypeCompatible(const Value: Variant): Boolean; virtual; property BoldAttributeRTInfo: TBoldAttributeRTInfo read GetBoldAttributeRTInfo; property IsNull: Boolean read GetIsNull; end; { TBoldAttribute_Proxy } - TBoldAttribute_Proxy = class(TBoldMember_Proxy, IBoldNullableValue) + TBoldAttribute_Proxy = class(TBoldMember_Proxy, IBoldNullableValue, IBoldStringRepresentable) private - function GetProxedAttribute: TBoldAttribute; + function GetProxedAttribute: TBoldAttribute; {$IFDEF BOLD_INLINE}inline;{$ENDIF} protected - procedure AssignContentValue(Source: IBoldValue); override; - procedure SetContentToNull; - function GetContentIsNull: Boolean; + procedure AssignContentValue(const Source: IBoldValue); override; + procedure SetContentToNull; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetContentIsNull: Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} property ProxedAttribute: TBoldAttribute read GetProxedAttribute implements IBoldNullableValue; + function GetStringRepresentation(representation:integer): String; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetStringRepresentation(Representation: integer; const NewValue: String); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetContentAsString: String; virtual; end; { TBoldFailureReason } TBoldFailureReason = class(TObject) private FMessageFormatStr: String; - fOriginator: TBoldDomainElement; + fOriginator: TBoldElement; fReason: string; fSubscriber: TBoldPassThroughSubscriber; procedure ReceiveOriginatorDestroy(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); protected function GetException(const Msg: String): EBoldFailure; virtual; public - constructor create(reason: String; Originator: TBoldDomainElement); - constructor CreateFmt(Reason: string; const args: array of const; Originator: TBoldDomainElement); + constructor Create(AReason: String; Originator: TBoldElement); + constructor CreateFmt(Reason: string; const args: array of const; Originator: TBoldElement); destructor Destroy; override; property MessageFormatStr: String read fMessageFormatStr write fMessageFormatStr; - property Originator: TBoldDomainElement read fOriginator; + property Originator: TBoldElement read fOriginator; property Reason: string read fReason; end; @@ -704,7 +837,7 @@ TBoldObjectReference = class(TBoldMember) fObjectReferenceController: TBoldAbstractObjectReferenceController; procedure AdjustOldValues(Translationlist: TBoldIdTranslationlist); override; function GetBoldObject: TBoldObject; - function GetBoldRoleRTInfo: TBoldRoleRTInfo; + function GetBoldRoleRTInfo: TBoldRoleRTInfo; {$IFDEF BOLD_INLINE}inline;{$ENDIF} function InternalMayUpdate: Boolean; override; procedure InternalSetLocator(NewLocator: TBoldObjectLocator); procedure MakeDbCurrent; override; @@ -716,27 +849,29 @@ TBoldObjectReference = class(TBoldMember) function GetOldEmbeddingOtherEndId: TBoldObjectId; procedure PreDiscard; override; procedure DoSetInitialValue; override; - function GetLocator: TBoldObjectLocator; + function GetLocator: TBoldObjectLocator; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetLocator(NewLocator: TBoldObjectLocator); + function GetIsEmpty: boolean; protected function GetStreamName: String; override; + function GetFreeStandingClass: TBoldFreeStandingElementClass; override; function GetStringRepresentation(Representation: TBoldRepresentation): string; override; - procedure InitializeMember(AOwningElement: TBoldDomainElement; ElementTypeInfo: TBoldElementTypeInfo); override; - procedure SetStringRepresentation(Representation: TBoldRepresentation; Value: string); override; - function ProxyClass: TBoldMember_ProxyClass; override; + procedure Initialize; override; + procedure SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); override; + function GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; public constructor CreateTypedReference(ObjectClass: TBoldObjectClass); destructor Destroy; override; procedure Assign(Source: TBoldElement); override; - function CanClear(Subscriber: TBoldSubscriber): Boolean; - function CanSet(NewObject: TBoldObject; Subscriber: TBoldSubscriber): Boolean; + function CanClear(Subscriber: TBoldSubscriber): Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function CanSet(NewObject: TBoldObject; Subscriber: TBoldSubscriber): Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} function CanSetLocator(NewLocator: TBoldObjectLocator; Subscriber: TBoldSubscriber): Boolean; procedure Clear; function CompareToAs(CompareType: TBoldCompareType; BoldElement: TBoldElement): Integer; override; procedure DefaultSubscribe(Subscriber: TBoldSubscriber; RequestedEvent: TBoldEvent = breReEvaluate); override; procedure GetAsList(ResultList: TBoldIndirectElement); override; function IsEqualAs(CompareType: TBoldCompareType; BoldElement: TBoldElement): Boolean; override; - function IsEqualToValue(Value: IBoldValue): Boolean; override; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; function ObserverMayModify(Observer: TObject): Boolean; override; function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; override; procedure SubscribeToStringRepresentation(Representation: TBoldRepresentation; Subscriber: TBoldSubscriber; RequestedEvent: TBoldEvent = breReEvaluate); override; @@ -745,6 +880,21 @@ TBoldObjectReference = class(TBoldMember) property Locator: TBoldObjectLocator read GetLocator write SetLocator; property OldEmbeddingOtherEndId: TBoldObjectId read GetOldEmbeddingOtherEndId; property HasOldValues: Boolean index befHasOldValues read GetElementFlag write SetElementFlag; + property IsEmpty: boolean read GetIsEmpty; + end; + + TBoldListEnumerator = class + private + FIndex: Integer; + FList: TBoldList; + protected + property Index: Integer read fIndex; + property List: TBoldList read fList; + public + constructor Create(AList: TBoldList); + function GetCurrent: TBoldElement; + function MoveNext: Boolean; + property Current: TBoldElement read GetCurrent; end; { TBoldList } @@ -752,9 +902,15 @@ TBoldList = class(TBoldMember) private fListController: TBoldListController; function GetController: TBoldAbstractController; override; - function GetDuplicateMode: TBoldListDupMode; + function GetDuplicateMode: TBoldListDupMode; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure PrepareClear; virtual; procedure SetDuplicateMode(NewMode: TBoldListDupMode); + function GetFirst: TBoldElement; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetLast: TBoldElement; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetEmpty: Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function DefaultCompare(Item1, Item2: TBoldElement): Integer; + function GetCapacity: integer; virtual; + procedure SetCapacity(const Value: integer); virtual; protected procedure AddElement(Element: TBoldElement); virtual; abstract; procedure AllocateData; virtual; @@ -767,7 +923,7 @@ TBoldList = class(TBoldMember) function GetStringRepresentation(Representation: TBoldRepresentation): string; override; function IncludesElement(Item: TBoldElement): Boolean; virtual; abstract; function IndexOfElement(Item: TBoldElement): Integer; virtual; abstract; - procedure InitializeMember(AOwningElement: TBoldDomainElement; ElementTypeInfo: TBoldElementTypeInfo); override; + procedure Initialize; override; procedure InsertElement(index: Integer; Element: TBoldElement); virtual; abstract; function InternalAddNew: TBoldElement; virtual; abstract; function GetCanCreateNew: Boolean; virtual; @@ -775,35 +931,59 @@ TBoldList = class(TBoldMember) procedure InternalClear; virtual; abstract; property ListController: TBoldListController read fListController write fListController; public + constructor CreateWithTypeInfo(ElementTypeInfo: TBoldElementTypeInfo); override; destructor Destroy; override; - procedure Add(Element: TBoldElement); + function GetEnumerator: TBoldListEnumerator; + procedure Add(Element: TBoldElement); {$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure AddList(List: TBoldList); virtual; - function AddNew: TBoldElement; + procedure RemoveList(List: TBoldList); virtual; + procedure IntersectList(List: TBoldList); virtual; + function AddNew: TBoldElement; {$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure AddToStrings(Representation: TBoldRepresentation; S: TStrings); - function CanClear(Subscriber: TBoldSubscriber): Boolean; + function CanClear(Subscriber: TBoldSubscriber): Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} function CanInsert(index: Integer; Element: TBoldElement; Subscriber: TBoldSubscriber): Boolean; virtual; function CanMove(CurIndex, NewIndex: Integer; Subscriber: TBoldSubscriber = nil): Boolean; virtual; function CanRemove(index: Integer; Subscriber: TBoldSubscriber): Boolean; virtual; function CanSet(index: Integer; Item: TBoldElement; Subscriber: TBoldSubscriber): Boolean; virtual; procedure Clear; + function CompareToAs(CompType: TBoldCompareType; BoldElement: TBoldElement): Integer; override; procedure DefaultSubscribe(Subscriber: TBoldSubscriber; RequestedEvent: TBoldEvent = breReEvaluate); override; procedure EnsureRange(FromIndex: integer; ToIndex: integer); virtual; procedure GetAsList(ResultList: TBoldIndirectElement); override; - function Includes(Item: TBoldElement): Boolean; - function IndexOf(Item: TBoldElement): Integer; + function Includes(Item: TBoldElement): Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function IncludesAny(aList: TBoldList): Boolean; + function IncludesAll(aList: TBoldList): Boolean; + function IndexOf(Item: TBoldElement): Integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure Insert(index: Integer; Element: TBoldElement); procedure InsertNew(index: Integer); virtual; abstract; procedure Move(CurIndex, NewIndex: Integer); virtual; abstract; procedure MakeContentsImmutable; - procedure Remove(Item: TBoldElement); virtual; + procedure Remove(Item: TBoldElement; ARaiseIfNotFound: boolean = true); virtual; procedure RemoveByIndex(index: Integer); virtual; abstract; - procedure Sort(CompareFunc: TBoldElementCompare); + procedure Sort(CompareFunc: TBoldElementCompare; FirstIndex, LastIndex: + Integer; SortMode: TBoldSortMode = BoldDefaultSortMode); overload; + procedure Sort(CompareFunc: TBoldElementCompare; SortMode: TBoldSortMode = + BoldDefaultSortMode); overload; + procedure Sort; overload; {$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure ToStrings(Representation: TBoldRepresentation; S: TStrings); procedure ToStringsWithNil(Representation: TBoldRepresentation; S: TStrings; nilString: string); + function HasDuplicates: boolean; + function AsCommaText(AIncludeType: boolean = true; Representation: TBoldRepresentation = brDefault; const ASeparator: string = ','): string; + function AsDebugCommaText(const ASeparator: string = ','): string; property CanCreateNew: Boolean read GetCanCreateNew; property Count: Integer read GetCount; property DuplicateMode: TBoldListDupMode read GetDuplicateMode write SetDuplicateMode; property Elements[index: Integer]: TBoldElement read GetElement write SetElement; default; + property Empty: Boolean read GetEmpty; + property First: TBoldElement read GetFirst; + property Last: TBoldElement read GetLast; + property Capacity: integer read GetCapacity write SetCapacity; + end; + + TBoldMemberListEnumerator = class(TBoldListEnumerator) + public + function GetCurrent: TBoldMember; + property Current: TBoldMember read GetCurrent; end; {---TBoldMemberList---} @@ -816,8 +996,10 @@ TBoldMemberList = class(TBoldList) function CheckReplace(index: Integer; NewMember: TBoldMember): Boolean; procedure SetCloneMembers(const Value: Boolean); function GetBoldMember(index: Integer): TBoldMember; - procedure SetBoldMember(index: Integer; Value: TBoldMember); - procedure InternalAddWithoutCloning(Item: TBoldMember); // FIXME remove when TBoldClass no longer member + procedure SetBoldMember(index: Integer; Value: TBoldMember); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure InternalAddWithoutCloning(Item: TBoldMember); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetCapacity: integer; override; + procedure SetCapacity(const Value: integer); override; property List: TList read faList; protected procedure AddElement(Element: TBoldElement); override; @@ -829,18 +1011,22 @@ TBoldMemberList = class(TBoldList) function GetElement(index: Integer): TBoldElement; override; function GetStreamName: String; override; function GetStringRepresentation(Representation: TBoldRepresentation): string; override; + procedure SetStringRepresentation(Representation: integer; const NewValue: String); override; function IncludesElement(Item: TBoldElement): Boolean; override; + function IncludesValue(Item: TBoldElement): Boolean; function IndexOfElement(Item: TBoldElement): Integer; override; - procedure InitializeMember(AOwningElement: TBoldDomainElement; ElementTypeInfo: TBoldElementTypeInfo); override; + procedure Initialize; override; procedure InsertElement(index: Integer; Element: TBoldElement); override; procedure SetElement(index: Integer; Value: TBoldElement); override; function InternalAddNew: TBoldElement; override; - function ProxyClass: TBoldMember_ProxyClass; override; + function GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; procedure InternalClear; override; public + function GetEnumerator: TBoldMemberListEnumerator; procedure Add(Item: TBoldMember); procedure Assign(Source: TBoldElement); override; - function IndexOf(Item: TBoldMember): Integer; + function IndexOf(Item: TBoldMember): Integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function IndexOfFirstEqualElement(Item: TBoldMember): Integer; procedure Insert(index: Integer; Item: TBoldMember); procedure InsertNew(index: Integer); override; procedure Move(CurIndex, NewIndex: Integer); override; @@ -849,29 +1035,40 @@ TBoldMemberList = class(TBoldList) property CloneMembers: Boolean read FCloneMembers write SetCloneMembers; end; + TBoldObjectListEnumerator = class(TBoldListEnumerator) + public + function GetCurrent: TBoldObject; + property Current: TBoldObject read GetCurrent; + end; + + TBoldObjectListLocatorEnumerator = class(TBoldListEnumerator) + public + function GetCurrent: TBoldObjectLocator; + property Current: TBoldObjectLocator read GetCurrent; + end; + {---TBoldObjectList ---} TBoldObjectList = class(TBoldList) private - function CheckAdd(NewLocator: TBoldObjectLocator): Boolean; - function CheckInsert(index: Integer; NewLocator: TBoldObjectLocator): Boolean; + function CheckAdd(NewLocator: TBoldObjectLocator): Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function CheckInsert(index: Integer; NewLocator: TBoldObjectLocator): Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} function CheckReplace(index: Integer; NewLocator: TBoldObjectLocator): Boolean; - function GetBoldRoleRTInfo: TBoldRoleRTInfo; - function GetObjectListController: TBoldAbstractObjectListController; + function GetBoldRoleRTInfo: TBoldRoleRTInfo; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetObjectListController: TBoldAbstractObjectListController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure MakeDbCurrent; override; - function GetSubscribeToObjectsInList: Boolean; + function GetSubscribeToObjectsInList: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetSubscribeToObjectsInList(const Value: Boolean); - function GetSubscribeToLocatorsInList: Boolean; + function GetSubscribeToLocatorsInList: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetSubscribeToLocatorsInList(const Value: Boolean); procedure InternalRemoveByIndex(index: Integer); procedure AssignContentValueFromElement(source: TBoldElement); override; procedure PrepareClear; override; - function GetBoldObject(index: Integer): TBoldObject; + function GetBoldObject(index: Integer): TBoldObject; {$IFDEF BOLD_INLINE}inline;{$ENDIF} function GetElementTypeInfoForType: TBoldElementTypeInfo; override; - function GetLocator(index: Integer): TBoldObjectLocator; + function GetLocator(index: Integer): TBoldObjectLocator; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetBoldObject(index: Integer; NewObject: TBoldObject); procedure SetLocator(index: Integer; NewLocator: TBoldObjectLocator); function VerifyClass(aLocator: TBoldObjectLocator): Boolean; - property ObjectListController: TBoldAbstractObjectListController read GetObjectListController; protected procedure AddElement(Element: TBoldElement); override; procedure AllocateData; override; @@ -879,35 +1076,41 @@ TBoldObjectList = class(TBoldList) function GetCount: Integer; override; function GetElement(index: Integer): TBoldElement; override; function GetStreamName: String; override; + function GetFreeStandingClass: TBoldFreeStandingElementClass; override; function IncludesElement(Item: TBoldElement): Boolean; override; function IndexOfElement(Item: TBoldElement): Integer; override; - procedure InitializeMember(AOwningElement: TBoldDomainElement; ElementTypeInfo: TBoldElementTypeInfo); override; + procedure Initialize; override; procedure InsertElement(index: Integer; Element: TBoldElement); override; - procedure SetElement(index: Integer; Value: TBoldElement); override; - function ProxyClass: TBoldMember_ProxyClass; override; + function GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; procedure FreeContent; override; function InternalAddNew: TBoldElement; override; procedure InternalClear; override; + property ObjectListController: TBoldAbstractObjectListController read GetObjectListController; public - constructor InternalCreateClassList(System: TBoldSystem; ListTypeInfo: TBoldListTypeINfo); // used by ClassListController - constructor CreateTypedList(ObjectClass: TBoldObjectClass); - procedure Add(BoldObject: TBoldObject); + function GetEnumerator: TBoldObjectListEnumerator; + function GetLocatorEnumerator: TBoldObjectListLocatorEnumerator; + constructor InternalCreateClassList(System: TBoldSystem; ListTypeInfo: TBoldListTypeInfo); + constructor CreateTypedList(ObjectClass: TBoldObjectClass; ABoldSystem: TBoldSystem = nil); + constructor CreateRootClassList(ABoldSystem: TBoldSystem = nil); + procedure Add(BoldObject: TBoldObject); {$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure AddList(List: TBoldList); override; procedure AddLocator(NewLocator: TBoldObjectLocator); procedure Assign(Source: TBoldElement); override; function AtTime(Time: TBoldTimestampType): TBoldMember; override; - function CreateObjectIdList: TBoldObjectIdList; - procedure EnsureObjects; + function CreateObjectIdList(WithoutDuplicates: boolean = false): TBoldObjectIdList; + procedure EnsureObjects; {$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure EnsureRange(FromIndex: integer; ToIndex: integer); override; procedure FillFromIDList(ObjectIdList: TBoldObjectIdList; BoldSystem: TBoldSystem); - function GetByIndex(MemberList: TBoldMemberList): TBoldObject; + procedure RemoveDeletedObjects; + function FilterOnType(BoldClassTypeInfo: TBoldClassTypeInfo; IncludeSubclasses: boolean = true): TBoldObjectList; + function GetByIndex(MemberList: TBoldMemberList): TBoldObject; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetByIndexAndSubscribe(MemberList: TBoldMemberList; Subscriber: TBoldSubscriber): TBoldObject; - function Includes(BoldObject: TBoldObject): Boolean; - function IndexOf(BoldObject: TBoldObject): Integer; - function IndexOfLocator(Locator: TBoldObjectLocator): Integer; + function Includes(BoldObject: TBoldObject): Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function IndexOf(BoldObject: TBoldObject): Integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function IndexOfLocator(Locator: TBoldObjectLocator): Integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure InsertNew(index: Integer); override; - procedure Insert(index: Integer; BoldObject: TBoldObject); + procedure Insert(index: Integer; BoldObject: TBoldObject); {$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure InsertLocator(index: Integer; Locator: TBoldObjectLocator); function LocatorInList(NewLocator: TBoldObjectLocator): Boolean; function CanInsert(index: Integer; Element: TBoldElement; Subscriber: TBoldSubscriber): Boolean; override; @@ -918,6 +1121,14 @@ TBoldObjectList = class(TBoldList) function ObserverMayModify(Observer: TObject): Boolean; override; function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; override; procedure RemoveByIndex(index: Integer); override; + procedure RemoveLocator(ALocator: TBoldObjectLocator); + procedure DeleteObjects; + function BeginUpdate: boolean; + procedure EndUpdate; + function IsEqualToValue(const Value: IBoldValue): Boolean; override; + function LeastCommonClassType(ABoldSystem: TBoldSystem): TBoldClassTypeInfo; + function Clone: TBoldMember; overload; override; + function Clone(ACopyDuplicateMode: boolean; ASubscribeToObjectsInList: boolean): TBoldMember; reintroduce; overload; property BoldObjects[index: Integer]: TBoldObject read GetBoldObject write SetBoldObject; default; property BoldRoleRTInfo: TBoldRoleRTInfo read GetBoldRoleRTInfo; property Locators[index: Integer]: TBoldObjectLocator read GetLocator write SetLocator; @@ -931,18 +1142,22 @@ TBoldObjectList = class(TBoldList) {---TBoldAbstractController---} TBoldAbstractController = class(TBoldMemoryManagedObject) protected + function GetRoleRTInfo: TBoldRoleRTInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetBoldSystem: TBoldSystem; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetOwningObject: TBoldObject; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure Changed(Event: TBoldEvent; const Args: array of const); function GetStreamName: string; virtual; abstract; + function GetFreeStandingClass: TBoldFreeStandingElementClass; virtual; function GetOwningMember: TBoldMember; virtual; abstract; - function LocatorForID(ObjectId: TBoldObjectId): TBoldObjectLocator; + function LocatorForID(ObjectId: TBoldObjectId): TBoldObjectLocator; {$IFDEF BOLD_INLINE}inline;{$ENDIF} function AssertedLocatorForID(ObjectId: TBoldObjectId): TBoldObjectLocator; - procedure PreChange; - function StartModify: Boolean; - class function GetControllerForMember(Member: TBoldMember): TBoldAbstractController; + procedure PreChange; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function StartModify: Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + class function GetControllerForMember(Member: TBoldMember): TBoldAbstractController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function NewValueInOptimisticLocking: IBoldValue; procedure DbFetchOwningMember; procedure DbFetchClassForMember(Timestamp: TBoldTimestampType); - procedure EndModify; + procedure EndModify; {$IFDEF BOLD_INLINE}inline;{$ENDIF} public function AssertIntegrity: Boolean; virtual; procedure Unlink(OldLocator: TBoldObjectLocator; Mode: TBoldLinkUnlinkMode); virtual; @@ -950,13 +1165,15 @@ TBoldAbstractController = class(TBoldMemoryManagedObject) function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; virtual; property StreamName: String read GetStreamName; property OwningMember: TBoldMember read GetOwningMember; + property OwningObject: TBoldObject read GetOwningObject; + property RoleRTInfo: TBoldRoleRTInfo read GetRoleRTInfo; + property BoldSystem: TBoldSystem read GetBoldSystem; end; {---TBoldListController---} TBoldListController = class(TBoldAbstractController) private fOwningList: TBoldList; - function GetBoldSystem: TBoldSystem; protected function GetOwningMember: TBoldMember; override; property OwningList: TBoldList read fOwningList; @@ -964,8 +1181,10 @@ TBoldListController = class(TBoldAbstractController) function GetCanCreateNew: Boolean; virtual; function CreateNew: TBoldElement; virtual; function GetStringrepresentation: String; virtual; + function GetCapacity: integer; virtual; + procedure SetCapacity(const Value: integer); virtual; public - constructor Create(OwningList: TBoldList); + constructor Create(OwningList: TBoldList); virtual; procedure AddElement(Element: TBoldElement); virtual; abstract; function GetElement(index: Integer): TBoldElement; virtual; abstract; function IncludesElement(Item: TBoldElement): Boolean; virtual; abstract; @@ -974,18 +1193,19 @@ TBoldListController = class(TBoldAbstractController) procedure Move(CurrentIndex: Integer; NewIndex: Integer); virtual; abstract; procedure RemoveByIndex(index: Integer); virtual; abstract; procedure SetElement(index: Integer; Value: TBoldElement); virtual; abstract; - property BoldSystem: TBoldSystem read GetBoldSystem; property CanCreateNew: Boolean read GetCanCreateNew; property Count: integer read GetCount; + property Capacity: integer read GetCapacity write SetCapacity; end; {---TBoldAbstractObjectListController---} TBoldAbstractObjectListController = class(TBoldListController) private protected - function GetObjectList: TBoldObjectList; + function GetDebugInfo: string; override; + function GetObjectList: TBoldObjectList; {$IFDEF BOLD_INLINE}inline;{$ENDIF} property OwningObjectList: TBoldObjectList read GetObjectList; - function ProxyClass: TBoldMember_ProxyClass; virtual; abstract; + function GetProxy(Member: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; virtual; abstract; procedure PrepareClear; virtual; public procedure AddElement(Element: TBoldElement); override; @@ -1019,7 +1239,7 @@ TBoldAbstractObjectReferenceController = class(TBoldAbstractController) function OtherEndControllerForLinkObject(Obj: TBoldObject): TBoldAbstractObjectReferenceController; function ControllerForLinkRole: TBoldAbstractObjectReferenceController; function ControllerForMainRole: TBoldAbstractObjectReferenceController; - function ProxyClass: TBoldMember_ProxyClass; virtual; abstract; + function GetProxy(Member: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; virtual; abstract; public constructor Create(Owner: TBoldObjectReference); virtual; function GetLocator: TBoldObjectLocator; virtual; abstract; @@ -1036,11 +1256,12 @@ TBoldObjectReferenceController = class(TBoldAbstractObjectReferenceController) procedure ObjectChangeReceive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); protected function GetStreamName: string; override; - function ProxyClass: TBoldMember_ProxyClass; override; + function GetFreeStandingClass: TBoldFreeStandingElementClass; override; + function GetProxy(Member: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; public constructor Create(Owner: TBoldObjectReference); override; destructor Destroy; override; - procedure AssignContentValue(Source: IBoldValue); + procedure AssignContentValue(const Source: IBoldValue); function GetLocator: TBoldObjectLocator; override; procedure SetLocator(NewLocator: TBoldObjectLocator); override; procedure MakeDbCurrent; override; @@ -1076,129 +1297,316 @@ TBoldLocatorHashIndex = class(TBoldHashIndex) public function FindLocatorByLocator(BoldObjectLocator: TBoldObjectLocator): TBoldObjectLocator; end; - {$ENDIF} + TBoldMemberDeriver = class({$IFDEF LightMemberDeriver}TBoldAbstractDeriver{$ELSE}TBoldEventPluggedDeriver{$ENDIF}) + strict private + fDerivedMember: TBoldMember; + strict protected + procedure SetInternalDeriverState(const Value: TBoldDeriverState); override; + function GetInternalDeriverState: TBoldDeriverState; override; + procedure DoNotifyOutOfDate; override; + function GetDerivedObject: TObject; override; + procedure DoDeriveAndSubscribe(subscribe: Boolean); override; + procedure DoReverseDerive; override; + function GetCanReverseDerive: Boolean; override; + public + constructor Create(Member: TBoldMember); + destructor Destroy; override; + property DerivedMember: TBoldMember read fDerivedMember; + property CanReverseDerive: Boolean read GetCanReverseDerive; + end; + + IBoldSystemObjectContents = interface + ['{FB4110D9-C06D-4E92-B6A9-242D8836BC79}'] + function EnsureMemberAndGetValueByIndex(Member: TBoldMember): IBoldValue; + end; + + TBoldSystemFreeStandingObjectContents = class(TBoldFreeStandingObjectContents, IBoldSystemObjectContents) + function EnsureMemberAndGetValueByIndex(Member: TBoldMember): IBoldValue; + end; + function GetBoldLastFailureReason: TBoldFailureReason; procedure SetBoldLastFailureReason(const Value: TBoldFailureReason); -procedure BoldRaiseLastFailure(originator: TBoldDomainElement; const MethodName: String; const DefaultMessage: String); -procedure BoldClearLastFailure; +procedure BoldRaiseLastFailure(originator: TBoldElement; const MethodName: String; const DefaultMessage: String); +procedure BoldClearLastFailure; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + +//PATCH +function GetTransactionInfo(aSystem: TBoldSystem): string; + +function BoldSystemCount: integer; +function BoldSystems(Index: integer): TBoldSystem; + +function TopSortedIndex2ClassName(ATopSortedIndex: integer): string; +function VerifyLocatorType(ALocator: TBoldObjectLocator; AExpectedClassType: TBoldClassTypeInfo; ARaise: boolean = true): Boolean; + +var + G_LastFailureReason: TBoldFailureReason = nil; implementation uses SysUtils, - BoldMemoryManager, + Variants, + Windows, BoldLogHandler, BoldGuard, BoldLinks, BoldObjectListControllers, BoldOcl, Typinfo, - BoldOptimisticLockingSupport, // could be avoided with factory - BoldSystemPersistenceHandler, // could be avoided with factory - BoldSystemOldValueHandler, // could be avoided with factory, will need mechanism for selectiing several + BoldOptimisticLockingSupport, + BoldSystemPersistenceHandler, + BoldSystemOldValueHandler, BoldExternalizedReferences, BoldDefaultId, BoldTaggedValueSupport, BoldUndoHandler, - BoldDefaultStreamNames, - BoldCoreConsts; +{$IFDEF SpanFetch} + AttracsSpanFetchManager, +{$ENDIF} + BoldDefaultStreamNames, + BoldAttributes, + BoldFreeStandingValueFactories, + BoldMath; var - G_ExternalDerivers: TBoldExternalizedReferenceList; - G_LastFailureReason: TBoldFailureReason = nil; G_DefaultBoldSystem: TBoldSystem = nil; - IX_BoldObjectId: integer = -1; + _BoldSystemList: TList; + +procedure BoldSystemActivated(ABoldSystem: TBoldSystem); +begin + if not Assigned(_BoldSystemList) then + _BoldSystemList := TList.Create; + _BoldSystemList.Add(ABoldSystem); +end; + +procedure BoldSystemDeActivated(ABoldSystem: TBoldSystem); +begin + if Assigned(_BoldSystemList) then + _BoldSystemList.Remove(ABoldSystem); +end; + +function BoldSystems(Index: integer): TBoldSystem; +begin + if (Index < 0) or (Index > BoldSystemCount-1) then + raise EBold.Create('Index out of bounds in function BoldSystems(Index: integer): TBoldSystem;'); + result := TBoldSystem(_BoldSystemList[Index]); +end; + +function BoldSystemCount: integer; +begin + if Assigned(_BoldSystemList) then + result := _BoldSystemList.Count + else + result := 0; +end; -// Utility functions -// If object exists, just return it, otherwise create it and set existance and persistencestate. +var + _BoldSystemInternalLog: TStringList; -function EnsureObjectInFsValueSpace(BoldObject: TBoldObject; ValueSpace: TBoldFreeStandingValueSpace): TBoldFreeStandingObjectContents; +procedure _BoldInternalLog(const AMessage: string); var - ObjectId: TBoldObjectId; + i: integer; +begin + if not Assigned(_BoldSystemInternalLog) then + begin + _BoldSystemInternalLog := TStringList.Create; + _BoldSystemInternalLog.Sorted := true; + _BoldSystemInternalLog.Duplicates := dupIgnore; + end; + i := _BoldSystemInternalLog.Count; + _BoldSystemInternalLog.Add(AMessage); + if _BoldSystemInternalLog.Count > i then + BoldLog.Log(AMessage); +end; + +procedure LogDerivationSideEffects(BoldMember: TBoldMember); +var + vBoldSystem: TBoldSystem; + vMessage: string; +begin + vBoldSystem := BoldMember.BoldSystem; + Assert(Assigned(vBoldSystem)); + Assert(vBoldSystem.CurrentDerivedMember <> nil); + if vBoldSystem.CurrentDerivedMember.GetBoldMemberRTInfo.IsReverseDerived then + vMessage := Format('Reverse Derivation side effects detected, derived member: %s. Dirty member: %s.', [vBoldSystem.CurrentDerivedMember.BoldMemberRTInfo.ExpressionName, BoldMember.BoldMemberRTInfo.ExpressionName]) + else + vMessage := Format('Derivation side effects detected, derived member: %s. Dirty member: %s.', [vBoldSystem.CurrentDerivedMember.BoldMemberRTInfo.ExpressionName, BoldMember.BoldMemberRTInfo.ExpressionName]); + _BoldInternalLog(vMessage); +end; + +procedure LogDerivationDeleteSideEffects(BoldObject: TBoldObject); +var + vBoldSystem: TBoldSystem; + vMessage: string; +begin + vBoldSystem := BoldObject.BoldSystem; + Assert(Assigned(vBoldSystem)); + Assert(vBoldSystem.CurrentDerivedMember <> nil); + if vBoldSystem.CurrentDerivedMember.GetBoldMemberRTInfo.IsReverseDerived then + vMessage := Format('Reverse Derivation side effects detected, derived member: %s. Deleted object: %s.', [vBoldSystem.CurrentDerivedMember.BoldMemberRTInfo.ExpressionName, BoldObject.BoldClassTypeInfo.AsString]) + else + vMessage := Format('Derivation side effects detected, derived member: %s. Deleted object: %s.', [vBoldSystem.CurrentDerivedMember.BoldMemberRTInfo.ExpressionName, BoldObject.BoldClassTypeInfo.AsString ]); + _BoldInternalLog(vMessage); +end; + +procedure LogDerivationCreateSideEffects(BoldObject: TBoldObject); +var + vBoldSystem: TBoldSystem; + vMessage: string; +begin + vBoldSystem := BoldObject.BoldSystem; + Assert(Assigned(vBoldSystem)); + Assert(vBoldSystem.CurrentDerivedMember <> nil); + if vBoldSystem.CurrentDerivedMember.GetBoldMemberRTInfo.IsReverseDerived then + vMessage := Format('Reverse Derivation side effects detected, derived member: %s. Created object: %s.', [vBoldSystem.CurrentDerivedMember.BoldMemberRTInfo.ExpressionName, BoldObject.BoldClassTypeInfo.AsString]) + else + vMessage := Format('Derivation side effects detected, derived member: %s. Created object: %s.', [vBoldSystem.CurrentDerivedMember.BoldMemberRTInfo.ExpressionName, BoldObject.BoldClassTypeInfo.AsString]); + _BoldInternalLog(vMessage); +end; + +function MemberCanBeModified(MemberRtInfo: TBoldMemberRtInfo; BoldSystem: TBoldSystem): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} +begin + Result := assigned(MemberRtInfo) and + (MemberRtInfo.IsStoredInObject or + (MemberRtInfo.IsMultiRole and + (assigned(BoldSystem.PersistenceController) and + BoldSystem.PersistenceController.MultilinksAreStoredInObject))); +end; + +//PATCH +function GetTransactionInfo(aSystem: TBoldSystem): string; +begin + Result := 'GetTransactionInfo raised exception'; + try + Result := Format('TransactionNesting:%d TransactionRollbackOnly:%s TransactionMode:%d', + [aSystem.fTransactionNesting, + BoolToStr(aSystem.fTransactionRollbackOnly, True), + Ord(aSystem.fTransactionMode)]); + Result := Result + Format(' TransactionList.Count:%d', [aSystem.fTransactionList.Count]); + except + {Eat} + end; +end; +//PATCH + +function TopSortedIndex2ClassName(ATopSortedIndex: integer): string; +begin + result := TBoldSystem.DefaultSystem.BoldSystemTypeInfo.TopSortedClasses[ATopSortedIndex].ExpressionName; +end; + +function TBoldObject.GetBoldExistenceState: TBoldExistenceState; +begin + result := TBoldExistenceState(GetInternalState(BoldExistenceStateMask, BoldESShift)); +end; + +function TBoldObject.GetBoldPersistenceState: TBoldValuePersistenceState; +begin + result := TBoldValuePersistenceState(GetInternalState(BoldPersistenceStateMask, BoldPSShift)); +end; + +function TBoldSystem.GetUndoHandler: TBoldAbstractUndoHandler; +begin + if not Assigned(fUndoHandler) then + fUndoHandler := TBoldUndoHandler.Create(self); + Result := fUndoHandler; +end; + +function TBoldSystem.GetUndoHandlerInterface: IBoldUndoHandler; begin - Assert(assigned(ValueSpace)); - ObjectId := BoldObject.BoldObjectLocator.BoldObjectID; - Result := ValueSpace.GetFSObjectContentsByObjectId(ObjectID); - if not assigned(Result) then + Result := UndoHandler as IBoldUndoHandler; +end; + +function EnsureObjectInFsValueSpace(BoldObject: TBoldObject; ValueSpace: TBoldFreeStandingValueSpace; out ACreated: boolean): TBoldFreeStandingObjectContents; overload; +begin + Assert(Assigned(ValueSpace)); + result := ValueSpace.GetEnsuredFSObjectContentsByObjectId(BoldObject.BoldObjectLocator.BoldObjectId, ACreated); + if ACreated then begin - Result := ValueSpace.GetEnsuredFSObjectContentsByObjectId(ObjectId); - Result.BoldExistenceState := BoldObject.BoldExistenceState; - Result.BoldPersistenceState := BoldObject.BoldPersistenceState; + result.BoldExistenceState := BoldObject.BoldExistenceState; + result.BoldPersistenceState := BoldObject.BoldPersistenceState; + result.TimeStamp := BoldObject.GetTimeStamp; end; end; +function EnsureObjectInFsValueSpace(BoldObject: TBoldObject; ValueSpace: TBoldFreeStandingValueSpace): TBoldFreeStandingObjectContents; overload; +var + lCreated: boolean; +begin + result := EnsureObjectInFsValueSpace(BoldObject, ValueSpace, lCreated); +end; + + type + {---TBoldLocatorIdHashIndex---} TBoldLocatorIdHashIndex = class(TBoldHashIndex) protected - function ItemAsLocator(Item: TObject): TBoldObjectLocator; virtual; + function ItemAsLocator(Item: TObject): TBoldObjectLocator; {$IFDEF BOLD_INLINE} inline; {$ENDIF} {virtual;} // no need to be virtual until we actually override it somewhere function HashItem(Item: TObject): Cardinal; override; function Match(const Key; Item:TObject):Boolean; override; function Hash(const Key): Cardinal; override; public - function FindLocatorById(BoldObjectId: TBoldObjectId): TBoldObjectLocator; + function FindLocatorById(BoldObjectId: TBoldObjectId): TBoldObjectLocator; {$IFDEF BOLD_INLINE} inline; {$ENDIF} end; { TBoldSystem_Proxy } TBoldSystem_Proxy = class(TBoldDomainElement_Proxy, IBoldValueSpace) private - function GetProxedSystem: TBoldSystem; - // IBoldValueSpace + fProxedSystem: TBoldSystem; procedure AllObjectIds(resultList: TBoldObjectIdList; OnlyLoaded: Boolean); procedure ApplytranslationList(IdTranslationList: TBoldIdTranslationList); - procedure ApplyValueSpace(ValueSpace: IBoldValueSpace; IgnorePersistenceState: Boolean); + procedure ApplyValueSpace(const ValueSpace: IBoldValueSpace; IgnorePersistenceState: Boolean); procedure EnsureObjectContents(ObjectId: TBoldObjectId); procedure EnsureObjectId(ObjectId: TBoldObjectId); procedure ExactifyIDs(TranslationList: TBoldIdTranslationList); function GetHasContentsForId(ObjectId: TBoldObjectId): boolean; function GetObjectContentsByObjectId(ObjectId: TBoldObjectId): IBoldObjectContents; function GetEnsuredObjectContentsByObjectId(ObjectId: TBoldObjectId): IBoldObjectContents; + function GetEnsuredObjectContentsByObjectIdAndCheckIfCreated(ObjectId: TBoldObjectId; out aBoldObjectContents: IBoldObjectContents): boolean; + function IdCount: integer; + function IsEmpty: boolean; protected - property ProxedSystem: TBoldSystem read GetProxedSystem; + property ProxedSystem: TBoldSystem read fProxedSystem; + public + constructor Create(ProxedSystem: TBoldSystem; Mode: TBoldDomainElementProxyMode); end; { TBoldObject_Proxy } TBoldObject_Proxy = class(TBoldDomainElement_Proxy, IBoldObjectContents) private - function GetProxedObject: TBoldObject; - // IBoldObjectContents + fProxedObject: TBoldObject; procedure EnsureMember(MemberId: TBoldMemberId; const ContentName: string); - function GetBoldExistenceState: TBoldExistenceState; - function GetBoldMemberCount: Integer; - function GetBoldPersistenceState: TBoldValuePersistenceState; - function GetGlobalId: string; - function GetIsModified: Boolean; - function GetIsReadOnly: Boolean; - function GetObjectId: TBoldObjectId; + function EnsureMemberAndGetValueByIndex(MemberIndex: Integer; const ContentName: string): IBoldValue; + function GetBoldExistenceState: TBoldExistenceState; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetBoldMemberCount: Integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetBoldPersistenceState: TBoldValuePersistenceState; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetGlobalId: string; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetIsModified: Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetIsReadOnly: Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetObjectId: TBoldObjectId; {$IFDEF BOLD_INLINE}inline;{$ENDIF} function GetValueByIndex(I: Integer): IBoldValue; - function GetValueByMemberId(MemberId: TBoldMemberID):IBoldValue; - function GetTimeStamp: TBoldTimeStampType; - procedure SetBoldExistenceState(Value: TBoldExistenceState); - procedure SetBoldPersistenceState(Value: TBoldValuePersistenceState); - procedure SetGlobalId(const NewValue: string); - procedure SetIsReadOnly(NewValue: Boolean); - procedure SetTimeStamp(NewValue: TBoldTimeStampType); + function GetValueByMemberId(MemberId: TBoldMemberID):IBoldValue; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetTimeStamp: TBoldTimeStampType; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetBoldExistenceState(Value: TBoldExistenceState); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetBoldPersistenceState(Value: TBoldValuePersistenceState); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetGlobalId(const NewValue: string); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetIsReadOnly(NewValue: Boolean); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetTimeStamp(NewValue: TBoldTimeStampType); {$IFDEF BOLD_INLINE}inline;{$ENDIF} protected - property ProxedObject: TBoldObject read GetProxedObject; + constructor Create(ProxedObject: TBoldObject; Mode: TBoldDomainElementProxyMode); + property ProxedObject: TBoldObject read fProxedObject; end; { TBoldObjectReference_Proxy } TBoldObjectReference_Proxy = class(TBoldMember_Proxy) protected - procedure AssignContentValue(Source: IBoldValue); override; - end; - - TBoldMemberDeriver = class(TBoldEventPluggedDeriver) - protected - procedure SetInternalDeriverState(const Value: TBoldDeriverState); override; - function GetInternalDeriverState: TBoldDeriverState; override; + procedure AssignContentValue(const Source: IBoldValue); override; end; -// Utility functions -function GetValueFromValuespace(ValueSpace: IBoldValueSpace; Id: TBoldObjectId; MemberIndex: integer): IBoldValue; +function GetValueFromValuespace(const ValueSpace: IBoldValueSpace; Id: TBoldObjectId; MemberIndex: integer): IBoldValue; var MemberId: TBoldMemberId; ObjectContents: IBoldObjectContents; @@ -1224,7 +1632,7 @@ procedure SetBoldLastFailureReason(const Value: TBoldFailureReason); G_LastFailureReason := value; end; -procedure BoldRaiseLastFailure(originator: TBoldDomainElement; const MethodName: String; const DefaultMessage: String); +procedure BoldRaiseLastFailure(originator: TBoldElement; const MethodName: String; const DefaultMessage: String); var OriginatorStr: String; MessageStr: String; @@ -1247,10 +1655,10 @@ procedure BoldRaiseLastFailure(originator: TBoldDomainElement; const MethodName: if MessageStr = '' then MessageStr := DefaultMessage; if MessageStr = '' then - MessageStr := sReasonUnknown; + MessageStr := 'Reason unknown'; if MessageFormatStr = '' then - MessageFormatStr := sFailureMessage; + MessageFormatStr := '%s.%s failed: %s'; if Assigned(G_LastFailureReason) then Failure := G_LastFailureReason.GetException(Format(MessageFormatStr, [OriginatorStr, MethodName, MessageStr])) @@ -1295,13 +1703,34 @@ function TBoldLocatorIdHashIndex.FindLocatorById(boldObjectId:TboldObjectId): TB Result := TBoldObjectLocator(Find(boldObjectId)); end; + constructor TBoldSystemLocatorList.Create; begin inherited; SetIndexCapacity(1); + IX_BoldObjectId := -1; SetIndexVariable(IX_BoldObjectId, AddIndex(TBoldLocatorIdHashIndex.Create)); end; +{$IFDEF ATINDEXDEBUG} +//PATCH +function TBoldSystemLocatorList.GetDebugInfo: string; +begin + Result := 'TBoldSystemLocatorList.Count:'+IntToStr(Count)+#13#10+ + (Indexes[0] as TBoldLocatorIdHashIndex).GetDebugInfo; +end; +{$ENDIF} + +function TBoldSystemLocatorList.GetEnumerator: TBoldLocatorListTraverser; +begin + result := CreateTraverser; +end; + +function TBoldSystemLocatorList.GetLocatorByID(ObjectID: TBoldObjectId): TBoldObjectLocator; +begin + Result := TBoldObjectLocator(TBoldHashIndex(Indexes[IX_BoldObjectId]).Find(ObjectID)); +end; + function TBoldSystemLocatorList.GetObjectByID(ObjectID: TBoldObjectId): TBoldObject; var Locator: TBoldObjectLocator; @@ -1313,9 +1742,31 @@ function TBoldSystemLocatorList.GetObjectByID(ObjectID: TBoldObjectId): TBoldObj Result := nil; end; -function TBoldSystemLocatorList.GetLocatorByID(ObjectID: TBoldObjectId): TBoldObjectLocator; +function TBoldSystemLocatorList.GetObjectByIDString( + const ID: string): TBoldObject; +var + ObjectID: TBoldDefaultID; +begin + ObjectId := TBoldDefaultID.CreateWithClassID(0, false); + try + ObjectId.AsInteger := StrToInt(Id); + result := GetObjectByID(ObjectId); + finally + ObjectID.free; + end; +end; + +function TBoldSystemLocatorList.GetLocatorByIDString(const ID: string): TBoldObjectLocator; +var + ObjectID: TBoldDefaultID; begin - Result := TBoldLocatorIdHashIndex(Indexes[IX_BoldObjectId]).FindLocatorById(ObjectID); + ObjectId := TBoldDefaultID.CreateWithClassID(0, false); + try + ObjectId.AsInteger := StrToInt(Id); + result := GetLocatorByID(ObjectId); + finally + ObjectID.free; + end; end; function TBoldSystem.GetEnsuredLocatorByID(ObjectID: TBoldObjectId): TBoldObjectLocator; @@ -1327,12 +1778,20 @@ function TBoldSystem.GetEnsuredLocatorByID(ObjectID: TBoldObjectId): TBoldObject end; end; +function TBoldSystem.EnsureLocatorByID(ObjectID: TBoldObjectId; out ACreated: boolean): TBoldObjectLocator; +begin + Result := Locators.GetLocatorByID(ObjectID); + ACreated := not Assigned(Result); + if ACreated then + Result := TBoldObjectLocator.CreateWithObjectId(Self, ObjectID) +end; + constructor TBoldObjectLocator.CreateWithObjectId(BoldSystem: TBoldSystem; BoldObjectID: TBoldObjectId); begin inherited Create; fBoldSystem := BoldSystem; fBoldObjectID := BoldObjectId.Clone; - BoldSystem.Locators.Add(Self); + AddToLocators; end; constructor TBoldObjectLocator.CreateWithClassID(BoldSystem: TBoldSystem; TopSortedIndex: integer; Exact: Boolean); @@ -1340,7 +1799,7 @@ constructor TBoldObjectLocator.CreateWithClassID(BoldSystem: TBoldSystem; TopSor inherited Create; FBoldSystem := BoldSystem; fBoldObjectID := TBoldInternalObjectId.CreateWithClassID(TopSortedIndex, Exact); - BoldSystem.Locators.Add(Self); + AddToLocators; end; function TBoldObjectLocator.GetAsString: string; @@ -1348,12 +1807,21 @@ function TBoldObjectLocator.GetAsString: string; Result := fBoldObjectID.AsString; end; +function TBoldObjectLocator.GetDebugInfo: string; +begin + if Assigned(FBoldObject) then + result := FBoldObject.DebugInfo + else + result := AsString; +end; + destructor TBoldObjectLocator.Destroy; begin if Assigned(FBoldObject) then - raise EBoldInternal.CreateFmt(sBoldObjectAssigned, [ClassName]); + raise EBoldInternal.CreateFmt('%s.Destroy: BoldObject assigned', [ClassName]); + if not BoldSystem.IsDestroying then + BoldSystem.Locators.RemoveFromAllIndexes(Self); FreeAndNil(fBoldObjectID); - FreeAndNil(fEmbeddedSingleLinks); inherited; end; @@ -1369,39 +1837,53 @@ procedure TBoldObjectLocator.UnloadBoldObject; begin BoldClearLastFailure; if not BoldObject.CanUnload then - BoldRaiseLastFailure(nil, 'TBoldObjectLocator.UnloadBoldObject', ''); // do not localize + BoldRaiseLastFailure(nil, 'TBoldObjectLocator.UnloadBoldObject', ''); + if not BoldSystem.isDestroying then + BoldObject.SendEvent(beObjectUnloaded); BoldSystem.MarkObjectClean(BoldObject); BoldObject.FreePublisher; BoldObject.FBoldObjectLocator := nil; - EmbeddedSingleLinksFromObject; - FreeEmbeddedSingleLinksOfOtherEnd; + if not BoldSystem.isDestroying then + begin + EmbeddedSingleLinksFromObject; + FreeEmbeddedSingleLinksOfOtherEnd; + end; FreeAndNil(fBoldObject); end; end; -procedure TBoldObjectLocator.DiscardBoldObject; +procedure TBoldObjectLocator.DiscardBoldObject(ADiscardTransientLinks: boolean = true); begin if Assigned(BoldObject) then - BoldObject.Discard; + begin + if ADiscardTransientLinks then + BoldObject.Discard + else + BoldObject.DiscardPersistentMembers; + end; end; procedure TBoldObjectLocator.FetchBoldObject; begin - if BoldObjectID.IsStorable then - BoldSystem.fSystemPersistenceHandler.FetchObjectById(BoldObjectID) - else - raise EBoldInternal.CreateFmt('%s.FetchBoldObject: Can''t fetch Internal object', [Classname]); + if not BoldObjectID.NonExisting then + begin + if not BoldObjectID.IsStorable then + raise EBoldInternal.CreateFmt('%s.FetchBoldObject: Can''t fetch Internal object', [Classname]); + BoldSystem.fSystemPersistenceHandler.FetchObjectById(BoldObjectID); + end; end; function TBoldObjectLocator.GetEnsuredBoldObject: TBoldObject; begin - if not assigned(self) then - result := nil - else + if Assigned(Self) then begin EnsureBoldObject; - result := BoldObject; + Result := BoldObject; + end + else + begin + Result := nil end; end; @@ -1411,14 +1893,12 @@ function TBoldObjectLocator.Hash: Cardinal; end; { TBoldSystem } -constructor TBoldSystem.Create(AOwningElement: TBoldDomainElement); -begin - raise EBold.CreateFmt(sIllegalConstruction, [ClassName]); -end; function TBoldSystem.GetAsIBoldvalueSpace(Mode: TBoldDomainElementProxyMode): IBoldvalueSpace; begin - ProxyInterface(IBoldValueSpace, Mode, result); + if not Assigned(fSystemProxyCache[Mode]) then + ProxyInterface(IBoldValueSpace, Mode, fSystemProxyCache[Mode]); + result := fSystemProxyCache[Mode]; end; constructor TBoldSystem.CreateWithTypeInfo(AOwningElement: TBoldDomainElement; SystemTypeInfo: TBoldSystemTypeInfo; PersistenceController: TBoldPersistenceController; RegionFactory: TBoldAbstractRegionFactory = nil); @@ -1426,36 +1906,106 @@ constructor TBoldSystem.CreateWithTypeInfo(AOwningElement: TBoldDomainElement; S I: Integer; ListTypeInfo: TBoldListTypeInfo; ListClass: TBoldObjectListClass; + +{$IFDEF ACCESSSTATISTICS} //// START PATCH ACCESSSTATISTICS //////////////////// + procedure InitAccessStats; + var + I: Integer; + ClassTypeInfo: TBoldClassTypeInfo; + begin + SetLength(fAccessStats, SystemTypeInfo.TopSortedClasses.Count); + SetLength(fDeriveStats, SystemTypeInfo.TopSortedClasses.Count); + SetLength(fInvalidateStats, SystemTypeInfo.TopSortedClasses.Count); + SetLength(fModifyStats, SystemTypeInfo.TopSortedClasses.Count); + for I := 0 to SystemTypeInfo.TopSortedClasses.Count-1 do + begin + ClassTypeInfo := SystemTypeInfo.TopSortedClasses[I]; + SetLength(fAccessStats[I], ClassTypeInfo.AllMembersCount); + SetLength(fDeriveStats[I], ClassTypeInfo.AllMembersCount); + SetLength(fInvalidateStats[I], ClassTypeInfo.AllMembersCount); + SetLength(fModifyStats[I], ClassTypeInfo.AllMembersCount); + end; + end; +{$ENDIF} //// END PATCH ACCESSSTATISTICS /////////////////////////////////////// + begin - inherited Create(AOwningElement); + inherited CreateWithOwner(AOwningElement); fTransactionMode := stmNormal; fOldValueHandler := TBoldOldValueHandler.Create(Self); fBoldSystemTypeInfo := SystemTypeInfo; SetElementFlag(befpersistent, SystemTypeInfo.Persistent and assigned(PersistenceController)); + Assert((PersistenceController = nil) or (PersistenceController is TBoldPersistenceController)); fPersistenceController := PersistenceController; + fPersistenceControllerSubscriber := TBoldPassthroughSubscriber.Create(ReceiveFromPersistenceController); + if Assigned(fPersistenceController) then + begin + fPersistenceController.AddSmallSubscription(fPersistenceControllerSubscriber, [beDestroying], beDestroying); +// fPersistenceController.SubscribeToPeristenceEvents(fPersistenceControllerSubscriber); + fPersistenceController.AddSubscription(fPersistenceControllerSubscriber, bpeStartFetch, bpeStartFetch); + fPersistenceController.AddSubscription(fPersistenceControllerSubscriber, bpeEndFetch, bpeEndFetch); + end; fDirtyObjects := TList.Create; - fDirtyObjectsInvalid := False; + DirtyObjectsInvalid := False; fClasses := TBoldMemberList.Create; fClasses.fBoldMetaType := BoldSystemTypeInfo.ListTypeInfoByElement[nil]; fLocators := TBoldSystemLocatorList.Create; fLocators.OwnsEntries := True; fDelayedDestructionList := TList.Create; fTransactionList := TBoldDomainElementCollection.Create; - + fDerivedMembers := TList.Create; +{$IFNDEF NoAutoSubscription} + fMembersReadDuringDerivation := TList.Create; +{$ENDIF} for I := 0 to SystemTypeInfo.TopSortedClasses.Count - 1 do begin - ListTypeInfo := SystemTypeInfo.ListTypeInfoByElement[SystemTypeInfo.TopSortedClasses[i]]; + ListTypeInfo := SystemTypeInfo.TopSortedClasses[i].ListTypeInfo; ListClass := TBoldObjectListClass(ListTypeInfo.ListClass); fClasses.InternalAddWithoutCloning(ListClass.InternalCreateClassList(self, ListTypeInfo)); end; - fClasses.MakeImmutable; fOptimisticLockHandler := TBoldOptimisticLockHandler.Create(self); fSystemPersistenceHandler := TBoldSystemPersistenceHandler.Create(self); fRegionFactory := RegionFactory; - if assigned(fRegionFactory) then fRegionFactory.fSystem := Self; + fRollbackArea := TBoldFreeStandingValueSpace.create; + fValidValueArea := TBoldFreeStandingValueSpace.create; + + +{$IFDEF ACCESSSTATISTICS} //// START PATCH ACCESSSTATISTICS //////////////////// + InitAccessStats; +{$ENDIF} //// END PATCH ACCESSSTATISTICS /////////////////////////////////////// + BoldSystemActivated(self); +end; + +function TBoldSystem.IsDerivingMembers: boolean; +begin + result := fDerivedMembers.Count > 0; +end; + +function TBoldSystem.CurrentDerivedMember: TBoldMember; +begin + if IsDerivingMembers then + result := fDerivedMembers[fDerivedMembers.count-1] + else + result := nil; +end; + +function TBoldMember.GetPSStateIsInvalid: Boolean; +begin + result := (StateAndFlagBank and BoldPersistenceStateMask) = (Cardinal(bvpsInvalid) shl BoldPSShift); +end; + +function TBoldObject.GetBoldMemberCount: Integer; +begin + Result := BoldClassTypeInfo.AllMembersCount; +end; + +function TBoldObject.GetBoldMemberAssigned(Index: integer): Boolean; +begin + if Cardinal(index) >= Cardinal(Length(fMemberArray)) then + raise EBold.CreateFmt('%s.GetBoldMemberAssigned: Index out of range (%d but max is %d)', [ClassName, Index, BoldMemberCount-1]); + result := assigned(fMemberArray[Index]); end; destructor TBoldSystem.Destroy; @@ -1463,48 +2013,50 @@ destructor TBoldSystem.Destroy; Traverser: TBoldLocatorListTraverser; i: integer; bo: TBoldObject; + bm: TBoldMember; + Locator: TBoldObjectLocator; begin + // CheckIntegrity; EnsureCanDestroy; + IsDestroying := True; PrepareToDestroy; IsDefault := False; FreeAndNil(fEvaluator); - FreeAndNil(fClasses); // will destroy classes + FreeAndNil(fClasses); + + for i := 0 to length(fSystemProxyCache) -1 do + fSystemProxyCache[TBoldDomainElementProxyMode(i)] := nil; - // discard all derived members first Traverser := Locators.CreateTraverser; - while not Traverser.EndOfList do + while Traverser.MoveNext do begin if assigned(Traverser.Locator.BoldObject) then begin bo := Traverser.Locator.BoldObject; for i := 0 to bo.BoldMemberCount - 1 do begin - if bo.BoldMemberAssigned[i] and bo.BoldMembers[i].Derived then + if bo.BoldMemberAssigned[i] then begin - if (bo.BoldMembers[i].BoldPersistenceState <> bvpsInvalid) then + bm := bo.BoldMembers[i]; + if bm.Derived and (not bm.BoldPersistenceStateIsInvalid) then begin - bo.BoldMembers[i].Invalidate; - bo.BoldMembers[i].Deriver.MarkSubscriptionOutOfDate; + bm.Invalidate; + bo.GetBoldMemberDeriver(bm).MarkSubscriptionOutOfDate; end; end; end; end; - Traverser.Next; end; Traverser.Free; if Assigned(fLocators) then - begin - Traverser := Locators.CreateTraverser; - while not Traverser.EndOfList do - begin - if assigned(Traverser.Locator.BoldObject) then - Traverser.Locator.UnloadBoldObject; - Traverser.Next; - end; - Traverser.Free; - end; + for Locator in fLocators do + if assigned(Locator.BoldObject) then + Locator.UnloadBoldObject; + FreeAndNil(fRollbackArea); + FreeAndNil(fValidValueArea); + FreeAndNil(fPersistenceControllerSubscriber); FreeAndNil(fLocators); FreeAndNil(fDirtyObjects); FreeAndNil(fDelayedDestructionList); @@ -1513,6 +2065,11 @@ destructor TBoldSystem.Destroy; FreeAndNil(fOptimisticLockHandler); FreeAndNil(fSystemPersistenceHandler); FreeAndNil(fUndoHandler); + FreeAndNil(fDerivedMembers); +{$IFNDEF NoAutoSubscription} + FreeAndNil(fMembersReadDuringDerivation); +{$ENDIF} + BoldSystemDeActivated(self); inherited Destroy; end; @@ -1521,12 +2078,17 @@ class function TBoldSystem.DefaultSystem: TBoldSystem; Result := G_DefaultBoldSystem end; +function TBoldSystem.GetIsFetching: Boolean; +begin + Result := fFetchNesting > 0; +end; + function TBoldSystem.GetClassByIndex(index: Integer): TBoldObjectList; begin if Assigned(fClasses) then begin - Assert(fClasses[index] is TBoldObjectList); Result := TBoldObjectList(fClasses[index]); + Assert(Result is TBoldObjectList); end else Result := nil; @@ -1540,7 +2102,13 @@ function TBoldSystem.CreateNewObjectByExpressionName(const ExpressionName: strin if Assigned(ClassTypeInfo) then Result := TBoldObjectClass(ClassTypeInfo.ObjectClass).InternalCreateNewWithClassAndSystem(ClassTypeInfo, Self, Persistent) else - raise EBold.CreateFmt(sNoSuchClass, [ClassName, 'CreateNewObjectByExpressionName', ExpressionName]); // do not localize + raise EBold.CreateFmt('%s.CreateNewObjectByExpressionName: System contains no class named: %s', [ClassName, ExpressionName]); +end; + +function TBoldSystem.CreateNewObjectFromClassTypeInfo(aClassTypeInfo: TBoldClassTypeInfo; Persistent: Boolean = True): TBoldObject; +begin + Assert(Assigned(aClassTypeInfo), 'aClassTypeInfo param is nil in CreateNewObjectFromClassTypeInfo.'); + Result := TBoldObjectClass(aClassTypeInfo.ObjectClass).InternalCreateNewWithClassAndSystem(aClassTypeInfo, Self, Persistent); end; function TBoldSystem.CreateExistingObjectByID(BoldObjectID: TBoldObjectId): TBoldObject; @@ -1552,7 +2120,7 @@ function TBoldSystem.CreateExistingObjectByID(BoldObjectID: TBoldObjectId): TBol if not BoldObjectID.TopSortedIndexExact then if ClassTypeInfo.IsAbstract or not assigned(OnCreateApproximateObjectError) then - raise EBold.CreateFmt(sCannotCreateInexact, + raise EBold.CreateFmt('Can not create objects with approximate type. ID: %s Class: %s', [BoldObjectId.AsString, ClassTypeInfo.ModelName]); Locator := EnsuredLocatorByID[BoldObjectID]; @@ -1584,12 +2152,23 @@ function TBoldSystem.GetClassByExpressionName(const ExpressionName: string): TBo begin Result := FindClassByExpressionName(ExpressionName); if not Assigned(Result) then - raise EBold.CreateFmt(sNoSuchClass, [ClassName, 'GetClassByExpressionName', ExpressionName]); // FIXME // do not localize + raise EBold.CreateFmt('%s.GetClassByExpressionName: System has no class named: %s', [ClassName, ExpressionName]); end; -procedure TBoldSystem.MarkObjectDirty(BoldObject: TBoldObject); {called by TBoldObject} +function TBoldSystem.GetClassByObjectClass( + AObjectClass: TBoldObjectClass): TBoldObjectList; +var + ClassTypeInfo: TBoldClassTypeInfo; +begin + ClassTypeInfo := BoldSystemTypeInfo.TopSortedClasses.ItemsByObjectClass[AObjectClass]; + if not Assigned(ClassTypeInfo) then + raise EBold.CreateFmt('%s.GetClassByObjectClass: System has no class : %s', [ClassName, AObjectClass.ClassName]); + Result := Classes[ClassTypeInfo.TopSortedIndex]; +end; + +procedure TBoldSystem.MarkObjectDirty(BoldObject: TBoldObject); {called by TBoldObject} begin - if BoldObject.BoldPersistent then + if Self.BoldPersistent and BoldObject.BoldPersistent then begin if Assigned(NewDirtyList) then NewDirtyList.Add(BoldObject); @@ -1600,22 +2179,32 @@ procedure TBoldSystem.MarkObjectDirty(BoldObject: TBoldObject); {called by TBold begin fDirtyObjects.Add(BoldObject); BoldObject.InDirtyList := True; + BoldObject.SendExtendedEvent(beObjectBecomingDirty, [BoldObject]); + if not DirtyObjectsInvalid then + SendExtendedEvent(beDirtyListInvalidOrItemDeleted, [BoldObject]); end; end; end; procedure TBoldSystem.MarkObjectClean(BoldObject: TBoldObject); {called by TBoldObject} +var + i: integer; begin if BoldObject.InDirtyList and BoldObject.BoldPersistent then begin fDirtyObjects.Remove(BoldObject); BoldObject.InDirtyList := False; - if (Assigned(NewDirtyList) and NewDirtyList.Includes(BoldObject)) then - NewDirtyList.Remove(BoldObject); + if Assigned(NewDirtyList) then + begin + i := NewDirtyList.IndexOf(BoldObject); + if i <> -1 then + NewDirtyList.RemoveByIndex(i);// Remove(BoldObject); + end; - if not fDirtyObjectsInvalid then - SendEvent(beDirtyListInvalidOrItemDeleted); + BoldObject.SendExtendedEvent(beObjectBecomingClean, [BoldObject]); + if not DirtyObjectsInvalid then + SendExtendedEvent(beDirtyListInvalidOrItemDeleted, [BoldObject]); end; end; @@ -1631,7 +2220,7 @@ ClassList := classes[ClassTypeInfo.TopSortedIndex]; alist.AddList(ClassList); end else - raise EBold.CreateFmt(sClassDoesNotBelongHere, [className, aClass.ClassName]); + raise EBold.CreateFmt('%s.GetAllInClass: %s does not belong to this system', [className, aClass.ClassName]); end; procedure TBoldSystem.GetAllWithCondition(aList: TBoldObjectList; Condition: TBoldCondition); @@ -1644,59 +2233,155 @@ procedure TBoldSystem.GetAllInClassWithSQL(aList: TBoldObjectList; AClass: TBold SystemPersistenceHandler.GetAllInClassWithSQL(AList, AClass, WhereClause, OrderByClause, Params, JoinInheritedTables, MAxAnswers, Offset); end; -procedure TBoldSystem.FetchLinksWithObjects(ObjectList: TBoldObjectList; const LinkName: string; FetchedObjects: TBoldObjectList = nil); +procedure TBoldSystem.GetAllInClassWithRawSQL(aList: TBoldObjectList; AClass: TBoldObjectClass; SQL: String; Params: TParams = nil; MaxAnswers: integer = -1; Offset: integer = -1); +begin + SystemPersistenceHandler.GetAllInClassWithRawSQL(AList, AClass, SQL, Params, MaxAnswers, Offset); +end; + +procedure TBoldSystem.FetchLinksWithObjects(ObjectList: TBoldObjectList; const LinkName: string;FetchObjectsInLink: Boolean = True{; const FetchedObjectList: TBoldObjectList = nil}); +begin + SystemPersistenceHandler.FetchLinksWithObjects(ObjectList, LinkName,FetchObjectsInLink{, FetchedObjectList}); +end; + +procedure TBoldSystem.FetchMembersWithObjects(aBoldObjectList: TBoldObjectList; aBoldMemberIdList: TBoldMemberIdList); +begin + SystemPersistenceHandler.FetchMembersWithObjects(aBoldObjectList, aBoldMemberIdList); +end; + +procedure TBoldSystem.FetchMembersWithObjects(aBoldObjectList: TBoldObjectList; const AMemberCommaList: string); +begin + SystemPersistenceHandler.FetchMembersWithObjects(aBoldObjectList, AMemberCommaList); +end; + +procedure TBoldSystem.FetchMembersWithObject(ABoldObject: TBoldObject; const AMemberCommaList: string); +var + BoldObjectList: TBoldObjectList; +begin + BoldObjectList := TBoldObjectList.Create; + try + BoldObjectList.Add(ABoldObject); + FetchMembersWithObjects(BoldObjectList, AMemberCommaList); + finally + BoldObjectList.free; + end; +end; + +procedure TBoldSystem.FetchIdList(FetchIdList: TBoldObjectIdList; AFetchObjects: boolean = true); +var + lObjectList: TBoldObjectList; + i: integer; +begin + if FetchIdList.Count > 0 then + begin + lObjectList := TBoldObjectList.Create; + try + lObjectList.FillFromIDList(FetchIdList, self); + if AFetchObjects then + SystemPersistenceHandler.FetchList(lObjectList); + finally + lObjectList.free; + end; + end; +end; + +function TBoldList.GetEmpty: Boolean; begin - SystemPersistenceHandler.FetchLinksWithObjects(ObjectList, LinkName, FetchedObjects); + result := count = 0; end; procedure TBoldSystem.DirtyAsObjectList(ObjectList: TBoldObjectList); var i: Integer; begin - for i := 0 to DirtyObjects.Count - 1 do - ObjectList.Add(TBoldObject(DirtyObjects[i])); + if ObjectList.BeginUpdate then + try + if ObjectList.Empty or (ObjectList.DuplicateMode = bldmAllow) then + with ObjectList.ObjectListController do + for I := 0 to DirtyObjects.Count - 1 do + AddLocator(TBoldObject(DirtyObjects[i]).BoldObjectLocator) + else + for I := 0 to DirtyObjects.Count - 1 do + ObjectList.AddLocator(TBoldObject(DirtyObjects[i]).BoldObjectLocator) + finally + ObjectList.EndUpdate; + end; end; procedure TBoldSystem.UpdateDatabase; var g: IBoldGuard; - aList: TBoldObjectList; + List: TBoldObjectList; begin - g := TBoldGuard.Create(aList); - aList := TBoldObjectList.CreateWithTypeInfo(BoldSystemTypeInfo.ListTypeInfoByElement[BoldSystemTypeInfo.RootClassTypeInfo]); - DirtyAsObjectList(alist); - UpdateDatabaseWithList(aList); + if not BoldDirty then + exit; + g := TBoldGuard.Create(List); + List := TBoldObjectList.Create;// BoldSystemTypeInfo.RootClassTypeInfo.ListTypeInfo.CreateElement as TBoldObjectList; + list.SetInternalState(BoldDuplicateModeMask, BoldDMShift, Integer(bldmAllow)); + list.SubscribeToObjectsInList := false; + list.Capacity := DirtyObjects.Count; + DirtyAsObjectList(list); + UpdateDatabaseWithList(List); end; procedure TBoldSystem.UpdateDatabaseWithList(ObjectList: TBoldObjectList); begin - if Assigned(fUndoHandler) then - fUndoHandler.PrepareUpdate(ObjectList); - SystemPersistenceHandler.UpdateDatabaseWithList(ObjectList); - fOldValueHandler.PurgeEqualValues; - // when all objects are saved, there should be nothing in the oldvalues-handler -{ - if (DirtyObjects.Count = 0) and not (fOldValueHandler.IsEmpty) then - BoldLog.Log('OldValueHandler is not empty after a complete save'); -} + Assert(not IsUpdatingDatabase, 'TBoldSystem.UpdateDatabaseWithList: Reentry detected.'); + IsUpdatingDatabase := True; + try + SystemPersistenceHandler.UpdateDatabaseWithList(ObjectList); + if (DirtyObjects.Count > 0) then + fOldValueHandler.PurgeEqualValues + else + begin +// fOldValueHandler.PurgeEqualValues; +// if not fOldValueHandler.IsEmpty then +// Assert(fOldValueHandler.IsEmpty); + // optimization: if there are no dirty objects do not PurgeEqualValue, just destroy OldValues instead. + FreeAndNil(fOldValueHandler); + fOldValueHandler := TBoldOldValueHandler.Create(Self); + end; + finally + IsUpdatingDatabase := False; + end; +end; + +procedure TBoldSystem.UpdateDatabaseWithObjects( + const aObjects: array of TBoldObject); +var + i: integer; + List: TBoldObjectList; +begin + if high(aObjects) = -1 then exit; + List := TBoldObjectList.Create; + list.SubscribeToObjectsInList := false; + try + for i := low(aObjects) to high(aObjects) do + if aObjects[i] <> nil then + List.Add(aObjects[i]); + UpdateDatabaseWithList(List); + finally + List.Free; + end; end; -procedure TBoldSystem.DiscardPersistent; +procedure TBoldSystem.DiscardPersistent(ADiscardTransientLinks: boolean); var LocalDirtyObjects: TList; i: integer; begin DelayObjectDestruction; try - // The while construction is to ensure that objects that get dirty due to - // discarding an object in the list are also discarded - // (Most likely to happen with links that are saved within another object or - // by themselves) while DirtyObjects.Count > 0 do begin - LocalDirtyObjects := DirtyObjects; // this is just to clean the list from non-dirty objects - for i := LocalDirtyObjects.Count - 1 downto 0 do - TBoldObject(LocalDirtyObjects[i]).BoldObjectLocator.DiscardBoldObject; + LocalDirtyObjects := DirtyObjects; + i := LocalDirtyObjects.Count - 1; + repeat + i := MinIntValue([i, LocalDirtyObjects.Count - 1]); + TBoldObject(LocalDirtyObjects[i]).BoldObjectLocator.DiscardBoldObject(ADiscardTransientLinks); + dec(i); + while i >= LocalDirtyObjects.Count do + dec(i); + until (i < 0) or (LocalDirtyObjects.Count = 0); end; finally AllowObjectDestruction; @@ -1707,14 +2392,20 @@ procedure TBoldSystem.DiscardTransient; var g: IBoldGuard; Traverser: TBoldLocatorListTraverser; + Locator: TBoldObjectLocator; begin g := TBoldGuard.Create(Traverser); Traverser := Locators.CreateTraverser; - while not Traverser.EndOfList do - begin - if assigned(Traverser.Locator.BoldObject) and not Traverser.Locator.BoldObject.BoldPersistent then - Traverser.Locator.DiscardBoldObject; - Traverser.Next; +// DelayObjectDestruction; + try + while Traverser.MoveNext do + begin + Locator := Traverser.Locator; + if assigned(Traverser.Locator.BoldObject) and not Locator.BoldObject.BoldPersistent then + Locator.DiscardBoldObject; + end; + finally +// AllowObjectDestruction; end; end; @@ -1724,11 +2415,12 @@ procedure TBoldSystem.Discard; DiscardTransient; if assigned(PessimisticLockHandler) then PessimisticLockHandler.ReleaseUnneededRegions; + if UndoHandlerInterface.Enabled then + UndoHandlerInterface.ClearAllUndoBlocks; end; procedure TBoldSystem.DefaultSubscribe(Subscriber: TBoldSubscriber; RequestedEvent: TBoldEvent = breReEvaluate); begin - // FIXME what here? end; procedure TBoldSystem.GetAsList(ResultList: TBoldIndirectElement); @@ -1745,26 +2437,90 @@ function TBoldSystem.GetDirtyObjects: TList; var i: Integer; begin - if fDirtyObjectsInvalid then + if DirtyObjectsInvalid then begin - i := 0; - while i < fDirtyObjects.Count do - if assigned(fDirtyObjects[i]) - and not TBoldObject(fDirtyObjects[i]).BoldDirty then - MarkObjectClean(TBoldObject(fDirtyObjects[i])) - else - inc(i); + i := fDirtyObjects.Count-1; + while (i >= 0) and (i < fDirtyObjects.Count) do + begin + if assigned(fDirtyObjects[i]) and not TBoldObject(fDirtyObjects[i]).BoldDirty then + MarkObjectClean(TBoldObject(fDirtyObjects[i])); + dec(i); + end; fDirtyObjects.Pack; - fDirtyObjectsInvalid := False; + DirtyObjectsInvalid := False; end; result := fDirtyObjects; end; +function TBoldSystem.GetDirtyObjectsAsBoldList(AClassType: TBoldObjectClass): TBoldObjectList; +var + i: integer; +begin + if not Assigned(AClassType) then + AClassType := TBoldObjectClass(BoldSystemTypeInfo.RootClassTypeInfo.ObjectClass); + result := TBoldObjectList.CreateTypedList(AClassType); + result.DuplicateMode := bldmAllow; + result.SubscribeToObjectsInList := false; + with result.ObjectListController, GetDirtyObjects do + for I := 0 to Count - 1 do + if TBoldObject(Items[i]) is AClassType then + AddLocator(TBoldObject(Items[i]).BoldObjectLocator); +end; + +function TBoldSystem.GetDirtyObjectsAsBoldListByClassExpressionName( + const AClass: string): TBoldObjectList; +var + ClassTypeInfo: TBoldClassTypeInfo; + AClassType: TBoldObjectClass; +begin + result := nil; + ClassTypeInfo := BoldSystemTypeInfo.ClassTypeInfoByExpressionName[AClass]; + if Assigned(ClassTypeInfo) then + begin + AClassType := TBoldObjectClass(ClassTypeInfo.ObjectClass); + result := GetDirtyObjectsAsBoldList(AClassType); + end; +end; + +function TBoldSystem.GetAllDirtyObjectsAsBoldList: TBoldObjectList; +begin + result := GetDirtyObjectsAsBoldList(nil); +end; + procedure TBoldSystem.MarkObjectPossiblyCleaner(BoldObject: TBoldObject); begin - if not fDirtyObjectsInvalid then - SendEvent(beDirtyListInvalidOrItemDeleted); - fDirtyObjectsInvalid := True; + if not DirtyObjectsInvalid then + begin + DirtyObjectsInvalid := True; + SendExtendedEvent(beDirtyListInvalidOrItemDeleted, [BoldObject]); + end; +end; + +procedure TBoldSystem.MemberDerivationBegin(Member: TBoldMember); +begin + fDerivedMembers.Add(Member); +{$IFNDEF NoAutoSubscription} + if fDerivedMembers.count > Length(fMembersReadDuringDerivationIndexArray) then + SetLength(fMembersReadDuringDerivationIndexArray, fDerivedMembers.count); + fMembersReadDuringDerivationIndexArray[fDerivedMembers.count-1] := fMembersReadDuringDerivation.Count; +{$ENDIF} +end; + +procedure TBoldSystem.MemberDerivationEnd(Member: TBoldMember); +var + i: integer; + vAccessedMember: TBoldMember; +begin +{$IFNDEF NoAutoSubscription} + for i := fMembersReadDuringDerivation.Count - 1 downto fMembersReadDuringDerivationIndexArray[fDerivedMembers.count-1] do + begin + vAccessedMember := TBoldMember(fMembersReadDuringDerivation[i]); + if Assigned(vAccessedMember) then + vAccessedMember.DefaultSubscribe(Member.Deriver); // place the subscription + fMembersReadDuringDerivation.Delete(i); + end; +{$ENDIF} + fDerivedMembers.Remove(Member); end; function TBoldSystem.GetBoldDirty: Boolean; @@ -1782,21 +2538,31 @@ procedure TBoldSystem.AllowObjectDestruction; var i: Integer; anObject: TBoldObject; + aList: TList; begin if fDelayedDestructionCount <= 0 then - raise EBold.CreateFmt(sDestructionNestingMismatch, [classname]); + raise EBold.CreateFmt('%s.AllowObjectDestruction: Called without a previous matching call to DelayObjectDestruction', [classname]); dec(fDelayedDestructionCount); if fDelayedDestructionCount = 0 then begin - for i := 0 to fDelayedDestructionList.Count - 1 do - begin - Assert(TObject(fDelayedDestructionList[i]) is TBoldObject); - anObject := TBoldObject(fDelayedDestructionList[i]); - if (anObject.BoldPersistenceState <> bvpsModified) and - (anObject.BoldExistenceState <> besExisting) then - DestroyObject(anObject); + while fDelayedDestructionList.Count > 0 do begin + aList := TList.Create; + try + aList.Assign(fDelayedDestructionList); + fDelayedDestructionList.count := 0; + for i := aList.Count - 1 downto 0 do begin + Assert(TObject(aList[i]) is TBoldObject); + anObject := TBoldObject(aList[i]); + if (anObject.BoldPersistenceState <> bvpsModified) and + (anObject.BoldExistenceState <> besExisting) then + begin + DestroyObject(anObject); + end; + end; + finally + aList.Free; + end; end; - fDelayedDestructionList.Clear; end; end; @@ -1809,62 +2575,151 @@ procedure TBoldSystem.DestroyObject(BoldObject: TBoldObject); var aLocator: TBoldObjectLocator; begin + if not Assigned(BoldObject) then //Patch + Exit; //PATCH Do not try to delete nil pointer. (This is for safty. No proof that it is needed.) if (BoldObject.BoldPersistenceState = bvpsModified) or (BoldObject.BoldExistenceState = besExisting) then - raise EBold.CreateFmt(sObjectNotDestroyable, [classname]); - if fDelayedDestructionCount > 0 then - fDelayedDestructionList.Add(BoldObject) + raise EBold.CreateFmt('%s.DestroyObject: Object is not destroyable. Either modified or existing.', [classname]); + BoldObject.FreeDerivers; + if (fDelayedDestructionCount > 0) then + begin + if not BoldObject.InDelayDestructionList then + begin + fDelayedDestructionList.Add(BoldObject); + BoldObject.InDelayDestructionList := true; + end; + end else begin aLocator := BoldObject.BoldObjectLocator; - SendExtendedEvent(beLocatorDestroying, [BoldObject]); - aLocator.UnloadBoldObject; - Locators.Remove(aLocator); + // If we got an exception duriung destoy, we might get an half uninitialized BoldObject without Locator next time. + if Assigned(aLocator) then //PATCH + begin + SendExtendedEvent(beLocatorDestroying, [BoldObject]); + aLocator.UnloadBoldObject; + Locators.Remove(aLocator); + end; end; end; +function TBoldObjectList.GetObjectListController: TBoldAbstractObjectListController; +begin + Result := TBoldAbstractObjectListController(ListController); + Assert(result is TBoldAbstractObjectListController); +end; + procedure TBoldSystem.ReceiveEventFromOwned(originator: TObject; - originalEvent: TBoldEvent); + originalEvent: TBoldEvent; const Args: array of const); var ClassList: TBoldObjectList; begin - if (OriginalEvent in [beObjectCreated, beObjectDeleted, beObjectFetched]) - and (originator is TBoldObject) - then + if (originalEvent in [beObjectCreated, beObjectDeleted, beObjectFetched, beObjectUnloaded, beCompleteModify]) + and (originator is TBoldObject) then begin - ClassList := Classes[TBoldObject(Originator).BoldClassTypeInfo.TopSortedIndex]; - Assert(ClassList.ObjectListController is TBoldClassListController); - TBoldClassListController(ClassList.ObjectListController).ReceiveClassEvent(TBoldObject(Originator), OriginalEvent); + if originalEvent in [beObjectCreated, beObjectDeleted, beObjectFetched, beObjectUnloaded] then + begin + ClassList := Classes[TBoldObject(Originator).BoldClassTypeInfo.TopSortedIndex]; + Assert(ClassList.ObjectListController is TBoldClassListController); + TBoldClassListController(ClassList.ObjectListController).ReceiveClassEvent(TBoldObject(Originator), OriginalEvent); + end; SendExtendedEvent(originalEvent, [originator]); + end + else +{$IFDEF BoldSystemBroadcastMemberEvents} + if (originalEvent in beBroadcastMemberEvents) and ((Originator is TBoldObject) or (Originator is TBoldMember) and (TBoldMember(Originator).OwnedByObject)) then + Publisher.SendExtendedEvent(Originator, originalEvent, Args); +{$ENDIF} +end; + +procedure TBoldSystem.ReceiveFromPersistenceController(Originator: TObject; + OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); +begin + if (OriginalEvent = beDestroying) and (fPersistenceController = Originator) then + fPersistenceController := nil + else + case OriginalEvent of + bpeStartFetch: Inc(fFetchNesting); + bpeEndFetch: + begin + Dec(fFetchNesting); + Assert(fFetchNesting >= 0, 'Negative fetch nesting'); + end; end; end; +{$IFNDEF BOLD_NO_QUERIES} +function TBoldSystem.ReceiveQueryFromOwned(Originator: TObject; + OriginalEvent: TBoldEvent; const Args: array of const; + Subscriber: TBoldSubscriber): Boolean; +begin + result := SendQuery(OriginalEvent, Args, Subscriber, Originator); +end; +{$ENDIF} function TBoldSystem.CanCreateObject(ClassTypeInfo: TBoldClassTypeInfo): boolean; begin +{$IFDEF BOLD_NO_QUERIES} + result := true; +{$ELSE} result := SendQuery(bqMayCreateObject, [ClassTypeInfo], nil); + {$ENDIF} end; -class function TBoldAbstractOldValueHandler.NewValueInValueSpace(BoldMember: TBoldMember; ValueSpace: IBoldValueSpace): IBoldValue; -var - ObjectContents: IBoldObjectContents; - MemberId: TBoldmemberId; - G: IBoldGuard; +function TBoldMember.GetIsPartOfSystem: Boolean; begin - G := TBoldGuard.Create(MemberId); - ObjectContents := ValueSpace.EnsuredObjectContentsByObjectId[BoldMember.OwningObject.BoldObjectLocator.BoldObjectId]; - MemberId := TBoldMemberId.Create(BoldMember.BoldMemberRTInfo.Index); - if assigned(ObjectContents.ValueByMemberId[MemberId]) then - result := nil + result := OwnedByObject or (OwningElement is TBoldSystem); +end; + +function TBoldMember.GetBoldMemberRTInfo: TBoldMemberRTInfo; +begin + if OwnedByObject then + begin + assert(fBoldMetaType is TBoldMemberRtInfo); + result := TBoldMemberRTInfo(fBoldMetaType); + end + else + result := nil; +end; + +function TBoldMember.GetIsReadOnly(Flag: TBoldElementFlag): Boolean; +begin + result := GetElementFlag(Flag) or + (assigned(BoldMemberRTInfo) and BoldMemberRTInfo.IsStoredInObject and OwningObject.IsReadOnly); +end; + +function TBoldMember.GetOwningObject: TBoldObject; +begin + if OwnedByObject then + begin + Result := TBoldObject(OwningElement); + Assert(result is TBoldObject); + end + else + begin + Assert(not (OwningElement is TBoldObject)); + Result := nil; + end; +end; + +function TBoldMember.GetBoldSystem: TBoldSystem; +begin + if OwnedByObject then + begin + Assert(OwningElement is TBoldObject); + Result := TBoldObject(OwningElement).BoldSystem + end else begin - ObjectContents.EnsureMember(MemberId, BoldMember.GetStreamName); - result := ObjectContents.ValueByMemberId[MemberId]; + result := OwningElement as TBoldSystem; end; end; function TBoldSystem.CanDeleteObject(anObject: TBoldObject): boolean; begin +{$IFDEF BOLD_NO_QUERIES} + result := true; +{$ELSE} result := SendQuery(bqMayDeleteObject, [AnObject], nil); +{$ENDIF} end; function TBoldSystem.GetBoldType: TBoldElementTypeInfo; @@ -1872,11 +2727,6 @@ function TBoldSystem.GetBoldType: TBoldElementTypeInfo; result := BoldSystemTypeInfo; end; -function TBoldSystem.GetDisplayName: String; -begin - result := boldType.ExpressionName; -end; - function TBoldSystem.GetEvaluator: TBoldEvaluator; begin if not assigned(fEvaluator) then @@ -1894,32 +2744,46 @@ function TBoldSystem.GetIsDefault: Boolean; Result := Self = G_DefaultBoldSystem; end; -procedure TBoldSystem.SetIsdefault(Value: Boolean); +function TBoldSystem.GetIsProcessingTransactionOrUpdatingDatabase: Boolean; +begin + Result := IsCommitting or IsRollingBack or IsUpdatingDatabase; +end; + +procedure TBoldSystem.SetIsDefault(Value: Boolean); +begin + if Value then + begin + G_DefaultBoldSystem := Self + end + else + if (self = G_DefaultBoldSystem) then + G_DefaultBoldSystem := nil; +end; + +function TBoldSystem.InTransaction: boolean; begin - if Value then - G_DefaultBoldSystem := Self - else if IsDefault then - G_DefaultBoldSystem := nil; + Result := fTransactionNesting <> 0; end; procedure TBoldSystem.StartTransaction(MinimalMode: TBoldSystemTransactionMode = stmNormal); begin +{$IFNDEF NoObjectSpaceTransactions} if MinimalMode <= TransactionMode then begin if not InTransaction then begin Assert(not RollbackAreaAssigned); - fRollbackArea := TBoldFreeStandingValueSpace.create; - fValidValueArea := TBoldFreeStandingValueSpace.create; + RollbackAreaAssigned := true; DelayObjectDestruction; end; inc(fTransactionNesting); end; +{$ENDIF} end; procedure TBoldSystem.CommitTransaction(MinimalMode: TBoldSystemTransactionMode = stmNormal); - function OrdernoDiffers(Value: IBoldValue; member: TBoldMember):Boolean; + function OrdernoDiffers(const Value: IBoldValue; member: TBoldMember):Boolean; begin Result := (member is TBoldObjectReference) and (TBoldObjectReference(member).GetController is TBoldDirectSingleLinkController) and @@ -1938,7 +2802,8 @@ procedure TBoldSystem.CommitTransaction(MinimalMode: TBoldSystemTransactionMode RegardAsExisting: Boolean; ObjIdRef: IBoldObjectIdRef; begin - { TODO : Lots of finishing } + if FRollBackArea.IsEmpty then + exit; G := TBoldGuard.Create(ObjectIds); ObjectIds := TBoldObjectIdList.Create; FRollBackArea.AllObjectIds(ObjectIDs, false); @@ -1946,18 +2811,18 @@ procedure TBoldSystem.CommitTransaction(MinimalMode: TBoldSystemTransactionMode begin ObjectContents := FRollBackArea.GetFSObjectContentsByObjectId(ObjectIds[O]); BoldObject := Locators.GetObjectByID(ObjectIds[O]); - assert(assigned(BoldObject)); // DelayDestruction should ensure that + assert(assigned(BoldObject)); RegardAsExisting := (((BoldObject.BoldPersistenceState = bvpsCurrent) and (BoldObject.BoldExistenceState = besExisting)) or ((BoldObject.BoldPersistenceState = bvpsModified) and (BoldObject.BoldExistenceState = besDeleted))) and - (ObjectContents.BoldExistenceState = besNotCreated); // was transacted at fetch - Assert(not RegardAsExisting); // Remove when tested enough + (ObjectContents.BoldExistenceState = besNotCreated); + Assert(not RegardAsExisting); UndoHandler.HandleObject(ObjectContents, RegardAsExisting); - for M := 0 to ObjectContents.MemberCount - 1 do + for M := ObjectContents.MemberCount - 1 downto 0 do begin - Value := ObjectContents.ValueByIndex[m]; + Value := ObjectContents.ValueByIndex[m]; if Assigned(Value) and BoldObject.BoldMemberAssigned[M] and BoldObject.BoldMembers[M].StoreInUndo then begin BoldMember := BoldObject.BoldMembers[M]; @@ -1969,13 +2834,13 @@ procedure TBoldSystem.CommitTransaction(MinimalMode: TBoldSystemTransactionMode Value := nil; end; end; - if (BoldObject.BoldExistenceState = besDeleted) then // deleted object, save all remaining values + if (BoldObject.BoldExistenceState = besDeleted) then begin for M := 0 to BoldObject.BoldMemberCount - 1 do if BoldObject.BoldMemberAssigned[M] and BoldObject.BoldMembers[M].StoreInUndo then begin - Value := BoldObject.BoldMembers[M].AsIBoldValue[bdepContents]; // Store as contents, UnDO only used in other direction - if BoldObject.BoldMembers[M].BoldPersistenceState <> bvpsInvalid then + Value := BoldObject.BoldMembers[M].AsIBoldValue[bdepContents]; + if (not BoldObject.BoldMembers[M].BoldPersistenceStateIsInvalid) then UndoHandler.HandleMember(ObjectContents, M, Value); Value := nil; end; @@ -1984,10 +2849,11 @@ procedure TBoldSystem.CommitTransaction(MinimalMode: TBoldSystemTransactionMode end; begin +{$IFNDEF NoObjectSpaceTransactions} if MinimalMode <= TransactionMode then begin if not InTransaction then - raise EBold.CreateFmt(sUnmatchedCommit, [classname]); + raise EBold.CreateFmt('%s.CommitTransaction: Unmatched call to commit. Transaction not started.', [classname]); if fTransactionNesting = 1 then begin @@ -1995,49 +2861,63 @@ procedure TBoldSystem.CommitTransaction(MinimalMode: TBoldSystemTransactionMode fTransactionList.Clear; if not fTransactionRollbackOnly then begin - if TBoldUndoHandler(UndoHandler).UndoState=busNormal then - HandleOldValues; - FreeAndNil(fRollbackArea); - FreeAndNil(fValidValueArea); - dec(fTransactionNesting); - AllowObjectDestruction; + Dec(fTransactionNesting); //PATCH If we get to this point we MUST decrease the counter to zero so we don't get stuck forever. + IsCommitting := True; + try + if UndoHandlerInterface.Enabled and (TBoldUndoHandler(UndoHandler).UndoState=busNormal) then + HandleOldValues; + finally //PATCH To strengten Transaction against exceptions + try //PATCH To strengten Transaction against exceptions + fRollbackArea.Clear; + finally + try + fValidValueArea.Clear; + finally + RollbackAreaAssigned := false; + AllowObjectDestruction; //PATCH Make sure this is called even if we get an exception when destroying valuespaces. + IsCommitting := false; + end; + end; + end; end else - BoldRaiseLastFailure(self, 'CommitTransaction', sCommitNotAllowed); // do not localize + BoldRaiseLastFailure(self, 'CommitTransaction', 'Transaction not allowed to be commited'); end else dec(fTransactionNesting); end; +{$ENDIF} end; procedure TBoldSystem.RollbackTransaction(MinimalMode: TBoldSystemTransactionMode = stmNormal); -var - aRollbackArea: TBoldFreestandingValueSpace; - aValidValueArea: TBoldFreestandingValueSpace; begin +{$IFNDEF NoObjectSpaceTransactions} if MinimalMode <= TransactionMode then begin if not InTransaction then - raise EBold.CreateFmt(sUnmatchedRollback, [classname]); - + raise EBold.CreateFmt('%s.RollbackTransaction: Unmatched call to rollback. Transaction not started.', [classname]); if fTransactionNesting = 1 then begin - aRollbackArea := fRollbackArea; - fRollbackArea := nil; // so rollback doesn't write to rollback area itself - aValidValueArea := fValidValueArea; - fValidValueArea := nil; - AsIBoldvalueSpace[bdepContents].ApplyValueSpace(aRollbackArea, false); - aRollbackArea.Free; - aValidValueArea.Free; - AllowObjectDestruction; - fTransactionList.Clear; - fTransactionRollbackOnly := false; - SendEvent(beRolledBack); + IsRollingBack := True; + try + fTransactionRollbackOnly := True; //PATCH + RollbackAreaAssigned := false; + AsIBoldvalueSpace[bdepContents].ApplyValueSpace(fRollbackArea, false); + finally + dec(fTransactionNesting); + IsRollingBack := False; + fRollbackArea.clear; + fValidValueArea.clear; + AllowObjectDestruction; + fTransactionList.Clear; + fTransactionRollbackOnly := false; + SendEvent(beRolledBack); + end; end else - fTransactionRollbackOnly := true; - dec(fTransactionNesting); + dec(fTransactionNesting); end; +{$ENDIF} end; function TBoldSystem.CanCommit: Boolean; @@ -2047,48 +2927,110 @@ function TBoldSystem.CanCommit: Boolean; begin g := TBoldGuard.Create(Traverser); try +{$IFDEF BOLD_NO_QUERIES} + result := true; +{$ELSE} result := SendQuery(bqMayCommit, [], nil); +{$ENDIF} Traverser := fTransactionList.CreateTraverser; - while result and not Traverser.EndOfList do + while result and Traverser.MoveNext do begin result := Traverser.item.CanCommit; - Traverser.Next; end; except result := false; end; end; -class procedure TBoldAbstractOldValueHandler.CopyMemberToValueSpace(BoldMember: TBoldMember; ValueSpace: IBoldValueSpace); +function TBoldSystemFreeStandingObjectContents.EnsureMemberAndGetValueByIndex( + Member: TBoldMember): IBoldValue; + + function CreateInstance( + Member: TBoldMember): TBoldFreeStandingValue; + var + ElementClass: TBoldFreeStandingElementClass; + begin + ElementClass := Member.GetFreeStandingClass; + if Assigned(ElementClass) then + result := ElementClass.Create as TBoldFreeStandingValue + else + raise EBold.createFmt('%s.CreateInstance: No freestanding class registered for name %s', [classname, Member.DisplayName]); + end; + var - Value: IBoldValue; - BoldObject: TBoldObject; + Index: integer; begin - Assert(assigned(valuespace)); - - BoldObject := BoldMember.OwningObject; - Assert(Assigned(BoldObject)); - CopyObjectToValueSpace(BoldObject, ValueSpace); - Value := NewValueInValueSpace(BoldMember, ValueSpace); - if Assigned(Value) then - Value.AssignContent(BoldMember.AsIBoldValue[bdepContents]); + Index := Member.BoldMemberRTInfo.index; + EnsureMemberListLength(Index); + if not assigned(fMemberlist[Index]) then + fMemberlist[Index] := CreateInstance(Member); + Result := fMemberlist[Index]; end; -class procedure TBoldAbstractOldValueHandler.CopyObjectToValueSpace(BoldObject: TBoldObject; ValueSpace: IBoldValueSpace); +class function TBoldAbstractOldValueHandler.NewValueInValueSpace(BoldMember: TBoldMember; const ValueSpace: IBoldValueSpace): IBoldValue; var - anObjectContents: IBoldObjectContents; - anObjectId: TBoldObjectId; + ObjectContents: IBoldObjectContents; + MemberIndex: Integer; + BoldSystemObjectContents: IBoldSystemObjectContents; begin - assert(assigned(ValueSpace)); + ObjectContents := ValueSpace.EnsuredObjectContentsByObjectId[BoldMember.OwningObject.BoldObjectLocator.BoldObjectId]; + MemberIndex := BoldMember.BoldMemberRTInfo.Index; + if assigned(ObjectContents.ValueByIndex[MemberIndex]) then + result := nil + else + begin + if Supports(ObjectContents, IBoldSystemObjectContents, BoldSystemObjectContents) then + result := BoldSystemObjectContents.EnsureMemberAndGetValueByIndex(BoldMember) + else + result := ObjectContents.EnsureMemberAndGetValueByIndex(MemberIndex, BoldMember.GetStreamName); + end; +end; + +class procedure TBoldAbstractOldValueHandler.CopyMemberToValueSpace(BoldMember: TBoldMember; const ValueSpace: IBoldValueSpace); + + function GetMemberFromContents(const ObjectContents: IBoldObjectContents): IBoldValue; + var + BoldSystemObjectContents: IBoldSystemObjectContents; + begin + if Supports(ObjectContents, IBoldSystemObjectContents, BoldSystemObjectContents) then + result := BoldSystemObjectContents.EnsureMemberAndGetValueByIndex(BoldMember) + else + result := ObjectContents.EnsureMemberAndGetValueByIndex(BoldMember.BoldMemberRTInfo.Index, BoldMember.GetStreamName); + end; +var + ObjectContents: IBoldObjectContents; + Member: IBoldValue; +begin + Assert(Assigned(Valuespace)); + Assert(Assigned(BoldMember)); + Assert(Assigned(BoldMember.OwningObject)); + Member := nil; + if ValueSpace.GetEnsuredObjectContentsByObjectIdAndCheckIfCreated(BoldMember.OwningObject.BoldObjectLocator.BoldObjectId, ObjectContents) then + with BoldMember.OwningObject do + begin + ObjectContents.BoldExistenceState := BoldExistenceState; + ObjectContents.BoldPersistenceState := BoldPersistenceState; + ObjectContents.TimeStamp := GetTimeStamp; + Member := GetMemberFromContents(ObjectContents); + end + else + if not assigned(ObjectContents.ValueByIndex[BoldMember.BoldMemberRTInfo.Index]) then + begin + Member := GetMemberFromContents(ObjectContents); + end; + if Assigned(Member) then + Member.AssignContent(BoldMember.AsIBoldValue[bdepContents]); +end; - anObjectId := BoldObject.BoldObjectLocator.BoldObjectID; - anObjectContents := ValueSpace.ObjectContentsByObjectId[anObjectID]; - if not assigned(anObjectContents) then +class procedure TBoldAbstractOldValueHandler.CopyObjectToValueSpace(BoldObject: TBoldObject; const ValueSpace: IBoldValueSpace); +var + aBoldObjectContents: IBoldObjectContents; +begin + Assert(Assigned(ValueSpace)); + if ValueSpace.GetEnsuredObjectContentsByObjectIdAndCheckIfCreated(BoldObject.BoldObjectLocator.BoldObjectId, aBoldObjectContents) then begin - ValueSpace.EnsureObjectContents(anObjectID); - anObjectContents := ValueSpace.ObjectContentsByObjectId[anObjectId]; - anObjectContents.BoldExistenceState := BoldObject.BoldExistenceState; - anObjectContents.BoldPersistenceState := BoldObject.BoldPersistenceState; + aBoldObjectContents.BoldExistenceState := BoldObject.BoldExistenceState; + aBoldObjectContents.BoldPersistenceState := BoldObject.BoldPersistenceState; end; end; @@ -2097,44 +3039,45 @@ procedure TBoldSystem.CopyMemberToRollBackBuffer(BoldMember: TBoldMember); Value: IBoldValue; FSObjectContents: TBoldFreeStandingObjectContents; MemberIndex: integer; + Created: boolean; begin - if RollBackAreaAssigned then + if RollBackAreaAssigned {$IFDEF DisableRollbackDuringFetch} and not IsFetching {$ENDIF} then begin MemberIndex := BoldMember.BoldMemberRTInfo.index; - FSObjectContents := EnsureObjectInFsValueSpace(BoldMember.OwningObject, fRollbackArea); - Value := FSObjectContents.ValueByIndex[BoldMember.BoldMemberRTInfo.Index]; + FSObjectContents := EnsureObjectInFsValueSpace(BoldMember.OwningObject, fRollbackArea, Created); + if Created then + Value := nil + else + Value := FSObjectContents.ValueByIndex[BoldMember.BoldMemberRTInfo.Index]; if Assigned(Value) then begin if (Value.BoldPersistenceState = bvpsInvalid) then begin - FSObjectContents := EnsureObjectInFsValueSpace(BoldMember.OwningObject, fValidValueArea); - if not Assigned(FSObjectContents.ValueByIndex[MemberIndex]) then - begin - FSObjectContents.EnsureMemberByIndex(MemberIndex, BoldMember.GetStreamName); - FSObjectContents.ValueByIndex[MemberIndex].AssignContent(BoldMember.AsIBoldValue[bdepContents]); - end; + FSObjectContents := EnsureObjectInFsValueSpace(BoldMember.OwningObject, fValidValueArea, Created); + TBoldSystemFreeStandingObjectContents(FSObjectContents).EnsureMemberAndGetValueByIndex(BoldMember).AssignContent(BoldMember.AsIBoldValue[bdepContents]);; end; end else begin Assert (not( (BoldMember is TBOldObjectReference) and - (BoldMember.BoldPersistenceState = bvpsInvalid) and + (BoldMember.BoldPersistenceStateIsInvalid) and TBOldObjectReference(BoldMember).HasOldValues and ((TBOldObjectReference(BoldMember).fObjectReferenceController as TBoldDirectSingleLinkController).GetLocator = nil) )); - FSObjectContents.EnsureMemberByIndex(MemberIndex, BoldMember.GetStreamName); - FSObjectContents.ValueByIndex[MemberIndex].AssignContent(BoldMember.AsIBoldValue[bdepContents]); + Value := BoldMember.AsIBoldValue[bdepContents]; + TBoldSystemFreeStandingObjectContents(FSObjectContents).EnsureMemberAndGetValueByIndex(BoldMember).AssignContent(Value); end; end; end; procedure TBoldSystem.CopyObjectToRollBackBuffer(BoldObject: TBoldObject); begin - if RollBackAreaAssigned then - EnsureObjectInFsValueSpace(BoldObject, fRollBackArea); + if RollBackAreaAssigned {$IFDEF DisableRollbackDuringFetch} and not IsFetching {$ENDIF} then + EnsureObjectInFsValueSpace(BoldObject, fRollBackArea); end; + procedure TBoldSystem.AddToTransaction(DomainElement: TBoldDomainElement); begin if RollbackAreaAssigned and not fTransactionList.Includes(DomainElement) then @@ -2156,7 +3099,7 @@ function TBoldSystem.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementPr begin if IsEqualGuid(IID, IBoldValueSpace) then begin - result := TBoldSystem_Proxy.create(self, Mode).GetInterface(IID, obj); + result := TBoldSystem_Proxy.Create(self, Mode).GetInterface(IID, obj); if not result then raise EBoldInternal.CreateFmt('ProxyClass for %s did not implement IBoldValueSpace', [ClassName]); end @@ -2164,14 +3107,53 @@ function TBoldSystem.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementPr result := inherited ProxyInterface(IID, Mode, Obj); end; -function TBoldSystem.InTransaction: boolean; +procedure TBoldSystem.CheckIntegrity; +var + Traverser: TBoldLocatorListTraverser; + i: integer; + bo: TBoldObject; + bm: TBoldMember; begin - Result := fTransactionNesting <> 0; + Traverser := Locators.CreateTraverser; + while Traverser.MoveNext do + begin + if assigned(Traverser.Locator.BoldObject) then + begin + + if not (Traverser.Locator.BoldObject is TBoldObject) then + raise Exception.Create('broken object'); + bo := Traverser.Locator.BoldObject; + for i := 0 to bo.BoldMemberCount - 1 do + begin + + if bo.BoldMemberAssigned[i] then + begin + + bm := bo.BoldMembers[i]; + if not (bm is TBoldMember) then + raise Exception.Create('broken member'); + end; + end; + end; + end; + Traverser.Free; + end; -function TBoldSystem.RollBackAreaAssigned: boolean; +procedure TBoldSystem.IncrementDeletingObjectsDepth; begin - Result := Assigned(fRollBackArea); + Inc(FDeletingObjectsDepth); + if FDeletingObjectsDepth = 1 then begin +// SendEvent(beStartObjectDeletion); + end; +end; + +procedure TBoldSystem.DecrementDeletingObjectsDepth; +begin + if FDeletingObjectsDepth = 1 then begin +// SendEvent(beEndObjectDeletion); + end; + Dec(FDeletingObjectsDepth); end; { EnsureCanDestroy will raise an exception if there are constraints @@ -2179,11 +3161,11 @@ function TBoldSystem.RollBackAreaAssigned: boolean; procedure TBoldSystem.EnsureCanDestroy; begin if InTransaction then - raise EBold.CreateFmt(sDestroy_TransactionNesting, [ClassName, fTransactionNesting, BoldSystemTypeInfo.Modelname]); + raise EBold.CreateFmt('%s.Destroy; TransactionNesting = %d', [ClassName, fTransactionNesting]); if RollbackAreaAssigned then - raise EBold.CreateFmt(sDestroy_RollbackAreaAssigned, [ClassName, BoldSystemTypeInfo.Modelname]); + raise EBold.CreateFmt('%s.Destroy; RollBackArea still assigned', [ClassName]); if BoldDirty then - raise EBold.CreateFmt(sDestroy_DirtyObjects, [ClassName, BoldSystemTypeInfo.Modelname]); + raise EBold.CreateFmt('%s.Destroy: Destroying system with dirty objects', [ClassName]); end; function TBoldSystem.GetTimeForTimestamp(Timestamp: TBoldTimestampType): TDateTime; @@ -2201,7 +3183,7 @@ procedure TBoldSystem.SetTransactionMode(const Value: TBoldSystemTransactionMode if value <> fTransactionMode then begin if InTransaction then - raise EBold.CreateFmt(sNotAllowedInTransaction, [classname]); + raise EBold.CreateFmt('%s.SetTransactionMode: Not allowed while inside a transaction', [classname]); fTransactionMode := Value; end; end; @@ -2209,7 +3191,7 @@ procedure TBoldSystem.SetTransactionMode(const Value: TBoldSystemTransactionMode procedure TBoldSystem.SetPessimisticLockHandler(const Value: TBoldAbstractPessimisticLockHandler); begin if assigned(fPessimisticLockHandler) then - raise EBold.CreateFmt(sCannotChangeLockHandler, [classname]); + raise EBold.CreateFmt('%s.SetPessimisticLockHandler: Can not change lock handler on a running system', [classname]); fPessimisticLockHandler := Value; end; @@ -2228,16 +3210,9 @@ function TBoldSystem.GetTimeStampOfLatestUpdate: TBoldTimeStampType; Result := SystemPersistenceHandler.TimeStampOfLatestUpdate end; -function TBoldSystem.GetUndoHandler: TBoldAbstractUndoHandler; -begin - if not Assigned(fUndoHandler) then - fUndoHandler := TBoldUndoHandler.Create(self); - Result := fUndoHandler; -end; - -function TBoldSystem.GetUndoHandlerInterface: IBoldUndoHandler; +function TBoldSystem.GetTimeOfLatestUpdate: TDateTime; begin - Result := UndoHandler as IBoldUndoHandler; + Result := SystemPersistenceHandler.TimeOfLatestUpdate end; function TBoldSystem.AssertLinkIntegrity: Boolean; @@ -2249,7 +3224,7 @@ function TBoldSystem.AssertLinkIntegrity: Boolean; begin G := TBoldGuard.Create(Traverser); Traverser := Locators.CreateTraverser; - while not Traverser.EndOfList do + while Traverser.MoveNext do begin if assigned(Traverser.Locator.BoldObject) then begin @@ -2259,49 +3234,143 @@ function TBoldSystem.AssertLinkIntegrity: Boolean; and (bo.BoldMembers[i].GetController <> nil) then bo.BoldMembers[i].GetController.AssertIntegrity; end; - Traverser.Next; end; Result := True; end; +function TBoldSystem.CanEvaluateInPS(sOCL: string; + aContext: TBoldElementTypeInfo = nil; + const aVariableList: TBoldExternalVariableList = nil): Boolean; +begin + Result := SystemPersistenceHandler.CanEvaluateInPS(sOCL, aContext, aVariableList); +end; + +function TBoldSystem.GetDiscarding: Boolean; +begin + Result := FDiscardCount > 0; +end; + +function TBoldSystem.ContainsDirtyObjectsOfClass(AClassType: TBoldObjectClass): boolean; +var + i: integer; + List: TList; +begin + result := false; + List := DirtyObjects; + for I := List.Count - 1 downto 0 do + begin + if TBoldObject(List[i]) is AClassType then + begin + result := true; + exit; + end; + end; +end; + +procedure TBoldSystem.RemoveDeletedObjects(IDList: TBoldObjectIdList); +var + i: integer; + TranslationList: TBoldIdTranslationList; +begin + TranslationList := TBoldIdTranslationList.Create; + try + PersistenceController.PMExactifyIDs(IdList, TranslationList, true); + for I := TranslationList.Count - 1 downto 0 do + if TranslationList.NewIds[i].NonExisting then + IdList.Remove(IdList.IDByID[TranslationList.OldIds[i]]); + finally + TranslationList.Free; + end; +end; + { TBoldObject } + function TBoldObject.GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; +begin + Result := GetDeriveMethodForMember(Member.BoldmemberRTInfo.Index); +end; + +function TBoldObject.GetDeriveMethodForMember(MemberIndex: Integer): TBoldDeriveAndResubscribe; begin result := nil; - if Member.BoldmemberRTInfo.IsDerived and - (Member.BoldMemberRTInfo.DeriveExpression <> '') then - result := Member.CalculateDerivedMemberWithExpression; end; function TBoldObject.GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; +begin + result := GetReverseDeriveMethodForMember(Member.BoldmemberRTInfo.Index); +end; + +function TBoldObject.GetReverseDeriveMethodForMember(MemberIndex: Integer): TBoldReverseDerive; begin result := nil; end; function TBoldObject.GetBoldMembers(index: Integer): TBoldMember; + procedure InternalRaise; + var + ID: String; + begin + if Assigned(FBoldObjectLocator) then + ID := FBoldObjectLocator.BoldObjectID.AsString + else + ID := '(NoID)'; + raise EBold.CreateFmt('%s[Id=%s].GetBoldMembers: Index out of range (%d but max is %d)', [ClassName, id, Index, BoldMemberCount-1]); + end; +var + MemberRTInfo: TBoldMemberRTInfo; begin - if (index < 0) or (index >= BoldMemberCount) then - raise EBold.CreateFmt(sIndexOutOfRange, [ClassName, 'GetBoldMembers', Index, BoldMemberCount]); // do not localize - Result := FDynamicData^[index]; + if Cardinal(index) >= Cardinal(Length(fMemberArray)) then + InternalRaise; + Result := fMemberArray[index]; if not assigned(result) then begin - if (BoldObjectLocator.BoldObjectID.TimeStamp <> BOLDMAXTIMESTAMP) and + if IsHistoricVersion and BoldClassTypeInfo.AllMembers[index].IsNonVersionedInVersionedClass then result := AtTime(BOLDMAXTIMESTAMP).BoldMembers[index] else begin - result := CreateMemberByIndex(index); - fDynamicData^[index] := result; - InitializeMember(result, BoldClassTypeInfo.AllMembers[index] {MemberRTInfo}, GetElementFlag(befObjectWasCreatedNew)); + MemberRTInfo := BoldClassTypeInfo.AllMembers[Index]; + result := TBoldMemberClass(MemberRTInfo.MemberClass).CreateAsObjectPart(Self, MemberRTInfo); + fMemberArray[index] := result; + InitializeMember(result, MemberRTInfo, GetElementFlag(befObjectWasCreatedNew)); end; end; end; -function TBoldObject.GetBoldMemberAssigned(Index: integer): Boolean; +function TBoldObject.GetBoldMemberDeriver(Member: TBoldMember): TBoldMemberDeriver; +var + index: integer; + procedure InternalRaise; + begin + raise EBold.CreateFmt('%s[Id=%s].GetBoldMemberDeriver: Index out of range (%d but max is %d)', [ClassName, self.FBoldObjectLocator.BoldObjectID.AsString, Index, BoldClassTypeInfo.DerivedMemberCount-1]); + end; +begin + index := Member.BoldMemberRTInfo.DeriverIndex; + if Cardinal(index) >= Cardinal(Length(fDeriverArray)) then + begin + if Cardinal(index) >= Cardinal(BoldClassTypeInfo.DerivedMemberCount) then + InternalRaise; + SetLength(fDeriverArray, BoldClassTypeInfo.DerivedMemberCount); + end; + result := fDeriverArray[index]; + if not Assigned(Result) then + begin + Result := TBoldMemberDeriver.Create(Member); + fDeriverArray[index] := Result; + Member.HasDeriver := True; + end; +end; + +function TBoldObject.SafeGetBoldMemberAssigned(Index: integer): Boolean; begin - if (index < 0) or (index >= BoldMemberCount) then - raise EBold.CreateFmt(sIndexOutOfRange, [ClassName, 'GetBoldMemberAssigned', Index, BoldMemberCount]); // do not localize - result := assigned(fDynamicData^[Index]); + result := assigned(fMemberArray[Index]); +end; + +function TBoldObject.GetBoldMemberIfAssigned(index: Integer): TBoldMember; +begin + if Cardinal(Index) >= Cardinal(Length(fMemberArray)) then + raise EBold.CreateFmt('%s.GetBoldMemberIfAssigned: Index out of range (%d but max is %d)', [ClassName, Index, BoldMemberCount-1]); + Result := fMemberArray[index]; end; function TBoldObject.GetBoldObjectIsDeleted: Boolean; @@ -2311,17 +3380,10 @@ function TBoldObject.GetBoldObjectIsDeleted: Boolean; function TBoldObject.GetBoldObjectIsNew: Boolean; begin - // newly created and yet not stored obejcts result := (BoldExistenceState = besExisting) and (BoldPersistenceState = bvpsModified); - // transient objects result := result or (BoldPersistenceState = bvpsTransient); end; -function TBoldObject.GetBoldMemberCount: Integer; -begin - Result := BoldClassTypeInfo.AllMembersCount; -end; - function TBoldObject.GetStringRepresentation(Representation: TBoldRepresentation): string; begin if BoldClassTypeInfo.defaultstringrepresentation <> '' then @@ -2332,7 +3394,7 @@ function TBoldObject.GetStringRepresentation(Representation: TBoldRepresentation (BoldMembers[Representation] is TBoldAttribute) then Result := BoldMembers[Representation].AsString else - Result := Format('%s:%s', [BoldObjectLocator.AsString, BoldClassTypeInfo.ModelName]); // do not localize + Result := Format('%s:%s', [BoldObjectLocator.AsString, BoldClassTypeInfo.ModelName]); end; end; @@ -2350,8 +3412,8 @@ procedure TBoldObject.SubscribeToStringRepresentation(Representation: TBoldRepre function TBoldObject.GetBoldSystem: TBoldSystem; begin - Assert(OwningElement is TBoldSystem); Result := TBoldSystem(OwningElement); + Assert(result is TBoldSystem); end; function TBoldObject.GetAsIBoldObjectContents(Mode: TBoldDomainElementProxyMode): IBoldObjectContents; @@ -2359,46 +3421,25 @@ function TBoldObject.GetAsIBoldObjectContents(Mode: TBoldDomainElementProxyMode) ProxyInterface(IBoldObjectContents, Mode, result); end; - -function TBoldObject.CreateMemberByIndex(Index: integer): TBoldMember; -var - MemberRTInfo: TBoldMemberRTInfo; -begin - MemberRTInfo := BoldClassTypeInfo.AllMembers[Index]; - result := TBoldMemberClass(MemberRTInfo.MemberClass).InternalCreate(Self, MemberRTInfo, - GetElementFlag(befObjectWasCreatedNew) and not MemberRTInfo.IsDerived); -end; - procedure TBoldObject.InitializeObject(System: TBoldSystem; ClassTypeInfo: TBoldClassTypeInfo; Locator: TBoldObjectLocator; Persistent: Boolean); -var - DynamicDataSize: integer; begin if ClassTypeInfo.IsAbstract then - raise EBold.CreateFmt(sCannotInstansiateAbstractClass, [ClassTypeInfo.ExpressionName]); + raise EBold.CreateFmt('%s.InitializeObject: Can''t instansiate abstract class', [ClassTypeInfo.ExpressionName]); if ClassTypeInfo.IsImported then - raise EBold.CreateFmt(sCannotInstansiateImportedClass, [ClassTypeInfo.ExpressionName]); + raise EBold.CreateFmt('%s.InitializeObject: Can''t instansiate imported class', [ClassTypeInfo.ExpressionName]); fBoldClassTypeInfo := ClassTypeInfo; SetElementFlag(befObjectWasCreatedNew, not Assigned(Locator)); SetElementFlag(befPersistent, System.BoldPersistent and ClassTypeInfo.Persistent and Persistent); - SetElementFlag(befStoresTimeStamp, BoldClassTypeInfo.OptimisticLocking = bolmTimeStamp); - - DynamicDataSize := GetDynamicDataSize; - if DynamicDataSize > 0 then - begin - fDynamicData := BoldMemoryManager_.AllocateMemory(DynamicDataSize); - FillChar(fDynamicData^, DynamicDataSize, 0); - end else - fDynamicData := nil; - - if BoldStoresTimeStamp then - fDynamicData^[BoldMemberCount] := Pointer(-1); // marco added ^ x3 + SetLength(fMemberArray, BoldMemberCount); + fTimeStamp := -1; if Assigned(Locator) then begin FBoldObjectLocator := Locator; BoldObjectLocator.FBoldObject := Self; BoldObjectLocator.EmbeddedSingleLinksToObject; + SetElementFlag(befIsHistoricVersion, BoldObjectLocator.BoldObjectID.TimeStamp <> BOLDMAXTIMESTAMP); end else begin @@ -2409,16 +3450,65 @@ procedure TBoldObject.InitializeObject(System: TBoldSystem; ClassTypeInfo: TBold ToBeRemovedClassAccessed; end; +procedure TBoldMember.InitializeStateToModified; +begin + SetInternalState(BoldPersistenceStateMask, BoldPSShift, Integer(bvpsModified)); +end; + +procedure TBoldMember.InitializeStateToInvalid; +begin + SetInternalState(BoldPersistenceStateMask, BoldPSShift, Integer(bvpsInvalid)); +end; + +function TBoldMember.GetBoldPersistenceState: TBoldValuePersistenceState; +begin + result := TBoldValuePersistenceState((StateAndFlagBank and BoldPersistenceStateMask) shr BoldPSShift); +end; + +procedure TBoldMember.InitializeStateToTransient; +begin + SetInternalState(BoldPersistenceStateMask, BoldPSShift, Integer(bvpsTransient)); +end; + +procedure TBoldMember.InitializeStateToCurrent; +begin + SetInternalState(BoldPersistenceStateMask, BoldPSShift, Integer(bvpsCurrent)); +end; + +function TBoldAttribute.GetAttributeTypeInfoForType: TBoldElementTypeInfo; +begin + result := FindASystem.BoldSystemTypeInfo.AttributeTypeInfoByDelphiName[Self.ClassName] +end; + +function TBoldAttribute.GetBoldAttributeRTInfo: TBoldAttributeRTInfo; +begin + Result := TBoldAttributeRTInfo(BoldMemberRTInfo); + Assert((not Assigned(result)) or (result is TBoldAttributeRTInfo)); +end; + procedure TBoldObject.InitializeMember(Member: TBoldMember; MemberRTInfo: TBoldMemberRTInfo; IsNewObject: Boolean); begin if IsNewobject then begin {New object} - if Member.BoldPersistent then - Member.InitializeStateToModified + if MemberCanBeModified(MemberRtInfo, BoldSystem) then + begin + if Member.BoldPersistent then + Member.InitializeStateToModified + else + Member.InitializeStateToTransient; + Member.DoSetInitialValue; + end else if Member.Derived then Member.InitializeStateToInvalid + else if Member.BoldPersistent then // Non-embedded Role starts as current since noone has associations to a new object + begin + Member.InitializeStateToCurrent; + end else + begin Member.InitializeStateToTransient; + Member.DoSetInitialValue; + end; end else begin {Old object} @@ -2430,15 +3520,13 @@ procedure TBoldObject.InitializeMember(Member: TBoldMember; MemberRTInfo: TBoldM (TBoldRoleRTInfo(MemberRTInfo).roleType in [rtInnerLinkRole, rtLinkRole]) then Member.InitializeStateToInvalid else + begin Member.InitializeStateToTransient; + if Assigned(Member.BoldMemberRTInfo) and Member.BoldMemberRTInfo.IsAttribute and TBoldAttribute(Member).BoldAttributeRtInfo.HasInitialValue then + Member.DoSetInitialValue; + end; end; - if IsNewObject and not memberRTInfo.IsDerived then - Member.DoSetInitialValue; - - if memberRTInfo.IsDerived and (MemberRTInfo.DeriveExpression <> '') then - Member.Deriver.OnDeriveAndSubscribe := Member.CalculateDerivedMemberWithExpression; - if MemberRTInfo.ToBeRemoved and not IsNewObject then ToBeRemovedMemberAccessed(MemberRTInfo); end; @@ -2448,7 +3536,7 @@ constructor TBoldObject.InternalCreateWithClassAndLocator(ClassTypeInfo: TBoldCl SetInternalState(BoldExistenceStateMask, BoldESShift, Integer(besExisting)); SetInternalState(BoldPersistenceStateMask, BoldPSShift, Integer(bvpsInvalid)); Assert(Assigned(Locator.BoldSystem)); - inherited Create(Locator.BoldSystem); + inherited CreateWithOwner(Locator.BoldSystem); InitializeObject(Locator.BoldSystem, ClassTypeInfo, Locator, True); EndReCreate; end; @@ -2458,46 +3546,60 @@ constructor TBoldObject.Create(AOwningElement: TBoldDomainElement; Persistent: B System: TBoldSystem; aClass: TBoldClassTypeInfo; begin + IsEffectiveInvalidKnown := false; SetInternalState(BoldExistenceStateMask, BoldESShift, Integer(besNotCreated)); SetInternalState(BoldPersistenceStateMask, BoldPSShift, Integer(bvpsCurrent)); if AOwningElement = nil then begin System := TBoldSystem.DefaultSystem; if not assigned(system) then - raise EBold.CreateFmt(sNoDefaultSystem, [ClassName]); + raise EBold.CreateFmt('%s.Create: unable to find a default system', [ClassName]); end else if AOwningElement is TBoldSystem then System := TBoldSystem(AOwningElement) else - raise EBold.CreateFmt(sOwningElementMustBeSystem, [ClassName]); + raise EBold.CreateFmt('%s.Create: OwningElement must be a TBoldSystem', [ClassName]); aClass := System.BoldSystemTypeInfo.TopSortedClasses.ItemsByObjectClass[ClassType]; if not assigned(aClass) then begin if not System.BoldSystemTypeInfo.UseGeneratedCode then - raise EBold.CreateFmt(sGeneratedCodeNotUsed + BOLDCRLF + - sGeneratedCode_HowToFix, + raise EBold.CreateFmt('%s.Create: The system does not use generated code...' + BOLDCRLF + + 'You must use BoldSystem.CreateNewObjectByExpressionName (or tell the SystemTypeInfoHandle to use the generated code)', [ClassName]) else - raise EBold.CreateFmt(sNoClassInformation, [ClassName, classname]) + raise EBold.CreateFmt('%s.Create: Unknown error, unable to find class information for %s', [ClassName, classname]) end; if aClass.IsLinkClass then - raise EBold.CreateFmt(sCannotCreateAssociationClass, [classname]); + raise EBold.CreateFmt('%s.Create: Cannot create instance of association class', [classname]); InternalCreateNewWithClassAndSystem(aClass, System, Persistent); end; -procedure TBoldObject.ReceiveEventFromOwned(originator: TObject; originalEvent: TBoldEvent); + +procedure TBoldObject.ReceiveEventFromOwned(originator: TObject; originalEvent: TBoldEvent; const Args: array of const); begin if (BoldExistenceState = besExisting) and (originalEvent in beValueEvents) then - SendEvent(beMemberChanged); - + SendExtendedEvent(beMemberChanged, [Originator]); +{$IFDEF BoldSystemBroadcastMemberEvents} + if (BoldExistenceState = besExisting) and + (originalEvent in beBroadcastMemberEvents) then + BoldSystem.ReceiveEventFromOwned(Originator, OriginalEvent, Args); // broadcast member events through BoldSystem +{$ENDIF} if (originalEvent in beValueEvents) and assigned(BoldSystem.NewModifiedList) and (not (Originator is TBoldMember) or (not TBoldMember(Originator).Derived)) then BoldSystem.NewModifiedList.Add(self); end; +{$IFNDEF BOLD_NO_QUERIES} +function TBoldObject.ReceiveQueryFromOwned(Originator: TObject; + OriginalEvent: TBoldEvent; const Args: array of const; + Subscriber: TBoldSubscriber): Boolean; +begin + result := SendQuery(OriginalEvent, Args, Subscriber, Originator); +end; +{$ENDIF} destructor TBoldObject.Destroy; var I: Integer; @@ -2505,7 +3607,6 @@ destructor TBoldObject.Destroy; begin if BoldExistenceState = besNotCreated then begin - // OwningElement might not be set if constructor failed if assigned(OwningElement) then begin if assigned(BoldObjectLocator) then @@ -2521,19 +3622,15 @@ destructor TBoldObject.Destroy; else begin if Assigned(BoldObjectLocator) then - raise EBold.CreateFmt(sIllegalDirectDestruction, [ClassName]); + raise EBold.CreateFmt('%s.Destroy: Can''t destroy a BoldObject directly. ' + + 'Call Id.Unload to unload from memory or Delete to delete object', [ClassName]); end; PrepareToDestroy; - - if Assigned(fDynamicData) then - begin - for i := 0 to BoldMemberCount - 1 do - if GetBoldMemberAssigned(i) then - BoldMembers[i].Free; - BoldMemorymanager_.DeAllocateMemory(fDynamicData, GetDynamicDataSize); - end; - + FreeDerivers; + for i := 0 to Length(fMemberArray) - 1 do + FreeAndNil(fMemberArray[i]); + SetLength(fMemberArray, 0); inherited Destroy; end; @@ -2541,34 +3638,54 @@ procedure TBoldObject.DefaultSubscribe(Subscriber: TBoldSubscriber; RequestedEve begin end; -procedure TBoldObject.UnLinkAll; +procedure TBoldObject.InternalUnLinkAll(AUnlinkPersistent: boolean); var - M: Integer; - MemberRTInfo: TBoldMemberRTInfo; + i, MemberIndex: Integer; + RoleRTInfo: TBoldRoleRTInfo; + Saved: boolean; begin - for M := 0 to BoldClassTypeInfo.AllMembers.Count - 1 do + Saved := BoldObjectLocator.BoldObjectID.IsStorable; + for i := 0 to BoldClassTypeInfo.AllRoles.Count - 1 do begin - MemberRTInfo := BoldClassTypeInfo.AllMembers[M]; - if MemberRTInfo.IsRole and MemberRTInfo.IsDerived then + RoleRTInfo := BoldClassTypeInfo.AllRoles[i]; + MemberIndex := RoleRTInfo.index; + if not Saved and not SafeGetBoldMemberAssigned(MemberIndex) then + continue; // can skip nil members if not persistent + if RoleRTInfo.IsDerived then begin - if GetBoldMemberAssigned(m) then - BoldMembers[m].Invalidate; + if SafeGetBoldMemberAssigned(MemberIndex) then + BoldMembers[MemberIndex].Invalidate; end - else if MemberRTInfo.isMultiRole then + else if not AUnlinkPersistent and not RoleRTInfo.Persistent then begin - if ((MemberRTInfo as TBoldRoleRTInfo).RoleType = rtRole) and - ((BoldMembers[M] as TBoldObjectList).Count <> 0) then - (BoldMembers[M] as TBoldObjectList).Clear; + // do not discard transient roles end - else if MemberRTInfo.isSingleRole then + else if RoleRTInfo.isMultiRole then begin - if ((MemberRTInfo as TBoldRoleRTInfo).RoleType = rtRole) and - assigned((BoldMembers[M] as TBoldObjectReference).Locator) then - (BoldMembers[M] as TBoldObjectReference).Clear; + if (RoleRTInfo.RoleType = rtRole) and + ((BoldMembers[MemberIndex] as TBoldObjectList).Count <> 0) then + (BoldMembers[MemberIndex] as TBoldObjectList).Clear; + end + else if RoleRTInfo.isSingleRole then + begin + if (RoleRTInfo.RoleType = rtRole) and + assigned((BoldMembers[MemberIndex] as TBoldObjectReference).Locator) then + (BoldMembers[MemberIndex] as TBoldObjectReference).Clear; end; end; end; +procedure TBoldObject.UnLinkAll; +begin + InternalUnLinkAll(True); +end; + +procedure TBoldObject.UnLinkAllPersistent; +begin + InternalUnLinkAll(False); +end; + +{$IFNDEF CompareToOldValues} procedure TBoldObject.MarkObjectDirty; var i: integer; @@ -2576,14 +3693,13 @@ procedure TBoldObject.MarkObjectDirty; if BoldDirty then exit; for i := 0 to BoldMemberCount - 1 do - if GetBoldMemberAssigned(i) and + if SafeGetBoldMemberAssigned(i) and BoldMembers[i].BoldMemberRTInfo.IsStoredInObject and (BoldMembers[i].BoldPersistenceState = bvpsCurrent) then begin BoldMembers[i].MarkMemberDirty; exit; end; - // if we could not find a loaded member, then take the first that is persistent. for i := 0 to BoldMemberCount - 1 do if BoldMembers[i].BoldMemberRTInfo.IsStoredInObject and (BoldMembers[i].BoldPersistenceState = bvpsCurrent) then @@ -2591,12 +3707,15 @@ procedure TBoldObject.MarkObjectDirty; BoldMembers[i].MarkMemberDirty; exit; end; - raise EBold.CreateFmt(sNoPersistentMembers, [classname]); + raise EBold.CreateFmt('%s.MarkObjectDirty: There are no persistent members', [classname]); end; +{$ENDIF} procedure TBoldObject.ReRead; begin - Invalidate; +// Invalidate; +// patch - do not invalidate, it invalidates all members, just fetch instead +// fetching will update only members with fresh value from db, leaving unomdified members valid BoldSystem.SystemPersistenceHandler.FetchObjectById(BoldObjectLocator.BoldObjectID); end; @@ -2678,7 +3797,7 @@ function TBoldObject.InternalCanDelete(CheckedObjects: TBoldDomainElementCollect if not result then begin - SetBoldLastFailureReason(TBoldFailureReason.Create(sObjectIsreadOnly, self)); + SetBoldLastFailureReason(TBoldFailureReason.Create('Object is read only', self)); exit; end; @@ -2693,22 +3812,34 @@ function TBoldObject.InternalCanDelete(CheckedObjects: TBoldDomainElementCollect begin Assert(MemberRTInfo is TBoldRoleRTInfo); RoleRTInfo := TBoldRoleRTInfo(MemberRTInfo); - // in a transient system links that do not exist must be empty - if BoldSystem.BoldPersistent or GetBoldMemberAssigned(i) then + if BoldSystem.BoldPersistent or SafeGetBoldMemberAssigned(i) then begin if not RoleRTInfo.IsDerived and (RoleRTInfo.RoleType = rtRole) then begin case RoleRTInfo.DeleteAction of - daCascade: result := not cascade or (result and CascadeCanDelete(BoldMembers[i])); - daAllow: ; // do nothing - daProhibit: result := result and CheckEmpty(BoldMembers[i]); + daCascade: + begin + result := not cascade or (result and CascadeCanDelete(BoldMembers[i])); + if not result then + SetBoldLastFailureReason(TBoldFailureReason.Create('Related object via associationEnd ' + BoldMembers[i].DisplayName + ' has denied cascade delete.', self)); + end; + daAllow: ; + daProhibit: + begin + result := result and CheckEmpty(BoldMembers[i]); + if not result then + SetBoldLastFailureReason(TBoldFailureReason.Create('Object is related to other objects via associationEnd:'+ BoldMembers[i].DisplayName + ' and has DeleteAction set to daProhibit.', self)); + end; end; end else begin - // linkobjects will always be deleted when the original object is deleted, so we must cascade the question if RoleRTInfo.RoleType = rtLinkRole then - result := result and CascadeCanDelete(BoldMembers[i]) ; + begin + result := result and CascadeCanDelete(BoldMembers[i]); + if not result then + SetBoldLastFailureReason(TBoldFailureReason.Create('LinkObject:'+ BoldMembers[i].DisplayName + ' denied cascade delete.', self)); + end; end; if not result then break; @@ -2717,9 +3848,17 @@ function TBoldObject.InternalCanDelete(CheckedObjects: TBoldDomainElementCollect end; if result then - result := SendQuery(bqMayDelete, [], nil) and BoldSystem.CanDeleteObject(self) - else - SetBoldLastFailureReason(TBoldFailureReason.Create(sObjectHasRelations, self)); + begin + result := BoldSystem.CanDeleteObject(self); +{$IFNDEF BOLD_NO_QUERIES} + result := Result and BoldSystem.CanDeleteObject(self); +{$ENDIF} + end; +end; + +function TBoldObject.InternalCanDeleteObject: Boolean; +begin + Result := True; end; function TBoldObject.CanDelete: Boolean; @@ -2765,50 +3904,119 @@ procedure TBoldObject.Delete; if Member is TBoldObjectList then TBoldObjectList(Member).Clear else if member is TBoldObjectReference then - TBoldObjectReference(member).BoldObject := nil; + TBoldObjectReference(member).Clear; + end; + + procedure PreFetchLinks; + var + i: integer; + vRoleRTInfo: TBoldRoleRTInfo; + LinkList: TStringList; + begin + if not BoldPersistent then + exit; + LinkList := TStringList.Create; + try + for i := 0 to BoldClassTypeInfo.AllRolesCount - 1 do + begin + vRoleRTInfo := BoldClassTypeInfo.AllRoles[i]; + if not vRoleRTInfo.IsDerived and (vRoleRTInfo.RoleType in [rtRole, rtInnerLinkRole]) then + case vRoleRTInfo.DeleteAction of + daCascade, daAllow: + LinkList.Add(vRoleRTInfo.ExpressionName); + end; + end; + finally + BoldSystem.FetchMembersWithObject(Self, LinkList.CommaText); +// BoldSystem.FetchLinksWithObjects(AList, LinkList.CommaText); + LinkList.free; + end; end; procedure DoDelete; var - MemberRTInfo: TBoldMemberRTInfo; RoleRTInfo: TBoldRoleRTInfo; i: integer; begin - for i := 0 to BoldMemberCount - 1 do +// PreFetchLinks; + for i := 0 to BoldClassTypeInfo.AllRolesCount - 1 do begin - MemberRTInfo := BoldClassTypeInfo.AllMembers[i]; - - if MemberRTInfo.IsRole then - begin - Assert(MemberRTInfo is TBoldRoleRTInfo); - RoleRTInfo := TBoldRoleRTInfo(MemberRTInfo); + RoleRTInfo := BoldClassTypeInfo.AllRoles[i]; if not RoleRTInfo.IsDerived and (RoleRTInfo.RoleType in [rtRole, rtInnerLinkRole]) then begin case RoleRTInfo.DeleteAction of - daCascade: CascadeDelete(BoldMembers[i]); - daAllow: ClearRelation(BoldMembers[i]); - daProhibit: ;// do nothing, should always be empty by now + daCascade: + begin + if BoldPersistent or BoldMemberAssigned[RoleRTInfo.index] then + CascadeDelete(BoldMembers[RoleRTInfo.index]); + end; + daAllow: + begin + if BoldPersistent or BoldMemberAssigned[RoleRTInfo.index] then + ClearRelation(BoldMembers[RoleRTInfo.index]); + end; + daProhibit: ; + end; + end; + end; + end; + +{$IFNDEF NoAutoSubscription} + procedure ProcessDeleteInDerivation; + var + i: integer; + begin + // Clear any Members of deleted object that were acccesed during derivation + // and were supposed to be subscribed to in MemberDerivationEnd + with BoldSystem.fMembersReadDuringDerivation do + for i := 0 to Count - 1 do + if (Items[i] <> nil) and (TBoldMember(Items[i]).OwningObject = self) then + Items[i] := nil; + LogDerivationDeleteSideEffects(self); + end; +{$ENDIF} +begin + if (not Deleting) and (not DeletingOrDeletingByDiscard) then begin + BoldSystem.DelayObjectDestruction; + Deleting := True; + try + BoldClearLastFailure; + if InternalCanDeleteObject then begin + BoldSystem.IncrementDeletingObjectsDepth; + try + BoldSystem.StartTransaction(stmNormal); + try + if not StartDelete then + BoldRaiseLastFailure(self, 'Delete', 'StartDelete precondition not met'); + DoDelete; + EndDelete; + {$IFNDEF NoAutoSubscription} + if BoldSystem.IsDerivingMembers then + ProcessDeleteInDerivation; + {$ENDIF} + BoldSystem.CommitTransaction(stmNormal); + except + FailDelete; + BoldSystem.RollbackTransaction(stmNormal); + raise; end; + finally + BoldSystem.DecrementDeletingObjectsDepth; end; end; + finally + Deleting := False; + BoldSystem.AllowObjectDestruction; end; end; +end; +function TBoldObject.GetDeletingOrDeletingByDiscard: Boolean; begin - BoldClearLastFailure; - if not StartDelete then - BoldRaiseLastFailure(self, 'Delete', sPreconditionNotMet); // do not localize - try - BoldSystem.StartTransaction(stmNormal); - DoDelete; - EndDelete; - BoldSystem.CommitTransaction(stmNormal); - except - FailDelete; - BoldSystem.RollbackTransaction(stmNormal); - raise; - end; + Result := Deleting or + (Discarding and BoldObjectIsNew) or + BoldObjectIsDeleted; end; function TBoldObject.FindBoldMemberByExpressionName(const Name: string): TBoldMember; @@ -2826,7 +4034,7 @@ function TBoldObject.GetBoldMemberByExpressionName(const Name: string): TBoldMem begin Result := FindBoldMemberByExpressionName(Name); if not Assigned(Result) then - raise EBold.CreateFmt(sNoSuchMember, [ClassName, Name]); + raise EBold.CreateFmt('%s: No member named %s', [ClassName, Name]); end; function TBoldObject.GetBoldMemberIndexByExpressionName(const Name: string): Integer; @@ -2850,7 +4058,7 @@ function TBoldObject.IsEqualAs(CompareType: TBoldCompareType; BoldElement: TBold Result := BoldElement = Self; end; else - raise EBold.CreateFmt(sUnknownCompareType, [ClassName, 'IsEqualAs']); // do not localize + raise EBold.CreateFmt('%s.IsEqualAs: Unknown CompareType', [ClassName]); end; end; @@ -2859,7 +4067,7 @@ procedure TBoldObject.GetAsList(ResultList: TBoldIndirectElement); NewList: TBoldList; begin Assert(BoldType.SystemTypeInfo is TBoldSystemTypeInfo); - NewList := TBoldObjectList.CreateWithTypeInfo(TBoldSystemTypeInfo(BoldType.SystemTypeInfo).ListTypeInfoByElement[BoldType]); + NewList := BoldClassTypeInfo.ListTypeInfo.CreateElement as TBoldList; NewList.Add(Self); NewList.MakeImmutable; ResultList.SetOwnedValue(NewList); @@ -2887,6 +4095,7 @@ procedure TBoldObject.EndReCreate; begin SetBoldExistenceState(besExisting); SetBoldPersistenceState(bvpsCurrent); + CompleteRecreate; sendevent(beObjectFetched); end; @@ -2902,7 +4111,7 @@ function TBoldObject.StartDelete: Boolean; begin g := TBoldGuard.Create(List); if not (BoldExistenceState = besExisting) then - StateError('StartDelete'); // do not localize + StateError('StartDelete'); list := TBoldDomainElementCollection.Create; result := InternalCanDelete(list, false); @@ -2918,7 +4127,7 @@ procedure TBoldObject.EndDelete; SetBoldExistenceState(besDeleted); case BoldPersistenceState of bvpsModified: SetBoldPersistenceState(bvpsCurrent); - bvpsTransient: ; // do nothing + bvpsTransient: ; bvpsCurrent: SetBoldPersistenceState(bvpsModified); end; if BoldPersistenceState <> bvpsModified then @@ -2944,11 +4153,12 @@ function TBoldObject.GetBoldDirty: Boolean; end; end; -{ -function TBoldObject.GetEffectiveInvalid: Boolean; +function TBoldObject.CalculateEffectiveInvalid: Boolean; var i: Integer; + Member: TBoldMemberRTInfo; begin + if GetElementFlag(befObjectWasCreatedNew) then begin result := false; @@ -2957,23 +4167,56 @@ function TBoldObject.GetEffectiveInvalid: Boolean; for i := 0 to BoldMemberCount - 1 do begin - if (not BoldClassTypeInfo.AllMembers[i].DelayedFetch) and - (BoldClassTypeInfo.AllMembers[i].Persistent) and - (not GetBoldMemberAssigned(i) or (BoldMembers[i].BoldPersistenceState = bvpsInvalid)) then + if (not SafeGetBoldMemberAssigned(i) or (BoldMembers[i].BoldPersistenceState = bvpsInvalid)) then begin - result := True; - exit; + Member := BoldClassTypeInfo.AllMembers[i]; + if (not Member.DelayedFetch) and (Member.Persistent) then + begin + result := True; + exit; + end; end; end; result := False; end; -} + +function TBoldObject.GetEffectiveInvalid: Boolean; +begin + if not IsEffectiveInvalidKnown then + begin + IsEffectiveInvalid := CalculateEffectiveInvalid; + IsEffectiveInvalidKnown := true; + end; + result := IsEffectiveInvalid; +end; + +procedure TBoldObject.FreeDerivers; +var + i: integer; + Deriver: TBoldMemberDeriver; +begin + for I := 0 to Length(fDeriverArray) - 1 do + begin + Deriver := fDeriverArray[i]; + if Assigned(Deriver) then + begin + Deriver.DerivedMember.HasDeriver := false; + Deriver.Free; + fDeriverArray[i] := nil; + end; + end; + SetLength(fDeriverArray, 0); +end; + procedure TBoldObject.MemberBecomingModified(BoldMember: TBoldMember); begin MemberModified := true; MemberModifiedKnown := true; BoldSystem.MarkObjectDirty(self); + BoldMember.SendExtendedEvent(beMemberBecomingDirty, [BoldMember]); + if BoldSystem.IsDerivingMembers then + LogDerivationSideEffects(BoldMember); end; procedure TBoldObject.MemberBecomingClean(BoldMember: TBoldMember); @@ -2981,10 +4224,27 @@ procedure TBoldObject.MemberBecomingClean(BoldMember: TBoldMember); if MemberModified then begin MemberModifiedKnown := False; + BoldMember.SendExtendedEvent(beMemberBecomingClean, [BoldMember]); BoldSystem.MarkObjectPossiblyCleaner(self); end; end; +procedure TBoldObject.MemberChangingValidity(BoldMemberRtInfo: TBoldMemberRtInfo; NewValue: TBoldValuePersistenceState); +begin + if (not IsEffectiveInvalidKnown) then + Exit; + if (BoldMemberRtInfo.DelayedFetch) or (not BoldMemberRtInfo.Persistent) then + Exit; + if (NewValue = bvpsInvalid) then + begin + IsEffectiveInvalid := true; + IsEffectiveInvalidKnown := true; + end + else + if IsEffectiveInvalidKnown then + IsEffectiveInvalidKnown := false; +end; + procedure TBoldObject.CalculateMemberModified; var i: Integer; @@ -2994,11 +4254,11 @@ procedure TBoldObject.CalculateMemberModified; if BoldPersistent then for i := 0 to BoldMemberCount - 1 do begin - if GetBoldMemberAssigned(i) then + if SafeGetBoldMemberAssigned(i) then MemberModified := BoldMembers[i].BoldDirty else MemberModified := GetElementFlag(befObjectWasCreatedNew) and - BoldClassTypeInfo.AllMembers[i].IsStoredInObject and + MemberCanBeModified(BoldClassTypeInfo.AllMembers[i], BoldSystem) and Assigned(BoldSystem.PersistenceController); if MemberModified then Exit; @@ -3007,12 +4267,15 @@ procedure TBoldObject.CalculateMemberModified; procedure TBoldObject.CompleteCreate; begin - // intentionally left blank end; +procedure TBoldObject.CompleteReCreate; +begin +end; + + procedure TBoldObject.CompleteUpdate; begin - // intentionally left blank end; @@ -3023,7 +4286,6 @@ function TBoldObject.MayUpdate: Boolean; procedure TBoldObject.PrepareUpdate; begin - // intentionally left blank end; function TBoldObject.MayDelete: Boolean; @@ -3032,6 +4294,17 @@ function TBoldObject.MayDelete: Boolean; end; procedure TBoldObject.PrepareDelete; +begin +end; + +procedure TBoldObject.PrepareDiscard; +begin + if BoldObjectIsNew then begin + InternalPrepareDeleteOrDeleteByDiscard; + end; +end; + +procedure TBoldObject.InternalPrepareDeleteOrDeleteByDiscard; begin // intentionally left blank end; @@ -3044,6 +4317,7 @@ procedure TBoldObject.DoStartDelete; procedure TBoldObject.DoStartUpdate; begin +// SendEvent(bePrepareUpdate); PrepareUpdate; PrepareUpdateMembers; end; @@ -3068,10 +4342,7 @@ function TBoldObject.MayUpdateMembers: Boolean; begin for i := 0 to BoldMemberCount - 1 do begin - // we should add a guard here that checks BoldMemberAssigned. - // a nonassigned member can reasonably not prevent an update - // do not add this until enough testing can be performed prior to release - if MemberProhibitsUpdate(BoldMembers[i]) then + if SafeGetBoldMemberAssigned(i) and MemberProhibitsUpdate(BoldMembers[i]) then begin result := False; exit; @@ -3086,7 +4357,7 @@ procedure TBoldObject.EndUpdateMembers(Translationlist: TBoldIdTranslationlist); Member: TBoldMember; begin for i := 0 to BoldMemberCount - 1 do - if GetBoldMemberAssigned(i) then + if SafeGetBoldMemberAssigned(i) then begin Member := BoldMembers[i]; if Member.BoldPersistent and @@ -3172,29 +4443,41 @@ function TBoldObject.MayFetchMembers(MemberIdList: TBoldMemberIdList): Boolean; procedure TBoldObject.EndFetchMembers(MemberIdList: TBoldMemberIdList); - procedure IfNecessaryEndFetchMember(Member: TBoldMember); + procedure IfNecessaryEndFetchMember(aBoldMember: TBoldMember); {$IFDEF BOLD_INLINE} inline; {$ENDIF} begin - if assigned(Member) and (Member.BoldPersistenceState = bvpsInvalid) then - Member.BoldPersistenceState := bvpsCurrent; + if Assigned(aBoldMember) and (aBoldMember.BoldPersistenceState = bvpsInvalid) then + begin + aBoldMember.BoldPersistenceState := bvpsCurrent; + end; end; var i: Integer; - aMember: TBoldMember; + MemberRtInfo: TBoldMemberRTInfo; begin if assigned(MemberIdList) then + begin for i := 0 to MemberIdList.Count - 1 do - IfNecessaryEndFetchMember(BoldMembers[MemberIdList[i].MemberIndex]) + IfNecessaryEndFetchMember(BoldMembers[MemberIdList[i].MemberIndex]); + end else + begin for i := 0 to BoldMemberCount - 1 do begin - if not BoldClassTypeInfo.AllMembers[i].DelayedFetch then + memberRtInfo := BoldClassTypeInfo.AllMembers[i]; + if not memberRtInfo.DelayedFetch and + not MemberRtInfo.IsDerived then begin - aMember := BoldMembers[i]; - if aMember.BoldPersistent then - IfNecessaryEndFetchMember(aMember); + if BoldMembers[i].BoldPersistent then + IfNecessaryEndFetchMember(BoldMembers[i]); end; end; + end; +end; + +procedure TBoldObject.BeforeDiscard; +begin + Inc(BoldSystem.FDiscardCount); end; procedure TBoldObject.BoldMakePersistent; @@ -3204,17 +4487,17 @@ procedure TBoldObject.BoldMakePersistent; if not BoldPersistent then begin if BoldPersistenceState <> bvpsTransient then - StateError('BoldMakePersistent'); // do not localize + StateError('BoldMakePersistent'); if not Assigned(BoldClassTypeInfo) or (not BoldClassTypeInfo.Persistent) or (not BoldSystem.BoldPersistent) then - raise EBold.CreateFmt(sCannotMakePersistent, [ClassName]); + raise EBold.CreateFmt('%s: Can''t make object persistent', [ClassName]); if BoldClassTypeInfo.IsLinkClass then for i := BoldClassTypeInfo.FirstOwnMemberIndex to BoldMemberCount - 1 do if BoldMembers[i].BoldMemberRTInfo.IsSingleRole and (TBoldRoleRTInfo(BoldMembers[i].BoldMemberRTInfo).RoleType = rtInnerLinkRole) and not (BoldMembers[i] as TBoldObjectReference).Locator.ObjectIsPersistent then - raise EBold.CreateFmt(sCannotMakeLinkPersistent, [Classname]); + raise EBold.CreateFmt('%s: Can''t make link object persistent. Linked object is transient.', [Classname]); SetElementFlag(befPersistent, true); SetBoldPersistenceState(bvpsModified); @@ -3231,16 +4514,20 @@ procedure TBoldObject.SetIsReadOnly(NewValue: Boolean); function TBoldObject.GetTimeStamp: TBoldTimeStampType; begin - if BoldStoresTimeStamp then - result := TBoldTimeStampType(fDynamicData^[BoldMemberCount]) - else - result := -1; + result := fTimeStamp; end; procedure TBoldObject.SetTimeStamp(NewValue: TBoldTimeStampType); +var + OldTimeStamp: TBoldTimeStampType; begin - if BoldStoresTimeStamp then - fDynamicData^[BoldMemberCount] := Pointer(NewValue); + if fTimeStamp <> NewValue then + begin + OldTimeStamp := fTimeStamp; + fTimeStamp := NewValue; + if OldTimeStamp <> -1 then // this will not send event on initial fetch, only on subsequent ones + SendExtendedEvent(beObjectTimestampChanged, [OldTimeStamp, NewValue]); + end; end; function TBoldObject.GetObjectHasSubscribers: Boolean; @@ -3258,40 +4545,47 @@ function TBoldObject.GetObjectHasSubscribers: Boolean; procedure TBoldObject.StateError(S: String); begin - inherited StateError(format('%s (ExistenceState: %s PersistenceState: %s)', // do not localize - [s, GetEnumName(TypeInfo(TBoldExistenceState), Ord(BoldExistenceState)), + inherited StateError(format('%s ID:%s (ExistenceState: %s PersistenceState: %s)', + [s, BoldObjectLocator.AsString, GetEnumName(TypeInfo(TBoldExistenceState), Ord(BoldExistenceState)), GetEnumName(TypeInfo(TBoldValuePersistenceState), Ord(BoldPersistenceState))])); end; procedure TBoldObject.ToBeRemovedMemberAccessed(MemberRTInfo: TBoldMemberRTInfo); begin - BoldLog.LogFmt(sToBeRemovedAccessed, [dateTimeToStr(now), BoldClassTypeInfo.ExpressionName, MemberRTInfo.ExpressionName]); + BoldLog.LogFmt('%s: Accessed member flagged as "ToBeRemoved": %s.%s', [dateTimeToStr(now), BoldClassTypeInfo.ExpressionName, MemberRTInfo.ExpressionName]); end; procedure TBoldObject.ToBeRemovedMemberModified(MemberRTInfo: TBoldMemberRTInfo); begin - BoldLog.LogFmt(sToBeRemovedModified, [dateTimeToStr(now), BoldClassTypeInfo.ExpressionName, MemberRTInfo.ExpressionName]); + BoldLog.LogFmt('%s: Modified member flagged as "ToBeRemoved": %s.%s', [dateTimeToStr(now), BoldClassTypeInfo.ExpressionName, MemberRTInfo.ExpressionName]); end; procedure TBoldObject.ToBeRemovedClassAccessed; begin - BoldLog.LogFmt(sToBeRemovedObjectAccessed, [dateTimeToStr(now), BoldClassTypeInfo.ExpressionName]); + BoldLog.LogFmt('%s: Accessed an object flagged as "ToBeRemoved": %s', [dateTimeToStr(now), BoldClassTypeInfo.ExpressionName]); end; constructor TBoldObject.InternalCreateNewWithClassAndSystem( ClassTypeInfo: TBoldClassTypeInfo; aSystem: TBoldSystem; Persistent: Boolean); begin +{$IFDEF NoTransientInstancesOfPersistentClass} + if not Persistent and ClassTypeInfo.Persistent and aSystem.BoldPersistent then + raise EBold.Create('Transient instance of persistent class not allowed due to conditional define NoTransientInstancesOfPersistentClass.'); +{$ENDIF} + IsEffectiveInvalidKnown := false; if not aSystem.CanCreateObject(ClassTypeInfo) then - BoldRaiseLastFailure(aSystem, 'InternalCreateNewWithClassAndSystem', // do not localize - format(sCannotCreateOfType, [ClassTypeInfo.ExpressionName])); + BoldRaiseLastFailure(aSystem, 'InternalCreateNewWithClassAndSystem', + format('System does not allow creating objects of type %s', [ClassTypeInfo.ExpressionName])); aSystem.StartTransaction(stmNormal); try SetInternalState(BoldExistenceStateMask, BoldESShift, Integer(besNotCreated)); SetInternalState(BoldPersistenceStateMask, BoldPSShift, Integer(bvpsCurrent)); - inherited Create(aSystem); + inherited CreateWithOwner(aSystem); InitializeObject(aSystem, ClassTypeInfo, nil, Persistent); EndCreate; aSystem.CommitTransaction(stmNormal); + if BoldSystem.IsDerivingMembers then + LogDerivationCreateSideEffects(self); except aSystem.RollbackTransaction(stmNormal); raise; @@ -3305,17 +4599,17 @@ function TBoldObject.GetBoldType: TBoldElementTypeInfo; function TBoldObject.CanUpdate: Boolean; begin - result := MayUpdate and SendQuery(bqMayUpdate, [], nil); -end; - -function TBoldObject.GetIsReadOnly: Boolean; -begin - result := GetElementFlag(befObjectReadOnly); + result := MayUpdate; +{$IFNDEF BOLD_NO_QUERIES} + result := result and SendQuery(bqMayUpdate, [], nil); +{$ENDIF} end; function TBoldObject.GetDisplayName: String; begin - result := ClassName; + result := BoldType.AsString; // not inherited as typically we want ClassName instead of BusinessClasses.ClassName + if Assigned(BoldObjectLocator) then + result := '['+BoldObjectLocator.AsString + ']' + result; end; function TBoldObject.GetEvaluator: TBoldEvaluator; @@ -3327,7 +4621,7 @@ function TBoldObject.CanUnload: Boolean; begin result := not BoldDirty; if not result then - SetBoldLastFailureReason(TBoldFailureReason.create(sObjectIsDirty, self)); + SetBoldLastFailureReason(TBoldFailureReason.create('Object is dirty', self)); end; procedure TBoldObject.Invalidate; @@ -3335,40 +4629,70 @@ procedure TBoldObject.Invalidate; i: Integer; begin if BoldDirty then - raise EBold.CreateFmt(sCannotInvalidateDirtyObject, [classname]); - for i := 0 to BoldMemberCount - 1 do - if BoldMembers[i].BoldPersistent then - BoldMembers[i].Invalidate; + raise EBold.CreateFmt('%s.Invalidate: Can''t invalidate dirty object, use discard first', [classname]); + for i := 0 to BoldClassTypeInfo.AllMembersCount - 1 do + if BoldClassTypeInfo.AllMembers[i].Persistent and BoldMembers[i].BoldPersistent then + BoldMembers[i].Invalidate; end; -procedure TBoldObject.Discard; +procedure TBoldObject.InternalDiscard(ADiscardPersistentLinks: boolean); var i: Integer; begin - if BoldSystem.fTransactionNesting <> 0 then - raise EBold.Create(sCannotDiscardInTransaction); - - if not BoldObjectLocator.BoldObjectID.IsStorable then - UnlinkAll; + if (not Discarding) and (not Deleting) then begin + BoldSystem.DelayObjectDestruction; + Discarding := True; + BeforeDiscard; + try + if BoldSystem.fTransactionNesting <> 0 then + raise EBold.Create('Can not discard an object while the system inside a transaction'); + PrepareDiscard; + if not BoldObjectLocator.BoldObjectID.IsStorable then + begin + if ADiscardPersistentLinks then + UnlinkAll + else + UnLinkAllPersistent; + end; - for i := 0 to BoldMemberCount - 1 do - if BoldMemberAssigned[i] then - BoldMembers[i].InternalDiscard; + for i := 0 to BoldMemberCount - 1 do + if BoldMemberAssigned[i] then + begin + // if ADiscardPersistentLinks = false then do not discard non persistent roles + if ADiscardPersistentLinks or not (BoldMembers[i].BoldMemberRTInfo.IsRole and not BoldMembers[i].BoldPersistent) then + BoldMembers[i].InternalDiscard; + end; - if BoldObjectIsNew then - begin - SetBoldExistenceState(besDeleted); - SetBoldPersistenceState(bvpsCurrent); - BoldSystem.DestroyObject(self); - end - else if (BoldPersistenceState = bvpsModified) and - (BoldExistenceState = besDeleted) then - begin - SetBoldExistenceState(besExisting); - SetBoldPersistenceState(bvpsCurrent); + if BoldObjectIsNew then + begin + SetBoldExistenceState(besDeleted); + SetBoldPersistenceState(bvpsCurrent); + BoldSystem.DestroyObject(self); + end + else if (BoldPersistenceState = bvpsModified) and + (BoldExistenceState = besDeleted) then + begin + SetBoldExistenceState(besExisting); + SetBoldPersistenceState(bvpsCurrent); + end; + finally + AfterDiscard; + Discarding := False; + BoldSystem.AllowObjectDestruction; + end; end; end; +procedure TBoldObject.Discard; +begin + InternalDiscard(true); +end; + +procedure TBoldObject.DiscardPersistentMembers; +begin + InternalDiscard(false); +end; + procedure TBoldObject.SetBoldExistenceState(Value: TBoldExistenceState); begin if Value <> BoldExistenceState then @@ -3400,28 +4724,23 @@ procedure TBoldObject.SetBoldPersistenceState(Value: TBoldValuePersistenceState) end; end; -function TBoldObject.GetBoldExistenceState: TBoldExistenceState; -begin - result := TBoldExistenceState(GetInternalState(BoldExistenceStateMask, BoldESShift)); -end; - -function TBoldObject.GetBoldPersistenceState: TBoldValuePersistenceState; -begin - result := TBoldValuePersistenceState(GetInternalState(BoldPersistenceStateMask, BoldPSShift)); -end; - function TBoldObject.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; begin if IsEqualGuid(IID, IBoldObjectContents) then begin - result := TBoldObject_Proxy.create(self, Mode).GetInterface(IID, obj); + result := TBoldObject_Proxy.Create(self, Mode).GetInterface(IID, obj); if not result then - raise EBoldInternal.CreateFmt(sInterfaceNotImplemented, [ClassName]); + raise EBoldInternal.CreateFmt('ProxyClass for %s did not implement IBoldObjectContents', [ClassName]); end else result := inherited ProxyInterface(IID, Mode, Obj); end; +procedure TBoldObject.AfterDiscard; +begin + Dec(BoldSystem.FDiscardCount); +end; + function TBoldObject.AtTime(Time: TBoldTimestampType): TBoldObject; begin result := BoldObjectLocator.AtTime(time).EnsuredBoldObject; @@ -3437,7 +4756,7 @@ procedure TBoldObject.PrepareUpdateMembers; i: integer; begin for i := 0 to BoldMemberCount - 1 do - if GetBoldMemberAssigned(i) and BoldMembers[i].BoldDirty then + if SafeGetBoldMemberAssigned(i) and BoldMembers[i].BoldDirty then BoldMembers[i].PrepareUpdate; end; @@ -3447,43 +4766,47 @@ function TBoldObject.GetBoldObjectExists: Boolean; end; function TBoldObject.ValidateMember(const ObjectDelphiName, MemberDelphiName: String; GeneratedMemberIndex: integer; MemberClass: TBoldMemberClass): Boolean; + + procedure InternalRaise(ExceptionClass: ExceptClass; const Msg: string; const Args: array of const); + begin + raise ExceptionClass.CreateFmt(Msg, args) + end; + +const + sValidate_NoSuchMember = 'Class %s has no member %s. (Generated code might be out of sync with model)'; + sValidate_MemberNotAssigned = 'Unable to access member %s.%s: %0:s is not assigned!'; + sValidate_WrongMember = 'Class %s member at index %d is %s, expected %s. (Generated code might be out of sync with model)'; + sValidate_MemberIndexOutOfSync = 'Member indexes in generated code out of sync with model (%s.%s has %d in code and %d in model)'; + sValidate_InvalidMemberType = 'Invalid member type for %s.%s. Expected %s, was %s (Generated code might be out of sync with model)'; + sValidate_InternalError = 'Internal Error: Member %s.%s is not assigned'; var Member: TBoldMember; MemberRTInfo: TBoldMemberRTInfo; begin if not assigned(self) then - raise EBold.CreateFmt(sValidate_MemberNotAssigned, - [ObjectDelphiName, MemberDelphiName]); + InternalRaise(EBold, sValidate_MemberNotAssigned, [ObjectDelphiName, MemberDelphiName, ObjectDelphiName]); - MemberRTInfo := BoldClassTypeInfo.AllMembers.ItemsByDelphiName[MemberDelphiName] as TBoldMemberRTInfo; - - if not assigned(MemberRTInfo) then - raise EBold.CreateFmt(sValidate_NoSuchMember, - [ObjectDelphiName, MemberDelphiName]); - - if (GeneratedMemberIndex <> -1) and (MemberRTInfo.index <> GeneratedMemberIndex) then - raise EBold.CreateFmt(sValidate_MemberIndexOutOfSynch, [ - ObjectDelphiName, MemberDelphiName, GeneratedMemberIndex, MemberRTInfo.index]); - - Member := BoldMembers[MemberRTInfo.index]; + if Cardinal(GeneratedMemberIndex) >= Cardinal(BoldMemberCount) then + begin + MemberRTInfo := BoldClassTypeInfo.AllMembers.ItemsByDelphiName[MemberDelphiName] as TBoldMemberRTInfo; + if not assigned(MemberRTInfo) then + InternalRaise(EBold, sValidate_NoSuchMember, [ObjectDelphiName, MemberDelphiName]); + InternalRaise(EBold, sValidate_MemberIndexOutOfSync, [ObjectDelphiName, MemberDelphiName, GeneratedMemberIndex, MemberRTInfo.index]); + end; + Member := BoldMembers[GeneratedMemberIndex]; if not assigned(Member) then - raise EBoldInternal.CreateFmt('Internal Error: Member %s.%s is not assigned', - [ObjectDelphiName, MemberDelphiName]); + InternalRaise(EBoldInternal, sValidate_InternalError, [ObjectDelphiName, MemberDelphiName]); if not (Member is MemberClass) then - raise EBold.CreateFmt(sValidate_InvalidMemberType, - [ObjectDelphiName, MemberDelphiName, MemberClass.ClassName, Member.ClassName]); + InternalRaise(EBold, sValidate_InvalidMemberType, [ObjectDelphiName, MemberDelphiName, MemberClass.ClassName, Member.ClassName]); - result := true; -end; + MemberRTInfo := Member.BoldMemberRTInfo; -function TBoldObject.GetDynamicDataSize: Integer; -begin - Result := BoldMemberCount * SizeOf(Pointer); + if MemberRTInfo.DelphiName <> MemberDelphiName then + InternalRaise(EBold, sValidate_WrongMember, [ObjectDelphiName, GeneratedMemberIndex, MemberDelphiName, MemberRTInfo.DelphiName]); - if BoldStoresTimeStamp then - Result := Result + SizeOf(TBoldTimeStampType); + result := true; end; procedure TBoldObject.ClearTouched; @@ -3516,107 +4839,227 @@ function TBoldMember.GetStreamName: string; raise EBoldInternal.Createfmt('%s.GetStreamName: Method is abstract, please implement', [classname]); end; -function TBoldMember.GetBoldMemberRTInfo: TBoldMemberRTInfo; +function TBoldMember.GetFreeStandingClass: TBoldFreeStandingElementClass; begin - if OwnedByObject then - begin - assert(fBoldMetaType is TBoldMemberRtInfo); - result := TBoldMemberRTInfo(fBoldMetaType); - end - else - result := nil; + raise EBoldInternal.Createfmt('%s.GetFreeStandingClass: Method is abstract, please implement', [classname]); +end; + +function TBoldMember.GetDeriverState: TBoldDeriverState; +begin + result := TBoldDeriverState(GetInternalState(BoldDerivationStateMask, BoldDSShift)); +end; + +procedure TBoldMember.SetDeriverState(value: TBoldDeriverState); +begin + SetInternalState(BoldDerivationStateMask, BoldDSShift, integer(Value)); end; -constructor TBoldMember.InternalCreate(OwningObject: TBoldObject; MemberRTInfo: TBoldMemberRTInfo; SetInitialValue: Boolean); +constructor TBoldMember.CreateAsObjectPart(OwningObject: TBoldObject; MemberRTInfo: TBoldMemberRTInfo); begin + inherited CreateWithOwner(OwningObject); fBoldMetaType := MemberRTInfo; OwnedByObject := True; - - if assigned(MemberRtInfo) then + SetElementFlag(befPersistent, OwningObject.BoldPersistent and MemberRTInfo.Persistent); + if MemberRTInfo.IsDerived then begin - InitializeMember(OwningObject, MemberRTInfo.BoldType); + DeriverState := bdsSubscriptionOutOfDate; + SetElementFlag(befDerived, true); end else - InitializeMember(OwningObject, nil); + SetElementFlag(befDerived, false); + Initialize; +end; + +procedure TBoldMember.DeriveMember(Subscriber: TBoldSubscriber); +begin + if IsPartOfSystem then + BoldSystem.MemberDerivationBegin(self); + try + if BoldmemberRTInfo.IsDerived and + (BoldMemberRTInfo.DeriveExpression <> '') then + CalculateDerivedMemberWithExpression(Subscriber) + else + CalculateDerivedMemberWithDeriveMethod(Subscriber); + IsPreFetched := false; + finally + if IsPartOfSystem then + BoldSystem.MemberDerivationEnd(self); + end; end; destructor TBoldMember.Destroy; +{$IFNDEF NoAutoSubscription} +// Clear any references to member in list of accesed members during derivation + procedure ClearDerivationReferences; + var + i: integer; + begin + with BoldSystem.fMembersReadDuringDerivation do + for i := 0 to Count - 1 do + if Items[i] = self then +// if (Items[i] <> nil) and (TBoldMember(Items[i]) = self) then + Items[i] := nil; + end; +{$ENDIF} begin +{$IFNDEF NoAutoSubscription} + if Assigned(OwningObject) and BoldSystem.IsDerivingMembers then + ClearDerivationReferences; +{$ENDIF} PrepareToDestroy; - if HasDeriver then - G_ExternalDerivers.ReferencedObjects[self] := nil; inherited Destroy; end; -function TBoldMember.GetOwningObject: TBoldObject; -begin - if OwnedByObject then - begin - Assert(OwningElement is TBoldObject); - Result := TBoldObject(OwningElement) - end - else +procedure TBoldMember.CalculateDerivedMemberWithDeriveMethod( + Subscriber: TBoldSubscriber); +var + DeriveMethod: TMethod; + {$IFDEF EXPRESSION_OVERRIDES_DOUBLE_DERIVE} + Expression, s: string; + ie: TBoldIndirectElement; + nonMatch: boolean; + + function DerivationMatches(oclValue: TBoldElement): boolean; + var + selfasList, valueAsList: TBoldObjectList; + i: Integer; begin - Assert(not (OwningElement is TBoldObject)); - Result := nil; + if (self is TBoldObjectReference) then + begin + if oclValue = nil then + Result := ((self as TBoldObjectReference).Locator = nil) + else if oclValue is TBoldObject then + Result := oclvalue = (self as TBoldObjectReference).BoldObject + else if oclValue is TBoldObjectReference then + Result := (oclvalue as TBoldObjectReference).Locator = (self as TBoldObjectReference).Locator + else + Result := false; + end + else if (self is TBoldObjectList) and (oclValue is TBoldObjectList) then + begin + selfAsList := self as TBoldObjectList; + valueAsList := oclValue as TBoldObjectList; + if selfAsList.Count <> valueAsList.Count then + Result := false + else + begin + Result := true; + for I := 0 to selfAsList.Count - 1 do + if selfAsList[i] <> valueAsList[i] then + Result := false; + end; + end + else if IsEqual(oclValue) then + Result := true + else if (self is TBAFLoat) and + (oclValue is TBAFLoat) and + (abs((self as TBAFLoat).AsFloat - (oclValue as TBAFLoat).asFloat) < 0.011) then + result := true + else + result := false; end; -end; - -function TBoldMember.GetBoldSystem: TBoldSystem; +{$ENDIF} begin - if OwnedByObject then + DeriveMethod.Code := BoldmemberRTInfo.Derivemethod; + if DeriveMethod.Code = nil then begin - Assert(OwningElement is TBoldObject); - Result := TBoldObject(OwningElement).BoldSystem + DeriveMethod := TMethod(OwningObject.GetDeriveMethodForMember(Self)); + BoldmemberRTInfo.Derivemethod := DeriveMethod.Code; + if BoldmemberRTInfo.Derivemethod = nil then + raise EBoldInternal.CreateFmt('Derivation method not found for %s, check model.', [displayName]); end - else if not assigned(OwningElement) then - result := nil else - begin - Assert(OwningElement is TBoldSystem); - result := TBoldSystem(OwningElement) - end; + DeriveMethod.Data := OwningObject; + TBoldDeriveAndResubscribe(DeriveMethod)(self, Subscriber); + {$IFDEF EXPRESSION_OVERRIDES_DOUBLE_DERIVE} + Expression := TExpressionOverride.GetOclDerivationForCodeDerived(self.BoldMemberRTInfo); + if Expression <> '' then + begin + ie := TBoldIndirectElement.Create; + try + try + OwningObject.evaluateAndSubscribeToExpression(Expression, subscriber, ie, false); + if Assigned(ie.Value) and (ie.value is TBoldmember) then + TBoldMember(ie.value).EnsureContentsCurrent; + nonMatch := true; + + if not DerivationMatches(ie.Value) then + raise EBold.Create(Format('OclDerivationOverride for %s.%s gives %s, code gives %s', + [BoldMemberRTInfo.ClassTypeInfo.ExpressionName, BoldMemberRTInfo.ExpressionName, ie.Value.AsString, AsString])); + nonmatch := false; + except + on e: Exception do + begin + if not nonmatch then + begin + if Assigned(OwningObject) then + s := 'ID:' + OwningObject.BoldObjectLocator.AsString + else + s := 'not owned.' + s := format('Failed to derive %s: %s' + BOLDCRLF + + 'OCL expression: %s' + BOLDCRLF + + 'Owner: %s' + BOLDCRLF + + 'Error: %s', [DisplayName, BoldType.AsString, Expression, s, e.Message]); + if assigned(ie.value) and not ie.value.BoldType.conformsto(boldtype) then + s := format(s + BOLDCRLF+ + 'Possible Reason: %s does not conform to %s', [ie.value.BoldType.AsString, boldtype.AsString]); + raise EBold.Create(s); + end; + end; + end; + finally + FreeAndNil(ie); + end; + end; + {$ENDIF} end; -procedure TBoldMember.CalculateDerivedMemberWithExpression(DerivedObject: TObject; Subscriber: TBoldSubscriber); +procedure TBoldMember.CalculateDerivedMemberWithExpression(Subscriber: TBoldSubscriber); var ie: TBoldIndirectElement; - g: IBoldGuard; + Expression: string; s: string; begin - g := TBoldGuard.Create(ie); ie := TBoldIndirectElement.Create; try - OwningObject.evaluateAndSubscribeToExpression(BoldMemberRTInfo.DeriveExpression, subscriber, ie, false); - if Assigned(ie.Value) and (ie.value is TBoldmember) then - TBoldMember(ie.value).EnsureContentsCurrent; - AssignContentValueFromElement(ie.Value); - except - on e: Exception do - begin - s := format(sFailedToDerive + BOLDCRLF + - sOCLExpressionError, [DisplayName, BoldType.AsString, BoldMemberRTInfo.DeriveExpression, e.Message]); - if assigned(ie.value) and not ie.value.BoldType.conformsto(boldtype) then - s := format(s + BOLDCRLF+ - sPossiblyBadConformance, [ie.value.BoldType.AsString, boldtype.AsString]); - raise EBold.Create(s); + try + {$IFDEF EXPRESSION_OVERRIDES} + Expression := TExpressionOverride.GetOclDerivationOverride(self.BoldMemberRTInfo); + if Expression = '' then + {$ENDIF} + Expression := BoldMemberRTInfo.DeriveExpression; + OwningObject.evaluateAndSubscribeToExpression(Expression, subscriber, ie, false); + if Assigned(ie.Value) and (ie.value is TBoldmember) then + TBoldMember(ie.value).EnsureContentsCurrent; + AssignContentValueFromElement(ie.Value); + except + on e: Exception do + begin + s := format('Failed to derive %s: %s (ID:%s)' + BOLDCRLF + + 'OCL expression: %s' + BOLDCRLF + + 'Error: %s', [DisplayName, BoldType.AsString, OwningObject.BoldObjectLocator.AsString, Expression, e.Message]); + if assigned(ie.value) and not ie.value.BoldType.conformsto(boldtype) then + s := format(s + BOLDCRLF+ + 'Possible Reason: %s does not conform to %s', [ie.value.BoldType.AsString, boldtype.AsString]); + raise EBold.Create(s); + end; end; + finally + FreeAndNil(ie); end; end; function TBoldMember.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; begin if IsEqualGuid(IID, IBoldValue) or IsEqualGuid(IID, IBoldStreamable) then - Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldValue/IBoldStreamable') // do not localize + Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldValue/IBoldStreamable') else result := inherited ProxyInterface(IID, Mode, Obj); end; function TBoldMember.ObserverMayModify(Observer: TObject): Boolean; begin - Result := CanModify and - ((ModifiedValueHolder = nil) or - (ModifiedValueHolder = Observer)); + result := inherited ObserverMayModify(Observer) and CanModify; end; procedure TBoldMember.GetAsList(ResultList: TBoldIndirectElement); @@ -3640,7 +5083,7 @@ procedure TBoldMember.GetAsValue(ResultElement: TBoldIndirectElement); function TBoldMember.StartModify: Boolean; begin if not (BoldPersistenceState in [bvpsCurrent, bvpsModified, bvpsTransient, bvpsInvalid]) then - StateError('StartModify'); // do not localize + StateError('StartModify'); result := CanModify; if result and assigned(BoldSystem) and assigned(OwningObject) and assigned(BoldSystem.PessimisticLockHandler) and @@ -3648,34 +5091,81 @@ function TBoldMember.StartModify: Boolean; result := BoldSystem.PessimisticLockHandler.LockElement(self); if result then begin - if assigned(OwningObject) and not BoldSystem.InTransaction and StoreInUndo then // Object always has system + if assigned(OwningObject) and not BoldSystem.InTransaction and StoreInUndo then BoldSystem.UndoHandler.HandleMember(OwningObject.AsIBoldObjectContents[bdepContents], BoldMemberRTInfo.Index, AsIBoldValue[bdepContents]); DoStartModify; end; end; + procedure TBoldMember.EndModify; -begin - if (BoldPersistenceState in [bvpsCurrent, bvpsInvalid]) and - assigned(BoldMemberRTInfo) and - (BoldMemberRTInfo.IsStoredInObject or - // this test should be moved to a DataMappingModel, and not the persistenceController - // it is needed for FileMapper since it has to store multilinks - (BoldMemberRTInfo.IsMultiRole and - (assigned(BoldSystem.PersistenceController) and - BoldSystem.PersistenceController.MultilinksAreStoredInObject))) then +{$IFDEF CompareToOldValues} +var + vOldValue: IBoldValue; + function OrdernoDiffers(const Value: IBoldValue; member: TBoldMember):Boolean; begin + Result := (member is TBoldObjectReference) and + (TBoldObjectReference(member).GetController is TBoldDirectSingleLinkController) and + ((Value as IBoldObjectIdRef).OrderNo <> TBoldDirectSingleLinkController(TBoldObjectReference(member).GetController).OrderNo); + end; +{$ENDIF} +var +{$IFDEF ACCESSSTATISTICS} //// START PATCH ACCESSSTATISTICS //////////////////// + G_BoldMemberRTInfo: TBoldMemberRTInfo; + G_OwningElement: TBoldDomainElement; + G_BoldSystem: TBoldSystem; +{$ENDIF} //// END PATCH ACCESSSTATISTICS /////////////////////////////////////// + System: TBoldSystem; +begin + System := BoldSystem; +{$IFNDEF CompareToOldValues} + if (BoldPersistenceState in [bvpsCurrent, bvpsInvalid]) and MemberCanBeModified(BoldMemberRTinfo, System) then BoldPersistenceState := bvpsModified; +{$ELSE} + if (BoldPersistenceState <> bvpsTransient) and OwnedByObject and BoldPersistent then + begin + vOldValue := OldValue; + if Assigned(vOldValue) and IsEqualToValue(vOldValue) and not OrdernoDiffers(vOldValue, self) then + begin + vOldValue := nil; + BoldPersistenceState := bvpsCurrent + end + else + begin + if (BoldPersistenceState <> bvpsModified) and MemberCanBeModified(BoldMemberRTinfo, System) then + BoldPersistenceState := bvpsModified; + end; end; +{$ENDIF} if Derived and not (DeriverState in bdsIsDeriving) then Deriver.ReverseDerive; CompleteModify; - SendEvent(beCompleteModify); - if assigned(OwningObject) then + SendExtendedEvent(beCompleteModify, [self]); + if OwnedByObject then + begin + System.AddToTransaction(OwningObject); + System.AddToTransaction(self); + end; + {$IFDEF ACCESSSTATISTICS} //// START PATCH ACCESSSTATISTICS ////////////////// + //The messy code is for getting better performance /FH + if OwnedByObject then begin - BoldSystem.AddToTransaction(OwningObject); - BoldSystem.AddToTransaction(self); + G_BoldMemberRTInfo := TBoldMemberRTInfo(fBoldMetaType); + G_OwningElement := OwningElement; + if (G_OwningElement<>nil) then + begin + if (G_OwningElement is TBoldObject) then + begin + G_BoldSystem := TBoldSystem(TBoldObject(G_OwningElement).OwningElement); + Inc(G_BoldSystem.fModifyStats[G_BoldMemberRTInfo.ClassTypeInfo.TopSortedIndex, G_BoldMemberRTInfo.index]); + end + else + begin + Inc(TBoldSystem(G_OwningElement).fModifyStats[G_BoldMemberRTInfo.ClassTypeInfo.TopSortedIndex, G_BoldMemberRTInfo.index]); + end; + end; end; + {$ENDIF} //// END PATCH ACCESSSTATISTICS ///////////////////////////////////// end; procedure TBoldMember.FailModify; @@ -3690,7 +5180,6 @@ procedure TBoldMember.EndUpdate(Translationlist: TBoldIdTranslationlist); procedure TBoldMember.AdjustOldValues(Translationlist: TBoldIdTranslationlist); begin - // intentionally left blank end; function TBoldMember.GetBoldDirty: Boolean; @@ -3710,22 +5199,19 @@ function TBoldMember.MayModify: Boolean; procedure TBoldMember.PrepareModify; begin - // intentionally left blank end; procedure TBoldMember.CompleteModify; begin - // intentionally left blank end; procedure TBoldMember.CompleteUpdate; begin - // intentionally left blank end; + procedure TBoldMember.PrepareUpdate; begin - // intentionally left blank end; procedure TBoldMember.DoStartModify; @@ -3744,129 +5230,264 @@ function TBoldMember.CanModify: Boolean; result := Mutable; if not result then begin - SetBoldLastFailureReason(TBoldFailureReason.Create(sMemberIsImmutable, self)); + SetBoldLastFailureReason(TBoldFailureReason.Create('Member is immutable', self)); + exit; + end; + + if assigned(OwningObject) and OwningObject.BoldObjectIsDeleted and not Derived and not OwningObject.Discarding then + begin + Result := false; + SetBoldLastFailureReason(TBoldFailureReason.CreateFmt('Can not modify member %s, owning object is deleted.', [DisplayName], self)); exit; end; result := not IsReadOnly; if not result then begin - SetBoldLastFailureReason(TBoldFailureReason.Create(sMemberIsreadOnly, self)); + SetBoldLastFailureReason(TBoldFailureReason.Create('Member is read only', self)); exit; end; if Derived then - Result := (DeriverState in bdsIsDeriving) or Deriver.CanReverseDerive; + Result := (DeriverState in bdsIsDeriving) or (Deriver.CanReverseDerive); if not result then begin - SetBoldLastFailureReason(TBoldFailureReason.Create(sMemberIsreadOnlyDerived, self)); + SetBoldLastFailureReason(TBoldFailureReason.Create('Member is read-only derived', self)); exit; end; - result := not assigned(OwningObject) or (OwningObject.BoldTime = BOLDMAXTIMESTAMP); - if not result then + if assigned(OwningObject) then begin - SetBoldLastFailureReason(TBoldFailureReason.Create(sMemberIsHistory, self)); - exit; + if OwningObject.IsHistoricVersion then + begin + Result := false; + SetBoldLastFailureReason(TBoldFailureReason.Create('Member belongs to historical object', self)); + exit; + end; end; - result := MayModify and SendQuery(bqMayModify, [], nil); + result := result and MayModify; +{$IFNDEF BOLD_NO_QUERIES} + result := result and SendQuery(bqMayModify, [], nil); +{$ENDIF} +end; + +function TBoldMember.CanUpdate: Boolean; +begin + result := InternalMayUpdate and MayUpdate; +{$IFNDEF BOLD_NO_QUERIES} + result := result and SendQuery(bqMayUpdate, [], nil); +{$ENDIF} end; -function TBoldMember.CanUpdate: Boolean; +procedure TBoldMember.DoMarkTouched; begin - result := InternalMayUpdate and MayUpdate and SendQuery(bqMayUpdate, [], nil); + SetElementFlag(befTouched, true); + if assigned(owningObject) then + OwningObject.SetElementFlag(befTouched, true); end; procedure TBoldMember.EnsureContentsCurrent; begin - inherited; - if (BoldPersistenceState = bvpsInvalid) and - not GetElementFlag(befEnsuringCurrent) then - begin - SetElementFlag(befEnsuringCurrent, true); - try - if Derived then - begin - if DeriverState <> bdsCurrent then - Deriver.EnsureCurrent; - if not (DeriverState in bdsIsDeriving) then - BoldPersistenceState := bvpsTransient; - end - else - MakeDbCurrent; - finally - SetElementFlag(befEnsuringCurrent, false); - end; - end; - if not GetElementFlag(befTouched) then - begin - SetElementFlag(befTouched, true); - if assigned(owningObject) then - OwningObject.SetElementFlag(befTouched, true); - end; + if (StateAndFlagBank and BoldPersistenceStateMask) = (Cardinal(bvpsInvalid) shl BoldPSShift) then + DoEnsureContentsCurrent; + if not GetElementFlag(befTouched) then + DoMarkTouched; +{$IFNDEF NoAutoSubscription} + if IsPartOfSystem and BoldSystem.IsDerivingMembers and (BoldSystem.CurrentDerivedMember <> self) and Mutable and not BoldSystem.IsCommitting then + BoldSystem.fMembersReadDuringDerivation.Add(self); +{$ENDIF} +end; + +procedure TBoldMember.DoEnsureContentsCurrent; +{$IFDEF ACCESSSTATISTICS} //// START PATCH ACCESSSTATISTICS //////////////////// +var + G_BoldMemberRTInfo: TBoldMemberRTInfo; + G_OwningElement: TBoldDomainElement; + G_BoldSystem: TBoldSystem; +{$ENDIF} //// END PATCH ACCESSSTATISTICS /////////////////////////////////////// +begin + if not GetElementFlag(befEnsuringCurrent) then + begin + if Derived then + begin + {$IFDEF SpanFetch} + if IsPartOfSystem and not IsPrefetched then + begin + AttracsSpanFetchManager.PrefetchDerivedMember(self); + IsPrefetched := true; + end; + {$ENDIF} + end; + + SetElementFlag(befEnsuringCurrent, true); + try + if Derived then + begin + if DeriverState <> bdsCurrent then + begin + Deriver.EnsureCurrent; + {$IFDEF ACCESSSTATISTICS} //// START PATCH ACCESSSTATISTICS ////////// + //The messy code is for getting better performance /FH + if OwnedByObject then + begin + G_BoldMemberRTInfo := TBoldMemberRTInfo(fBoldMetaType); + G_OwningElement := OwningElement; + if (G_OwningElement<>nil) then + begin + if (G_OwningElement is TBoldObject) then + begin + G_BoldSystem := TBoldSystem(TBoldObject(G_OwningElement).OwningElement); + Inc(G_BoldSystem.fDeriveStats[G_BoldMemberRTInfo.ClassTypeInfo.TopSortedIndex, G_BoldMemberRTInfo.index]); + end + else + begin + Inc(TBoldSystem(G_OwningElement).fDeriveStats[G_BoldMemberRTInfo.ClassTypeInfo.TopSortedIndex, G_BoldMemberRTInfo.index]); + end; + end; + end; + {$ENDIF} //// END PATCH ACCESSSTATISTICS ///////////////////////////// + end; + if not (DeriverState in bdsIsDeriving) then + BoldPersistenceState := bvpsTransient; + end + else + MakeDbCurrent; + finally + SetElementFlag(befEnsuringCurrent, false); + end; + end; + {$IFDEF ACCESSSTATISTICS} //// START PATCH ACCESSSTATISTICS ////////////////// + //The messy code is for getting better performance /FH + if OwnedByObject then + begin + G_BoldMemberRTInfo := TBoldMemberRTInfo(fBoldMetaType); + G_OwningElement := OwningElement; + if (G_OwningElement<>nil) then + begin + if (G_OwningElement is TBoldObject) then + begin + G_BoldSystem := TBoldSystem(TBoldObject(G_OwningElement).OwningElement); + Inc(G_BoldSystem.fAccessStats[G_BoldMemberRTInfo.ClassTypeInfo.TopSortedIndex, G_BoldMemberRTInfo.index]); + end + else + begin + Inc(TBoldSystem(G_OwningElement).fAccessStats[G_BoldMemberRTInfo.ClassTypeInfo.TopSortedIndex, G_BoldMemberRTInfo.index]); + end; + end; + end; + {$ENDIF} //// END PATCH ACCESSSTATISTICS ///////////////////////////////////// + end; procedure TBoldMember.Invalidate; +var + aLinkMember: TBoldMember; +{$IFDEF ACCESSSTATISTICS} //// START PATCH ACCESSSTATISTICS //////////////////// + G_BoldMemberRTInfo: TBoldMemberRTInfo; + G_OwningElement: TBoldDomainElement; + G_BoldSystem: TBoldSystem; +{$ENDIF} //// END PATCH ACCESSSTATISTICS /////////////////////////////////////// begin if not (BoldPersistenceState in [bvpsCurrent, bvpsInvalid, bvpsTransient]) then - StateError('Invalidate'); // do not localize + StateError('Invalidate'); if assigned(BoldMemberRTInfo) and not BoldMemberRTInfo.IsDerived and (BoldPersistenceState = bvpsTransient) then - raise EBold.CreateFmt(sCannotInvalidateTransient, [classname, displayname]); + raise EBold.CreateFmt('%s.Invalidate: Can''t invalidate transient member: %s', [classname, displayname]); if BoldPersistenceState in [bvpsCurrent, bvpsTransient] then begin + if not Derived and OwnedByObject and OwningObject.BoldObjectIsNew then + raise EBold.CreateFmt('%s.Invalidate: Can''t invalidate member of a new unsaved object: %s', [classname, displayname]); BoldPersistenceState := bvpsInvalid; if HasDeriver then Deriver.MarkOutOfdate; FreeContent; SendEvent(beValueInvalid); + {$IFDEF ACCESSSTATISTICS} //// START PATCH ACCESSSTATISTICS ////////////////// + //The messy code is for getting better performance /FH + if OwnedByObject then + begin + G_BoldMemberRTInfo := TBoldMemberRTInfo(fBoldMetaType); + G_OwningElement := OwningElement; + if (G_OwningElement<>nil) then + begin + if (G_OwningElement is TBoldObject) then + begin + G_BoldSystem := TBoldSystem(TBoldObject(G_OwningElement).OwningElement); + Inc(G_BoldSystem.fInvalidateStats[G_BoldMemberRTInfo.ClassTypeInfo.TopSortedIndex, G_BoldMemberRTInfo.index]); + end + else + begin + Inc(TBoldSystem(G_OwningElement).fInvalidateStats[G_BoldMemberRTInfo.ClassTypeInfo.TopSortedIndex, G_BoldMemberRTInfo.index]); + end; + end; + end; + {$ENDIF} //// END PATCH ACCESSSTATISTICS ///////////////////////////////////// + /// + // n:n-associations: always invalidate LinkRole with MainRole. + // On OSS-Sync for example only the MainRole gets invalid. + // Likewise in TBoldObject.Invalidate, because the LinkRole is not persistent. + if (BoldMemberRTInfo is TBoldRoleRTInfo) and + (TBoldRoleRTInfo(BoldMemberRTInfo).IndexOfLinkObjectRole <> -1) then + begin + aLinkMember := OwningObject.BoldMembers[TBoldRoleRTInfo(BoldMemberRTInfo).IndexOfLinkObjectRole]; + if (aLinkMember.BoldPersistenceState <> bvpsModified) and + ((aLinkMember.BoldPersistenceState <> bvpsTransient) or + (aLinkMember.BoldMemberRTInfo.IsDerived)) then + begin + aLinkMember.Invalidate; + end; + end; end; end; function TBoldMember.CanRead(Subscriber: TBoldSubscriber): Boolean; begin - result := SendQuery(bqMayRead, [], Subscriber); -end; - -procedure TBoldMember.InitializeStateToModified; -begin - SetInternalState(BoldPersistenceStateMask, BoldPSShift, Integer(bvpsModified)); -end; - -procedure TBoldMember.InitializeStateToInvalid; -begin - SetInternalState(BoldPersistenceStateMask, BoldPSShift, Integer(bvpsInvalid)); -end; - -function TBoldMember.GetBoldPersistenceState: TBoldValuePersistenceState; -begin - result := TBoldValuePersistenceState(GetInternalState(BoldPersistenceStateMask, BoldPSShift)); + result := true; +// result := SendQuery(bqMayRead, [], Subscriber); end; procedure TBoldMember.SetBoldPersistenceState( Value: TBoldValuePersistenceState); var OldPState: TBoldValuePersistenceState; + OwningObj: TBoldObject; + rtInfo: TBoldMemberRtInfo; begin OldPState := BoldPersistenceState; if Value <> OldPState then begin - if Assigned(OwningObject) then - OwningObject.BoldSystem.fOldValueHandler.MemberPersistenceStatePreChange(self, Value); + OwningObj := OwningObject; + RtInfo := BoldMemberRTInfo; + if Assigned(OwningObj) then + OwningObj.BoldSystem.fOldValueHandler.MemberPersistenceStatePreChange(self, Value); SetInternalState(BoldPersistenceStateMask, BoldPSShift, integer(value)); - if OwnedByObject and BoldMemberRTInfo.IsSingleRole and (not Derived) and (not TBoldObjectReference(self).BoldRoleRTInfo.IsIndirect)and (Value = bvpsInvalid) then - TBoldObjectReference(self).HasOldValues := ((TBoldObjectReference(self).fObjectReferenceController as TBoldDirectSingleLinkController).GetLocator <> nil); - if not derived and assigned(OwningObject) then + if Assigned(OwningObj) and (Value = bvpsInvalid) and RtInfo.IsSingleRole and (not Derived) and (not TBoldObjectReference(self).BoldRoleRTInfo.IsIndirect) then + begin + if OwningObj.Discarding then + TBoldObjectReference(Self).HasOldValues := False + else +// Original Bold code was: +// TBoldObjectReference(self).HasOldValues := ((TBoldObjectReference(self).fObjectReferenceController as TBoldDirectSingleLinkController).GetLocator <> nil); +// But this assert can fail: +// Assert(TBoldObjectReference(self).fObjectReferenceController is TBoldDirectSingleLinkController, TBoldObjectReference(self).fObjectReferenceController.CLassName ); +// Controller can also be TBoldLinkObjectReferenceController instead of TBoldDirectSingleLinkController. Both descend from TBoldAbstractObjectReferenceController +// It is not clear if intention here was to only handle TBoldDirectSingleLinkController, or it handle all TBoldAbstractObjectReferenceController descendants ? +// TBoldAbstractObjectReferenceController is used, but needs to be tested + TBoldObjectReference(self).HasOldValues := ((TBoldObjectReference(self).fObjectReferenceController as TBoldAbstractObjectReferenceController).GetLocator <> nil); + end; + if not derived and assigned(OwningObj) then begin + if (value = bvpsInvalid) or (OldPState = bvpsInvalid) then + OwningObj.MemberChangingValidity(RtInfo, value); if Value = bvpsModified then - OwningObject.MemberBecomingModified(self) + OwningObj.MemberBecomingModified(self) else if OldPState = bvpsModified then - OwningObject.MemberBecomingClean(self); + OwningObj.MemberBecomingClean(self); end; end; end; @@ -3875,23 +5496,9 @@ procedure TBoldMember.MakeDbCurrent; begin end; -function TBoldMember.GetDeriver: TBoldEventPluggedDeriver; +function TBoldMember.GetDeriver: TBoldMemberDeriver; begin - Assert((G_ExternalDerivers.ReferencedObjects[self] = nil) - or (G_ExternalDerivers.ReferencedObjects[self] is TBoldMemberDeriver)); - result := TBoldMemberDeriver(G_ExternalDerivers.ReferencedObjects[self]); - if not Assigned(Result) then - begin - Result := TBoldMemberDeriver.Create(Self); - if assigned(OwningObject) then - begin - result.OnDeriveAndSubscribe := OwningObject.GetDeriveMethodForMember(self); - result.OnReverseDerive := OwningObject.GetReverseDeriveMethodForMember(self); - end; - Result.OnNotifyOutOfdate := _NotifyOutOfDate; - G_ExternalDerivers.ReferencedObjects[Self] := Result; - SetElementFlag(befHasDeriver, True); - end; + Result := OwningObject.GetBoldMemberDeriver(self) end; procedure TBoldMember._NotifyOutOfDate; @@ -3907,7 +5514,7 @@ procedure TBoldMember.StateError(S: String); Membername := '(' + BoldMemberRTInfo.ExpressionName + ') ' else Membername := ''; - inherited StateError(format('%s %s(PersistenceState: %s)', // do not localize + inherited StateError(format('%s %s(PersistenceState: %s)', [s, MemberName, GetEnumName(TypeInfo(TBoldValuePersistenceState), Ord(BoldPersistenceState))])); end; @@ -3949,54 +5556,50 @@ function TBoldMember.Clone: TBoldMember; end; end; -constructor TBoldMember.Create; +procedure TBoldMember.Initialize; begin - InitializeMember(nil, nil); end; -function TBoldMember.GetIsPartOfSystem: Boolean; +procedure TBoldMember.InitializeNonObjectOwned(ElementTypeInfo: TBoldElementTypeInfo); begin - result := OwnedByObject or (OwningElement is TBoldSystem); + SetElementFlag(befPersistent, false); + if assigned(ElementTypeInfo) then + fBoldMetaType := ElementTypeInfo + else + fBoldMetaType := GetElementTypeInfoForType; + Initialize; end; -function TBoldMember.GetIsReadOnly(Flag: TBoldElementFlag): Boolean; +constructor TBoldMember.Create; begin - result := GetElementFlag(Flag) or - (assigned(BoldMemberRTInfo) and BoldMemberRTInfo.IsStoredInObject and OwningObject.IsReadOnly); + inherited CreateWithOwner(nil); + InitializeNonObjectOwned(nil); end; -procedure TBoldMember.InitializeMember(AOwningElement: TBoldDomainElement; - ElementTypeInfo: TBoldElementTypeInfo); -begin - inherited Create(AOwningElement); - - Assert(OwnedByObject = ( assigned(fBoldMetaType) and (fBoldMetaType is TBoldMemberRtInfo))); - if OwnedByObject then - begin - SetElementFlag(befDerived, BoldMemberRTInfo.IsDerived); - SetElementFlag(befPersistent, (AOwningElement is TBoldDomainElement) and TBoldDomainElement(AOwningElement).BoldPersistent and BoldMemberRTInfo.Persistent); - if Derived then - DeriverState := bdsSubscriptionOutOfDate; - end - else +procedure TBoldMember.InternalDiscard; +{$IFNDEF NoAutoSubscription} + procedure ClearDerivationReferences; + var + i: integer; begin - SetElementFlag(befPersistent, false); - if assigned(ElementTypeInfo) then - fBoldMetaType := ElementTypeInfo - else - fBoldMetaType := GetElementTypeInfoForType; + // Clear any references to member from the list of members acccesed during derivation + with BoldSystem.fMembersReadDuringDerivation do + for i := 0 to Count - 1 do + if (Items[i] <> nil) and (TBoldMember(Items[i]) = self) then + Items[i] := nil; end; -end; - -procedure TBoldMember.InternalDiscard; +{$ENDIF} begin if BoldPersistenceState in [bvpsModified, bvpsTransient] then begin PreDiscard; +{$IFNDEF NoAutoSubscription} + if Assigned(BoldSystem) and BoldSystem.IsDerivingMembers then + ClearDerivationReferences; +{$ENDIF} case BoldPersistenceState of bvpsModified: begin - // if the object is not stored yet, then we can not set the member - // to invalid, since it can not be fetched... + if not OwningObject.BoldObjectLocator.BoldObjectID.IsStorable then BoldPersistenceState := bvpsCurrent else @@ -4005,7 +5608,7 @@ procedure TBoldMember.InternalDiscard; FreeContent; SendEvent(beValueInvalid); end; - bvpsTransient: if not Derived then + bvpsTransient: if not Derived and mutable then DoSetInitialValue; end; end; @@ -4016,7 +5619,7 @@ procedure TBoldMember.Discard; if OwningObject.BoldObjectLocator.BoldObjectID.IsStorable then InternalDiscard else - raise EBold.CreateFmt(sCannotDiscardUnsavedSingleLinks, [ClassName]); + raise EBold.CreateFmt('%s.Discard: This is not allowed for single members on objects that are not saved, discard the whole object', [ClassName]); end; procedure TBoldMember.PreDiscard; @@ -4053,15 +5656,12 @@ function TBoldMember.InternalMayUpdate: Boolean; result := True; end; -procedure TBoldMember.InitializeStateToTransient; -begin - SetInternalState(BoldPersistenceStateMask, BoldPSShift, Integer(bvpsTransient)); -end; - procedure TBoldMember.PreChange; begin +{$IFNDEF NoObjectSpaceTransactions} if assigned(OwningObject) and not BoldMemberRTInfo.IsDerived then - OwningObject.BoldSystem.CopyMemberToRollbackBuffer(self); + BoldSystem.CopyMemberToRollbackBuffer(self); +{$ENDIF} end; procedure TBoldMember.DoSetInitialValue; @@ -4089,29 +5689,33 @@ function TBoldMember.CloneIfPossible: TBoldElement; function TBoldMember.RetrieveProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj; const InterfaceName: string): Boolean; begin - result := ProxyClass.create(self, Mode).GetInterface(IID, obj); + result := GetProxy(Mode).GetInterface(IID, obj); if not result then - raise EBoldInternal.CreateFmt(sProxyClassDidNotImplementInterface, [ProxyClass.ClassName, ClassName, InterfaceName]); + raise EBoldInternal.CreateFmt('ProxyClass for %s did not implement %s', [ClassName, InterfaceName]); +end; + +procedure TBoldMember.ReverseDeriveMember; +var + ReverseDeriveMethod: TMethod; +begin + ReverseDeriveMethod.Code := BoldmemberRTInfo.ReverseDeriveMethod; + if ReverseDeriveMethod.Code = nil then + begin + ReverseDeriveMethod := TMethod(OwningObject.GetReverseDeriveMethodForMember(Self)); + BoldmemberRTInfo.ReverseDeriveMethod := ReverseDeriveMethod.Code; + end + else + ReverseDeriveMethod.Data := OwningObject; + TBoldReverseDerive(ReverseDeriveMethod)(self); end; procedure TBoldMember.AssignContentValueFromElement(source: TBoldElement); begin if not assigned(source) then -// AssignContentValue(nil) else if source is TBoldMember then AsIBoldValue[bdepContents].AssignContent(TBoldMember(source).AsIBoldValue[bdepContents]) else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, 'AssignContentValuefromElement']); // do not localize -end; - -function TBoldMember.GetDeriverState: TBoldDeriverState; -begin - result := TBoldDeriverState(GetInternalState(BoldDerivationStateMask, BoldDSShift)); -end; - -procedure TBoldMember.SetDeriverState(value: TBoldDeriverState); -begin - SetInternalState(BoldDerivationStateMask, BoldDSShift, integer(Value)); + raise EBold.CreateFmt('%s.AssignContentValuefromElement: Unknown source: %s', [classname, Source.BoldType.AsString]); end; function TBoldMember.GetOldValue: IBoldValue; @@ -4119,7 +5723,7 @@ function TBoldMember.GetOldValue: IBoldValue; ObjectContents: IBoldObjectContents; begin result := nil; - if assigned(OwningObject) and assigned(BoldSystem) then + if OwnedByObject and not OwningObject.BoldObjectIsNew then begin ObjectContents := BoldSystem.fOldValueHandler.OldValues.GetObjectContentsByObjectId(OwningObject.BoldObjectLocator.BoldObjectID) as IBoldObjectContents; if assigned(ObjectContents) then @@ -4136,48 +5740,65 @@ function TBoldMember.MemberHasSubscribers: Boolean; function TBoldMember.StoreInUndo: Boolean; begin - Result := Assigned(BoldMemberRTinfo) and (not BoldMemberRTInfo.IsDerived) and - (BoldMemberRTInfo.IsAttribute or - (TBoldRoleRTInfo(BoldMemberRTInfo).RoleType = rtRole) and(not (TBoldRoleRTInfo(BoldMemberRTInfo).IsMultiRole or TBoldRoleRTInfo(BoldMemberRTInfo).IsIndirect)) or - (TBoldRoleRTInfo(BoldMemberRTInfo).RoleType = rtInnerLinkRole) - ); + Result := Assigned(BoldMemberRTinfo) and BoldMemberRTinfo.StoreInUndo; end; -function TBoldMember.IsEqualToValue(Value: IBoldValue): Boolean; -begin{ TODO : Make part of IBoldVAlue } - raise Ebold.Create(sIsEqualToValueNotImplemented); +function TBoldMember.IsEqualToValue(const Value: IBoldValue): Boolean; +begin + raise Ebold.Create('TBoldMember.IsEqualToValue: not implemented for memberclass ' + ClassName); end; -function TBoldAttribute.IsEqualToValue(Value: IBoldValue): Boolean; +function TBoldAttribute.IsEqualToValue(const Value: IBoldValue): Boolean; var MemberOfSameType: TBoldMember; G: IBoldGuard; -begin{ TODO : Make part of IBoldVAlue } - // Messy - G := TBoldGuard.Create(MemberOfSameType); - if assigned(BoldType) then - MemberOfSameType := TBoldMemberFactory.CreateMemberFromBoldType(BoldType) +{$IFDEF StringAttributeComparison} + s: IBoldStringRepresentable; +{$ENDIF} +begin + Assert(Assigned(Value), ClassName + '.IsEqualToValue: Value can not be nil.'); +{$IFDEF StringAttributeComparison} + if Value.QueryInterface(IBoldStringRepresentable, S) = S_OK then + result := StringCompare(ctDefault, Self.AsString, s.StringRepresentation[brDefault]) = 0 else - MemberOfSameType := TBoldMemberClass(classtype).Create; - MemberOfSameType.AsIBoldValue[bdepContents ].AssignContent(Value); - MemberOfSameType.BoldPersistenceState := bvpsTransient; - Result := IsEqual(MemberOfSameType); +{$ENDIF} + begin + G := TBoldGuard.Create(MemberOfSameType); + if assigned(BoldType) then + MemberOfSameType := TBoldMemberFactory.CreateMemberFromBoldType(BoldType) + else + MemberOfSameType := TBoldMemberClass(classtype).Create; + MemberOfSameType.AsIBoldValue[bdepContents].AssignContent(Value); + MemberOfSameType.BoldPersistenceState := bvpsTransient; + Result := IsEqual(MemberOfSameType); + end; +end; + +function TBoldAttribute.IsVariantTypeCompatible(const Value: Variant): Boolean; +begin + result := true; end; -function TBoldObjectReference.IsEqualToValue(Value: IBoldValue): Boolean; +function TBoldObjectReference.IsEqualToValue(const Value: IBoldValue): Boolean; var IdRef: IBoldObjectIdRef; IdRefPair: IBoldObjectIdRefPair; ValueId : TBoldObjectId; -begin{ TODO : Make part of IBoldVAlue } +begin + Assert(Assigned(Value), ClassName + '.IsEqualToValue: Value can not be nil.'); if Supports(Value, IBoldObjectIdRef,IdRef) then ValueId := Idref.id else if Supports(Value, IBoldObjectIdRefPair,IdRefPair) then - ValueId := IdRefPair.Id1 + begin + if (BoldRoleRTInfo.RoleType = rtRole) and Assigned(BoldRoleRTInfo.LinkClassTypeInfo) then + ValueId := IdRefPair.Id2 + else + ValueId := IdRefPair.Id1 + end else - raise EBoldInternal.Create('Internal error'); + raise EBold.Create('Internal error'); if Assigned(Locator) and Assigned(ValueId) then - Result := Locator.BoldObjectID.IsEqual[ValueId] + Result := Locator.BoldObjectID.IsEqual[ValueId] else Result := (Locator = nil) and (ValueId = nil); end; @@ -4195,18 +5816,12 @@ procedure TBoldAttribute.DefaultSubscribe(Subscriber: TBoldSubscriber; Requested AddSmallSubscription(Subscriber, [beValueChanged, beValueInvalid], RequestedEvent); end; -function TBoldAttribute.GetBoldAttributeRTInfo: TBoldAttributeRTInfo; -begin - Assert((not Assigned(BoldMemberRTInfo)) or (BoldMemberRTInfo is TBoldAttributeRTInfo)); - Result := TBoldAttributeRTInfo(BoldMemberRTInfo); -end; - function TBoldAttribute.GetIsNull: Boolean; begin EnsureContentsCurrent; BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, 'GetIsNull', ''); // do not localize + BoldRaiseLastFailure(self, 'GetIsNull', ''); Result := ContentIsNull; end; @@ -4214,12 +5829,12 @@ procedure TBoldAttribute.SetToNull; begin BoldClearLastFailure; if not CanSetToNull(nil) then - BoldRaiseLastFailure(self, 'SetToNull', ''); // do not localize + BoldRaiseLastFailure(self, 'SetToNull', ''); if not IsNull then begin if not StartModify then - BoldRaiseLastFailure(self, 'SetToNull', sStartModifyPreconditionNotMet); // do not localize + BoldRaiseLastFailure(self, 'SetToNull', 'StartModify precondition not met'); try SetContentToNull; EndModify; @@ -4230,10 +5845,59 @@ procedure TBoldAttribute.SetToNull; end; end; + +function UnicodeCompareLen(CaseSensitive: Boolean; s1, s2 : string; n : Integer) : Integer; +const + CSTR_EQUAL = 2; +begin + if CaseSensitive then + Result:=CompareStringEx(nil, 0, PWideChar(s1), n, PWideChar(s2), n, nil, nil, 0)-CSTR_EQUAL + else + Result:=CompareStringEx(nil, NORM_IGNORECASE, PWideChar(s1), n, PWideChar(s2), n, nil, nil, 0)-CSTR_EQUAL +end; + +function UnicodeCompareText(CaseSensitive: Boolean; const s1, s2 : UnicodeString) : Integer; +var + n1, n2, dn : Integer; +begin + if S1<>'' then begin + if S2<>'' then begin + n1:=Length(s1); + n2:=Length(s2); + dn:=n1-n2; + if dn<0 then begin + Result:=UnicodeCompareLen(CaseSensitive, s1, s2, n1); + if Result=0 then + Result:=-1; + end else begin + Result:=UnicodeCompareLen(CaseSensitive, S1, s2, n2); + if (Result=0) and (dn>0) then + Result:=1; + end; + end else Result:=1; + end else if S2<>'' then + Result:=-1 + else Result:=0; +end; + +function TBoldAttribute.StringCompare(CompareType: TBoldCompareType; const s1, s2: string): integer; +begin + case CompareType of + ctDefault, ctCaseInsensitive: + Result := UnicodeCompareText(false, s1, s2); + ctAsString, ctCaseSensitive: + Result := UnicodeCompareText(true, s1, s2); + else + raise EBold.CreateFmt('%s.StringCompare Unsupported CompareType %s in StringCompare.', [ClassName, GetEnumName(TypeInfo(TBoldCompareType), Ord(CompareType))]); + end; +end; + function TBoldAttribute.CanSetToNull(Subscriber: TBoldSubscriber): Boolean; begin - result := ((not Assigned(BoldAttributeRTInfo)) or BoldAttributeRTInfo.AllowNull) and - SendQuery(bqMaySetToNull, [], Subscriber); + result := ((not Assigned(BoldAttributeRTInfo)) or BoldAttributeRTInfo.AllowNull); +{$IFNDEF BOLD_NO_QUERIES} + Result := result and SendQuery(bqMaySetToNull, [], Subscriber); +{$ENDIF} if not result then nullfailure; end; @@ -4241,7 +5905,7 @@ function TBoldAttribute.CanSetToNull(Subscriber: TBoldSubscriber): Boolean; function TBoldAttribute.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; begin if IsEqualGuid(IID, IBoldNullableValue) then - Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldNullableValue') // do not localize + Result := RetrieveProxyInterface(IID, Mode, obj, 'IBoldNullableValue') else result := inherited ProxyInterface(IID, Mode, Obj); end; @@ -4251,6 +5915,16 @@ procedure TBoldAttribute.SubscribeToStringRepresentation(Representation: TBoldRe DefaultSubscribe(Subscriber, RequestedEvent); end; +function TBoldAttribute.ValidateVariant(const Value: Variant; + Representation: TBoldRepresentation): Boolean; +begin + result := true; + if VarIsNull(Value) then + result := CanSetToNull(nil) + else if not IsVariantTypeCompatible(Value) then + result := inherited ValidateVariant(Value, Representation); +end; + procedure TBoldAttribute.SetToNonNull; begin SetElementFlag(befIsNull, False); @@ -4259,7 +5933,14 @@ procedure TBoldAttribute.SetToNonNull; procedure TBoldAttribute.EnsureNotNull; begin if IsNull then - raise EBoldAccessNullValue.CreateFmt(sNullValueAccess, [DisplayName]); + begin +{$IFNDEF NoNilAttributeExceptions} + if OwnedByObject then + raise EBoldAccessNullValue.CreateFmt('%s: Attempt to access Value of Attribute that is null. OwningObject: %s', [DisplayName, OwningObject.BoldObjectLocator.AsString]) + else + raise EBoldAccessNullValue.CreateFmt('%s: Attempt to access Value of Attribute that is null', [DisplayName]); +{$ENDIF} + end; end; procedure TBoldAttribute.MakeDbCurrent; @@ -4267,10 +5948,10 @@ procedure TBoldAttribute.MakeDbCurrent; if OwningObject.BoldObjectLocator.BoldObjectID.IsStorable then OwningObject.BoldSystem.SystemPersistenceHandler.FetchMember(self) else - raise EBoldInternal.CreateFmt(sObjectIDIsInternal, [BoldType.AsString]); + raise EBoldInternal.CreateFmt('%s.MakeDbCurrent: Attribute belongs to object with internal ID', [BoldType.AsString]); end; -class function TBoldAttribute.EitherIsNull(Attribute1, Attribute2: TBoldAttribute): Boolean; +class function TBoldAttribute.EitherIsNull(Attribute1, Attribute2: TBoldAttribute): Boolean; begin Result := Attribute1.IsNull or Attribute2.IsNull; end; @@ -4329,12 +6010,19 @@ function TBoldMember.IsInvalid: Boolean; result := BoldPersistenceState = bvpsInvalid; end; +function TBoldMember.GetIsCurrent: Boolean; +begin + result := BoldPersistenceState = bvpsCurrent; +end; + function TBoldMember.GetDisplayName: String; begin if assigned(BoldMemberRTInfo) then - result := BoldMemberRTInfo.ClassTypeInfo.ExpressionName + '.' + BoldMemberRTInfo.ExpressionName + result := BoldMemberRTInfo.ExpressionName else - result := ClassName; + result := inherited GetDisplayName; // ClassName; + if OwnedByObject then + result := OwningObject.DisplayName + '.' + result; end; procedure TBoldAttribute.NullFailure; @@ -4343,23 +6031,38 @@ procedure TBoldAttribute.NullFailure; begin CurrentFailureReason := GetBoldLastFailureReason; if not assigned(CurrentFailureReason) then - SetBoldLastFailureReason(TBoldFailureReason.Create(sNullValueNotAllowed, self)); + SetBoldLastFailureReason(TBoldFailureReason.Create('Null value not allowed', self)); end; procedure TBoldAttribute.FormatFailure(const value, ExpectedDataType: String); begin - SetBoldLastFailureReason(TBoldFailureReason.CreateFmt(sFailure_Invalid, [value, expectedDataType], self)); + SetBoldLastFailureReason(TBoldFailureReason.CreateFmt('%s is not a valid %s', [value, expectedDataType], self)); end; -function TBoldAttribute.GetContentIsNull: Boolean; +function TBoldAttribute.GetAsVariant: Variant; begin - Result := GetElementFlag(befIsNull); + if IsNull then + Result := Null + else + Result := inherited GetAsVariant; +end; + +procedure TBoldAttribute.SetAsVariant(const Value: Variant); +begin + if VarIsNull(Value) then + SetToNull + else + inherited; end; procedure TBoldAttribute.SetContentToNull; begin if not ContentIsNull then begin + PreChange; +{$IFDEF NoNilAttributeExceptions} + FreeContent; +{$ENDIF} SetElementFlag(befIsNull, True); Changed(beValueChanged, []); end; @@ -4369,21 +6072,28 @@ procedure TBoldAttribute.DoSetInitialValue; var InitialValue: string; begin - if Assigned(BoldAttributeRTInfo) and BoldAttributeRtInfo.HasInitialValue then + if Assigned(BoldAttributeRTInfo) then begin - InitialValue := BoldAttributeRTInfo.InitialValue; - if CompareText(InitialValue, '') = 0 then // do not localize - SetToNull - else - try - AsString := InitialValue; - except - on e: Exception do - begin - Raise EBold.CreateFmt(sIllegalInitialValue, - [InitialValue, BoldAttributeRTInfo.AsString, BOLDCRLF, e.message]); + if BoldAttributeRtInfo.HasInitialValue then + begin + InitialValue := BoldAttributeRTInfo.InitialValue; + if CompareText(InitialValue, '') = 0 then + SetToNull + else + try + AsString := InitialValue; + except + on e: Exception do + begin + Raise EBold.CreateFmt('Illegal InitialValue (%s) for attribute %s. ErrorMessage: ' + BOLDCRLF + '%s', + [InitialValue, BoldAttributeRTInfo.AsString, e.message]); + end; end; - end; + end + else + begin + SetEmptyValue; + end; end; end; @@ -4408,7 +6118,7 @@ procedure TBoldAttribute.Assign(Source: TBoldElement); procedure TBoldAttribute.SetEmptyValue; begin - raise Ebold.CreateFmt(sMethodNotImplemented, [classname, 'SetEmptyValue']); // do not localize + raise Ebold.CreateFmt('%s.SetEmptyValue: Operation not implemented', [classname]); end; { TBoldObjectReference } @@ -4426,12 +6136,17 @@ procedure TBoldObjectReference.DefaultSubscribe(Subscriber: TBoldSubscriber; Req AddSmallSubscription(Subscriber, [beValueChanged, beValueInvalid], RequestedEvent); end; +function TBoldObjectReference.GetIsEmpty: boolean; +begin + result := not Assigned(Locator); +end; + function TBoldObjectReference.GetLocator: TBoldObjectLocator; begin EnsureContentsCurrent; BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, 'GetLocator', ''); // do not localize + BoldRaiseLastFailure(self, 'GetLocator', ''); Result := ReferenceController.GetLocator; end; @@ -4440,7 +6155,7 @@ function TBoldObjectReference.GetBoldObject: TBoldObject; aLocator: TBoldObjectLocator; begin aLocator := Locator; {CanRead, EnsureContentsCurrent called by GetLocator} - if not Assigned(aLocator) then + if not Assigned(aLocator) or aLocator.BoldObjectID.NonExisting then Result := nil else begin @@ -4466,7 +6181,7 @@ procedure TBoldObjectReference.InternalSetLocator(NewLocator: TBoldObjectLocator begin BoldClearLastFailure; if not CanSetLocator(NewLocator, nil) then - BoldRaiseLastFailure(self, 'SetLocator', ''); // do not localize + BoldRaiseLastFailure(self, 'SetLocator', ''); ReferenceController.SetLocator(NewLocator); end; end; @@ -4476,14 +6191,16 @@ procedure TBoldObjectReference.SetBoldObject(NewObject: TBoldObject); if Assigned(NewObject) then Locator := NewObject.BoldObjectLocator else - Clear; // this will cause "CanClear" to be checked before the "CanSetLocator" + Clear; end; procedure TBoldObjectReference.Clear; begin + if not Assigned(Locator) then + exit; BoldClearLastFailure; if not canClear(nil) then - BoldRaiseLastFailure(self, 'Clear', ''); // do not localize + BoldRaiseLastFailure(self, 'Clear', ''); Locator := nil; end; @@ -4495,11 +6212,10 @@ function TBoldObjectReference.GetStringRepresentation(Representation: TBoldRepre Result := ''; end; -procedure TBoldObjectReference.SetStringRepresentation(Representation: TBoldRepresentation; Value: string); +procedure TBoldObjectReference.SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); begin if Assigned(BoldObject) then BoldObject.SetStringRepresentation(Representation, Value); - //FixMe: is it an error trying to set the stringrep of a singlelink without value? end; function TBoldObjectReference.IsEqualAs(CompareType: TBoldCompareType; BoldElement: TBoldElement): Boolean; @@ -4515,7 +6231,7 @@ function TBoldObjectReference.IsEqualAs(CompareType: TBoldCompareType; BoldEleme case CompareType of ctDefault: Result := BoldObject.IsEqualAs(CompareType, BoldElement); else - raise EBold.CreateFmt(sUnknownCompareType, [ClassName, 'IsEqualAs']); // do not localize + raise EBold.CreateFmt('%s.IsEqualAs: Unknown Comparetype', [ClassName]); end; end else @@ -4527,9 +6243,12 @@ procedure TBoldObjectReference.GetAsList(ResultList: TBoldIndirectElement); NewList: TBoldObjectList; begin Assert(BoldType.SystemTypeInfo is TBoldSystemTypeInfo); - NewList := TBoldObjectList.CreateWithTypeInfo(TBoldSystemTypeInfo(BoldType.SystemTypeInfo).ListTypeInfoByElement[BoldType]); + NewList := TBoldObjectList.CreateWithTypeInfo(BoldType.ListTypeInfo); if Assigned(BoldObject) then - NewList.Add(BoldObject); + begin + NewList.Capacity := 1; + NewList.ObjectListController.AddLocator(BoldObject.BoldObjectLocator); + end; NewList.MakeImmutable; ResultList.SetOwnedValue(NewList); end; @@ -4557,6 +6276,11 @@ function TBoldObjectReference.GetStreamName: String; Result := ReferenceController.StreamName; end; +function TBoldObjectReference.GetFreeStandingClass: TBoldFreeStandingElementClass; +begin + result := ReferenceController.GetFreeStandingClass; +end; + procedure TBoldObjectReference.Assign(Source: TBoldElement); begin if not assigned(Source) then @@ -4584,9 +6308,9 @@ function TBoldObjectReference.CompareToAs(CompareType: TBoldCompareType; BoldEle else if not assigned(BoldElement) then CompareObj := nil else - raise EBold.CreateFmt(sUnknownObjectType, [ClassName, BoldElement.ClassName]); + raise EBold.CreateFmt('%s.CompareToAs: unknown type of object (%s)', [ClassName, BoldElement.ClassName]); - if CompareObj = BoldObject then // covers the case of both = nil + if CompareObj = BoldObject then result := 0 else if not assigned(CompareObj) then result := 1 @@ -4599,12 +6323,35 @@ function TBoldObjectReference.CompareToAs(CompareType: TBoldCompareType; BoldEle function TBoldObjectReference.CanSetLocator(NewLocator: TBoldObjectLocator; Subscriber: TBoldSubscriber): Boolean; begin - if assigned(newLocator) and assigned(OwningObject) and (OwningObject.BoldSystem <> NewLocator.BoldSystem) then - result := false + result := VerifyClass(NewLocator); +{$IFNDEF BOLD_NO_QUERIES} + result := result and SendQuery(bqMaySetValue, [NewLocator], Subscriber) +{$ENDIF} +end; + +function VerifyLocatorType(ALocator: TBoldObjectLocator; AExpectedClassType: TBoldClassTypeInfo; ARaise: boolean = true): Boolean; +var + KnownClass: TBoldClassTypeInfo; +begin + if Assigned(AExpectedClassType) and assigned(aLocator) then + begin + Assert(AExpectedClassType is TBoldClassTypeInfo); + KnownClass := aLocator.BoldClassTypeInfo; + Assert(Assigned(KnownClass)); + if KnownClass.ConformsTo(AExpectedClassType) then + result := true + else if aLocator.BoldObjectId.TopSortedIndexExact then + result := false + else + result := AExpectedClassType.ConformsTo(knownclass); + if not result and ARaise then + raise EBold.CreateFmt('Locator is: %s, expected: %s ', [KnownClass.ExpressionName, AExpectedClassType.ExpressionName]); + end else - result := VerifyClass(NewLocator) and SendQuery(bqMaySetValue, [NewLocator], Subscriber); + result := true; end; + function TBoldObjectReference.VerifyClass(aLocator: TBoldObjectLocator): Boolean; var AllowedClass, KnownClass: TBoldClassTypeInfo; @@ -4614,15 +6361,15 @@ function TBoldObjectReference.VerifyClass(aLocator: TBoldObjectLocator): Boolean Assert(BoldType is TBoldClassTypeInfo); Assert(BoldType.SystemTypeInfo is TBoldSystemTypeInfo); AllowedClass := TBoldClassTypeInfo(BoldType); - KnownClass := TBoldSystemTypeInfo(BoldType.SystemTypeInfo).TopSortedClasses[aLocator.BoldObjectId.TopSortedIndex]; + KnownClass := aLocator.BoldClassTypeInfo; if KnownClass.ConformsTo(AllowedClass) then result := true else if aLocator.BoldObjectId.TopSortedIndexExact then result := false - else // if it looks wrong, but the classID is inexact, then we will allow it if it _could_ be right... + else result := allowedClass.ConformsTo(knownclass); if not result then - SetBoldLastFailureReason(TBoldFailureReason.CreateFmt(sCannotSetSuchReference, [KnownClass.ExpressionName, AllowedClass.ExpressionName], self)); + SetBoldLastFailureReason(TBoldFailureReason.CreateFmt('Can not set a %s in a %s-reference', [KnownClass.ExpressionName, AllowedClass.ExpressionName], self)); end else result := true; @@ -4642,16 +6389,16 @@ constructor TBoldObjectReference.CreateTypedReference(ObjectClass: TBoldObjectCl var aSystem: TBoldSystem; begin + inherited CreateWithOwner(nil); aSystem := TBoldSystem.DefaultSystem; if assigned(aSystem) then - InitializeMember(nil, aSystem.BoldSystemTypeInfo.TopSortedClasses.ItemsByObjectClass[ObjectClass]) + InitializeNonObjectOwned(aSystem.BoldSystemTypeInfo.TopSortedClasses.ItemsByObjectClass[ObjectClass]) else - InitializeMember(nil, nil); + InitializeNonObjectOwned(nil); HasOldValues := false; end; -procedure TBoldObjectReference.InitializeMember( - AOwningElement: TBoldDomainElement; ElementTypeInfo: TBoldElementTypeInfo); +procedure TBoldObjectReference.Initialize; begin inherited; if not assigned(BoldMemberRTInfo) or BoldMemberRTInfo.IsDerived then @@ -4667,8 +6414,10 @@ procedure TBoldObjectReference.InitializeMember( fObjectReferenceController := TBoldLinkObjectReferenceController.Create(Self) else if IsIndirect then fObjectReferenceController := TBoldIndirectSingleLinkController.Create(Self) + else if OtherEndOrdered then + fObjectReferenceController := TBoldOrderedDirectSingleLinkController.Create(Self) else - fObjectReferenceController := TBoldDirectSingleLinkController.Create(Self); + fObjectReferenceController := TBoldUnOrderedDirectSingleLinkController.Create(Self) end; end; end; @@ -4693,7 +6442,11 @@ function TBoldObjectReference.GetBoldRoleRTInfo: TBoldRoleRTInfo; function TBoldObjectReference.CanClear(Subscriber: TBoldSubscriber): Boolean; begin +{$IFDEF BOLD_NO_QUERIES} + result := true; +{$ELSE} result := SendQuery(bqMayClear, [], Subscriber); +{$ENDIF} end; function TBoldObjectReference.InternalMayUpdate: Boolean; @@ -4701,9 +6454,9 @@ function TBoldObjectReference.InternalMayUpdate: Boolean; result := ReferenceController.MayUpdate; end; -function TBoldObjectReference.ProxyClass: TBoldMember_ProxyClass; +function TBoldObjectReference.GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin - result := ReferenceController.ProxyClass; + result := ReferenceController.GetProxy(self, Mode); end; procedure TBoldObjectReference.AssignContentValueFromElement(source: TBoldElement); @@ -4726,7 +6479,7 @@ procedure TBoldObjectReference.AdjustOldValues(Translationlist: TBoldIdTranslati OldLink: IBoldValue; OldValues: IBoldValueSpace; - procedure GetOldValueAsIdLists(IdList1, IdList2: TBoldObjectIdList; Oldvalue: IBoldValue); + procedure GetOldValueAsIdLists(IdList1, IdList2: TBoldObjectIdList; const Oldvalue: IBoldValue); var i: integer; IdList: IBoldObjectIdListRef; @@ -4747,7 +6500,7 @@ procedure TBoldObjectReference.AdjustOldValues(Translationlist: TBoldIdTranslati end; end; - procedure RemoveIdFromLink(LinkId: TBoldObjectId; OldLink: IBoldValue); + procedure RemoveIdFromLink(LinkId: TBoldObjectId; const OldLink: IBoldValue); var IdRef: IBoldObjectIdRef; IdRefPair: IBoldObjectIdRefPair; @@ -4755,7 +6508,7 @@ procedure TBoldObjectReference.AdjustOldValues(Translationlist: TBoldIdTranslati FreestandingListPair: IBoldFreeStandingIdListPair; begin if OldLink.QueryInterface(IBoldObjectIdref, IdRef) = S_OK then - IdRef.SetFromId(nil) + IdRef.SetFromId(nil, false) else if OldLink.QueryInterface(IBoldObjectIdrefPair, IdRefPair) = S_OK then IdRefPair.SetFromIds(nil, nil) else if OldLink.QueryInterface(IBoldFreeStandingIdList, FreestandingList) = S_OK then @@ -4766,7 +6519,7 @@ procedure TBoldObjectReference.AdjustOldValues(Translationlist: TBoldIdTranslati raise EBoldInternal.CreateFmt('%s.AdjustOldValues (RemoveIdFromLink): Unknown type of link', [Classname]); end; - procedure AddIdToLink(Id1, Id2: TBoldObjectId; OldLink: IBoldValue); + procedure AddIdToLink(Id1, Id2: TBoldObjectId; const OldLink: IBoldValue); var IdRef: IBoldObjectIdRef; IdRefPair: IBoldObjectIdRefPair; @@ -4774,7 +6527,7 @@ procedure TBoldObjectReference.AdjustOldValues(Translationlist: TBoldIdTranslati FreestandingListPair: IBoldFreeStandingIdListPair; begin if OldLink.QueryInterface(IBoldObjectIdref, IdRef) = S_OK then - IdRef.SetFromId(TranslationList.TranslateToNewId[Id1]) + IdRef.SetFromId(TranslationList.TranslateToNewId[Id1], false) else if OldLink.QueryInterface(IBoldObjectIdrefPair, IdRefPair) = S_OK then IdRefPair.SetFromIds(TranslationList.TranslateToNewId[Id1], TranslationList.TranslateToNewId[Id2]) else if OldLink.QueryInterface(IBoldFreeStandingIdList, FreestandingList) = S_OK then @@ -4791,13 +6544,11 @@ procedure TBoldObjectReference.AdjustOldValues(Translationlist: TBoldIdTranslati begin inherited; - // this happens for direct singlelinks and for innerlinks. - // Either way, the Role that should be adjusted is always the one pointed out by BoldRoleRTInfo.IndexOfOtherEnd + Oldvalues := OwningObject.BoldSystem.fOldValueHandler.Oldvalues; if BoldRoleRTInfo.IsStoredInObject then begin - // fix to remove deleted objects from Oldvalues OldRef := OldValue as IBoldObjectIdRef; if assigned(OldRef) and Assigned(OldRef.Id) then begin @@ -4805,7 +6556,7 @@ procedure TBoldObjectReference.AdjustOldValues(Translationlist: TBoldIdTranslati if assigned(OldObjectContents) then begin OldLink := OldObjectContents.ValueByIndex[BoldRoleRTInfo.IndexOfOtherEnd]; - if assigned(OldLink) then + if assigned(OldLink) and (OldLink.BoldPersistenceState <> bvpsInvalid) {?} then RemoveIdFromLink(OwningObject.BoldObjectLocator.BoldObjectId, OldLink); end; end; @@ -4833,7 +6584,7 @@ procedure TBoldObjectReference.AdjustOldValues(Translationlist: TBoldIdTranslati procedure TBoldObjectReference.DoSetInitialValue; begin - if BoldRoleRTInfo.RoleType = rtRole then // only regular roles have an inital value. + if BoldRoleRTInfo.RoleType = rtRole then BoldObject := nil; end; @@ -4854,6 +6605,27 @@ function TBoldObjectReference.GetOldEmbeddingOtherEndId: TBoldObjectId; end; end; +{ TBoldListEnumerator } + +constructor TBoldListEnumerator.Create(AList: TBoldList); +begin + inherited Create; + FIndex := -1; + FList := AList; +end; + +function TBoldListEnumerator.GetCurrent: TBoldElement; +begin + Result := List[FIndex]; +end; + +function TBoldListEnumerator.MoveNext: Boolean; +begin + Result := Index < List.Count - 1; + if Result then + Inc(FIndex); +end; + { TBoldList } destructor TBoldList.Destroy; @@ -4872,7 +6644,7 @@ procedure TBoldList.DefaultSubscribe(Subscriber: TBoldSubscriber; RequestedEvent procedure TBoldList.AllocateData; begin - raise EBold.CreateFmt(sLocatedAbstractError, [ClassName, 'AllocateData']); // do not localize + raise EBold.CreateFmt('%s.AllocateData is abstract. Implementation required', [ClassName]); end; function TBoldList.GetController: TBoldAbstractController; @@ -4882,41 +6654,84 @@ function TBoldList.GetController: TBoldAbstractController; function TBoldList.GetStringRepresentation(Representation: TBoldRepresentation): string; begin - result := ListController.GetStringRepresentation +{$IFDEF BOLDJSON} + if Representation = brJson then + Result := BoldElementToJsonString(Self) + else +{$ENDIF} + result := ListController.GetStringRepresentation end; procedure TBoldList.Clear; begin + if count = 0 then + exit; BoldClearLastFailure; PrepareClear; if mutable and not CanClear(nil) then - BoldRaiseLastFailure(self, 'Clear', ''); // do not localize - - // Speed optimizing -// if Derived and Deriver.IsDeriving then -// begin -// for i := count - 1 downto 0 do -// ListController.RemoveByIndex(i); -// end -// else -// begin - if assigned(BoldSYstem) then + BoldRaiseLastFailure(self, 'Clear', ''); + + if assigned(BoldSystem) then BoldSystem.StartTransaction; try InternalClear; - if assigned(BoldSYstem) then + if assigned(BoldSystem) then BoldSystem.CommitTransaction; except if assigned(BoldSYstem) then BoldSystem.RollbackTransaction; raise; end; -// end; end; -function TBoldList.Includes(Item: TBoldElement): Boolean; +function TBoldList.IndexOf(Item: TBoldElement): Integer; +begin + result := IndexOfElement(Item); +end; + +function TBoldList.Includes(Item: TBoldElement): Boolean; +begin + Result := IncludesElement(Item); +end; + +function TBoldList.IncludesAny(aList: TBoldList): Boolean; +var + i: integer; +begin + for i := 0 to aList.Count - 1 do + begin + if includes(aList[i]) then + begin + result := true; + exit; + end; + end; + result := false; +end; + +function TBoldList.IncludesAll(aList: TBoldList): Boolean; +var + i: integer; +begin + result := true; + for i := 0 to aList.Count - 1 do + begin + if not includes(aList[i]) then + begin + result := false; + exit; + end; + end; +end; + +procedure TBoldList.SetCapacity(const Value: integer); begin - Result := IncludesElement(Item); + ListController.Capacity := Value +end; + +function TBoldList.GetDuplicateMode: TBoldListDupMode; +begin + result := TBoldListDupMode(GetInternalState(BoldDuplicateModeMask, BoldDMShift)); end; procedure TBoldList.SetDuplicateMode(NewMode: TBoldListDupMode); @@ -4926,7 +6741,8 @@ procedure TBoldList.SetDuplicateMode(NewMode: TBoldListDupMode); begin OldMode := GetDuplicateMode; if (NewMode <> OldMode) and (NewMode = bldmMerge) then - begin // warning: Timecomplexity is O(n2) + begin + // TODO: This is very inefficient, improve it i := 0; while i < Count do begin @@ -4941,47 +6757,194 @@ procedure TBoldList.SetDuplicateMode(NewMode: TBoldListDupMode); inc(i); end; end; - SetInternalState(BoldDuplicateModeMask, BoldDMShift, Integer(NewMode)); end; -procedure TBoldList.Remove(Item: TBoldElement); +function TBoldList.HasDuplicates: boolean; +var + i, j: integer; + SortedList: TBoldList; + G: IBoldGuard; +begin + result := false; + if Count < 2 then + exit; + if DuplicateMode = bldmAllow then + begin + if Count < 10 then // actually test to determine the correct number + begin + // implementation fast enough for few elements + i := 0; + while i < Count do + begin + j := i + 1; + while j < Count do + begin + if Elements[i].IsEqual(Elements[j]) then + begin + result := true; + exit; + end + else + inc(j); + end; + inc(i); + end; + end + else + begin + // Clone, sort, then compare neighbouring values only + G := TBoldGuard.Create(SortedList); +// SortedList := Clone as TBoldList; + if Assigned(BoldType) then + SortedList := TBoldMemberFactory.CreateMemberFromBoldType(BoldType) as TBoldList + else + SortedList := TBoldMemberClass(ClassType).Create as TBoldList; + if SortedList is TBoldMemberList then + TBoldMemberList(SortedList).CloneMembers := true; // if CloneMembers = true then sorting messes up the list. + SortedList.AddList(self); + SortedList.Sort; + for i := 1 to SortedList.Count - 1 do + if SortedList[i].IsEqual(SortedList[i-1]) then + begin + result := true; + exit; + end; + end; + end; +end; + +procedure TBoldList.Remove(Item: TBoldElement; ARaiseIfNotFound: boolean); var I: Integer; begin + if not mutable then + MutableError('Remove'); EnsureContentsCurrent; I := IndexOf(Item); if I <> -1 then RemoveByIndex(I) else - raise EBold.CreateFmt(sItemNotInList, [ClassName]); + if ARaiseIfNotFound then + raise EBold.CreateFmt('%s.Remove: Item not in list', [ClassName]); +end; + +procedure TBoldList.Insert(index: Integer; Element: TBoldElement); +begin + if not mutable then MutableError('InsertElementToList'); + InsertElement(index, Element); end; procedure TBoldList.Add(Element: TBoldElement); begin if not mutable then - MutableError('AddToList'); // do not localize + MutableError('AddToList'); AddElement(Element); end; procedure TBoldList.AddList(List: TBoldList); var I: Integer; + vBoldSystem: TBoldSystem; begin - if not mutable then MutableError('AddListToList'); // do not localize - for I := 0 to List.Count - 1 do - AddElement(List[I]); + if not mutable then MutableError('AddListToList'); + i := List.Count; + if i > 0 then + begin + vBoldSystem := BoldSystem; + if Assigned(vBoldSystem) then + vBoldSystem.StartTransaction(stmNormal); + try + if (i > 4) then + begin + if DuplicateMode = bldmAllow then + Capacity := Count + i; + if i > Count then + Capacity := i; + end; + for I := 0 to i - 1 do + AddElement(List[I]); + if Assigned(vBoldSystem) then + vBoldSystem.CommitTransaction(stmNormal); + except + if Assigned(vBoldSystem) then + vBoldSystem.RollbackTransaction(stmNormal); + raise; + end; + end; end; -function TBoldList.IndexOf(Item: TBoldElement): Integer; +procedure TBoldList.RemoveList(List: TBoldList); +var + i, j: Integer; + vBoldSystem: TBoldSystem; begin - result := IndexOfElement(Item); + if not Mutable then MutableError('TBoldList.RemoveList'); // do not localize + EnsureContentsCurrent; + if Empty or List.Empty then + exit; + vBoldSystem := BoldSystem; + if Assigned(vBoldSystem) then + vBoldSystem.StartTransaction(stmNormal); + try + if List.Count < count then + for i := List.Count - 1 downto 0 do + begin + // IndexOf() is faster in BoldList, BoldMemberList, yet slower in BoldObjectList so we reimplement this method there + j := IndexOf(List[i]); + if j <> -1 then + RemoveByIndex(j); + end + else + begin + i := count - 1; + repeat + if List.Includes( Elements[i] ) then + begin + RemoveByIndex(i); + i := count - 1; // this a safeguard in case removing 1 element consequently removes others too + end + else + dec(i); + until i = -1 + end; + if Assigned(vBoldSystem) then + vBoldSystem.CommitTransaction(stmNormal); + except + if Assigned(vBoldSystem) then + vBoldSystem.RollbackTransaction(stmNormal); + raise; + end; end; -procedure TBoldList.Insert(index: Integer; Element: TBoldElement); +procedure TBoldList.IntersectList(List: TBoldList); +var + i, j: Integer; + vBoldSystem: TBoldSystem; begin - if not mutable then MutableError('InsertElementToList'); // do not localize - InsertElement(index, Element); + if not Mutable then MutableError('TBoldList.RemoveList'); // do not localize + EnsureContentsCurrent; + vBoldSystem := BoldSystem; + if Assigned(vBoldSystem) then + vBoldSystem.StartTransaction(stmNormal); + try + i := count - 1; + repeat + if not List.Includes( Elements[i] ) then + begin + RemoveByIndex(i); + i := count - 1; // this a safeguard in case removing 1 element consequently removes others too + end + else + dec(i); + until i = -1; + if Assigned(vBoldSystem) then + vBoldSystem.CommitTransaction(stmNormal); + except + if Assigned(vBoldSystem) then + vBoldSystem.RollbackTransaction(stmNormal); + raise; + end; end; function TBoldList.GetCanCreateNew: Boolean; @@ -4989,11 +6952,16 @@ function TBoldList.GetCanCreateNew: Boolean; result := CanModify and assigned(ListController) and ListController.CanCreateNew; end; +function TBoldList.GetCapacity: integer; +begin + result := ListController.Capacity; +end; + procedure TBoldList.EnsureCanCreateNew; begin BoldClearLastFailure; if not CanCreateNew then - BoldRaiseLastFailure(self, 'EnsureCanCreateNew', sCannotCreateNewElement); // do not localize + BoldRaiseLastFailure(self, 'EnsureCanCreateNew', 'Can''t create new element'); end; function TBoldList.CreateNew: TBoldElement; @@ -5002,6 +6970,13 @@ function TBoldList.CreateNew: TBoldElement; result := ListController.CreateNew; end; +constructor TBoldList.CreateWithTypeInfo(ElementTypeInfo: TBoldElementTypeInfo); +begin + if Assigned(ElementTypeInfo) and not (ElementTypeInfo is TBoldListTypeInfo) then + ElementTypeInfo := ElementTypeInfo.ListTypeInfo; + inherited; +end; + function TBoldList.AddNew: TBoldElement; begin result := InternalAddNew; @@ -5032,6 +7007,46 @@ procedure TBoldList.ToStringsWithNil(Representation: TBoldRepresentation; S: TSt AddToStrings(Representation, S); end; +function TBoldList.AsCommaText(AIncludeType: boolean; Representation: TBoldRepresentation; const ASeparator: string): string; +var + i: integer; + s: string; +begin + result := ''; + for I := 0 to Count - 1 do + begin + if Assigned(Elements[i]) then + begin + s := Elements[i].StringRepresentation[Representation]; + if AIncludeType then + s := Elements[i].ClassName + ':' + s; + end + else + s := 'nil'; + if i < count-1 then + s := s + ASeparator; + result := result + s; + end; +end; + +function TBoldList.AsDebugCommaText(const ASeparator: string = ','): string; +var + i: integer; + s: string; +begin + result := ''; + for I := 0 to Count - 1 do + begin + if Assigned(Elements[i]) then + s := Elements[i].DebugInfo + else + s := 'nil'; + if i < count-1 then + s := s + ASeparator; + result := result + s; + end; +end; + procedure TBoldList.GetAsList(ResultList: TBoldIndirectElement); begin ResultList.SetReferenceValue(Self); @@ -5039,47 +7054,88 @@ procedure TBoldList.GetAsList(ResultList: TBoldIndirectElement); procedure TBoldList.EnsureRange(FromIndex, ToIndex: integer); begin - // do nothing end; function TBoldList.canInsert(index: Integer; Element: TBoldElement; Subscriber: TBoldSubscriber): Boolean; begin +{$IFDEF BOLD_NO_QUERIES} + result := true; +{$ELSE} result := SendQuery(bqMayInsert, [index, Element], Subscriber); +{$ENDIF} end; function TBoldList.CanRemove(index: Integer; Subscriber: TBoldSubscriber): Boolean; begin +{$IFDEF BOLD_NO_QUERIES} + result := true; +{$ELSE} result := SendQuery(bqMayRemove, [index], Subscriber); +{$ENDIF} end; function TBoldList.CanMove(CurIndex, NewIndex: Integer; Subscriber: TBoldSubscriber = nil): Boolean; begin - result := (NewIndex >= 0) and (NewIndex < Count) and - SendQuery(bqMayMove, [CurIndex, NewIndex], Subscriber); + result := (NewIndex >= 0) and (NewIndex < Count); +{$IFNDEF BOLD_NO_QUERIES} + result := result and SendQuery(bqMayMove, [CurIndex, NewIndex], Subscriber); +{$ENDIF} end; function TBoldList.CanSet(index: Integer; Item: TBoldElement; Subscriber: TBoldSubscriber): Boolean; begin +{$IFDEF BOLD_NO_QUERIES} + result := true; +{$ELSE} result := SendQuery(bqMayReplace, [index, Item], Subscriber); +{$ENDIF} end; constructor TBoldMember.CreateWithTypeInfo(ElementTypeInfo: TBoldElementTypeInfo); begin - InitializeMember(nil, ElementTypeInfo); + inherited CreateWithOwner(nil); + InitializeNonObjectOwned(ElementTypeInfo); end; -procedure TBoldList.Sort(CompareFunc: TBoldElementCompare); +procedure TBoldList.Sort(CompareFunc: TBoldElementCompare; FirstIndex, + LastIndex: Integer; SortMode: TBoldSortMode = BoldDefaultSortMode); + + ////////////////////////////////////////////////////////////////////////////// + // Insertion Sort: // + // stable, inplace, but only fast on small lists // + ////////////////////////////////////////////////////////////////////////////// + procedure InsertSort(Left, Right: Integer; SCompare: TBoldElementCompare); + var + I, J: Integer; + T: TBoldElement; + begin + for I := Left + 1 to Right do begin + if SCompare(Elements[I], Elements[I - 1]) < 0 then begin + J := I; + T := Elements[J]; + while (J > Left) and (SCompare(T, Elements[J - 1]) < 0) do begin + Elements[J] := Elements[J - 1]; + Dec(J); + end; + Elements[J] := T; + end; + end; + end; - procedure QuickSort(L, R: Integer; - SCompare: TBoldElementCompare); + ////////////////////////////////////////////////////////////////////////////// + // Quick Sort: // + // fast, inplace (without help array), // + // but NOT stable (sorting changes within same elements) // + ////////////////////////////////////////////////////////////////////////////// + procedure QuickSort(Left, Right: Integer; SCompare: TBoldElementCompare); var I, J: Integer; P: TBoldElement; begin repeat - I := L; - J := R; - P := Elements[(L + R) shr 1]; + I := Left; + J := Right; + P := Elements[(Left + Right) shr 1]; repeat while SCompare(Elements[I], P) < 0 do Inc(I); @@ -5096,15 +7152,232 @@ procedure TBoldList.Sort(CompareFunc: TBoldElementCompare); Dec(J); end; until I > J; - if L < J then - QuickSort(L, J, SCompare); - L := I; - until I >= R; + if Left < J then + QuickSort(Left, J, SCompare); + Left := I; + until I >= Right; + end; + + ////////////////////////////////////////////////////////////////////////////// + // Merge Sort - Inplace Variant: // + // http://thomas.baudel.name/Visualisation/VisuTri/inplacestablesort.html // + // stable, inplace, but slower than Quicksort and normal Mergesort // + ////////////////////////////////////////////////////////////////////////////// + function Lower(Left, Right, Val: Integer; SCompare: TBoldElementCompare): + Integer; + var + iLen: Integer; + iHalf: Integer; + iMid: Integer; + begin + iLen := Right - Left; + while iLen > 0 do begin + iHalf := iLen div 2; + iMid := Left + iHalf; + if SCompare(Elements[iMid], Elements[Val]) < 0 then begin + Left := iMid + 1; + iLen := iLen - iHalf - 1; + end else begin + iLen := iHalf; + end; + end; + Result := Left; + end; + + function Upper(Left, Right, Val: Integer; SCompare: TBoldElementCompare): + Integer; + var + iLen: Integer; + iHalf: Integer; + iMid: Integer; + begin + iLen := Right - Left; + while iLen > 0 do begin + iHalf := iLen div 2; + iMid := Left + iHalf; + if SCompare(Elements[Val], Elements[iMid]) < 0 then begin + iLen := iHalf; + end else begin + Left := iMid + 1; + iLen := iLen - iHalf - 1; + end; + end; + Result := Left; + end; + + function GCD(M, N: Integer): Integer; + var + T: Integer; + begin + while (N <> 0) do begin + T := M mod N; + M := N; N := T; + end; + Result := M; + end; + + procedure Rotate(Left, Middle, Right: Integer; SCompare: TBoldElementCompare); + var + N: Integer; + SavedElement: TBoldElement; + Shift: Integer; + P1, P2: Integer; + begin + if (Left <> Middle) and (Right <> Middle) then begin + N := GCD(Right - Left, Middle - Left); + while N <> 0 do begin + Dec(N); + SavedElement := Elements[Left + N]; + Shift := Middle - Left; + P1 := Left + N; + P2 := Left + N + Shift; + while (P2 <> Left + N) do begin + Elements[P1] := Elements[P2]; + P1 := P2; + if Right - P2 > Shift then begin + Inc(P2, Shift); + end else begin + P2 := Left + (Shift - (Right - P2)); + end; + end; + Elements[P1] := SavedElement; + end; + end; + end; + + procedure MergeInplace(Left, Pivot, Right, Len1, Len2: Integer; SCompare: + TBoldElementCompare); + var + iFirstCut, iSecondCut: Integer; + iLen11, iLen22: Integer; + iNewMid: Integer; + begin + if (Len1 <> 0) and (Len2 <> 0) then begin + if Len1 + Len2 = 2 then begin + if SCompare(Elements[Pivot], Elements[Left]) < 0 then begin + if Pivot < Left then begin + Move(Pivot, Left); + Move(Left - 1, Pivot); + end else begin + Move(Left, Pivot); + Move(Pivot - 1, Left); + end; + end; + end else begin + if Len1 > Len2 then begin + iLen11 := Len1 div 2; + iFirstCut := Left + iLen11; + iSecondCut := Lower(Pivot, Right, iFirstCut, SCompare); + iLen22 := iSecondCut - Pivot; + end else begin + iLen22 := Len2 div 2; + iSecondCut := Pivot + iLen22; + iFirstCut := Upper(Left, Pivot, iSecondCut, SCompare); + iLen11 := iFirstCut - Left; + end; + Rotate(iFirstCut, Pivot, iSecondCut, SCompare); + iNewMid := iFirstCut + iLen22; + MergeInplace(Left, iFirstCut, iNewMid, iLen11, iLen22, SCompare); + MergeInplace(iNewMid, iSecondCut, Right, Len1 - iLen11, Len2 - iLen22, SCompare); + end; + end; + end; + + procedure MergeSortInplace(Left, Right: Integer; SCompare: TBoldElementCompare); + var + Middle: Integer; + begin + if Right - Left < 8 then begin + InsertSort(Left, Right, SCompare); + end else begin + Middle := (Left + Right) div 2; + MergeSortInplace(Left, Middle, SCompare); + MergeSortInplace(Middle, Right, SCompare); + MergeInplace(Left, Middle, Right, Middle - Left, Right - Middle, SCompare); + end; + end; + + ////////////////////////////////////////////////////////////////////////////// + // Merge Sort: // + // http://www.iti.fh-flensburg.de/lang/algorithmen/sortieren/merge/merge.htm// + // fastest, stable, // + // but not fully inplace (help array with only n/2 is needed) // + ////////////////////////////////////////////////////////////////////////////// + procedure DoMergeSort(var HelpArray: array of Pointer; Left, Right: Integer; + SCompare: TBoldElementCompare); + var + m: Integer; + i, j, k: Integer; + begin + if Left < Right then begin + if Right - Left < 4 then begin + InsertSort(Left, Right, SCompare); + end else begin + m := (Left + Right) div 2; + DoMergeSort(HelpArray, Left, m, SCompare); + DoMergeSort(HelpArray, m + 1, Right, SCompare); + + i := 0; + j := Left; + // Copy first half of elements in help array + while j <= m do begin + HelpArray[i] := Elements[j]; + Inc(i); + Inc(j); + end; + + i := 0; + k := Left; + // Copy back the next largest element + while (k < j) and (j <= Right) do begin + if SCompare(HelpArray[i], Elements[j]) <= 0 then begin + Elements[k] := HelpArray[i]; + Inc(i); + end else begin + Elements[k] := Elements[j]; + Inc(j); + end; + Inc(k); + end; + + // Copy back the rest of help array if existing + while k < j do begin + Elements[k] := HelpArray[i]; + Inc(k); + Inc(i); + end; + end; + end; end; + procedure MergeSort(Left, Right: Integer; SCompare: TBoldElementCompare); + var + HelpArray: array of Pointer; + begin + SetLength(HelpArray, (Count + 1) div 2); + DoMergeSort(HelpArray, FirstIndex, LastIndex, CompareFunc); + SetLength(HelpArray, 0); + end; + +begin + if Assigned(Self) and (Count > 1) then begin + case SortMode of + smQuickSort: QuickSort(FirstIndex, LastIndex, CompareFunc); + smMergeSort: MergeSort(FirstIndex, LastIndex, CompareFunc); + smMergeSortInplace: MergeSortInplace(FirstIndex, LastIndex, CompareFunc); + end; + end; +end; + +procedure TBoldList.Sort(CompareFunc: TBoldElementCompare; SortMode: + TBoldSortMode = BoldDefaultSortMode); +begin + Sort(CompareFunc, 0, Count - 1, SortMode); +end; + +procedure TBoldList.Sort; begin - if (self <> nil) and (Count > 0) then - QuickSort(0, Count - 1, CompareFunc); + Sort(DefaultCompare, 0, Count - 1); end; function TBoldList.DuplicateControl: Boolean; @@ -5115,32 +7388,71 @@ function TBoldList.DuplicateControl: Boolean; bldmMerge: Result := False; bldmError: - raise EBold.CreateFmt(sDuplicateInList, [ClassName]); + raise EBold.CreateFmt('%s.DuplicateControl: Duplicate value in list', [ClassName]); else - raise EBoldInternal.CreateFmt(sUnknownDuplicationMode, [ClassName]); + raise EBoldInternal.CreateFmt('%s.DuplicateControl: Unknown duplication mode', [ClassName]); end; end; -procedure TBoldList.InitializeMember(AOwningElement: TBoldDomainElement; - ElementTypeInfo: TBoldElementTypeInfo); +procedure TBoldList.Initialize; begin inherited; AllocateData; end; +function TBoldList.CompareToAs(CompType: TBoldCompareType; BoldElement: TBoldElement): Integer; +begin + if BoldElement is TBoldList then + begin + if TBoldList(BoldElement).Count <> Count then + result := -1 + else + if IncludesAll(TBoldList(BoldElement)) then + result := 0 + else + result := -1 + end + else + Result := inherited CompareToAs(CompType, BoldElement); +end; + function TBoldList.CanClear(Subscriber: TBoldSubscriber): Boolean; begin +{$IFDEF BOLD_NO_QUERIES} + result := true; +{$ELSE} result := SendQuery(bqMayClear, [], Subscriber); +{$ENDIF} end; -function TBoldList.GetDuplicateMode: TBoldListDupMode; +function TBoldList.DefaultCompare(Item1, Item2: TBoldElement): Integer; begin - result := TBoldListDupMode(GetInternalState(BoldDuplicateModeMask, BoldDMShift)); + Result := Item1.CompareTo(Item2); +end; + +function TBoldList.GetEnumerator: TBoldListEnumerator; +begin + result := TBoldListEnumerator.Create(Self); +end; + +function TBoldList.GetFirst: TBoldElement; +begin + if empty then + result := nil + else + result := Elements[0]; +end; + +function TBoldList.GetLast: TBoldElement; +begin + if empty then + result := nil + else + result := Elements[count-1]; end; procedure TBoldList.PrepareClear; begin - // do nothing end; procedure TBoldList.MakeContentsImmutable; @@ -5151,6 +7463,13 @@ procedure TBoldList.MakeContentsImmutable; Elements[I].MakeImmutable; end; +{ TBoldMemberListEnumerator } + +function TBoldMemberListEnumerator.GetCurrent: TBoldMember; +begin + Result := List[Index] as TBoldMember; +end; + { TBoldMemberList } procedure TBoldMemberList.AllocateData; @@ -5174,10 +7493,10 @@ procedure TBoldMemberList.Assign(Source: TBoldElement); I: Integer; begin if not (Source is TBoldMemberList) then - raise EBold.CreateFmt(sSourceNotBoldMemberList, [ClassName, Source.ClassName]); + raise EBold.CreateFmt('%s.Assign: Source is not a BoldMemberList (%s)', [ClassName, Source.ClassName]); SourceList := TBoldMemberList(Source); for I := 0 to SourceList.Count - 1 do - Add(SourceList[I]); // Addoperator will clone each element before adding to list + Add(SourceList[I]); end; procedure TBoldMemberList.AddElement(Element: TBoldElement); @@ -5185,11 +7504,11 @@ procedure TBoldMemberList.AddElement(Element: TBoldElement); EnsureContentsCurrent; BoldClearLastFailure; if not CanInsert(-1, Element, nil) then - BoldRaiseLastFailure(self, 'AddElement', ''); // do not localize + BoldRaiseLastFailure(self, 'AddElement', ''); if Element is TBoldMember then Add(TBoldMember(Element)) else - raise EBold.CreateFmt(sElementNotBoldMember, [ClassName, 'AddElement']); // do not localize + raise EBold.CreateFmt('%s.AddElement: Element not a TBoldMember', [ClassName]); end; procedure TBoldMemberList.InsertElement(index: Integer; Element: TBoldElement); @@ -5197,11 +7516,11 @@ procedure TBoldMemberList.InsertElement(index: Integer; Element: TBoldElement); EnsureContentsCurrent; BoldClearLastFailure; if not CanInsert(index, Element, nil) then - BoldRaiseLastFailure(self, 'InsertElement', ''); // do not localize + BoldRaiseLastFailure(self, 'InsertElement', ''); if Element is TBoldMember then Insert(index, TBoldMember(Element)) else - raise EBold.CreateFmt(sElementNotBoldMember, [ClassName, 'InsertElement']); // do not localize + raise EBold.CreateFmt('%s.InsertElement: Element not a TBoldMember', [ClassName]); end; function TBoldMemberList.GetElement(index: Integer): TBoldElement; @@ -5209,10 +7528,15 @@ function TBoldMemberList.GetElement(index: Integer): TBoldElement; EnsureContentsCurrent; BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, 'GetElement', ''); // do not localize + BoldRaiseLastFailure(self, 'GetElement', ''); Result := TBoldElement(List[index]); end; +function TBoldMemberList.GetEnumerator: TBoldMemberListEnumerator; +begin + result := TBoldMemberListEnumerator.Create(self) +end; + procedure TBoldMemberList.SetElement(index: Integer; Value: TBoldElement); begin EnsureContentsCurrent; @@ -5220,7 +7544,7 @@ procedure TBoldMemberList.SetElement(index: Integer; Value: TBoldElement); begin BoldClearLastFailure; if not CanSet(index, Value, nil) then - BoldRaiseLastFailure(self, 'SetElement', ''); // do not localize + BoldRaiseLastFailure(self, 'SetElement', ''); if CloneMembers then begin TBoldMember(List[index]).Free; @@ -5238,7 +7562,7 @@ function TBoldMemberList.GetCount: Integer; EnsureContentsCurrent; BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, 'GetCount', ''); // do not localize + BoldRaiseLastFailure(self, 'GetCount', ''); Result := List.Count; end; @@ -5263,8 +7587,8 @@ procedure TBoldMemberList.RemoveByIndex(index: Integer); function TBoldMemberList.GetBoldMember(index: Integer): TBoldMember; begin EnsureContentsCurrent; - Assert(Elements[index] is TBoldMember); Result := TBoldMember(Elements[index]); + Assert(Result is TBoldMember); end; procedure TBoldMemberList.SetBoldMember(index: Integer; Value: TBoldMember); @@ -5274,22 +7598,24 @@ procedure TBoldMemberList.SetBoldMember(index: Integer; Value: TBoldMember); procedure TBoldMemberList.Add(Item: TBoldMember); begin - if CloneMembers then - List.Add(TBoldMember(Item.Clone)) - else - if CheckAdd(Item) then + if CheckAdd(Item) then + begin + if CloneMembers then + List.Add(TBoldMember(Item.Clone)) + else List.Add(Item) + end; end; procedure TBoldMemberList.Move(CurIndex, NewIndex: Integer); begin - if not mutable then MutableError('MoveElementInList'); // do not localize + if not mutable then MutableError('MoveElementInList'); EnsureContentsCurrent; List.Move(CurIndex, NewIndex); Changed(beOrderChanged, []); end; -procedure TBoldMemberList.InternalAddWithoutCloning(Item: TBoldMember); // FIXME remove when TBoldClass no longer member +procedure TBoldMemberList.InternalAddWithoutCloning(Item: TBoldMember); begin List.Add(Item); end; @@ -5299,7 +7625,10 @@ procedure TBoldMemberList.Insert(index: Integer; Item: TBoldMember); if assigned(Item) then begin if CloneMembers then - List.Insert(index, TBoldMember(Item.Clone)) + begin + if CheckInsert(index, Item) then + List.Insert(index, TBoldMember(Item.Clone)); + end else begin if CheckInsert(index, Item) then @@ -5312,12 +7641,48 @@ procedure TBoldMemberList.Insert(index: Integer; Item: TBoldMember); function TBoldMemberList.GetStreamName: String; begin - raise EBoldFeatureNotImplementedYet.CreateFmt(sMethodNotImplemented, [ClassName, 'GetStreamName']); // do not localize + raise EBoldFeatureNotImplementedYet.CreateFmt('%s.GetStreamName: Not Implemented', [ClassName]); end; function TBoldMemberList.GetStringRepresentation(Representation: TBoldRepresentation): string; +var + sl: TStringList; +begin + sl := TStringList.Create; + try + ToStrings(Representation, sl); + result := sl.text; + finally + sl.free; + end; +end; + +procedure TBoldMemberList.SetStringRepresentation(Representation: integer; const NewValue: String); +var + sl: TStringList; + ElementTypeInfo: TBoldElementTypeInfo; + Element: TBoldElement; + i: integer; begin - result := IntToStr(Count); + ElementTypeInfo := (BoldType as TBoldListTypeInfo).ListElementTypeInfo; + self.Clear; + sl := TStringList.Create; + try + Sl.CommaText := NewValue; + for I := 0 to sl.count-1 do + begin + Element := ElementTypeInfo.CreateElement; + try + Element.AsString := sl[i]; + self.AddElement(Element); + finally + if CloneMembers then + Element.free; + end; + end; + finally + sl.free; + end; end; function TBoldMemberList.IndexOfElement(Item: TBoldElement): Integer; @@ -5333,31 +7698,55 @@ function TBoldMemberList.IncludesElement(Item: TBoldElement): Boolean; result := IndexOfElement(Item) <> -1; end; +function TBoldMemberList.IndexOfFirstEqualElement(Item: TBoldMember): Integer; +begin + if assigned(Item) then + for result := 0 to List.Count - 1 do + begin + if TBoldElement(List[result]).BoldType.ConformsTo(Item.BoldType) and TBoldElement(List[result]).IsEqual(Item) then + exit; + end; + result := -1; +end; + +function TBoldMemberList.IncludesValue(Item: TBoldElement): Boolean; +var + i: integer; +begin + result := false; + for I := 0 to Count - 1 do + if Elements[i].IsEqual(Item) then + begin + result := true; + exit; + end; +end; + +procedure TBoldMemberList.SetCapacity(const Value: integer); +begin + faList.Capacity := Value; +end; + procedure TBoldMemberList.SetCloneMembers(const Value: Boolean); begin if (count = 0) or (fCloneMembers = Value) then FCloneMembers := Value else - raise EBold.CreateFmt(sOnlyAllowedOnEmptyLists, [ClassName]); + raise EBold.CreateFmt('%s.SetCloneMembers: Only allowed on empty lists', [ClassName]); end; function TBoldMemberList.CheckAdd(NewMember: TBoldMember): Boolean; begin if (not Assigned(NewMember)) then Result := False // Adding nil does nothing - else if not Includes(NewMember) then - Result := True else - Result := DuplicateControl; + result := (DuplicateMode = bldmAllow) or not IncludesValue(NewMember) or DuplicateControl; end; function TBoldMemberList.CheckInsert(index: Integer; NewMember: TBoldMember): Boolean; begin assert(assigned(NewMember), 'nil not allowed, should have been filtered out before'); - if Includes(NewMember) then - Result := DuplicateControl - else - result := True; + result := (DuplicateMode = bldmAllow) or not IncludesValue(NewMember) or DuplicateControl; end; function TBoldMemberList.CheckReplace(index: Integer; NewMember: TBoldMember): Boolean; @@ -5373,8 +7762,7 @@ function TBoldMemberList.CheckReplace(index: Integer; NewMember: TBoldMember): B Result := DuplicateControl; end; -procedure TBoldMemberList.InitializeMember( - AOwningElement: TBoldDomainElement; ElementTypeInfo: TBoldElementTypeInfo); +procedure TBoldMemberList.Initialize; begin inherited; DuplicateMode := bldmAllow; @@ -5394,6 +7782,11 @@ function TBoldMemberList.GetCanCreateNew: Boolean; (TBoldListTypeInfo(BoldType).ListElementTypeInfo is TBoldAttributeTypeInfo); end; +function TBoldMemberList.GetCapacity: integer; +begin + result := faList.Capacity; +end; + function TBoldMemberList.InternalAddNew: TBoldElement; begin result := CreateNew; @@ -5405,9 +7798,10 @@ procedure TBoldMemberList.InsertNew(index: Integer); var Elem: TBoldElement; begin - Elem := CreateNew; - Assert(Elem is TBoldMember); + Elem := nil; try + Elem := CreateNew; + Assert(Elem is TBoldMember); Insert(index, TBoldMember(Elem)); if CloneMembers then FreeAndNil(Elem); @@ -5416,7 +7810,8 @@ procedure TBoldMemberList.InsertNew(index: Integer); raise end; end; -function TBoldMemberList.ProxyClass: TBoldMember_ProxyClass; + +function TBoldMemberList.GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin raise EBoldInternal.Create('No proxy for TBoldMemberList yet'); end; @@ -5429,21 +7824,54 @@ procedure TBoldMemberList.InternalClear; RemoveByIndex(I); end; + +{ TBoldObjectListEnumerator } + +function TBoldObjectListEnumerator.GetCurrent: TBoldObject; +begin + Result := List[Index] as TBoldObject; +end; + +{ TBoldObjectListLocatorEnumerator } + +function TBoldObjectListLocatorEnumerator.GetCurrent: TBoldObjectLocator; +begin + Result := TBoldObjectList(List).Locators[Index] as TBoldObjectLocator; +end; + { TBoldObjectList } -constructor TBoldObjectList.CreateTypedList(ObjectClass: TBoldObjectClass); +constructor TBoldObjectList.CreateTypedList(ObjectClass: TBoldObjectClass; ABoldSystem: TBoldSystem); var aSystem: TBoldSystem; ClassTypeInfo: TBoldClassTypeInfo; begin - aSystem := TBoldSystem.DefaultSystem; + inherited CreateWithOwner(ABoldSystem); + if Assigned(ABoldSystem) then + aSystem := ABoldSystem + else + aSystem := TBoldSystem.DefaultSystem; if not assigned(aSystem) then - raise EBold.CreateFmt(sCannotFindSystem, [classname]); + raise EBold.CreateFmt('%s.CreateTypedList: Can not find system', [classname]); ClassTypeInfo := aSystem.BoldSystemTypeInfo.TopSortedClasses.ItemsByObjectClass[ObjectClass]; if not assigned(ClassTypeInfo) then - raise EBold.CreateFmt(sClassIsNotBusinessClass, [classname, ObjectClass.ClassName]); + raise EBold.CreateFmt('%s.CreateTypedList: %s is not a business class', [classname, ObjectClass.ClassName]); + InitializeNonObjectOwned(ClassTypeInfo.ListTypeInfo); +end; - InitializeMember(nil, aSystem.BoldSystemTypeInfo.ListTypeInfoByElement[ClassTypeInfo]); +constructor TBoldObjectList.CreateRootClassList(ABoldSystem: TBoldSystem); +var + aSystem: TBoldSystem; + ClassTypeInfo: TBoldClassTypeInfo; +begin + if Assigned(ABoldSystem) then + aSystem := ABoldSystem + else + aSystem := TBoldSystem.DefaultSystem; + if not assigned(aSystem) then + raise EBold.CreateFmt('%s.CreateRootClassList: Can not find system', [classname]); + ClassTypeInfo := aSystem.BoldSystemTypeInfo.TopSortedClasses[0]; + CreateWithTypeInfo(ClassTypeInfo.ListTypeInfo); end; procedure TBoldObjectList.AllocateData; @@ -5453,15 +7881,19 @@ procedure TBoldObjectList.AllocateData; function TBoldObjectList.InternalAddNew: TBoldElement; var Obj: TBoldObject; + aSystem: TBoldSystem; begin - Result := CreateNew; - Obj := result as TBoldObject; - Obj.BoldSystem.StartTransaction; + aSystem := FindASystem; + if not assigned(aSystem) then + raise EBold.CreateFmt('%s.InternalAddNew: Can not find system', [classname]); + aSystem.StartTransaction; try + Result := CreateNew; + Obj := result as TBoldObject; Add(Obj); - Obj.BoldSystem.CommitTransaction; + aSystem.CommitTransaction; except - Obj.BoldSystem.RollBackTransaction; + aSystem.RollBackTransaction; raise; end; end; @@ -5469,14 +7901,18 @@ function TBoldObjectList.InternalAddNew: TBoldElement; procedure TBoldObjectList.InsertNew(index: Integer); var Obj: TBoldObject; + aSystem: TBoldSystem; begin - Obj := CreateNew as TBoldObject; - Obj.BoldSystem.StartTransaction; + aSystem := FindASystem; + if not assigned(aSystem) then + raise EBold.CreateFmt('%s.InsertNew: Can not find system', [classname]); + aSystem.StartTransaction; try + Obj := CreateNew as TBoldObject; Insert(index, Obj); - Obj.BoldSystem.CommitTransaction; + aSystem.CommitTransaction; except - Obj.BoldSystem.RollBackTransaction; + aSystem.RollBackTransaction; raise; end; end; @@ -5499,22 +7935,73 @@ procedure TBoldObjectList.AddElement(Element: TBoldElement); if Element is TBoldObject then AddLocator(TBoldObject(Element).BoldObjectLocator) else - raise EBold.CreateFmt(sElementNotBoldObject, [ClassName, 'AddElement']); // do not localize + if Element is TBoldObjectReference then + AddLocator(TBoldObjectReference(Element).Locator) + else + if Element is TBoldObjectList then + AddList(TBoldObjectList(Element)) + else + raise EBold.CreateFmt('%s.AddElement: Element %s is not a TBoldObject', [ClassName, Element.ClassName]); end; end; procedure TBoldObjectList.AddList(List: TBoldList); var - I: Integer; + i,j: Integer; ObjectList: TBoldObjectList; + vDuplicateMode: TBoldListDupMode; + vBoldSystem: TBoldSystem; begin if not mutable then - MutableError('AddListToList'); // do not localize + MutableError('AddListToList'); if not (List is TBoldObjectList) then - raise EBold.CreateFmt(sListNotObjectList, [ClassName]); - ObjectList := List as TBoldObjectList; - for I := 0 to ObjectList.Count - 1 do - AddLocator(ObjectList.Locators[I]); + raise EBold.CreateFmt('%s.AddList: List not a TBoldObjectList', [ClassName]); + i := List.Count; + if i > 0 then + begin + BeginUpdate; + try + vBoldSystem := BoldSystem; + if Assigned(vBoldSystem) then + vBoldSystem.StartTransaction(stmNormal); + try + if (i > 4) then + begin + if DuplicateMode = bldmAllow then + Capacity := Count + i; + if i > Count then + Capacity := i; + end; + vDuplicateMode := DuplicateMode; + try + if (Count = 0) and (List.DuplicateMode <> bldmAllow) then + DuplicateMode := bldmAllow; + ObjectList := List as TBoldObjectList; + j := 0; + while (j < i) do + begin + AddLocator(ObjectList.Locators[j]); + if i = List.count then + inc(j) + else // source list changed, we assume that current element has been removed + begin + i := List.count; + end; + end; + finally + SetInternalState(BoldDuplicateModeMask, BoldDMShift, Integer(vDuplicateMode)); + end; + if Assigned(vBoldSystem) then + vBoldSystem.CommitTransaction(stmNormal); + except + if Assigned(vBoldSystem) then + vBoldSystem.RollbackTransaction(stmNormal); + raise; + end; + finally + EndUpdate; + end; + end; end; procedure TBoldObjectList.InsertElement(index: Integer; Element: TBoldElement); @@ -5524,22 +8011,13 @@ procedure TBoldObjectList.InsertElement(index: Integer; Element: TBoldElement); if Element is TBoldObject then InsertLocator(index, TBoldObject(Element).BoldObjectLocator) else - raise EBold.CreateFmt(sElementNotBoldObject, [ClassName, 'InsertElement']); // do not localize + raise EBold.CreateFmt('%s.InsertElement: Element not a TBoldObject', [ClassName]); end; end; function TBoldObjectList.GetElement(index: Integer): TBoldElement; -var - aLocator: TBoldObjectLocator; begin - aLocator := GetLocator(index); - if Assigned(aLocator) then - begin - aLocator.EnsureBoldObject; - Result := aLocator.BoldObject; - end - else - Result := nil; + Result := GetLocator(index).EnsuredBoldObject; end; procedure TBoldObjectList.SetElement(index: Integer; Value: TBoldElement); @@ -5547,9 +8025,9 @@ procedure TBoldObjectList.SetElement(index: Integer; Value: TBoldElement); if Value is TBoldObject then SetLocator(index, TBoldObject(Value).BoldObjectLocator) else if not assigned(Value) then - raise EBold.CreateFmt(sElementIsNil, [classname]) + raise EBold.CreateFmt('%s.SetElement: Element is nil', [classname]) else - raise EBold.CreateFmt(sElementNotBoldObject, [classname, 'SetElement']); // do not localize + raise EBold.CreateFmt('%s.SetElement: Element not a TBoldObject', [classname]); end; function TBoldObjectList.IndexOfElement(Item: TBoldElement): Integer; @@ -5573,16 +8051,20 @@ function TBoldObjectList.GetCount: Integer; EnsureContentsCurrent; BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, 'GetCount', ''); // do not localize + BoldRaiseLastFailure(self, 'GetCount', ''); result := ListController.GetCount; end; function TBoldObjectList.GetLocator(index: Integer): TBoldObjectLocator; + procedure InternalRaise(self: TBoldObjectList); inline; + begin + BoldRaiseLastFailure(self, 'GetLocator', ''); + end; begin EnsureContentsCurrent; BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, 'GetLocator', ''); // do not localize + InternalRaise(self); result := ObjectListController.GetLocator(index); end; @@ -5592,11 +8074,27 @@ procedure TBoldObjectList.Assign(Source: TBoldElement); I: Integer; begin if not (Source is TBoldObjectList) then - raise EBold.CreateFmt(sSourceNotObjectList, [ClassName, Source.ClassName]); + raise EBold.CreateFmt('%s.Assign: Source is not a TBoldObjectList (%s)', [ClassName, Source.ClassName]); SourceList := TBoldObjectList(Source); - Clear; - for i := SourceList.Count - 1 downto 0 do // WARNING: TimeComplexity O2? How to ensure correct order when looping down? /Joho - InsertLocator(0, SourceList.Locators[I]); + if assigned(BoldSystem) then + BoldSystem.StartTransaction; + try + InternalClear; + Capacity := SourceList.Count; + if DuplicateMode = bldmAllow then + with ObjectListController do // using With ObjectListController skips the duplicate check on Insert + for i := SourceList.Count - 1 downto 0 do + InsertLocator(0, SourceList.Locators[I]) + else + for i := SourceList.Count - 1 downto 0 do + InsertLocator(0, SourceList.Locators[I]); + if assigned(BoldSystem) then + BoldSystem.CommitTransaction; + except + if assigned(BoldSystem) then + BoldSystem.RollbackTransaction; + raise; + end; end; procedure TBoldObjectList.SetLocator(index: Integer; NewLocator: TBoldObjectLocator); @@ -5606,7 +8104,7 @@ procedure TBoldObjectList.SetLocator(index: Integer; NewLocator: TBoldObjectLoca begin BoldClearLastFailure; if not CanSetLocator(index, NewLocator, nil) then - BoldRaiseLastFailure(self, 'SetLocator', ''); // do not localize + BoldRaiseLastFailure(self, 'SetLocator', ''); ObjectListController.SetLocator(index, NewLocator); end else @@ -5624,6 +8122,40 @@ procedure TBoldObjectList.SetBoldObject(index: Integer; NewObject: TBoldObject); SetElement(index, NewObject); end; +function TBoldObjectList.CheckAdd(NewLocator: TBoldObjectLocator): Boolean; +begin + if not Assigned(NewLocator) then + Result := False + else if OwnedByObject and (BoldSystem <> NewLocator.BoldSystem) then + result := false + else + Result := (DuplicateMode = bldmAllow) or not ObjectListController.IncludesLocator(NewLocator) or DuplicateControl; +end; + +function TBoldObjectList.CheckReplace(index: Integer; NewLocator: TBoldObjectLocator): Boolean; +begin + if not assigned(NewLocator) then + result := false + else if OwnedByObject and (BoldSystem <> NewLocator.BoldSystem) then + result := false + else if not ObjectListController.IncludesLocator(NewLocator) then + Result := True + else if IndexOfLocator(NewLocator) = index then + Result := False + else + Result := DuplicateControl; +end; + +function TBoldObjectList.CheckInsert(index: Integer; + NewLocator: TBoldObjectLocator): Boolean; +begin + assert(assigned(NewLocator), 'nil not allowed, should have been filtered out before'); + if OwnedByObject and (BoldSystem <> NewLocator.BoldSystem) then + result := false + else + Result := (DuplicateMode = bldmAllow) or not ObjectListController.IncludesLocator(NewLocator) or DuplicateControl; +end; + procedure TBoldObjectList.AddLocator(NewLocator: TBoldObjectLocator); begin EnsureContentsCurrent; @@ -5631,7 +8163,7 @@ procedure TBoldObjectList.AddLocator(NewLocator: TBoldObjectLocator); begin BoldClearLastFailure; if not CanInsertLocator(-1, NewLocator, nil) then - BoldRaiseLastFailure(self, 'AddLocator', ''); // do not localize + BoldRaiseLastFailure(self, 'AddLocator', ''); ObjectListController.AddLocator(NewLocator); end; end; @@ -5643,10 +8175,12 @@ procedure TBoldObjectList.Add(BoldObject: TBoldObject); procedure TBoldObjectList.Move(CurIndex, NewIndex: Integer); begin - if not mutable then MutableError('MoveElementInList'); // do not localize + if CurIndex = NewIndex then + exit; + if not mutable then MutableError('MoveElementInList'); BoldClearLastFailure; if not CanMove(CurIndex, NewIndex, nil) then - BoldRaiseLastFailure(self, 'Move', ''); // do not localize + BoldRaiseLastFailure(self, 'Move', ''); EnsureContentsCurrent; ListController.Move(CurIndex, NewIndex); end; @@ -5658,9 +8192,9 @@ procedure TBoldObjectList.InsertLocator(index: Integer; Locator: TBoldObjectLoca begin if CheckInsert(index, Locator) then begin - BoldClearLastFailure; + BoldClearLastFailure; if not CanInsertLocator(index, Locator, nil) then - BoldRaiseLastFailure(self, 'InsertLocator', ''); // do not localize + BoldRaiseLastFailure(self, 'InsertLocator', ''); ObjectListController.InsertLocator(index, Locator) end else @@ -5689,15 +8223,24 @@ procedure TBoldObjectList.RemoveByIndex(index: Integer); if not mutable then MutableError(IntToStr(index)); BoldClearLastFailure; if not CanRemove(index, nil) then - BoldRaiseLastFailure(self, 'RemoveByIndex', ''); // do not localize + BoldRaiseLastFailure(self, 'RemoveByIndex', ''); InternalRemoveByIndex(index); end; +procedure TBoldObjectList.RemoveLocator(ALocator: TBoldObjectLocator); +var + i: integer; +begin + i := IndexOfLocator(ALocator); + if i <> -1 then + RemoveByIndex(i); +end; + function TBoldObjectList.IndexOfLocator(Locator: TBoldObjectLocator): Integer; begin BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, 'IndexOfLocator', ''); // do not localize + BoldRaiseLastFailure(self, 'IndexOfLocator', ''); EnsureContentsCurrent; result := ObjectListController.IndexOfLocator(Locator); end; @@ -5707,44 +8250,110 @@ function TBoldObjectList.Includes(BoldObject: TBoldObject): Boolean; result := IncludesElement(BoldObject); end; +function TBoldObjectList.LeastCommonClassType(ABoldSystem: TBoldSystem): TBoldClassTypeInfo; +var + i: integer; + vSystemTypeInfo: TBoldSystemTypeInfo; +begin + Result := nil; + if Empty then + exit; + if not Assigned(ABoldSystem) then + begin + ABoldSystem := BoldObjects[0].BoldSystem; + end; + vSystemTypeInfo := ABoldSystem.BoldSystemTypeInfo; + Result := Locators[0].BoldClassTypeInfo; + for i := 1 to Count - 1 do + Result := Result.LeastCommonSuperClass(Locators[i].BoldClassTypeInfo); +end; + function TBoldObjectList.LocatorInList(NewLocator: TBoldObjectLocator): Boolean; begin BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, 'LocatorInList', ''); // do not localize + BoldRaiseLastFailure(self, 'LocatorInList', ''); EnsureContentsCurrent; result := ObjectListController.IncludesLocator(NewLocator); end; -function TBoldObjectList.CreateObjectIdList: TBoldObjectIdList; +function TBoldObjectList.CreateObjectIdList(WithoutDuplicates: boolean): TBoldObjectIdList; var I: Integer; begin Result := TBoldObjectIdList.Create; + Result.Capacity := Count; for I := 0 to Count - 1 do - Result.Add(Locators[I].BoldObjectID); + if WithoutDuplicates and (DuplicateMode = bldmAllow) then + Result.AddIfNotInList(Locators[I].BoldObjectID) + else + Result.Add(Locators[I].BoldObjectID); end; procedure TBoldObjectList.FillFromIDList(ObjectIdList: TBoldObjectIdList; BoldSystem: TBoldSystem); var I: Integer; begin - for I := 0 to ObjectIdList.Count - 1 do - AddLocator(BoldSystem.EnsuredLocatorByID[ObjectIdList[I]]); + if ObjectIdList.Count > 0 then + begin + Assert(ObjectListController is TBoldObjectListController, 'TBoldObjectList.FillFromIDList: Unsupported Controller: ' + ObjectListController.ClassName); + Capacity := ObjectIdList.Count; + if BeginUpdate then + try + for I := 0 to ObjectIdList.Count - 1 do + AddLocator(BoldSystem.EnsuredLocatorByID[ObjectIdList[I]]); + finally + EndUpdate; + end; + end; end; -function TBoldObjectList.GetByIndex(MemberList: TBoldMemberList): TBoldObject; +function TBoldObjectList.FilterOnType(BoldClassTypeInfo: TBoldClassTypeInfo; IncludeSubclasses: boolean): TBoldObjectList; +var + I: Integer; + iTopSortedIndex: Integer; + SystemTypeInfo: TBoldSystemTypeInfo; +begin + result := TBoldObjectList.Create; + result.DuplicateMode := bldmAllow; + iTopSortedIndex := BoldClassTypeInfo.TopSortedIndex; + SystemTypeInfo := BoldClassTypeInfo.SystemTypeInfo; + EnsureObjects; + for I := 0 to Count - 1 do + begin + if (Locators[I].BoldObjectID.TopSortedIndex = iTopSortedIndex) or (IncludeSubclasses + and Locators[I].BoldClassTypeInfo.BoldIsA(BoldClassTypeInfo)) then + Result.AddLocator(Locators[I]); + end; +end; + +procedure TBoldObjectList.RemoveDeletedObjects; +var + idList: TBoldObjectIdList; + i: integer; begin - result := GetByIndexAndSubscribe(MemberList, nil); + if not Assigned(BoldSystem) then + raise EBold.CreateFmt('%s.RemoveDeletedObjects: BoldSystem is needed to remove deleted objects.', [ClassName]); + EnsureContentsCurrent; + idList := CreateObjectIdList; + try + BoldSystem.RemoveDeletedObjects(IdList); + for I := count -1 downto 0 do + if not idList.Includes(self[i]) then + self.RemoveByIndex(i); + finally + idList.Free; + end; end; function TBoldObjectList.GetByIndexAndSubscribe(MemberList: TBoldMemberList; Subscriber: TBoldSubscriber): TBoldObject; var Locator: TBoldObjectLocator; begin + EnsureContentsCurrent; //PATCH - Needs to call makedbcurrent or calculate derivied link if invalid!!! BoldClearLastFailure; if not CanRead(nil) then - BoldRaiseLastFailure(self, 'GetByIndex', ''); // do not localize + BoldRaiseLastFailure(self, 'GetByIndex', ''); Locator := ObjectListController.GetLocatorByQualifiersAndSubscribe(MemberList, Subscriber); if Assigned(Locator) then result := Locator.EnsuredBoldObject @@ -5752,6 +8361,11 @@ function TBoldObjectList.GetByIndexAndSubscribe(MemberList: TBoldMemberList; Sub Result := nil; end; +function TBoldObjectList.GetByIndex(MemberList: TBoldMemberList): TBoldObject; +begin + result := GetByIndexAndSubscribe(MemberList, nil); +end; + function TBoldObjectList.VerifyClass(aLocator: TBoldObjectLocator): Boolean; var AllowedClass, KnownClass: TBoldClassTypeInfo; @@ -5762,26 +8376,27 @@ function TBoldObjectList.VerifyClass(aLocator: TBoldObjectLocator): Boolean; Assert(TBoldListTypeInfo(BoldType).ListElementTypeInfo is TBoldClassTypeInfo); Assert(BoldType.SystemTypeInfo is TBoldSystemTypeInfo); AllowedClass := TBoldClassTypeInfo(TBoldListTypeInfo(BoldType).ListElementTypeInfo); - KnownClass := TBoldSystemTypeInfo(BoldType.SystemTypeInfo).TopSortedClasses[aLocator.BoldObjectId.TopSortedIndex]; - if KnownClass.ConformsTo(AllowedClass) then - Result := true - else if aLocator.BoldObjectId.TopSortedIndexExact then - Result := false - else // if it looks wrong, but the classID is inexact, then we will allow it if it _could_ be right... - Result := AllowedClass.ConformsTo(knownclass); - if not result then - SetBoldLastFailureReason(TBoldFailureReason.CreateFmt(sItemNotAllowedInList, [KnownClass.ExpressionName, AllowedClass.ExpressionName], self)); + if AllowedClass.TopSortedIndex = 0 then // it's the root class so we allow anything + begin + Result := True; + end + else + begin + KnownClass := aLocator.BoldClassTypeInfo; + if KnownClass.ConformsTo(AllowedClass) then + Result := true + else if aLocator.BoldObjectId.TopSortedIndexExact then + Result := false + else + Result := AllowedClass.ConformsTo(knownclass); + if not result then + SetBoldLastFailureReason(TBoldFailureReason.CreateFmt('Can not put a %s in a %sList', [aLocator.debuginfo, self.debuginfo], self)); + end; end else result := true; end; -function TBoldObjectList.GetObjectListController: TBoldAbstractObjectListController; -begin - Assert(ListController is TBoldAbstractObjectListController); - Result := TBoldAbstractObjectListController(ListController) -end; - function TBoldObjectList.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; begin assert(assigned(ListController)); @@ -5800,41 +8415,58 @@ function TBoldObjectList.GetStreamName: String; Result := ObjectListController.StreamName; end; -procedure TBoldObjectList.EnsureObjects; +function TBoldObjectList.GetFreeStandingClass: TBoldFreeStandingElementClass; begin - EnsureRange(0, Count - 1); + Result := ObjectListController.GetFreeStandingClass; end; procedure TBoldObjectList.EnsureRange(FromIndex, ToIndex: integer); -var - FetchList: TBoldObjectList; - i: integer; - aSystem: TBoldSystem; - Locator: TBoldObjectLocator; - function RestrictRange(value, min, max: integer): integer; - begin - if value < min then - result := min - else if value > max then - result := max - else - result := value; - end; -begin - if Count > 0 then - begin - aSystem := nil; - FetchList := TBoldObjectList.Create; + procedure CheckObjects(min, max: integer); + var + FetchList: TBoldObjectList; + i: integer; + aSystem: TBoldSystem; + Locator: TBoldObjectLocator; + FullRange: boolean; + begin + aSystem := self.BoldSystem; + FetchList := nil; + FullRange := Count = max-min+1; + if FullRange then + begin + for i := min to max do + begin // first pass check if empty + if not assigned(aSystem) then + aSystem := Locators[i].BoldSystem; + if Assigned(Locators[i].BoldObject) then + begin + FullRange := false; + break + end; + end; + if FullRange and assigned(aSystem) then + begin + aSystem.SystemPersistenceHandler.FetchList(self); + exit; + end; + end; try - for i := RestrictRange(FromIndex, 0, count - 1) to RestrictRange(ToIndex, 0, count - 1) do + aSystem := nil; + for i := min to max do begin Locator := Locators[i]; - if not assigned(Locator.BoldObject) (*or - Locator.BoldObject.EffectiveInvalid*) then + // "or Locator.BoldObject.EffectiveInvalid" was commented out, but has been uncommented + if (not assigned(Locator.BoldObject) or Locator.BoldObject.EffectiveInvalid) and not Locator.BoldObjectID.NonExisting then begin if not assigned(aSystem) then + begin aSystem := Locator.BoldSystem; + FetchList := TBoldObjectList.Create; + FetchList.SubscribeToObjectsInList := false; + FetchList.DuplicateMode := bldmAllow; + FetchList.Capacity := max-min+1; + end; assert(Locator.BoldSystem = aSystem); FetchList.AddLocator(Locator); end; @@ -5842,19 +8474,41 @@ procedure TBoldObjectList.EnsureRange(FromIndex, ToIndex: integer); if assigned(aSystem) then aSystem.SystemPersistenceHandler.FetchList(FetchList); finally - FetchList.Free; + FreeAndNil(FetchList); end; end; + + function RestrictRange(value, min, max: integer): integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + begin + if value < min then + result := min + else if value > max then + result := max + else + result := value; + end; +var + vCount, x,y: integer; +begin + vCount := count; + if vCount = 0 then + exit; + x := RestrictRange(FromIndex, 0, vCount - 1); + y := RestrictRange(ToIndex, 0, vCount - 1); + CheckObjects(x,y); +end; + +procedure TBoldObjectList.EnsureObjects; +begin + EnsureRange(0, Count - 1); end; function TBoldObjectList.CanInsertLocator(index: Integer; Locator: TBoldObjectLocator; Subscriber: TBoldSubscriber): Boolean; begin - if not assigned(locator) then - result := false - else if ownedByObject and (locator.BoldSystem <> OwningObject.BoldSystem) then - result := false - else - result := VerifyClass(Locator) and SendQuery(bqMayInsert, [index, Locator], Subscriber); + result := VerifyClass(Locator); +{$IFNDEF BOLD_NO_QUERIES} + result := result and SendQuery(bqMayInsert, [index, Locator], Subscriber); +{$ENDIF} end; function TBoldObjectList.CanInsert(index: Integer; Element: TBoldElement; Subscriber: TBoldSubscriber): Boolean; @@ -5873,67 +8527,27 @@ function TBoldObjectList.CanSet(index: Integer; Element: TBoldElement; Subscribe function TBoldObjectList.CanSetLocator(index: Integer; Locator: TBoldObjectLocator; Subscriber: TBoldSubscriber): Boolean; begin - if not assigned(locator) then - result := false - else if ownedByObject and (locator.BoldSystem <> OwningObject.BoldSystem) then - result := false - else - result := VerifyClass(Locator) and SendQuery(bqMayReplace, [index, Locator], Subscriber); + result := VerifyClass(Locator); +{$IFNDEF BOLD_NO_QUERIES} + result := result and SendQuery(bqMayReplace, [index, Locator], Subscriber); +{$ENDIF} end; constructor TBoldObjectList.InternalCreateClassList(System: TBoldSystem; ListTypeInfo: TBoldListTypeInfo); begin - InitializeMember(System, ListTypeInfo); - DuplicateMode := bldmMerge; + inherited CreateWithOwner(system); + InitializeNonObjectOwned(ListTypeInfo); + SetInternalState(BoldDuplicateModeMask, BoldDMShift, Integer(bldmMerge{bldmError})); InitializeStateToInvalid; end; -function TBoldObjectList.CheckAdd(NewLocator: TBoldObjectLocator): Boolean; -begin - if not Assigned(NewLocator) then - Result := False // Adding nil does nothing - else if assigned(OwningObject) and (OwningObject.BoldSystem <> NewLocator.BoldSystem) then - result := false - else if not ObjectListController.IncludesLocator(NewLocator) then // LocatorInList ensures current, and we don't want that - Result := True - else - Result := DuplicateControl; -end; - -function TBoldObjectList.CheckReplace(index: Integer; NewLocator: TBoldObjectLocator): Boolean; -begin - if not assigned(NewLocator) then - result := false - else if assigned(OwningObject) and (OwningObject.BoldSystem <> NewLocator.BoldSystem) then - result := false - else if not ObjectListController.IncludesLocator(NewLocator) then - Result := True - else if IndexOfLocator(NewLocator) = index then - Result := False - else - Result := DuplicateControl; -end; - -function TBoldObjectList.CheckInsert(index: Integer; - NewLocator: TBoldObjectLocator): Boolean; -begin - assert(assigned(NewLocator), 'nil not allowed, should have been filtered out before'); - if assigned(OwningObject) and (OwningObject.BoldSystem <> NewLocator.BoldSystem) then - result := false - else if ObjectListController.IncludesLocator(NewLocator) then - result := DuplicateControl - else - result := True; -end; - -procedure TBoldObjectList.InitializeMember( - AOwningElement: TBoldDomainElement; ElementTypeInfo: TBoldElementTypeInfo); +procedure TBoldObjectList.Initialize; begin - inherited InitializeMember(AOwningElement, ElementTypeInfo); + inherited Initialize; DuplicateMode := bldmMerge; if not assigned(BoldMemberRTInfo) then begin - if assigned(AOwningElement) and (AOwningElement is TBoldSystem) then + if assigned(OwningElement) and (OwningElement is TBoldSystem) then ListController := TBoldClassListController.Create(Self) else begin @@ -5953,7 +8567,7 @@ procedure TBoldObjectList.InitializeMember( else ListController := TBoldDirectMultiLinkController.Create(Self) else - raise EBold.CreateFmt(sCannotCreateController, [ClassName]); + raise EBold.CreateFmt('%s.InitializeMember: Cannot create controller. Unknown Type.', [ClassName]); end; end; @@ -5975,13 +8589,12 @@ procedure TBoldObjectList.SetSubscribeToObjectsInList(const Value: Boolean); if value <> SubscribeToObjectsInList then begin SetElementFlag(befSubscribeToObjectsInList, value); - // the other subscription flag might be set... - (ListController as TBoldObjectListController).DropSubscriptions; // FIXME add to abstract controller - (ListController as TBoldObjectListController).Resubscribe; // FIXME add to abstract controller + (ListController as TBoldObjectListController).DropSubscriptions; + (ListController as TBoldObjectListController).Resubscribe; end; end else - raise EBold.CreateFmt(sCanOnlyChangeForStandAloneLists, [ClassName, 'SetSubscribeToObjectsInList']); // do not localize + raise EBold.CreateFmt('%s.SetSubscribeToObjectsInList: You can only change this property for stand-alone object lists', [ClassName]); end; function TBoldObjectList.GetSubscribeToLocatorsInList: Boolean; @@ -5996,18 +8609,68 @@ procedure TBoldObjectList.SetSubscribeToLocatorsInList(const Value: Boolean); if value <> SubscribeToLocatorsInList then begin SetElementFlag(befSubscribeToLocatorsInList, value); - // the other subscription flag might be set... (ListController as TBoldObjectListController).DropSubscriptions; (ListController as TBoldObjectListController).Resubscribe; end; end else - raise EBold.CreateFmt(sCanOnlyChangeForStandAloneLists, [ClassName, 'SetSubscribeToLocatorsInList']); // do not localize + raise EBold.CreateFmt('%s.SetSubscribeToLocatorsInList: You can only change this property for stand-alone object lists', [ClassName]); +end; + +function TBoldObjectList.Clone(ACopyDuplicateMode: boolean; ASubscribeToObjectsInList: boolean): TBoldMember; + + procedure FastAddList(AList: TBoldObjectList); + var + I: Integer; + vController: TBoldAbstractObjectListController; + begin + vController := ObjectListController as TBoldAbstractObjectListController; + TBoldObjectList(result).Capacity := AList.Count; + if TBoldObjectList(result).BeginUpdate then + try + with TBoldObjectList(result).ObjectListController do + for I := 0 to AList.Count - 1 do + AddLocator(vController.GetLocator(i)); + finally + TBoldObjectList(result).EndUpdate; + end; + end; + + +begin + if Assigned(BoldType) then + Result := TBoldMemberFactory.CreateMemberFromBoldType(BoldType) + else + Result := TBoldMemberClass(ClassType).Create; + if assigned(BoldSystem) then + BoldSystem.StartTransaction; + try + Result.BoldPersistenceState := bvpsTransient; + TBoldObjectList(Result).SubscribeToObjectsInList := ASubscribeToObjectsInList; + // using SetInternalState to avoid the duplicate check when setting it bldmMerge + Result.SetInternalState(BoldDuplicateModeMask, BoldDMShift, Integer(bldmAllow)); + if Count > 0 then + FastAddList(self); + if ACopyDuplicateMode then + Result.SetInternalState(BoldDuplicateModeMask, BoldDMShift, Integer(DuplicateMode)); + if assigned(BoldSystem) then + BoldSystem.CommitTransaction; + except + Result.Free; + if assigned(BoldSystem) then + BoldSystem.RollbackTransaction; + raise; + end; +end; + +function TBoldObjectList.Clone: TBoldMember; +begin + result := Clone(True, SubscribeToObjectsInList); end; -function TBoldObjectList.ProxyClass: TBoldMember_ProxyClass; +function TBoldObjectList.GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin - result := ObjectListController.ProxyClass; + result := ObjectListController.GetProxy(Self, Mode); end; function TBoldObjectList.AtTime(Time: TBoldTimestampType): TBoldMember; @@ -6018,6 +8681,19 @@ function TBoldObjectList.AtTime(Time: TBoldTimestampType): TBoldMember; result := inherited AtTime(Time); end; +function TBoldObjectList.BeginUpdate: boolean; +begin +// result := ObjectListController.StartModify; +// SendEvent(beBeginUpdate); + result := true; +end; + +procedure TBoldObjectList.EndUpdate; +begin +// ObjectListController.EndModify; +// SendEvent(beEndUpdate); +end; + procedure TBoldObjectList.FreeContent; begin inherited; @@ -6028,15 +8704,29 @@ procedure TBoldObjectList.AssignContentValueFromElement(source: TBoldElement); var i: integer; SourceList: TBoldObjectList; - Controller: TBoldObjectListController; + DestinationController: TBoldObjectListController; begin if (source is TBoldObjectList) and (ListController is TBoldObjectListController) then begin - Controller := ListController as TBoldObjectListController; SourceList := source as TBoldObjectList; - Controller.LocatorList.Clear; - for i := 0 to SourceList.Count - 1 do - Controller.Locatorlist.Add(SourceList.Locators[i]); + Clear; + if SourceList.Count = 0 then + exit; + Capacity := SourceList.Count; + if (DuplicateMode = bldmAllow) and not (hasSubscribers) then + begin + DestinationController := ListController as TBoldObjectListController; + with DestinationController.LocatorList do + begin + for i := 0 to SourceList.Count - 1 do + Add(SourceList.GetLocator(i)); + end; + end + else + begin + for I := 0 to SourceList.Count - 1 do + AddLocator(SourceList.Locators[i]); + end; end else inherited; @@ -6052,6 +8742,115 @@ procedure TBoldObjectList.InternalClear; ObjectListController.Clear; end; +procedure TBoldObjectList.DeleteObjects; +var + vBoldSystem: TBoldSystem; + + procedure FetchClass(AList: TBoldObjectList; AClass: TBoldClassTypeInfo); + var + i: integer; + vRoleRTInfo: TBoldRoleRTInfo; + begin + for i := 0 to AClass.AllRolesCount - 1 do + begin + vRoleRTInfo := AClass.AllRoles[i]; + if not vRoleRTInfo.IsDerived then + begin + case vRoleRTInfo.DeleteAction of + daCascade, daAllow: + begin + vBoldSystem.FetchLinksWithObjects(AList, vRoleRTInfo.ExpressionName); + end; + end; + end; + end; + end; + +var + vCommonClass: TBoldClassTypeInfo; + vSubClass: TBoldClassTypeInfo; + vSubclasses: TList; + vList: TBoldObjectList; + i: integer; +begin + EnsureObjects; + if empty then + exit; + vBoldSystem := BoldObjects[0].BoldSystem; + vCommonClass := LeastCommonClassType(vBoldSystem); + FetchClass(self, vCommonClass); + if vCommonClass.HasSubclasses then + begin + vSubclasses := TList.Create; + try + for I := 0 to Count - 1 do + begin + vSubClass := Locators[i].BoldObject.BoldClassTypeInfo; + if vSubClass <> vCommonClass then + begin + if vSubclasses.IndexOf(vSubClass) = -1 then + begin + vSubclasses.Add(vSubClass); + vList := FilterOnType(vSubClass, true); + try + FetchClass(vList, vSubClass); + finally + vList.free; + end; + end; + end; + end; + finally + vSubclasses.free; + end; + end; + + vBoldSystem.StartTransaction(); + vList := self.Clone as TBoldObjectList; + try + vList.SubscribeToObjectsInList := false; + vList.SubscribeToLocatorsInList := false; + for I := vList.Count - 1 downto 0 do + if not vList[i].BoldObjectIsDeleted then + vList[i].Delete + finally + vList.free; + vBoldSystem.CommitTransaction(); + end; +end; + +function TBoldObjectList.IsEqualToValue(const Value: IBoldValue): Boolean; +var + IdListRef: IBoldObjectIdListRef; + IdListRefPair: IBoldObjectIdListRefPair; + i: integer; +begin + result := false; + Assert(Assigned(Value), ClassName + '.IsEqualToValue: Value can not be nil.'); + if Supports(Value, IBoldObjectIdListRef, IdListRef) then + begin + result := IdListRef.Count = count; + if result then + for I := 0 to Count - 1 do + begin + result := result and Locators[i].BoldObjectID.IsEqual[IdListRef.IdList[i]]; + if not result then + exit; + end; + end + else if Supports(Value, IBoldObjectIdListRefPair, IdListRefPair) then + begin + result := IdListRefPair.count = count; + if result then + for I := 0 to Count - 1 do + begin + result := result and Locators[i].BoldObjectID.IsEqual[IdListRefPair.IdList2[i]]; + if not result then + exit; + end; + end; +end; + { TBoldListController } constructor TBoldListController.Create(OwningList: TBoldList); @@ -6061,17 +8860,17 @@ constructor TBoldListController.Create(OwningList: TBoldList); function TBoldListController.CreateNew: TBoldElement; begin - raise EBold.Create(sCannotCreateNewElement); + raise EBold.CreateFmt('%s.CreateNew: Can not create new elements', [ClassName]); end; -function TBoldListController.GetBoldSystem: TBoldSystem; +function TBoldListController.GetCanCreateNew: Boolean; begin - result := OwningList.BoldSystem; + result := false; end; -function TBoldListController.GetCanCreateNew: Boolean; +function TBoldListController.GetCapacity: integer; begin - result := false; + result := MaxInt; end; function TBoldListController.GetOwningMember: TBoldMember; @@ -6085,6 +8884,11 @@ function TBoldListController.GetStringrepresentation: String; Result := IntToStr(Count); end; +procedure TBoldListController.SetCapacity(const Value: integer); +begin + // nothing +end; + { TBoldAbstractObjectListController } procedure TBoldAbstractObjectListController.AddElement(Element: TBoldElement); @@ -6110,6 +8914,14 @@ procedure TBoldAbstractObjectListController.FreeContent; begin end; +function TBoldAbstractObjectListController.GetDebugInfo: string; +begin + if Assigned(OwningObjectList) then + result := Format('%s(%s)', [ClassName, OwningObjectList.DebugInfo]) + else + result := inherited GetDebugInfo +end; + function TBoldAbstractObjectListController.GetElement(index: Integer): TBoldElement; var aLocator: TBoldObjectLocator; @@ -6121,8 +8933,8 @@ function TBoldAbstractObjectListController.GetElement(index: Integer): TBoldElem function TBoldAbstractObjectListController.GetObjectList: TBoldObjectList; begin - Assert(inherited OwningList is TBoldObjectList); result := TBoldObjectList(inherited OwningList); + Assert(result is TBoldObjectList); end; function TBoldAbstractObjectListController.HandlesAtTime: Boolean; @@ -6150,7 +8962,6 @@ procedure TBoldAbstractObjectListController.InsertElement(index: Integer; Elemen procedure TBoldAbstractObjectListController.PrepareClear; begin - // do nothing end; procedure TBoldAbstractObjectListController.SetElement(index: Integer; Value: TBoldElement); @@ -6182,6 +8993,7 @@ constructor TBoldAbstractObjectReferenceController.Create(Owner: TBoldObjectRefe fOwningReference := Owner; end; + function TBoldAbstractObjectReferenceController.GetOwningMember: TBoldMember; begin Result := OwningReference; @@ -6204,17 +9016,21 @@ procedure TBoldAbstractObjectReferenceController.PreDiscard; begin end; -function TBoldObjectReferenceController.ProxyClass: TBoldMember_ProxyClass; +function TBoldObjectReferenceController.GetProxy(Member: TBoldMember; Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin - result := TBoldObjectReference_Proxy; + result := TBoldObjectReference_Proxy.MakeProxy(Member, Mode); end; { TBoldAbstractController } +function TBoldAbstractController.GetBoldSystem: TBoldSystem; +begin + result := OwningMember.BoldSystem; +end; + function TBoldAbstractController.AssertIntegrity: Boolean; begin Result := True; - // DO nothing, make abstract virtual later end; procedure TBoldAbstractController.Changed(Event: TBoldEvent; @@ -6246,9 +9062,23 @@ class function TBoldAbstractController.GetControllerForMember(Member: TBoldMembe result := Member.GetController; end; +function TBoldAbstractController.GetFreeStandingClass: TBoldFreeStandingElementClass; +begin + raise EBoldInternal.Createfmt('%s.GetFreeStandingClass: Method is abstract, please implement', [classname]); +end; + +function TBoldAbstractController.GetOwningObject: TBoldObject; +begin + result := OwningMember.OwningObject; +end; + +function TBoldAbstractController.GetRoleRTInfo: TBoldRoleRTInfo; +begin + result := OwningMember.BoldMemberRtInfo as TBoldRoleRTInfo; +end; + procedure TBoldAbstractController.linkto(NewLocator: TBoldObjectLocator; updateOrderNo: Boolean; Mode: TBoldLinkUnlinkMode); begin - // do nothing end; function TBoldAbstractController.LocatorForID( @@ -6277,7 +9107,6 @@ function TBoldAbstractController.StartModify: Boolean; procedure TBoldAbstractController.Unlink(OldLocator: TBoldObjectLocator; Mode: TBoldLinkUnlinkMode); begin - // do nothing end; function TBoldAbstractController.AssertedLocatorForID(ObjectId: TBoldObjectId): TBoldObjectLocator; @@ -6294,7 +9123,7 @@ procedure TBoldAbstractController.DbFetchClassForMember(TimeStamp: TBoldTimestam { TBoldObjectReferenceController } -procedure TBoldObjectReferenceController.AssignContentValue(Source: IBoldValue); +procedure TBoldObjectReferenceController.AssignContentValue(const Source: IBoldValue); var s: IBoldObjectIdRef; begin @@ -6303,10 +9132,10 @@ procedure TBoldObjectReferenceController.AssignContentValue(Source: IBoldValue); if Assigned(OwningReference) then fLocator := OwningReference.BoldSystem.EnsuredLocatorByID[s.Id] else - raise EBold.Create(sObjectRefMustBePartOfObject); + raise EBold.Create('AssignContentValue, ObjectReference must be part of Object'); end else - raise EBold.CreateFmt(sUnknownTypeOfSource, [classname, 'AssignContentValue']); // do not localize + raise EBold.CreateFmt('%s.AssignContentValue: unknown type of source', [classname]); end; constructor TBoldObjectReferenceController.Create(Owner: TBoldObjectReference); @@ -6321,6 +9150,11 @@ destructor TBoldObjectReferenceController.Destroy; inherited; end; +function TBoldObjectReferenceController.GetFreeStandingClass: TBoldFreeStandingElementClass; +begin + result := TBFSObjectIdRef; +end; + function TBoldObjectReferenceController.GetLocator: TBoldObjectLocator; begin result := fLocator; @@ -6330,7 +9164,7 @@ function TBoldObjectReferenceController.GetStreamName: string; begin result := BoldContentName_ObjectIdRef; end; - + procedure TBoldObjectReferenceController.MakeDbCurrent; begin raise EBoldInternal.CreateFmt('%s.MakeDBcurrent: This is only possible for link-controllers', [ClassName]); @@ -6347,7 +9181,7 @@ procedure TBoldObjectReferenceController.ObjectChangeReceive( procedure TBoldObjectReferenceController.SetLocator(NewLocator: TBoldObjectLocator); begin if not StartModify then - BoldRaiseLastFailure(OwningReference, 'SetLocator', ''); // do not localize + BoldRaiseLastFailure(OwningReference, 'SetLocator', ''); fLocator := NewLocator; Changed(beValueChanged, [NewLocator]); @@ -6374,8 +9208,8 @@ function TBoldLocatorHashIndex.HashItem(Item: TObject): Cardinal; function TBoldLocatorHashIndex.ItemAsLocator(Item: TObject): TBoldObjectLocator; begin - Assert(Item is TBoldObjectLocator); Result := TBoldObjectLocator(Item); + Assert(result is TBoldObjectLocator); end; function TBoldLocatorHashIndex.Match(const Key; Item: TObject): Boolean; @@ -6387,22 +9221,30 @@ function TBoldObjectList.GetElementTypeInfoForType: TBoldElementTypeInfo; var aSystem: TBoldSystem; begin - aSystem := FindASystem; + result := nil; + //TODO: check (System.BoldSystemTypeInfo.UseGeneratedCode) + if (ClassType <> TBoldObjectList) then // this will not work with systems that have no generated code + begin + aSystem := FindASystem; + if assigned(aSystem) then + result := aSystem.BoldSystemTypeInfo.ListTypes.ItemByListClass[self.ClassType] + end; +end; - if assigned(aSystem) then - result := aSystem.BoldSystemTypeInfo.ListTypes.ItemsByDelphiName[self.classname] - else - result := nil; +function TBoldObjectList.GetEnumerator: TBoldObjectListEnumerator; +begin + result := TBoldObjectListEnumerator.Create(self) end; -function TBoldAttribute.GetElementTypeInfoForType: TBoldElementTypeInfo; -var - aSystem: TBoldSystem; +function TBoldObjectList.GetLocatorEnumerator: TBoldObjectListLocatorEnumerator; begin - aSystem := FindASystem; + result := TBoldObjectListLocatorEnumerator.Create(self) +end; - if assigned(aSystem) then - result := aSystem.BoldSystemTypeInfo.AttributeTypeInfoByDelphiName[Self.ClassName] +function TBoldAttribute.GetElementTypeInfoForType: TBoldElementTypeInfo; +begin + if FindASystem <> nil then + result := GetAttributeTypeInfoForType else result := nil; end; @@ -6410,17 +9252,17 @@ function TBoldAttribute.GetElementTypeInfoForType: TBoldElementTypeInfo; procedure TBoldAttribute.RecycleValue; begin if Assigned(OwningObject) then - raise EBold.Create(sCannotRecyclePartOfObject); + raise EBold.Create('TBoldAttribute.RecycleValue: Can''t recycle part of object'); PrepareToDestroy; SetElementFlag(befImmutable, False); end; { TBoldFailureReason } -constructor TBoldFailureReason.create(reason: String; - Originator: TBoldDomainElement); +constructor TBoldFailureReason.create(AReason: String; + Originator: TBoldElement); begin - fReason := reason; + fReason := AReason; fOriginator := Originator; if assigned(fOriginator) then begin @@ -6430,7 +9272,7 @@ constructor TBoldFailureReason.create(reason: String; end; constructor TBoldFailureReason.CreateFmt(Reason: string; - const args: array of const; Originator: TBoldDomainElement); + const args: array of const; Originator: TBoldElement); begin Create(Format(Reason, Args), Originator); end; @@ -6464,26 +9306,17 @@ destructor EBoldFailure.Destroy; { TBoldMemberFactory } class function TBoldMemberFactory.CreateMemberFromBoldType(BoldType: TBoldElementTypeInfo): TBoldMember; -var - MemberClass: TBoldMemberClass; begin + if not assigned(BoldType) then + raise EBold.CreateFmt('%s.CreateMemberFromBoldType: Invalid BoldType (nil)', [ClassName]); if BoldType is TBoldListTypeInfo then - MemberClass := TBoldMemberClass(TBoldListTypeInfo(BoldType).ListClass) - else if BoldType is TBoldAttributeTypeInfo then - MemberClass := TBoldMemberClass(TBoldAttributeTypeInfo(BoldType).AttributeClass) - else if BoldType is TBoldClassTypeInfo then - MemberClass := TBoldObjectReference + result := TBoldMemberClass(TBoldListTypeInfo(BoldType).ListClass).CreateWithTypeInfo(BoldType) else begin - if assigned(BoldType) then - raise EBold.CreateFmt(sInvalidBoldType, [ClassName, BoldType.ClassName]) - else - raise EBold.CreateFmt(sInvalidBoldType_Nil, [ClassName]); + if (BoldType.ElementClass = nil) then + raise EBold.CreateFmt('%s.CreateMemberFromBoldType: Invalid BoldType (%s)', [ClassName, BoldType.ClassName]); + result := BoldType.CreateElement as TBoldMember; end; - if assigned(MemberClass) then - result := MemberClass.CreateWithTypeInfo(BoldType) - else - raise EBold.CreateFmt(sDelphiClassNotInstalled, [ClassName, BoldType.ExpressionName, BoldType.DelphiName]) end; class function TBoldMemberFactory.CreateMemberFromExpressionName(SystemTypeInfo: TBoldSystemTypeInfo; const Name: String): TBoldMember; @@ -6492,7 +9325,7 @@ class function TBoldMemberFactory.CreateMemberFromExpressionName(SystemTypeInfo: begin BoldType := SystemTypeInfo.ElementTypeInfoByExpressionName[Name]; if not assigned(BoldType) then - raise EBold.CreateFmt(sUnableToFindType, [classname, name]); + raise EBold.CreateFmt('%s.CreateMemberFromExpressionName: Unable to find a type for "%s"', [classname, name]); result := CreateMemberFromBoldType(BoldType); end; @@ -6501,6 +9334,11 @@ function TBoldObjectLocator.GetObjectIsPersistent: Boolean; result := not assigned(BoldObject) or BoldObject.BoldPersistent; end; +procedure TBoldObjectLocator.AddToLocators; +begin + BoldSystem.Locators.Add(Self); +end; + function TBoldObjectLocator.AtTime(Time: TBoldTimeStampType): TBoldObjectLocator; var NewId: TBoldObjectId; @@ -6522,37 +9360,62 @@ function TBoldObjectLocator.AtTime(Time: TBoldTimeStampType): TBoldObjectLocator { TBoldMember_Proxy } -procedure TBoldMember_Proxy.AssignContent(Source: IBoldValue); +procedure TBoldMember_Proxy.AssignContent(const Source: IBoldValue); begin + Assert(assigned(Source), 'TBoldMember_Proxy.AssignContent: Source = nil.'); AssignContentValue(Source); Assert ((Mode <> bdepPMIn) or (Source.BoldPersistenceState = bvpsCurrent)); ProxedMember.SetBoldPersistenceState(Source.BoldPersistenceState); end; +constructor TBoldMember_Proxy.Create(ProxedMember: TBoldMember; + Mode: TBoldDomainElementProxyMode); +begin + inherited Create(Mode); + fProxedMember := ProxedMember; +end; + function TBoldMember_Proxy.GetBoldPersistenceState: TBoldValuePersistenceState; begin result := ProxedMember.BoldPersistenceState; end; +function TBoldMember_Proxy.GetContentType: TBoldValueContentType; +begin + result := ProxedMember.GetFreeStandingClass.ContentType; +end; + function TBoldMember_Proxy.GetContentName: String; begin result := ProxedMember.GetStreamName; end; +function TBoldMember_Proxy.GetFreeStandingClass: TBoldFreeStandingElementClass; +begin + result := ProxedMember.GetFreeStandingClass; +end; + function TBoldMember_Proxy.GetStreamName: String; begin result := ProxedMember.GetStreamName; end; -function TBoldMember_Proxy.GetProxedController: TBoldAbstractController; +class function TBoldMember_Proxy.MakeProxy(ProxedMember: TBoldMember; + Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; begin - Result := ProxedMember.GetController; + Result := Self.Create(ProxedMember, Mode); end; -function TBoldMember_Proxy.GetProxedMember: TBoldMember; +procedure TBoldMember_Proxy.Retarget(ProxedMember: TBoldMember; + Mode: TBoldDomainElementProxyMode); begin - Assert(ProxedElement is TBoldMember); - result := TBoldMember(ProxedElement); + inherited Retarget(Mode); + fProxedMember := ProxedMember; +end; + +function TBoldMember_Proxy.GetProxedController: TBoldAbstractController; +begin + Result := ProxedMember.GetController; end; procedure TBoldMember_Proxy.SetBoldPersistenceState(Value: TBoldValuePersistenceState); @@ -6562,7 +9425,12 @@ procedure TBoldMember_Proxy.SetBoldPersistenceState(Value: TBoldValuePersistence { TBoldAttribute_Proxy } -procedure TBoldAttribute_Proxy.AssignContentValue(Source: IBoldValue); +function TBoldAttribute_Proxy.GetProxedAttribute: TBoldAttribute; +begin + result := TBoldAttribute(ProxedMember); +end; + +procedure TBoldAttribute_Proxy.AssignContentValue(const Source: IBoldValue); begin ProxedAttribute.AssignContentValue(Source); end; @@ -6572,15 +9440,26 @@ procedure TBoldAttribute_Proxy.SetContentToNull; ProxedAttribute.SetContentToNull; end; +procedure TBoldAttribute_Proxy.SetStringRepresentation(Representation: integer; + const NewValue: String); +begin + ProxedAttribute.StringRepresentation[Representation] := NewValue; +end; + +function TBoldAttribute_Proxy.GetContentAsString: String; +begin + Result := GetStringRepresentation(brDefault); +end; + function TBoldAttribute_Proxy.GetContentIsNull; begin - Result := ProxedAttribute.GetContentIsNull; + Result := ProxedAttribute.ContentIsNull; end; -function TBoldAttribute_Proxy.GetProxedAttribute: TBoldAttribute; +function TBoldAttribute_Proxy.GetStringRepresentation( + representation: integer): String; begin - Assert(ProxedElement is TBoldAttribute); - result := TBoldAttribute(ProxedElement); + result := ProxedAttribute.StringRepresentation[Representation]; end; { TBoldSystem_Proxy } @@ -6591,11 +9470,10 @@ procedure TBoldSystem_Proxy.AllObjectIds(resultList: TBoldObjectIdList; Traverser: TBoldLocatorListTraverser; begin Traverser := ProxedSystem.Locators.CreateTraverser; - while not Traverser.EndOfList do + while Traverser.MoveNext do begin if not OnlyLoaded or assigned(Traverser.Locator.BoldObject) then ResultList.Add(Traverser.Locator.BoldObjectID); - Traverser.Next; end; Traverser.Free; end; @@ -6606,18 +9484,18 @@ procedure TBoldSystem_Proxy.ApplytranslationList( I: Integer; Locator: TBoldObjectLocator; begin + if IdTranslationList.Count = 0 then + exit; for I := 0 to IdTranslationList.Count - 1 do begin if Assigned(IdTranslationList.OldIDs[I]) then begin Locator := ProxedSystem.Locators.LocatorByID[IdTranslationList.OldIDs[I]]; if Assigned(IdTranslationList.NewIDs[I]) then - // Id changed value ProxedSystem.Locators.UpdateId(Locator, IdTranslationList.NewIds[i]) end else begin - // Loaded an ID that might or might not be in-core already ProxedSystem.EnsuredLocatorByID[IdTranslationList.NewIDs[I]]; end; end; @@ -6625,17 +9503,17 @@ procedure TBoldSystem_Proxy.ApplytranslationList( ProxedSystem.fOldValueHandler.OldValues.ApplytranslationList(IdTranslationList); end; -procedure TBoldSystem_Proxy.ApplyValueSpace(ValueSpace: IBoldValueSpace; +procedure TBoldSystem_Proxy.ApplyValueSpace(const ValueSpace: IBoldValueSpace; IgnorePersistenceState: Boolean); - procedure ApplyObjectContents(BoldObject: TBoldObject; ObjectContents: IBoldObjectContents); + procedure ApplyObjectContents(BoldObject: TBoldObject; const ObjectContents: IBoldObjectContents); var i: Integer; aValue: IBoldValue; begin BoldObject.SetBoldExistenceState(ObjectContents.BoldExistenceState); BoldObject.SetBoldPersistenceState(ObjectContents.BoldPersistenceState); - for i := 0 to BoldObject.BoldMemberCount - 1 do + for i := BoldObject.BoldMemberCount - 1 downto 0 do begin aValue := ObjectContents.valueByIndex[i]; if assigned(aValue) then @@ -6665,6 +9543,15 @@ procedure TBoldSystem_Proxy.ApplyValueSpace(ValueSpace: IBoldValueSpace; end; end; + + +constructor TBoldSystem_Proxy.Create(ProxedSystem: TBoldSystem; + Mode: TBoldDomainElementProxyMode); +begin + inherited Create(Mode); + fProxedSystem := ProxedSystem; +end; + procedure TBoldSystem_Proxy.EnsureObjectContents(ObjectId: TBoldObjectId); begin if not assigned(ProxedSystem.Locators.ObjectByID[ObjectId]) then @@ -6676,7 +9563,7 @@ procedure TBoldSystem_Proxy.EnsureObjectId(ObjectId: TBoldObjectId); ObjectLocator: TBoldObjectLocator; begin ObjectLocator := ProxedSystem.GetEnsuredLocatorById(ObjectId); - if not ObjectLocator.BoldObjectID.TopSortedIndexExact and { TODO : Try to promote } + if not ObjectLocator.BoldObjectID.TopSortedIndexExact and ObjectId.TopSortedIndexExact then ProxedSystem.Locators.UpdateID(ObjectLocator, ObjectId); end; @@ -6685,9 +9572,14 @@ procedure TBoldSystem_Proxy.ExactifyIDs( TranslationList: TBoldIdTranslationList); var i: Integer; + ObjectLocator: TBoldObjectLocator; begin for i := 0 to TranslationList.Count - 1 do - ProxedSystem.Locators.UpdateId(ProxedSystem.Locators.LocatorByID[TranslationList.OldIds[i]], TranslationList.NewIds[i]); + begin + ObjectLocator := ProxedSystem.Locators.LocatorByID[TranslationList.OldIds[i]]; + if Assigned(ObjectLocator) then + ProxedSystem.Locators.UpdateId(ObjectLocator, TranslationList.NewIds[i]); + end; end; function TBoldSystem_Proxy.GetEnsuredObjectContentsByObjectId( @@ -6698,6 +9590,16 @@ function TBoldSystem_Proxy.GetEnsuredObjectContentsByObjectId( result := ProxedSystem.CreateExistingObjectByID(ObjectID).AsIBoldObjectContents[Mode]; end; +function TBoldSystem_Proxy.GetEnsuredObjectContentsByObjectIdAndCheckIfCreated( + ObjectId: TBoldObjectId; + out aBoldObjectContents: IBoldObjectContents): boolean; +begin + aBoldObjectContents := GetObjectContentsByObjectId(ObjectID); + result := not Assigned(aBoldObjectContents); + if result then + aBoldObjectContents := ProxedSystem.CreateExistingObjectByID(ObjectID).AsIBoldObjectContents[Mode]; +end; + function TBoldSystem_Proxy.GetHasContentsForId(ObjectId: TBoldObjectId): boolean; begin result := Assigned(ProxedSystem.Locators.ObjectByID[ObjectId]) @@ -6715,31 +9617,53 @@ function TBoldSystem_Proxy.GetObjectContentsByObjectId( result := nil; end; -function TBoldSystem_Proxy.GetProxedSystem: TBoldSystem; +function TBoldSystem_Proxy.IdCount: integer; begin - Assert(ProxedElement is TBoldSystem); - result := TBoldSystem(ProxedElement); + result := ProxedSystem.Locators.Count; end; +function TBoldSystem_Proxy.IsEmpty: boolean; +var + Traverser: TBoldLocatorListTraverser; +begin + result := true; + Traverser := ProxedSystem.Locators.CreateTraverser; + while Traverser.MoveNext do + begin + if assigned(Traverser.Locator.BoldObject) then + begin + result := false; + break + end; + end; + Traverser.Free; +end; { TBoldObject_Proxy } +constructor TBoldObject_Proxy.Create(ProxedObject: TBoldObject; + Mode: TBoldDomainElementProxyMode); +begin + inherited Create(Mode); + fProxedObject := ProxedObject; +end; + procedure TBoldObject_Proxy.EnsureMember(MemberId: TBoldMemberId; const ContentName: string); +begin + EnsureMemberAndGetValueByIndex(MemberId.MemberIndex, ContentName); +end; + +function TBoldObject_Proxy.EnsureMemberAndGetValueByIndex(MemberIndex: Integer; + const ContentName: string): IBoldValue; var Member: TBoldMember; begin - if MemberId.MemberIndex >= ProxedObject.BoldMembercount then - raise eBold.CreateFmt(sNotEnoughMembers, [classname, MemberId.MemberIndex]); - Member := ProxedObject.BoldMembers[MemberId.MemberIndex]; - if CompareText(Member.GetStreamName, ContentName) <> 0 then - raise EBold.CreateFmt(sUnexpectedStreamType, + Member := ProxedObject.BoldMembers[MemberIndex]; + if not SameText(Member.GetStreamName, ContentName) then + raise EBold.CreateFmt('%s.EnsureMember: %s was expected to stream as %s, but does stream as %s, check TypeNameHandle settings', [classname, Member.DisplayName, ContentName, Member.GetStreamName]); - -// FIXME: Make sure below works for BoldDirectSingleLink vs BoldObjectReference FIXME FIXME FIXME -// if AnsiCompareText(BoldMembers[MemberId.MemberIndex].TypeExpressionName, TypeExpressionName) <> 0 then -// raise EBold.CreateFmt('TBoldObject.EnsureMember: Member was of wrong type (was %s, should have been: %s', -// [BoldMembers[MemberId.MemberIndex].TypeExpressionName, TypeExpressionName]); + Result := GetValueByIndex(MemberIndex); end; function TBoldObject_Proxy.GetBoldExistenceState: TBoldExistenceState; @@ -6777,15 +9701,9 @@ function TBoldObject_Proxy.GetObjectId: TBoldObjectId; result := ProxedObject.BoldObjectLocator.BoldObjectId; end; -function TBoldObject_Proxy.GetProxedObject: TBoldObject; -begin - Assert(ProxedElement is TBoldObject); - result := TBoldObject(ProxedElement); -end; - procedure TBoldSystemLocatorList.UpdateID(Locator: TBoldObjectLocator; NewObjectID: TBoldObjectId; AllowInternal: Boolean); begin - if NewObjectID.IsStorable or AllowInternal then + if (NewObjectID.IsStorable or AllowInternal) or NewObjectID.NonExisting then begin if assigned(Locator.BoldObject) then Locator.BoldObject.SendEvent(bePreUpdateId); @@ -6811,16 +9729,15 @@ function TBoldObject_Proxy.GetValueByIndex(I: Integer): IBoldValue; function IncludeInPmOut: boolean; begin - Result := (Member.BoldPersistenceState <> bvpsInvalid) and + Result := (not Member.BoldPersistenceStateIsInvalid) and (not Member.Derived) and ((Member.BoldMemberRTInfo is TBoldAttributeRTInfo) or (TBoldRoleRTInfo(Member.BoldMemberRTInfo).RoleType in [rtRole, rtInnerLinkRole])); end; begin - if ProxedObject.BoldObjectIsNew or ProxedObject.BoldmemberAssigned[i] then - Member := ProxedObject.BoldMembers[i] - else - Member := nil; + Member := ProxedObject.GetBoldMemberIfAssigned(i); + if not ASsigned(Member) and ProxedObject.BoldObjectIsNew then + Member := ProxedObject.BoldMembers[i]; if Assigned(Member) and ((Mode <> bdepPmOut) or IncludeInPmOut) then Result := Member.AsIBoldValue[Mode] @@ -6881,8 +9798,8 @@ destructor EBoldOperationFailedForObjectList.Destroy; function TBoldLocatorListTraverser.GetLocator: TBoldObjectLocator; begin - Assert(item is TBoldObjectLocator); result := TBoldObjectLocator(item); + Assert(result is TBoldObjectLocator); end; function TBoldSystemLocatorList.CreateTraverser: TBoldLocatorListTraverser; @@ -6897,16 +9814,43 @@ function TBoldSystemLocatorList.TraverserClass: TBoldIndexableListTraverserClass { TBoldMemberDeriver } +constructor TBoldMemberDeriver.Create(Member: TBoldMember); +begin + inherited Create; + fDerivedMember := Member; +end; + +destructor TBoldMemberDeriver.Destroy; +begin + inherited; +end; + +procedure TBoldMemberDeriver.DoDeriveAndSubscribe(subscribe: Boolean); +begin + if Subscribe then + DerivedMember.DeriveMember(Self) + else + DerivedMember.DeriveMember(nil); +end; + +procedure TBoldMemberDeriver.DoNotifyOutOfDate; +begin + DerivedMember._NotifyOutOfDate; +end; + +function TBoldMemberDeriver.GetDerivedObject: TObject; +begin + Result := fDerivedMember; +end; + function TBoldMemberDeriver.GetInternalDeriverState: TBoldDeriverState; begin - Assert(DerivedObject is TBoldMember); - result := TBoldMember(DerivedObject).GetDeriverState; + result := DerivedMember.GetDeriverState; end; procedure TBoldMemberDeriver.SetInternalDeriverState(const Value: TBoldDeriverState); begin - Assert(DerivedObject is TBoldMember); - TBoldMember(DerivedObject).DeriverState := Value; + DerivedMember.DeriverState := Value; end; { TBoldAbstractOptimisticLockHandler } @@ -6923,135 +9867,126 @@ constructor TBoldSystemExtension.Create(System: TBoldSystem); fSystem := System; end; -(* -procedure TBoldObjectLocator.TypeAtLeast(TopSortedIndex: integer; Exact: Boolean); -var - OldId: TBoldObjectId; +function TBoldObjectLocator.GetClassTypeInfo: TBoldClassTypeInfo; begin - if (TopSortedIndex > BoldObjectId.TopSortedIndex) {Topsorted so more exact is always bigger} - or (Exact and not BoldObjectId.TopSortedIndexExact) then - begin - OldId := BoldObjectId; - fBoldObjectId := OldId.CloneWithClassId(TopSortedIndex, Exact); - OldId.Free; - end + if Assigned(BoldObjectId) then + result := BoldSystem.BoldSystemTypeInfo.TopSortedClasses[BoldObjectId.TopSortedIndex] + else + result := nil; end; -*) function TBoldObjectLocator.GetEmbeddedSingleLinks(EmbeddedIndex: integer): TBoldObjectLocator; begin - if Assigned(fEmbeddedSingleLinks) and - (EmbeddedIndex < fEmbeddedSingleLinks.Count) then - Result := TBoldObjectLocator(fEmbeddedSingleLinks[EmbeddedIndex]) - else - Result := nil; + if embeddedindex < Length(fEmbeddedSingleLinks) then + Result := fEmbeddedSingleLinks[EmbeddedIndex] + else + Result := nil; end; procedure TBoldObjectLocator.SetEmbeddedSingleLinks(EmbeddedIndex: integer; const Value: TBoldObjectLocator); begin - if not Assigned(fEmbeddedSingleLinks) then - fEmbeddedSingleLinks := TBoldObjectArray.Create(EmbeddedIndex + 1, []); - with fEmbeddedSingleLinks do - begin - if EmbeddedIndex >= Count then - Count := EmbeddedIndex + 1; - Items[EmbeddedIndex] := Value; - if Value = nil then {May be able to strip end} - begin - while (Count > 0) and (Items[Count - 1] = nil) do - Count := Count - 1; - if Count = 0 then - FreeAndNil(fEmbeddedSingleLinks) - else if Capacity > Count then - Capacity := Count; - end; - end; + if embeddedindex >= Length(fEmbeddedSingleLinks) then + SetLength(fEmbeddedSingleLinks, EmbeddedIndex+1); + fEmbeddedSingleLinks[EmbeddedIndex] := Value; + if Value = nil then + TryShrinkEmbeddedLinks; +end; + +procedure TBoldObjectLocator.TryShrinkEmbeddedLinks; +var + NewLength: integer; + OldLength: integer; +begin + OldLength := Length(fEmbeddedSingleLinks); + NewLength := OldLength; + while (NewLength > 0) and (not Assigned(fEmbeddedSingleLinks[NewLength-1])) do + Dec(NewLength); + if (NewLength = 0) or (NewLength < (OldLength - 3)) then + SetLength(fEmbeddedSingleLinks, NewLength); end; procedure TBoldObjectLocator.EmbeddedSingleLinksFromObject; var - m: integer; - EmbeddedIndex: integer; + i: integer; ObjectReferece: TBoldObjectReference; RoleRtInfo: TBoldRoleRTInfo; begin - for m := 0 to BoldObject.BoldClassTypeInfo.AllMembers.Count - 1 do + for i := 0 to BoldObject.BoldClassTypeInfo.AllRoles.Count - 1 do + begin + RoleRtInfo := TBoldRoleRTInfo(BoldObject.BoldClassTypeInfo.AllRoles[i]); + if (RoleRtInfo.EmbeddedLinkIndex <> -1) and BoldObject.BoldMemberAssigned[RoleRtInfo.index] then begin - EmbeddedIndex := BoldObject.BoldClassTypeInfo.AllMembers[m].EmbeddedLinkIndex; - if (EmbeddedIndex <> -1) and BoldObject.BoldMemberAssigned[m] then - begin - Assert(BoldObject.BoldClassTypeInfo.AllMembers[m] is TBoldRoleRTInfo); - Assert(BoldObject.BoldMembers[m] is TBoldObjectReference); - RoleRtInfo := TBoldRoleRTInfo(BoldObject.BoldClassTypeInfo.AllMembers[m]); - ObjectReferece := TBoldObjectReference(BoldObject.BoldMembers[m]); - if (ObjectReferece.BoldPersistenceState = bvpsCurrent) and - (RoleRtInfo.indexOfOtherEnd <> -1) and // if other end exists as is loaded, we must keep reference. - (ObjectReferece.Locator <> nil) and - (ObjectReferece.Locator.BoldObject <> nil) and - ObjectReferece.Locator.BoldObject.BoldMemberAssigned[RoleRtInfo.indexOfOtherEnd] then - EmbeddedSingleLinks[EmbeddedIndex] := ObjectReferece.Locator; - end; + Assert(BoldObject.BoldMembers[RoleRtInfo.Index] is TBoldObjectReference); + ObjectReferece := TBoldObjectReference(BoldObject.BoldMembers[RoleRtInfo.index]); + if (ObjectReferece.BoldPersistenceState = bvpsCurrent) and + (RoleRtInfo.indexOfOtherEnd <> -1) and + (ObjectReferece.Locator <> nil) and + (ObjectReferece.Locator.BoldObject <> nil) and + ObjectReferece.Locator.BoldObject.BoldMemberAssigned[RoleRtInfo.indexOfOtherEnd] then + EmbeddedSingleLinks[RoleRtInfo.EmbeddedLinkIndex] := ObjectReferece.Locator; end; + end; end; procedure TBoldObjectLocator.EmbeddedSingleLinksToObject; var - m: integer; - EmbeddedIndex: integer; + i: integer; ObjRef: TBoldObjectReference; + RoleRtInfo: TBoldRoleRTInfo; begin - if Assigned(fEmbeddedSingleLinks) then + if Length(fEmbeddedSingleLinks) > 0 then begin - for m := 0 to BoldObject.BoldClassTypeInfo.AllMembers.Count - 1 do + for i := 0 to BoldObject.BoldClassTypeInfo.AllRoles.Count - 1 do begin - EmbeddedIndex := BoldObject.BoldClassTypeInfo.AllMembers[m].EmbeddedLinkIndex; - if (EmbeddedIndex <> -1) and (EmbeddedSingleLinks[EmbeddedIndex] <> nil) then + RoleRtInfo := BoldObject.BoldClassTypeInfo.AllRoles[i]; + if (RoleRtInfo.EmbeddedLinkIndex <> -1) and (EmbeddedSingleLinks[RoleRtInfo.EmbeddedLinkIndex] <> nil) then begin - Assert(BoldObject.BoldMembers[m] is TBoldObjectReference); - ObjRef := TBoldObjectReference(BoldObject.BoldMembers[m]); - (ObjRef.AsIBoldValue[bdepInternalInitialize] as IBoldObjectIdRef).SetFromId(EmbeddedSingleLinks[EmbeddedIndex].BoldObjectID); + Assert(BoldObject.BoldMembers[RoleRtInfo.index] is TBoldObjectReference); + ObjRef := TBoldObjectReference(BoldObject.BoldMembers[RoleRtInfo.Index]); + (ObjRef.AsIBoldValue[bdepInternalInitialize] as IBoldObjectIdRef).SetFromId(EmbeddedSingleLinks[RoleRtInfo.EmbeddedLinkIndex].BoldObjectID, false); assert((ObjRef.AsIBoldValue[bdepContents] as IBoldObjectIdRef).BoldPersistenceState = bvpsInvalid); -// (ObjRef.AsIBoldValue[bdepInternalInitialize] as IBoldObjectIdRef).BoldPersistenceState := bvpsInvalid; ObjRef.HasOldValues := True; end; end; - FreeAndNil(fEmbeddedSingleLinks); + SetLength(fEmbeddedSingleLinks, 0); end; end; procedure TBoldObjectLocator.FreeEmbeddedSingleLinksOfOtherEnd; var - m: integer; - i: integer; + i,m: integer; SingleLink: TBoldObjectReference; MultiLink: TBoldObjectList; + RoleInfo: TBoldRoleRTInfo; begin - for m := 0 to BoldObject.BoldClassTypeInfo.AllMembers.Count - 1 do + for i := 0 to BoldObject.BoldClassTypeInfo.AllRoles.Count - 1 do begin - if BoldObject.BoldClassTypeInfo.AllMembers[m].IsRole and - (TBoldRoleRTInfo(BoldObject.BoldClassTypeInfo.AllMembers[m]).RoleType = rtLinkRole) and - BoldObject.BoldMemberAssigned[m] and - (BoldObject.BoldMembers[m].BoldPersistenceState = bvpsCurrent) then + RoleInfo := BoldObject.BoldClassTypeInfo.AllRoles[i]; + if (RoleInfo.RoleType = rtLinkRole) and + (RoleInfo.IndexOfMainRole=RoleInfo.index) and + BoldObject.BoldMemberAssigned[RoleInfo.Index] and + (BoldObject.BoldMembers[RoleInfo.Index].BoldPersistenceState = bvpsCurrent) then + begin + if BoldObject.BoldMembers[RoleInfo.Index] is TBoldObjectReference then begin - if BoldObject.BoldMembers[m] is TBoldObjectReference then - begin - SingleLink := TBoldObjectReference(BoldObject.BoldMembers[m]); - if Assigned(SingleLink.Locator) and Assigned(SingleLink.Locator.fEmbeddedSingleLinks) then - SingleLink.Locator.EmbeddedSingleLinks[SingleLink.BoldRoleRTInfo.RoleRTInfoOfOtherEnd.EmbeddedLinkIndex] := nil; - end - else - begin - multiLink := BoldObject.BoldMembers[m] as TBoldObjectList; - for i := 0 to Multilink.Count - 1 do - if Assigned(Multilink.Locators[i].fEmbeddedSingleLinks) then // FIXME which locator for indirects? - Multilink.Locators[i].EmbeddedSingleLinks[MultiLink.BoldRoleRTInfo.RoleRTInfoOfOtherEnd.EmbeddedLinkIndex] := nil; - end; + SingleLink := TBoldObjectReference(BoldObject.BoldMembers[RoleInfo.Index]); + if Assigned(SingleLink.Locator) and (Length(SingleLink.Locator.fEmbeddedSingleLinks) > 0) then + SingleLink.Locator.EmbeddedSingleLinks[RoleInfo.RoleRTInfoOfOtherEnd.EmbeddedLinkIndex] := nil; + end + else + begin + multiLink := BoldObject.BoldMembers[RoleInfo.Index] as TBoldObjectList; + for m := 0 to Multilink.Count - 1 do + if Length(Multilink.Locators[m].fEmbeddedSingleLinks) > 0 then + Multilink.Locators[m].EmbeddedSingleLinks[RoleInfo.RoleRTInfoOfOtherEnd.EmbeddedLinkIndex] := nil; end; + end; end; end; { TBoldAbstractUndoHandler } + procedure TBoldAbstractUndoHandler.DeleteObject(BoldObject: TBoldObject); begin if BoldObject.BoldPersistenceState <> bvpsModified then @@ -7066,13 +10001,13 @@ class function TBoldAbstractUndoHandler.GetControllerForMember(Member: TBoldMemb { TBoldObjectReference_Proxy } -procedure TBoldObjectReference_Proxy.AssignContentValue(Source: IBoldValue); +procedure TBoldObjectReference_Proxy.AssignContentValue(const Source: IBoldValue); begin Assert(ProxedController is TBoldObjectReferenceController); if Mode = bdepContents then TBoldObjectReferenceController(ProxedController).AssignContentValue(Source) else - UnsupportedMode(Mode, 'AssignContentValue'); // do not localize + UnsupportedMode(Mode, 'AssignContentValue'); end; function TBoldLocatorIdHashIndex.Hash(const Key): Cardinal; @@ -7090,7 +10025,7 @@ procedure TBoldAbstractSystemPersistenceHandler.EndFetchForAll( begin for i := 0 to ObjectList.Count - 1 do begin - anObject := ObjectList[i]; + anObject := ObjectList.Locators[i].BoldObject; if assigned(anObject) then anObject.EndFetchMembers(MemberIdList); end; @@ -7119,7 +10054,7 @@ procedure TBoldAbstractSystemPersistenceHandler.EndUpdateForAll( end; function TBoldAbstractSystemPersistenceHandler.StartUpdateForAll(ObjectList: TBoldObjectList): Boolean; - +{$IFNDEF NoMayUpdate} function MayUpdateForAll: Boolean; function ObjectProhibitsUpdate(anObject: TBoldObject): Boolean; @@ -7160,19 +10095,47 @@ function TBoldAbstractSystemPersistenceHandler.StartUpdateForAll(ObjectList: TBo IfNecessaryDoStartUpdateObject(anObject); end; end; - +{$ENDIF} begin +{$IFNDEF NoMayUpdate} result := MayUpdateForAll; if result then DoStartUpdateForAll; +{$ELSE} + result := true; +{$ENDIF} end; -initialization - G_ExternalDerivers := TBoldExternalizedReferenceList.Create; - G_ExternalDerivers.ManageReferencedObject := true; -finalization - G_ExternalDerivers.Free; -end. +procedure TBoldMemberDeriver.DoReverseDerive; +begin + SetDeriverState(bdsReverseDeriving); + if CanReversederive then + DerivedMember.ReverseDeriveMember; + case deriverstate of + bdsReverseDeriving: SetDeriverState(bdsOutOfDate); + bdsReverseDerivingSubscriptionOutOfDate: SetDeriverState(bdsSubscriptionOutOfDate); + end; +end; + +function TBoldMemberDeriver.GetCanReverseDerive: Boolean; +begin + Result := fDerivedMember.GetBoldMemberRTInfo.IsReverseDerived; +end; + +procedure InitDebugMethods; +begin + exit; + TBoldSystemLocatorList.Create.LocatorByIDString['']; + TBoldSystemLocatorList.Create.ObjectByIDString['']; + TopSortedIndex2ClassName(0); +end; +initialization + BoldFreeStandingObjectContentsClass := TBoldSystemFreeStandingObjectContents; + InitDebugMethods; +finalization + FreeAndNil(_BoldSystemList); + FreeAndNil(_BoldSystemInternalLog); +end. diff --git a/Source/ObjectSpace/BORepresentation/BoldSystemOldValuehandler.pas b/Source/ObjectSpace/BORepresentation/BoldSystemOldValuehandler.pas index 2c39fd18..a6724103 100644 --- a/Source/ObjectSpace/BORepresentation/BoldSystemOldValuehandler.pas +++ b/Source/ObjectSpace/BORepresentation/BoldSystemOldValuehandler.pas @@ -1,5 +1,7 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSystemOldValuehandler; -// Implementation of Old values in the form used for the optimistic locking support. interface @@ -31,7 +33,9 @@ TBoldOldValueHandler = class(TBoldAbstractOldValueHandler) implementation uses - SysUtils; + SysUtils, + BoldRev; + { TBoldOldValueHandler } @@ -54,20 +58,29 @@ function TBoldOldValueHandler.GetIsEmpty: Boolean; ObjectIdList: TBoldObjectIdList; ObjectContents: TBoldFreeStandingObjectContents; value: TBoldFreeStandingValue; - begin - result := true; + result := fOldValues.IdCount = 0; + if result then + exit; ObjectIdList := TBoldObjectIdList.Create; - fOldValues.AllObjectIds(objectIdList, false); - for i := 0 to ObjectIdList.Count-1 do - begin - ObjectContents := fOldValues.GetFSObjectContentsByObjectId(ObjectIdList[i]); - if assigned(objectContents) then - for m := 0 to ObjectContents.MemberCount do - begin - value := ObjectContents.FSValueByIndex[m]; - result := result and not assigned(value); - end; + try + fOldValues.AllObjectIds(objectIdList, false); // do we really need ALL objects ? + for i := 0 to ObjectIdList.Count-1 do + begin + ObjectContents := fOldValues.GetFSObjectContentsByObjectId(ObjectIdList[i]); + if assigned(objectContents) then + for m := 0 to ObjectContents.MemberCount do + begin + value := ObjectContents.FSValueByIndex[m]; + if assigned(value) then + begin + result := false; + exit; + end; + end; + end; + finally + ObjectIdList.Free; end; end; @@ -81,12 +94,17 @@ procedure TBoldOldValueHandler.MemberPersistenceStatePreChange( var aFSObjectContent: TBoldFreeStandingObjectContents; begin - // note! multilinks can have an oldvalue even if they are current. If they are invalidated, we drop the old value + if fOldValues.IsEmpty then + exit; if (BoldMember.BoldPersistenceState in [bvpsModified, bvpsCurrent]) and (NewState in [bvpsCurrent, bvpsInvalid]) then begin aFSObjectContent := fOldValues.GetFSObjectContentsByObjectId(BoldMember.OwningObject.BoldObjectLocator.BoldObjectID); if assigned(aFSObjectContent) then + begin aFSObjectContent.RemoveMemberByIndex(BoldMember.BoldMemberRTInfo.Index); + if aFSObjectContent.IsEmpty then + fOldValues.RemoveFSObjectContents(aFSObjectContent); + end; end; end; @@ -123,6 +141,7 @@ procedure TBoldOldValueHandler.PurgeEqualValues; value: TBoldFreeStandingValue; Id: TBoldObjectId; Member: TBoldMember; + bEqual: Boolean; function IdListPairEqual(IdList: TBFSObjectIdListrefPair; ObjectList: TBoldObjectList): Boolean; var @@ -152,6 +171,14 @@ procedure TBoldOldValueHandler.PurgeEqualValues; result := not assigned(ObjectRef.Locator) end; + function IdEqual(IdRef: TBFSObjectIdRef; ObjectRef: TBoldObjectReference): Boolean; + begin + if Assigned(IdRef.Id) then + result := assigned(ObjectRef.Locator) and IdRef.Id.IsEqual[ObjectRef.Locator.BoldObjectID] + else + result := not assigned(ObjectRef.Locator) + end; + begin ObjectIdList := TBoldObjectIdList.Create; try @@ -173,31 +200,67 @@ procedure TBoldOldValueHandler.PurgeEqualValues; value := ObjectContents.FSValueByIndex[m]; if assigned(value) then begin - if not Locator.BoldObject.BoldMemberAssigned[m] then - ObjectContents.RemoveMemberByIndex(m) - else - begin + if not Locator.BoldObject.BoldMemberAssigned[m] then begin + ObjectContents.RemoveMemberByIndex(m); + end else begin Member := Locator.BoldObject.BoldMembers[m]; - if Member.BoldPersistenceState = bvpsInvalid then - ObjectContents.RemoveMemberByIndex(m) // invalidate should have handled this case already... - else if (value is TBFSObjectIdListrefPair) and - IdListPairEqual(value as TBFSObjectIdListRefPair, Member as TBoldObjectList) then - ObjectContents.RemoveMemberByIndex(m) - else if (value is TBFSObjectIdListRef) and - IdListEqual(value as TBFSObjectIdListRef, Member as TBoldObjectList) then - ObjectContents.RemoveMemberByIndex(m) - else if (value is TBFSObjectIdRefPair) and - IdPairEqual(value as TBFSObjectIdRefPair, Member as TBoldObjectReference) then - ObjectContents.RemoveMemberByIndex(m) + if Member.BoldPersistenceState = bvpsInvalid then begin + ObjectContents.RemoveMemberByIndex(m); // invalidate should have handled this case already... + end else if (value is TBFSObjectIdListrefPair) then begin + if IdListPairEqual(TBFSObjectIdListRefPair(value), + Member as TBoldObjectList) then + begin + ObjectContents.RemoveMemberByIndex(m); + end; + end else if (value is TBFSObjectIdListRef) then begin + if IdListEqual(TBFSObjectIdListRef(value), + Member as TBoldObjectList) then + begin + ObjectContents.RemoveMemberByIndex(m); + end; + end else if (value is TBFSObjectIdRefPair) then begin + if IdPairEqual(TBFSObjectIdRefPair(value), + Member as TBoldObjectReference) then + begin + ObjectContents.RemoveMemberByIndex(m); + end; + end else if (value is TBFSObjectIdRef) then begin + if IdEqual(TBFSObjectIdRef(value), + Member as TBoldObjectReference) then + begin + ObjectContents.RemoveMemberByIndex(m); + end; + end else if (Member is TBoldAttribute) and + Member.IsEqualToValue(value) then + begin + ObjectContents.RemoveMemberByIndex(m); + end; end; end; end; + + bEqual := True; + // Is there no longer any difference, OldValue can be completely removed + for m := 0 to ObjectContents.MemberCount do begin + value := ObjectContents.FSValueByIndex[m]; + if Assigned(value) then begin + bEqual := False; + Break; + end; + end; + if bEqual then begin + fOldValues.RemoveFSObjectContentsByObjectId(Id); + end; end; end; end; finally ObjectIdList.Free; end; + + fOldValues.ClearWhenObjectContentsEmpty; end; +initialization + end. diff --git a/Source/ObjectSpace/BORepresentation/BoldSystemPersistenceHandler.pas b/Source/ObjectSpace/BORepresentation/BoldSystemPersistenceHandler.pas index a476fe9d..bb6c1772 100644 --- a/Source/ObjectSpace/BORepresentation/BoldSystemPersistenceHandler.pas +++ b/Source/ObjectSpace/BORepresentation/BoldSystemPersistenceHandler.pas @@ -1,6 +1,8 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSystemPersistenceHandler; -// This unit contains implementations of functions in TBoldSystem related to persistence -// which could resonably have been separated, but are provided on TBoldSystem for user convenience + interface @@ -11,7 +13,8 @@ interface BoldSystem, BoldId, BoldPersistenceController, - BoldCondition; + BoldCondition, + BoldElements; type { forward declarations } @@ -22,28 +25,35 @@ TBoldTimeMappingCache = class; TBoldSystemPersistenceHandler = class(TBoldAbstractSystemPersistenceHandler) private fTimeStampOfLatestUpdate: TBoldTimeStampType; + fTimeOfLatestUpdate: TDateTime; fTimestampToTimeCache: TBoldTimeMappingCache; fTimeToTimestampCache: TBoldTimeMappingCache; - procedure DoPreUpdate; - function GetPersistenceController: TBoldPersistenceController; + procedure DoPreUpdate(ObjectList: TBoldObjectList); + procedure DoPostUpdate(ObjectList: TBoldObjectList); + function GetPersistenceController: TBoldPersistenceController; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure PMFetch(ObjectList: TBoldObjectList; MemberIdList: TBoldMemberIdList); protected function GetTimeStampOfLatestUpdate: TBoldTimeStampType; override; + function GetTimeOfLatestUpdate: TDateTime; override; property PersistenceController: TBoldPersistenceController read GetPersistenceController; public constructor Create(System: TBoldSystem); override; destructor Destroy; override; function EnsureEnclosure(ObjectList: TBoldObjectList; ValidateOnly: Boolean): Boolean; override; - procedure FetchLinksWithObjects(ObjectList: TBoldObjectList; const LinkName: string; FetchedObjects: TBoldObjectList); override; + procedure FetchMembersWithObjects(aBoldObjectList: TBoldObjectList; aBoldMemberIdList: TBoldMemberIdList); override; + procedure FetchMembersWithObjects(aBoldObjectList: TBoldObjectList; AMemberCommaList: string); override; + procedure FetchLinksWithObjects(ObjectList: TBoldObjectList; const LinkName: string; FetchObjectsInLink: Boolean = True{; const FetchedObjectList: TBoldObjectList = nil}); override; procedure FetchList(FetchList: TBoldObjectList); override; procedure FetchObjectById(BoldObjectId: TBoldObjectId); override; procedure FetchMember(Member: TBoldMember); override; procedure FetchClass(ClassList: TBoldObjectList; Time: TBoldTimestampType); override; procedure GetAllWithCondition(aList: TBoldObjectList; Condition: TBoldCondition); override; procedure GetAllInClassWithSQL(aList: TBoldObjectList; AClass: TBoldObjectClass; WhereClause, OrderByClause: String; Params: TParams; JoinInheritedTables: Boolean; MaxAnswers: integer; Offset: integer); override; + procedure GetAllInClassWithRawSQL(aList: TBoldObjectList; AClass: TBoldObjectClass; SQL: String; Params: TParams; MaxAnswers: integer; Offset: integer);override; function GetTimeForTimestamp(Timestamp: TBoldTimestampType): TDateTime; override; function GetTimestampForTime(ClockTime: TDateTime): TBoldTimestampType; override; - procedure UpdateDatabaseWithList(ObjectList: TBoldObjectList); override; + procedure UpdateDatabaseWithList(ObjectList: TBoldObjectList); override; + function CanEvaluateInPS(sOCL: string; aContext: TBoldElementTypeInfo = nil; const aVariableList: TBoldExternalVariableList = nil): Boolean; override; end; { TBoldTimeMappingCache } @@ -60,11 +70,14 @@ TBoldTimeMappingCache = class(TBoldMemoryManagedObject) procedure Add(Timestamp: TBoldTimestampType; ClockTime: TDateTime); end; + implementation uses + Classes, SysUtils, - BoldvalueInterfaces, + BoldSubscription, + BoldValueInterfaces, BoldValueSpaceInterfaces, BoldDomainElement, BoldSystemRT, @@ -72,31 +85,46 @@ implementation BoldUpdatePrecondition, BoldGuard, BoldMath, - BoldCoreConsts; + BoldRev; { TBoldSystemPersistenceHandler } +function TBoldSystemPersistenceHandler.CanEvaluateInPS(sOCL: string; + aContext: TBoldElementTypeInfo; + const aVariableList: TBoldExternalVariableList): Boolean; +begin + Result := PersistenceController.CanEvaluateInPS(sOCL, System, aContext, aVariableList); +end; + constructor TBoldSystemPersistenceHandler.Create(System: TBoldSystem); begin Inherited Create(System); fTimeStampOfLatestUpdate := -1; + fTimeOfLatestUpdate := 0; fTimestampToTimeCache := TBoldTimeMappingCache.Create(100); fTimeToTimestampCache := TBoldTimeMappingCache.Create(20); end; -procedure TBoldSystemPersistenceHandler.DoPreUpdate; +procedure TBoldSystemPersistenceHandler.DoPreUpdate(ObjectList: TBoldObjectList); begin + System.SendExtendedEvent(beBeginUpdate, [ObjectList]); if Assigned(OnPreUpdate) then - OnPreUpdate(self); + OnPreUpdate(ObjectList); +end; + +procedure TBoldSystemPersistenceHandler.DoPostUpdate( + ObjectList: TBoldObjectList); +begin + System.SendExtendedEvent(beEndUpdate, [ObjectList]); + if Assigned(OnPostUpdate) then + OnPostUpdate(ObjectList); end; function TBoldSystemPersistenceHandler.EnsureEnclosure(ObjectList: TBoldObjectList; ValidateOnly: Boolean): Boolean; -// TODO: The enclosure should include the expanded "regions" of all objects in the list var - I, M : Integer; + I,J,M : Integer; ExamineBoldObject: TBoldObject; ListIsEnclosure: Boolean; - MemberRTInfo: TBoldMemberRTInfo; RoleRTInfo: TBoldRoleRTInfo; OtherEnd: TBoldObjectReference; ObjectReference: TBoldObjectReference; @@ -110,7 +138,8 @@ function TBoldSystemPersistenceHandler.EnsureEnclosure(ObjectList: TBoldObjectLi if not ValidateOnly then begin if (Locator.BoldObjectId is TBoldInternalObjectId) and not assigned(Locator.BoldObject) then - assert(false, 'Internal Error, a deleted non-saved object got into the enclosure, try to figure out why...') + assert(false, Format('Internal Error, a deleted non-saved object got into the enclosure, while processing Object ID:%s(%s), Role:%s. Locator.Id:%s.', + [ExamineBoldObject.Displayname, ExamineBoldObject.BoldObjectLocator.AsString, RoleRTInfo.asString, Locator.BoldObjectId.AsString])) else ObjectList.AddLocator(Locator); end; @@ -143,13 +172,11 @@ function TBoldSystemPersistenceHandler.EnsureEnclosure(ObjectList: TBoldObjectLi begin if RoleRTInfo.IsMultiRole then begin - // Indirect MultiLink for i := 0 to (OldValue as IBoldObjectIdListRefPair).Count-1 do AddIdToEnclosure((OldValue as IBoldObjectIdListRefPair).IdList1[i]); end else begin - // Indirect SingleLink AddIdToEnclosure((OldValue as IBoldObjectIdRefPair).Id1); end; end @@ -157,13 +184,11 @@ function TBoldSystemPersistenceHandler.EnsureEnclosure(ObjectList: TBoldObjectLi begin if RoleRTInfo.IsMultiRole then begin - // Direct Multilink for i := 0 to (OldValue as IBoldObjectIdListRef).Count-1 do AddIdToEnclosure((OldValue as IBoldObjectIdListRef).IdList[i]); end else begin - // Direct Singlelink if RoleRTInfo.RoleRTInfoOfOtherEnd.IsStoredInObject then AddIdToEnclosure((OldValue as IBoldObjectIdRef).Id); end; @@ -171,59 +196,125 @@ function TBoldSystemPersistenceHandler.EnsureEnclosure(ObjectList: TBoldObjectLi end; end; +var + OldCount: Integer; //PATCH begin +{$IFDEF NoEnsureEnclosure} + exit; +{$ENDIF} ListIsEnclosure := true; i := 0; while i < ObjectList.Count do - begin + begin + OldCount := ObjectList.Count; //PATCH ExamineBoldObject := ObjectList[i]; - for M := 0 to ExamineBoldObject.BoldClassTypeInfo.AllMembers.Count - 1 do + if OldCount<=ObjectList.Count then //PATCH + Inc(i); //PATCH + for J := 0 to ExamineBoldObject.BoldClassTypeInfo.AllRoles.Count - 1 do begin - MemberRTInfo := ExamineBoldObject.BoldClassTypeInfo.AllMembers[M]; - if memberRTInfo.IsRole then + RoleRTInfo := ExamineBoldObject.BoldClassTypeInfo.AllRoles[J]; + M := RoleRTInfo.Index; + if RoleRTInfo.IsSingleRole and RoleRTInfo.Persistent and RoleRTInfo.IsStoredInObject and + ExamineBoldObject.BoldMemberAssigned[M] and (ExamineBoldObject.BoldMembers[M].BoldPersistenceState = bvpsModified) then begin - RoleRTInfo := MemberRTInfo as TBoldRoleRTInfo; - - if RoleRTInfo.IsSingleRole and RoleRTInfo.Persistent and RoleRTInfo.IsStoredInObject and - ExamineBoldObject.BoldMemberAssigned[M] and - (ExamineBoldObject.BoldMembers[M].BoldPersistenceState = bvpsModified) then + ObjectReference := ExamineBoldObject.BoldMembers[M] as TBoldObjectReference; + if Assigned(ObjectReference.Locator) and not ObjectReference.Locator.ObjectIsPersistent then + raise EBold.CreateFmt('Can not update Object "%s", role "%s" points to object "%s" which is transient.', [ExamineBoldObject.DisplayName, ExamineBoldObject.BoldMembers[M].BoldMemberRTInfo.ExpressionName, ObjectReference.BoldObject.DisplayName]); + if RoleRTInfo.RoleRTInfoOfOtherEnd.IsStoredInObject then begin - // singlelinks should include the other end if it is stored or belongs to a new object - ObjectReference := ExamineBoldObject.BoldMembers[M] as TBoldObjectReference; - if RoleRTInfo.RoleRTInfoOfOtherEnd.IsStoredInObject then - begin - AddLocatorToEnclosure(ObjectReference.Locator); - AddOldValuesForRole(ObjectReference, RoleRTInfo); - end - else + AddLocatorToEnclosure(ObjectReference.Locator); + AddOldValuesForRole(ObjectReference, RoleRTInfo); + end + else + begin + AddUnsavedLocatorToEnclosure(ObjectReference.Locator); + if RoleRTInfo.RoleRTInfoOfOtherEnd.IsSingleRole then begin - AddUnsavedLocatorToEnclosure(ObjectReference.Locator); - if RoleRTInfo.RoleRTInfoOfOtherEnd.IsSingleRole then + + if assigned(ObjectReference.Locator) and assigned(ObjectReference.Locator.BoldObject) then begin - // the other end is single-nonembedded, so we must include the old value of that link in our enclosure - // to make sure that the unlinking of that link is saved at the same time. - if assigned(ObjectReference.Locator) and assigned(ObjectReference.Locator.BoldObject) then - begin - OtherEnd := ObjectReference.Locator.BoldObject.BoldMembers[RoleRTInfo.IndexOfOtherEnd] as TBoldObjectReference; - AddIdToEnclosure(OtherEnd.OldEmbeddingOtherEndId); - end; + OtherEnd := ObjectReference.Locator.BoldObject.BoldMembers[RoleRTInfo.IndexOfOtherEnd] as TBoldObjectReference; + AddIdToEnclosure(OtherEnd.OldEmbeddingOtherEndId); end; end; end; + end; - if ExamineBoldObject.BoldObjectIsDeleted then - begin - AddOldValuesForRole(ExamineBoldObject.BoldMembers[M], RoleRTInfo); - end; + if ExamineBoldObject.BoldObjectIsDeleted then + begin + AddOldValuesForRole(ExamineBoldObject.BoldMembers[M], RoleRTInfo); end; end; System.OptimisticLockHandler.EnsureEnclosure(ExamineBoldObject, ObjectList, ValidateOnly, ListIsEnclosure); - inc(i); + //PATCH MOVED UP Inc(i); end; result := ListIsEnclosure; end; -procedure TBoldSystemPersistenceHandler.FetchLinksWithObjects(ObjectList: TBoldObjectList; const LinkName: string; FetchedObjects: TBoldObjectList); +procedure TBoldSystemPersistenceHandler.FetchMembersWithObjects( + aBoldObjectList: TBoldObjectList; aBoldMemberIdList: TBoldMemberIdList); +var + ListToFetch: TBoldObjectList; + vObject: TBoldObject; + i,j: integer; +begin + ListToFetch := TBoldObjectList.Create; + try + for i := 0 to aBoldObjectList.Count - 1 do + begin + vObject := aBoldObjectList.Locators[i].BoldObject; + if not Assigned(vObject) then + ListToFetch.AddLocator(aBoldObjectList.Locators[i]) + else + if Assigned(aBoldMemberIdList) then + begin + for j := 0 to aBoldMemberIdList.Count - 1 do + if not vObject.BoldMemberAssigned[aBoldMemberIdList[j].MemberIndex] then + begin + ListToFetch.Add(vObject); + break; + end; + end + else + ListToFetch.Add(vObject); + end; + PMFetch(ListToFetch, aBoldMemberIdList); + finally + ListToFetch.free; + end; +end; + +procedure TBoldSystemPersistenceHandler.FetchMembersWithObjects( + aBoldObjectList: TBoldObjectList; AMemberCommaList: string); +var + sl: TStringList; + i,j: integer; + vMemberIdList: TBoldMemberIdList; + vLeastCommonClassType: TBoldClassTypeInfo; +begin + if aBoldObjectList.Empty then + exit; + sl := TStringList.Create; + vMemberIdList := TBoldMemberIdList.Create; + try + sl.CommaText := AMemberCommaList; + vLeastCommonClassType := aBoldObjectList.LeastCommonClassType(System); + for i := 0 to sl.Count - 1 do + begin + j := vLeastCommonClassType.MemberIndexByExpressionName[sl[i]]; + if j = -1 then + raise EBold.CreateFmt('Member %s not found in class %s.', [sl[i], vLeastCommonClassType.ExpressionName]); + if vLeastCommonClassType.AllMembers[j].Persistent then + vMemberIdList.Add(TBoldMemberId.create(j)); + end; + FetchMembersWithObjects(aBoldObjectList, vMemberIdList); + finally + vMemberIdList.free; + sl.free; + end; +end; + +procedure TBoldSystemPersistenceHandler.FetchLinksWithObjects(ObjectList: TBoldObjectList; const LinkName: string;FetchObjectsInLink: Boolean = True{; const FetchedObjectList: TBoldObjectList = nil}); var CommonClass: TBoldClassTypeInfo; I, J: Integer; @@ -243,77 +334,79 @@ procedure TBoldSystemPersistenceHandler.FetchLinksWithObjects(ObjectList: TBoldO end; begin - Guard := tBoldGuard.Create(FetchList, MemberIdList); - - if not System.BoldPersistent or (ObjectList.Count = 0) then + if not System.BoldPersistent then exit; - - FetchList := TBoldObjectList.create; - MemberIdList := TBoldMemberIdList.Create; - ObjectList.EnsureObjects; - - // Find common class - CommonClass := ObjectList[0].BoldClassTypeInfo; - for I := 1 to ObjectList.Count - 1 do + if ObjectList.Count > 0 then begin - CommonClass := CommonClass.LeastCommonSuperClass(ObjectList[I].BoldClassTypeInfo); - if ObjectList[I].BoldSystem <> System then - raise EBoldFeatureNotImplementedYet.Create(sCannotFetchWithLinksFromMultipleSystems); - end; + Guard := TBoldGuard.Create(FetchList, MemberIdList); + FetchList := TBoldObjectList.Create; + FetchList.SubscribeToObjectsInList := False; + MemberIdList := TBoldMemberIdList.Create; + CommonClass := ObjectList[0].BoldClassTypeInfo; + for I := 1 to ObjectList.Count - 1 do + begin + CommonClass := CommonClass.LeastCommonSuperClass(ObjectList[I].BoldClassTypeInfo); + if ObjectList[I].BoldSystem <> System then + raise EBoldFeatureNotImplementedYet.Create('Can''t Fetch with link objects from multiple systems'); + end; - if not Assigned(CommonClass) then - raise EBold.CreateFmt(sNoCommonSuperClass, [ClassName]); + if not Assigned(CommonClass) then + raise EBold.CreateFmt('%s.FetchLinksWithObjects: Objects have no common superClass', [ClassName]); - MemberRTInfo := CommonClass.MemberRTInfoByExpressionName[LinkName]; - if not (MemberRTInfo is TBoldRoleRTInfo) then - raise EBold.CreateFmt(sNoRoleCalledX, [ClassName, CommonClass.ExpressionName, LinkName]); + MemberRTInfo := CommonClass.MemberRTInfoByExpressionName[LinkName]; + if not (MemberRTInfo is TBoldRoleRTInfo) then + raise EBold.CreateFmt('%s.FetchLinksWithObjects: class %s has no role called %s', [ClassName, CommonClass.ExpressionName, LinkName]); - roleRTInfo := MemberRTInfo as TBoldRoleRTInfo; + roleRTInfo := MemberRTInfo as TBoldRoleRTInfo; - if not roleRTInfo.IsStoredInObject and RoleRTInfo.Persistent and (RoleRTInfo.RoleType = rtRole) then - begin - for I := 0 to ObjectList.Count - 1 do - if ObjectList[I].BoldMembers[roleRTInfo.index].BoldPersistenceState = bvpsInvalid then - FetchList.Add(ObjectList[I]); - if FetchList.count > 0 then + if not roleRTInfo.IsStoredInObject and RoleRTInfo.Persistent and (RoleRTInfo.RoleType = rtRole) then begin - MemberIdList.Add(TBoldMemberId.Create(MemberRTInfo.index)); - PMFetch(FetchList, MemberIdList); + for I := 0 to ObjectList.Count - 1 do + if ObjectList[I].BoldMembers[roleRTInfo.index].BoldPersistenceState = bvpsInvalid then + FetchList.Add(ObjectList[I]); + if FetchList.count > 0 then + begin + MemberIdList.Add(TBoldMemberId.Create(MemberRTInfo.index)); + PMFetch(FetchList, MemberIdList); + end; end; - end; - - FetchList.Clear; - for I := 0 to ObjectList.Count - 1 do - begin - if roleRTInfo.IsMultiRole then - begin - MultiLink := ObjectList[I].BoldMembers[roleRTInfo.index] as TBoldObjectList; - for J := 0 to MultiLink.Count - 1 do - InternalAddLocator(MultiLink.Locators[J]); - end - else + FetchList.Clear; + for I := 0 to ObjectList.Count - 1 do begin - SingleLink := ObjectList[I].BoldMembers[roleRTInfo.index] as TBoldObjectReference; - InternalAddLocator(SingleLink.Locator); + if roleRTInfo.IsMultiRole then + begin + Assert(ObjectList[I].BoldMembers[roleRTInfo.index] is TBoldObjectList); + MultiLink := TBoldObjectList(ObjectList[I].BoldMembers[roleRTInfo.index]); + for J := 0 to MultiLink.Count - 1 do + InternalAddLocator(MultiLink.Locators[J]); + end + else + begin + Assert(ObjectList[I].BoldMembers[roleRTInfo.index] is TBoldObjectReference); + SingleLink := TBoldObjectReference(ObjectList[I].BoldMembers[roleRTInfo.index]); + InternalAddLocator(SingleLink.Locator); + end; end; + if (FetchList.Count>0) and FetchObjectsInLink then + PMFetch(FetchList, nil); end; - if FetchList.Count > 0 then - PMFetch(FetchList, nil); - if Assigned(FetchedObjects) then - FetchedObjects.Assign(FetchList); end; procedure TBoldSystemPersistenceHandler.FetchObjectById(BoldObjectId: TBoldObjectId); var ObjectList: TBoldObjectList; begin + PersistenceController.SendExtendedEvent(bpeStartFetchObjectById, [BoldObjectId]); ObjectList := TBoldObjectList.Create; + ObjectList.SubscribeToObjectsInList := false; + ObjectList.duplicateMode := bldmAllow; try ObjectList.AddLocator(System.EnsuredLocatorByID[BoldObjectID]); PMFetch(ObjectList, nil); finally ObjectList.Free; + PersistenceController.SendExtendedEvent(bpeEndFetchObjectById, [BoldObjectId]); end; end; @@ -324,11 +417,10 @@ procedure TBoldSystemPersistenceHandler.GetAllWithCondition(aList: TBoldObjectLi ObjectIdList: TBoldObjectIdList; begin if not assigned(PersistenceController) then - raise EBold.Create(sNoPersistenceController); + raise EBold.Create('Unable to fetch object ID''s. No PersistenceController...'); ObjectIdList := TBoldObjectIdList.Create; try PersistenceController.PMFetchIDListWithCondition(ObjectIdList, System.AsIBoldvalueSpace[bdepPMIn], fmNormal, Condition, NOTVALIDCLIENTID); - // remove objects that have been deleted in memory for I := ObjectIdList.Count - 1 downto 0 do begin Locator := System.Locators.LocatorByID[ObjectIdList[i]]; @@ -341,12 +433,57 @@ procedure TBoldSystemPersistenceHandler.GetAllWithCondition(aList: TBoldObjectLi end; end; +procedure TBoldSystemPersistenceHandler.GetAllInClassWithRawSQL( + aList: TBoldObjectList; AClass: TBoldObjectClass; SQL: String; + Params: TParams; MaxAnswers, Offset: integer); +var + Condition: TBoldRawSQLCondition; + LocalParams: TParams; + ClasstypeInfo: TBoldClasstypeInfo; + Guard: IBoldGuard; +begin + Guard := TBoldGuard.Create(Condition, LocalParams); + Condition := TBoldRawSQLCondition.Create; + Condition.SQL := SQL; + Condition.MaxAnswers := MaxAnswers; + Condition.Offset := Offset; + if assigned(aClass) then + begin + ClassTypeInfo := System.BoldSystemTypeInfo.TopSortedClasses.ItemsByObjectClass[AClass]; + if Assigned(ClassTypeInfo) then + Condition.TopSortedIndex := ClassTypeInfo.TopSortedIndex + else + raise EBold.CreateFmt('%s.GetAllInClassWithSQL: "%s" is not a class in the model', [classname, aClass.ClassName]); + end + else + raise EBold.CreateFmt('%s.GetAllInClassWithSQL: Must not be called without a class-parameter', [classname]); + + if not assigned(Params) then + begin + LocalParams := TParams.Create(nil); + Condition.Params := LocalParams; + end + else + begin + Condition.Params := PArams; + LocalParams := nil; + end; + PersistenceController.SendExtendedEvent(bpeStartFetchAllInClassWithRawSQL, [aList, AClass, Condition]); + try + GetAllWithCondition(aList, Condition); + finally + PersistenceController.SendExtendedEvent(bpeEndFetchAllInClassWithRawSQL, [aList, AClass, Condition]); + end; +end; + procedure TBoldSystemPersistenceHandler.GetAllInClassWithSQL(aList: TBoldObjectList; AClass: TBoldObjectClass; WhereClause, OrderByClause: String; Params: TParams; JoinInheritedTables: Boolean; MaxAnswers: integer; Offset: integer); var Condition: TBoldSQLCondition; LocalParams: TParams; ClasstypeInfo: TBoldClasstypeInfo; + Guard: IBoldGuard; begin + Guard := TBoldGuard.Create(Condition, LocalParams); Condition := TBoldSQLCondition.Create; Condition.WhereFragment := WhereClause; Condition.OrderBy := OrderByClause; @@ -359,10 +496,10 @@ procedure TBoldSystemPersistenceHandler.GetAllInClassWithSQL(aList: TBoldObjectL if Assigned(ClassTypeInfo) then Condition.TopSortedIndex := ClassTypeInfo.TopSortedIndex else - raise EBold.CreateFmt(sNoSuchClassInModel, [classname, aClass.ClassName]); + raise EBold.CreateFmt('%s.GetAllInClassWithSQL: "%s" is not a class in the model', [classname, aClass.ClassName]); end else - raise EBold.CreateFmt(sClassParameterMissing, [classname]); + raise EBold.CreateFmt('%s.GetAllInClassWithSQL: Must not be called without a class-parameter', [classname]); if not assigned(Params) then begin @@ -374,12 +511,11 @@ procedure TBoldSystemPersistenceHandler.GetAllInClassWithSQL(aList: TBoldObjectL Condition.Params := PArams; LocalParams := nil; end; - + PersistenceController.SendExtendedEvent(bpeStartFetchAllInClassWithSQL, [aList, AClass, Condition]); try GetAllWithCondition(aList, Condition); finally - Condition.Free; - LocalParams.Free; + PersistenceController.SendExtendedEvent(bpeEndFetchAllInClassWithSQL, [aList, AClass, Condition]); end; end; @@ -393,25 +529,23 @@ procedure TBoldSystemPersistenceHandler.UpdateDatabaseWithList(ObjectList: TBold Precondition: TBoldOptimisticLockingPrecondition; begin if System.InTransaction then - raise EBold.Create(sCannotUpdateWhileInTransaction); + raise EBold.Create('Can not update the database while in a transaction'); + if not assigned(PersistenceController) then + raise EBold.Create('Unable to UpdateDatabaseWithList. No PersistenceController.'); System.DelayObjectDestruction; ObjectsToUpdate := ObjectList.Clone as TBoldObjectList; try for i := ObjectsToUpdate.Count-1 downto 0 do - begin - if ObjectsToUpdate.Locators[i].BoldSystem <> System then - raise EBold.CreateFmt(sForeignObjectInUpdate, [classname]); if not assigned(ObjectsToUpdate.Locators[i].BoldObject) or not ObjectsToUpdate[i].BoldPersistent then ObjectsToUpdate.RemoveByIndex(i); - end; if ObjectsToUpdate.Count > 0 then begin - DoPreUpdate; EnsureEnclosure(ObjectsToUpdate, false); - ObjectIdList := ObjectsToUpdate.CreateObjectIdList; + DoPreUpdate(ObjectsToUpdate); + ObjectIdList := ObjectsToUpdate.CreateObjectIdList(true); aTranslationList := TBoldIdTranslationList.Create; if System.BoldSystemTypeInfo.OptimisticLocking = bolmOff then Precondition := nil @@ -423,21 +557,19 @@ procedure TBoldSystemPersistenceHandler.UpdateDatabaseWithList(ObjectList: TBold FreeAndNil(PreCondition); end; - //TODO: in the future, call another function to add optimistic locking data for optimistic region locking - //TODO: If the model wants optimistic locking, but none of the classes of objects to be updated, - // the precondition should be freed. + try if assigned(System.PessimisticLockHandler) and not System.PessimisticLockHandler.EnsureLocks then - raise EBold.CreateFmt(sRequiredLocksNotHeld, [classname]); + raise EBold.CreateFmt('%s.UpdateDatabaseWithList: Not allowed to update. No longer holding the required locks.', [classname]); BoldClearLastfailure; try if not StartUpdateForAll(ObjectsToUpdate) then - BoldRaiseLastFailure(System, 'UpdateDatabaseWithList', sStartUpdateFailed); // do not localize + BoldRaiseLastFailure(System, 'UpdateDatabaseWithList', 'StartUpdate failed'); - PersistenceController.PMUpdate(ObjectIdList, System.AsIBoldvalueSpace[bdepPMOut], nil, Precondition, aTranslationList, fTimeStampOfLatestUpdate, NOTVALIDCLIENTID); + PersistenceController.PMUpdate(ObjectIdList, System.AsIBoldvalueSpace[bdepPMOut], System.OptimisticLockHandler.OldValues, Precondition, aTranslationList, fTimeStampOfLatestUpdate, fTimeOfLatestUpdate, NOTVALIDCLIENTID); if assigned(Precondition) and Precondition.Failed then begin if assigned(system.OnOptimisticLockingFailed) then @@ -457,12 +589,15 @@ procedure TBoldSystemPersistenceHandler.UpdateDatabaseWithList(ObjectList: TBold for i := 0 to ObjectsToUpdate.Count - 1 do ObjectsToUpdate[i].AsIBoldObjectContents[bdepPMIn].TimeStamp := TimeStampOfLatestUpdate; EndUpdateForAll(ObjectsToUpdate, aTranslationList); + if Assigned(System.UndoHandler) then + System.UndoHandler.PrepareUpdate(ObjectList); end; + DoPostUpdate(ObjectList); except on e: Exception do begin if GetBoldLastFailureReason <> nil then - BoldRaiseLastFailure(System, 'UpdateDatabaseWithlist', e.message) // do not localize + BoldRaiseLastFailure(System, 'UpdateDatabaseWithlist', e.message) else raise; end; @@ -487,6 +622,11 @@ function TBoldSystemPersistenceHandler.GetTimeStampOfLatestUpdate: TBoldTimeStam Result := fTimeStampOfLatestUpdate; end; +function TBoldSystemPersistenceHandler.GetTimeOfLatestUpdate: TDateTime; +begin + Result := fTimeOfLatestUpdate; +end; + function TBoldSystemPersistenceHandler.GetPersistenceController: TBoldPersistenceController; begin Result := System.PersistenceController; @@ -499,8 +639,11 @@ procedure TBoldSystemPersistenceHandler.FetchMember(Member: TBoldMember); MemberId: TBoldMemberId; Guard: IBoldguard; begin + PersistenceController.SendExtendedEvent(bpeStartFetchMember, [Member]); Guard := TBoldGuard.Create(ObjectList, MemberIdList); ObjectList := TBoldObjectList.Create; + ObjectList.SubscribeToObjectsInList := false; + ObjectList.DuplicateMode := bldmAllow; ObjectList.Add(Member.OwningObject); if Member.BoldMemberRTInfo.DelayedFetch then begin @@ -509,6 +652,7 @@ procedure TBoldSystemPersistenceHandler.FetchMember(Member: TBoldMember); MemberIdList.Add(MemberId); end; PMFetch(ObjectList, MemberIdList); + PersistenceController.SendExtendedEvent(bpeEndFetchMember, [Member]); end; procedure TBoldSystemPersistenceHandler.FetchClass(ClassList: TBoldObjectList; Time: TBoldTimestampType); @@ -519,8 +663,9 @@ procedure TBoldSystemPersistenceHandler.FetchClass(ClassList: TBoldObjectList; T ListInterface: IBoldObjectIdListRef; begin if not assigned(PersistenceController) then - raise EBold.Create(sNoPersistenceController); + raise EBold.Create('Unable to fetch object ID''s. No PersistenceController.'); ClassTypeInfo := (ClassList.BoldType as TBoldListTypeInfo).ListElementTypeInfo as TBoldClassTypeInfo; + PersistenceController.SendExtendedEvent(bpeStartFetchClass, [ClassTypeInfo]); ObjectIdList := TBoldObjectIdList.Create; Condition := TBoldConditionWithClass.Create; @@ -534,6 +679,7 @@ procedure TBoldSystemPersistenceHandler.FetchClass(ClassList: TBoldObjectList; T finally FreeAndNil(Condition); FreeAndNil(ObjectIdList); + PersistenceController.SendExtendedEvent(bpeEndFetchClass, [ClassTypeInfo]); end; end; @@ -570,15 +716,13 @@ procedure TBoldSystemPersistenceHandler.PMFetch(ObjectList: TBoldObjectList; Mem var ObjectIdList: TBoldObjectIdList; Guard: IBoldGuard; - i: integer; begin - Guard := TBoldguard.Create(ObjectidList); - if Objectlist.Count > 0 then + if not assigned(PersistenceController) then + raise EBold.Create('Unable to PMFetch. No PersistenceController...'); + if (Objectlist.Count > 0) then begin - ObjectIdList := TBoldObjectIdList.Create; - for i := 0 to Objectlist.Count-1 do - ObjectIdList.Add(ObjectList.Locators[i].BoldObjectID); - + Guard := TBoldguard.Create(ObjectidList); + ObjectIdList := Objectlist.CreateObjectIdList(true); PersistenceController.PMFetch(ObjectIdList, System.AsIBoldvalueSpace[bdepPMIn], MemberIdList, fmNormal, NOTVALIDCLIENTID); EndFetchForAll(ObjectList, MemberIdList); end; diff --git a/Source/ObjectSpace/BORepresentation/BoldTypeList.pas b/Source/ObjectSpace/BORepresentation/BoldTypeList.pas index 6e2bab2b..fb00e8c6 100644 --- a/Source/ObjectSpace/BORepresentation/BoldTypeList.pas +++ b/Source/ObjectSpace/BORepresentation/BoldTypeList.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldTypeList; interface @@ -7,7 +10,8 @@ interface BoldSubscription, BoldSystem, BoldDomainElement, - BoldElements; + BoldElements, + BoldDefs; type { forward declarations } @@ -24,12 +28,13 @@ TBoldTypeList = class(TBoldList) function GetElement(index: Integer): TBoldElement; override; function IncludesElement(Item: TBoldElement): Boolean; override; function IndexOfElement(Item: TBoldElement): Integer; override; - procedure InitializeMember(AOwningElement: TBoldDomainElement; ElementTypeInfo: TBoldElementTypeInfo); override; + procedure Initialize; override; procedure InsertElement(index: Integer; Element: TBoldElement); override; procedure SetElement(index: Integer; Value: TBoldElement); override; function InternalAddNew: TBoldElement; override; - function ProxyClass: TBoldMember_ProxyClass; override; + function GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; override; procedure InternalClear; override; + function GetStringRepresentation(Representation: TBoldRepresentation): string; override; public procedure Assign(Source: TBoldElement); override; procedure DefaultSubscribe(Subscriber: TBoldSubscriber; RequestedEvent: TBoldEvent = breReEvaluate); override; @@ -48,10 +53,8 @@ implementation uses SysUtils, - BoldDefs, BoldMetaElementList, - BoldSystemRT, - BoldCoreConsts; + BoldSystemRT; type { TBoldTypeListController } @@ -65,7 +68,7 @@ TBoldTypeListController = class(TBoldListController) property List: TBoldElementTypeInfoList read fList; function GetStreamName: string; override; public - constructor Create(OwningList: TBoldList); + constructor Create(OwningList: TBoldList); override; destructor Destroy; override; procedure AddElement(Element: TBoldElement); override; function GetElement(index: Integer): TBoldElement; override; @@ -81,13 +84,12 @@ TBoldTypeListController = class(TBoldListController) procedure TBoldTypeList.AddElement(Element: TBoldElement); begin - if (ListController.IndexOfElement(element) = -1) or DuplicateControl then - listcontroller.AddElement(element); + if (DuplicateMode = bldmAllow) or (ListController.IndexOfElement(element) = -1) or DuplicateControl then + ListController.AddElement(element); end; procedure TBoldTypeList.AllocateData; begin - // do nothing end; procedure TBoldTypeList.Assign(Source: TBoldElement); @@ -105,7 +107,6 @@ procedure TBoldTypeList.DefaultSubscribe(Subscriber: TBoldSubscriber; RequestedE procedure TBoldTypeList.FreeData; begin - // do nothing end; function TBoldTypeList.GetCount: Integer; @@ -118,6 +119,16 @@ function TBoldTypeList.GetElement(index: Integer): TBoldElement; result := ListController.GetElement(index); end; +function TBoldTypeList.GetProxy(Mode: TBoldDomainElementProxyMode): TBoldMember_Proxy; +begin + raise EBold.CreateFmt('%s.GetProxy: Not available in this class.', [classname]) +end; + +function TBoldTypeList.GetStringRepresentation(Representation: TBoldRepresentation): string; +begin + result := IntToStr(Count); +end; + function TBoldTypeList.IncludesElement(Item: TBoldElement): Boolean; begin result := ListController.IncludesElement(item); @@ -128,7 +139,7 @@ function TBoldTypeList.IndexOfElement(Item: TBoldElement): Integer; result := ListController.IndexOfElement(item); end; -procedure TBoldTypeList.InitializeMember(AOwningElement: TBoldDomainElement; ElementTypeInfo: TBoldElementTypeInfo); +procedure TBoldTypeList.Initialize; begin ListController := TBoldTypeListController.Create(self); DuplicateMode := bldmAllow; @@ -142,12 +153,12 @@ procedure TBoldTypeList.InsertElement(index: Integer; Element: TBoldElement); procedure TBoldTypeList.InsertNew(index: Integer); begin - raise EBold.CreateFmt(sCannotInsertTypes, [classname]) + raise EBold.CreateFmt('%s.InsertNew: Types can not be inserted like this', [classname]) end; function TBoldTypeList.InternalAddNew: TBoldElement; begin - raise EBold.CreateFmt(sCannotAddTypes, [classname]) + raise EBold.CreateFmt('%s.InternalAddNew: Types can not be added like this', [classname]) end; procedure TBoldTypeList.InternalClear; @@ -163,10 +174,12 @@ procedure TBoldTypeList.Move(CurIndex, NewIndex: Integer); ListController.Move(CurIndex, NewIndex); end; +(* function TBoldTypeList.ProxyClass: TBoldMember_ProxyClass; begin - raise EBold.CreateFmt(sAbstractError_InterfaceNotSupported, [ClassName]); + raise EBold.CreateFmt('Abstract error: %s.ProxyClass (IBoldValue not supported!)', [ClassName]); end; +*) procedure TBoldTypeList.RemoveByIndex(index: Integer); begin @@ -185,7 +198,7 @@ procedure TBoldTypeListController.AddElement(Element: TBoldElement); if element is TBoldElementTypeInfo then list.Add(element as TBoldElementTypeInfo) else - raise EBold.CreateFmt(sCannotAddElement, [element.ClassName]); + raise EBold.CreateFmt('Can not add element: %s', [element.ClassName]); end; constructor TBoldTypeListController.Create(OwningList: TBoldList); @@ -196,7 +209,7 @@ constructor TBoldTypeListController.Create(OwningList: TBoldList); function TBoldTypeListController.CreateNew: TBoldElement; begin - raise EBold.Create(sCannotCreateNewInTypeLists); + raise EBold.Create('Can not create new in Typelists'); end; destructor TBoldTypeListController.Destroy; @@ -223,7 +236,7 @@ function TBoldTypeListController.GetElement(index: Integer): TBoldElement; function TBoldTypeListController.GetStreamName: string; begin result := ''; - raise EBold.create(sNotImplemented); + raise EBold.create('not implemented'); end; function TBoldTypeListController.IncludesElement(Item: TBoldElement): Boolean; @@ -241,6 +254,7 @@ procedure TBoldTypeListController.InsertElement(index: Integer; Element: TBoldE list.Insert(index, element); end; + procedure TBoldTypeListController.Move(CurrentIndex, NewIndex: Integer); begin list.Move(CurrentIndex, NewIndex); @@ -253,7 +267,7 @@ procedure TBoldTypeListController.RemoveByIndex(index: Integer); procedure TBoldTypeListController.SetElement(index: Integer; Value: TBoldElement); begin - raise Ebold.Create(sCannotSetElementsInTypeLists); + raise Ebold.Create('Can not set elements in TypeLists'); end; { TBoldTypeListFactory } diff --git a/Source/ObjectSpace/COM/BoldComObjectSpace.pas b/Source/ObjectSpace/COM/BoldComObjectSpace.pas index 079c7caf..d4aacc57 100644 --- a/Source/ObjectSpace/COM/BoldComObjectSpace.pas +++ b/Source/ObjectSpace/COM/BoldComObjectSpace.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComObjectSpace; interface @@ -45,8 +48,7 @@ implementation uses SysUtils, BoldComUtils, - BoldComObjectSpace_TLB, - BoldComConst; + BoldComObjectSpace_TLB; var G_TypeLibrary: ITypeLib = nil; @@ -56,9 +58,11 @@ function BoldComObjectSpaceTypeLibrary: ITypeLib; if not Assigned(G_TypeLibrary) then begin if Failed(LoadRegTypeLib(LIBID_BoldComObjectSpace,1,0,0,G_TypeLibrary)) then - raise EBoldCom.Create(sUnableToLoadComObjectSpace); + raise EBoldCom.Create('Unable to load type library (BoldComObjectSpace)'); end; Result := G_TypeLibrary; end; +initialization + end. diff --git a/Source/ObjectSpace/COM/BoldComObjectSpaceAdapters.pas b/Source/ObjectSpace/COM/BoldComObjectSpaceAdapters.pas index 6bdb6cbc..2f36d6a2 100644 --- a/Source/ObjectSpace/COM/BoldComObjectSpaceAdapters.pas +++ b/Source/ObjectSpace/COM/BoldComObjectSpaceAdapters.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComObjectSpaceAdapters; interface @@ -633,8 +636,7 @@ implementation BoldComUtils, BoldComObj, BoldComServer, - BoldComObjectSpace, - BoldComConst; + BoldComObjectSpace; procedure CreateIndirectAdapter(IndirectElement: TBoldIndirectElement; const IID: TGUID; out Obj); var @@ -660,13 +662,13 @@ procedure CreateIndirectAdapter(IndirectElement: TBoldIndirectElement; const IID if not Assigned(Adapter) then begin if Owner then Adaptee.Free; - raise EBoldCom.CreateFmt(sNoAdapterRegistered, [Adaptee.ClassName]); + raise EBoldCom.CreateFmt('No adapter registered for %s', [Adaptee.ClassName]); end; UnknownAdapter := Adapter; if UnknownAdapter.QueryInterface(IID,Obj) <> 0 then begin UnknownAdapter := nil; - raise EBoldCom.CreateFmt(sUnsupportedInterface, [Adapter.ClassName]); + raise EBoldCom.CreateFmt('%s: Unsupported interface', [Adapter.ClassName]); end; end; end; @@ -1081,12 +1083,12 @@ procedure TBoldComElementAdapter.Set_AsString(const Value: WideString); function TBoldComElementAdapter.Get_AsVariant: OleVariant; begin - Result := AsElement.GetAsVariant; + Result := AsElement.AsVariant; end; procedure TBoldComElementAdapter.Set_AsVariant(Value: OleVariant); begin - AsElement.SetAsVariant(Value); + AsElement.AsVariant := Value; end; function TBoldComElementAdapter.Get_BoldType: IBoldElementTypeInfo; @@ -1599,7 +1601,7 @@ procedure TBoldComObjectAdapter.LinkObject(const RoleName: WideString; else if LinkObj is TBoldObjectList then TBoldObjectList(LinkObj).Add(BoldObj) else - raise EBoldCom.CreateFmt(sRoleDoesNotExist, [ClassName, 'LinkObject', RoleName]); // do not localize + raise EBoldCom.CreateFmt('%.LinkObject: Role %s does not exist', [ClassName, RoleName]); end; end; @@ -1644,7 +1646,7 @@ procedure TBoldComObjectAdapter.UnlinkObject(const RoleName: WideString; end; end else - raise EBoldCom.CreateFmt(sRoleDoesNotExist, [ClassName, 'UnlinkObject', RoleName]); // do not localize + raise EBoldCom.CreateFmt('%.UnlinkObject: Role %s does not exist', [ClassName, RoleName]); end; function TBoldComObjectAdapter.Get_BoldClassTypeInfo: IBoldClassTypeInfo; @@ -1673,17 +1675,17 @@ function TBoldComObjectAdapter.Get_BoldMember(Index: OleVariant): IBoldMember; function TBoldComObjectAdapter.Get_BoldMemberValue(Index: OleVariant): OleVariant; begin if BoldVariantIsType(Index,varOleStr) then - Result := AsObject.BoldMemberByExpressionName[Index].GetAsVariant + Result := AsObject.BoldMemberByExpressionName[Index].AsVariant else - Result := AsObject.BoldMembers[Index].GetAsVariant; + Result := AsObject.BoldMembers[Index].AsVariant; end; procedure TBoldComObjectAdapter.Set_BoldMemberValue(Index: OleVariant; Value: OleVariant); begin if BoldVariantIsType(Index,varOleStr) then - AsObject.BoldMemberByExpressionName[Index].SetAsVariant(Value) + AsObject.BoldMemberByExpressionName[Index].AsVariant := Value else - AsObject.BoldMembers[Index].SetAsVariant(Value); + AsObject.BoldMembers[Index].AsVariant := Value; end; function TBoldComObjectAdapter.Get_BoldMemberValues: OleVariant; @@ -1704,7 +1706,7 @@ function TBoldComObjectAdapter.Get_BoldMemberValues: OleVariant; begin Member := ThisObject.BoldMembers[MemberIndex]; NameArray[MemberIndex] := Member.BoldMemberRtInfo.ExpressionName; - DataArray[MemberIndex] := Member.GetAsVariant; + DataArray[MemberIndex] := Member.AsVariant; end; Result := VarArrayCreate([0, 1], varVariant); Result[0] := NameArray; @@ -1728,7 +1730,7 @@ procedure TBoldComObjectAdapter.Set_BoldMemberValues(Values: OleVariant); end; end else - raise EBoldCom.CreateFmt(sUnknownDataFormat, [ClassName]); + raise EBoldCom.CreateFmt('%s.BoldMemberValues: Unknown data format', [ClassName]); end; function TBoldComObjectAdapter.Get_BoldPersistenceState: Integer; @@ -1838,6 +1840,7 @@ procedure TBoldComMemberAdapter.ReceiveEvent(Originator: TObject; inherited; end; + {-- TBoldComAttributeAdapter -----------------------------------------------------} constructor TBoldComAttributeAdapter.Create(AdaptableObject: TBoldAdaptableObject; @@ -2345,7 +2348,7 @@ function TBoldComSystemHandleAdapter.GetData(DataFlags: Integer; Result := True; This := AsSystemHandle; if dataflags = DF_HANDLEID then - NamedValues := BoldCreateNamedValues(['HandleId'], [integer(this)]) // do not localize + NamedValues := BoldCreateNamedValues(['HandleId'], [integer(this)]) else begin BoldComCreateAdapter(This.Value, False, IBoldElement, Value); @@ -2361,9 +2364,9 @@ function TBoldComSystemHandleAdapter.GetData(DataFlags: Integer; BoldList := nil; ListElementType := nil; NamedValues := BoldCreateNamedValues( - ['HandleId', // do not localize - 'Active', // do not localize - 'Persistent'], // do not localize + ['HandleId', + 'Active', + 'Persistent'], [Integer(This), This.Active, This.Persistent]); @@ -2373,7 +2376,6 @@ function TBoldComSystemHandleAdapter.GetData(DataFlags: Integer; function TBoldComSystemHandleAdapter.SetData(DataFlags: Integer; const Value: IBoldElement; NamedValues: OleVariant): WordBool; begin - // not allowed to set Result := False; end; @@ -2406,7 +2408,7 @@ function TBoldComDerivedHandleAdapter.GetData(DataFlags: Integer; Result := True; This := AsDerivedHandle; if dataflags = DF_HANDLEID then - NamedValues := BoldCreateNamedValues(['HandleId'], [integer(this)]) // do not localize + NamedValues := BoldCreateNamedValues(['HandleId'], [integer(this)]) else begin BoldComCreateAdapter(This.Value, False, IBoldElement, Value); @@ -2419,12 +2421,12 @@ function TBoldComDerivedHandleAdapter.GetData(DataFlags: Integer; BoldList := nil; ListElementType := nil; NamedValues := BoldCreateNamedValues( - ['HandleId', // do not localize - 'StaticSystemHandle', // do not localize - 'Enabled', // do not localize - 'RootHandle', // do not localize - 'RootTypeName', // do not localize - 'Subscribe'], // do not localize + ['HandleId', + 'StaticSystemHandle', + 'Enabled', + 'RootHandle', + 'RootTypeName', + 'Subscribe'], [Integer(This), Integer(This.StaticSystemHandle), This.Enabled, @@ -2443,7 +2445,7 @@ function TBoldComDerivedHandleAdapter.SetData(DataFlags: Integer; This := AsDerivedHandle; if (DataFlags and DF_STATICSYSTEMHANDLE) <> 0 then begin - HandleId := BoldGetNamedValue(NamedValues,'StaticSystemHandle'); // do not localize + HandleId := BoldGetNamedValue(NamedValues,'StaticSystemHandle'); if HandleId = 0 then This.StaticSystemHandle := nil else @@ -2451,11 +2453,11 @@ function TBoldComDerivedHandleAdapter.SetData(DataFlags: Integer; end; if (DataFlags and DF_ENABLED) <> 0 then begin - This.Enabled := BoldGetNamedValue(NamedValues, 'Enabled'); // do not localize + This.Enabled := BoldGetNamedValue(NamedValues, 'Enabled'); end; if (DataFlags and DF_ROOTHANDLE) <> 0 then begin - HandleId := BoldGetNamedValue(NamedValues, 'RootHandle'); // do not localize + HandleId := BoldGetNamedValue(NamedValues, 'RootHandle'); if HandleId = 0 then This.RootHandle := nil else @@ -2463,11 +2465,11 @@ function TBoldComDerivedHandleAdapter.SetData(DataFlags: Integer; end; if (DataFlags and DF_ROOTTYPENAME) <> 0 then begin - This.RootTypeName := BoldGetNamedValue(NamedValues, 'RootTypeName'); // do not localize + This.RootTypeName := BoldGetNamedValue(NamedValues, 'RootTypeName'); end; if (DataFlags and DF_SUBSCRIBE) <> 0 then begin - This.Subscribe := BoldGetNamedValue(NamedValues, 'Subscribe'); // do not localize + This.Subscribe := BoldGetNamedValue(NamedValues, 'Subscribe'); end; end; @@ -2500,7 +2502,7 @@ function TBoldComExpressionHandleAdapter.GetData(DataFlags: Integer; Result := True; This := AsExpressionHandle; if dataflags = DF_HANDLEID then - NamedValues := BoldCreateNamedValues(['HandleId'], [integer(this)]) // do not localize + NamedValues := BoldCreateNamedValues(['HandleId'], [integer(this)]) else begin BoldComCreateAdapter(This.Value, False, IBoldElement, Value); @@ -2513,14 +2515,14 @@ function TBoldComExpressionHandleAdapter.GetData(DataFlags: Integer; BoldList := nil; ListElementType := nil; NamedValues := BoldCreateNamedValues( - ['HandleId', // do not localize - 'StaticSystemHandle', // do not localize - 'Enabled', // do not localize - 'RootHandle', // do not localize - 'RootTypeName', // do not localize - 'Subscribe', // do not localize - 'Expression', // do not localize - 'EvaluateInPS'], // do not localize + ['HandleId', + 'StaticSystemHandle', + 'Enabled', + 'RootHandle', + 'RootTypeName', + 'Subscribe', + 'Expression', + 'EvaluateInPS'], [Integer(This), Integer(This.StaticSystemHandle), This.Enabled, @@ -2541,7 +2543,7 @@ function TBoldComExpressionHandleAdapter.SetData(DataFlags: Integer; This := AsExpressionHandle; if (DataFlags and DF_STATICSYSTEMHANDLE) <> 0 then begin - HandleId := BoldGetNamedValue(NamedValues, 'StaticSystemHandle'); // do not localize + HandleId := BoldGetNamedValue(NamedValues, 'StaticSystemHandle'); if HandleId = 0 then This.StaticSystemHandle := nil else @@ -2549,11 +2551,11 @@ function TBoldComExpressionHandleAdapter.SetData(DataFlags: Integer; end; if (DataFlags and DF_ENABLED) <> 0 then begin - This.Enabled := BoldGetNamedValue(NamedValues, 'Enabled'); // do not localize + This.Enabled := BoldGetNamedValue(NamedValues, 'Enabled'); end; if (DataFlags and DF_ROOTHANDLE) <> 0 then begin - HandleId := BoldGetNamedValue(NamedValues, 'RootHandle'); // do not localize + HandleId := BoldGetNamedValue(NamedValues, 'RootHandle'); if HandleId = 0 then This.RootHandle := nil else @@ -2561,19 +2563,19 @@ function TBoldComExpressionHandleAdapter.SetData(DataFlags: Integer; end; if (DataFlags and DF_ROOTTYPENAME) <> 0 then begin - This.RootTypeName := BoldGetNamedValue(NamedValues, 'RootTypeName'); // do not localize + This.RootTypeName := BoldGetNamedValue(NamedValues, 'RootTypeName'); end; if (DataFlags and DF_SUBSCRIBE) <> 0 then begin - This.Subscribe := BoldGetNamedValue(NamedValues, 'Subscribe'); // do not localize + This.Subscribe := BoldGetNamedValue(NamedValues, 'Subscribe'); end; if (DataFlags and DF_EXPRESSION) <> 0 then begin - This.Expression := BoldGetNamedValue(NamedValues, 'Expression'); // do not localize + This.Expression := BoldGetNamedValue(NamedValues, 'Expression'); end; if (DataFlags and DF_EVALUATEINPS) <> 0 then begin - This.EvaluateInPs := BoldGetNamedValue(NamedValues,'EvaluateInPS'); // do not localize + This.EvaluateInPs := BoldGetNamedValue(NamedValues,'EvaluateInPS'); end; end; @@ -2606,7 +2608,7 @@ function TBoldComCursorHandleAdapter.GetData(DataFlags: Integer; Result := True; This := AsCursorHandle; if dataflags = DF_HANDLEID then - NamedValues := BoldCreateNamedValues(['HandleId'], [integer(this)]) // do not localize + NamedValues := BoldCreateNamedValues(['HandleId'], [integer(this)]) else begin BoldComCreateAdapter(This.Value, False, IBoldElement, Value); @@ -2622,15 +2624,15 @@ function TBoldComCursorHandleAdapter.GetData(DataFlags: Integer; BoldComCreateAdapter(This.List, False, IBoldList, BoldList); BoldComCreateAdapter(This.ListElementType, False, IBoldElementTypeInfo, ListElementType); NamedValues := BoldCreateNamedValues( - ['HandleId', // do not localize - 'StaticSystemHandle', // do not localize - 'Enabled', // do not localize - 'RootHandle', // do not localize - 'RootTypeName', // do not localize - 'Subscribe', // do not localize - 'Count', // do not localize - 'CurrentIndex', // do not localize - 'AutoFirst'], // do not localize + ['HandleId', + 'StaticSystemHandle', + 'Enabled', + 'RootHandle', + 'RootTypeName', + 'Subscribe', + 'Count', + 'CurrentIndex', + 'AutoFirst'], [Integer(This), Integer(This.StaticSystemHandle), This.Enabled, @@ -2653,7 +2655,7 @@ function TBoldComCursorHandleAdapter.SetData(DataFlags: Integer; This := AsCursorHandle; if (DataFlags and DF_STATICSYSTEMHANDLE) <> 0 then begin - HandleId := BoldGetNamedValue(NamedValues, 'StaticSystemHandle'); // do not localize + HandleId := BoldGetNamedValue(NamedValues, 'StaticSystemHandle'); if HandleId = 0 then This.StaticSystemHandle := nil else @@ -2662,12 +2664,12 @@ function TBoldComCursorHandleAdapter.SetData(DataFlags: Integer; if (DataFlags and DF_ENABLED) <> 0 then begin - This.Enabled := BoldGetNamedValue(NamedValues, 'Enabled'); // do not localize + This.Enabled := BoldGetNamedValue(NamedValues, 'Enabled'); end; if (DataFlags and DF_ROOTHANDLE) <> 0 then begin - HandleId := BoldGetNamedValue(NamedValues, 'RootHandle'); // do not localize + HandleId := BoldGetNamedValue(NamedValues, 'RootHandle'); if HandleId = 0 then This.RootHandle := nil else @@ -2676,24 +2678,24 @@ function TBoldComCursorHandleAdapter.SetData(DataFlags: Integer; if (DataFlags and DF_ROOTTYPENAME) <> 0 then begin - This.RootTypeName := BoldGetNamedValue(NamedValues, 'RootTypeName'); // do not localize + This.RootTypeName := BoldGetNamedValue(NamedValues, 'RootTypeName'); end; if (DataFlags and DF_SUBSCRIBE) <> 0 then begin - This.Subscribe := BoldGetNamedValue(NamedValues, 'Subscribe'); // do not localize + This.Subscribe := BoldGetNamedValue(NamedValues, 'Subscribe'); end; if (DataFlags and DF_CURRENTINDEX) <> 0 then begin - NewIndex := BoldGetNamedValue(NamedValues,'CurrentIndex'); // do not localize + NewIndex := BoldGetNamedValue(NamedValues,'CurrentIndex'); if assigned(this.list) and (NewIndex < this.list.Count) and (newIndex >= -1) then This.CurrentIndex := NewIndex; end; if (DataFlags and DF_AUTOFIRST) <> 0 then begin - This.AutoFirst := BoldGetNamedValue(NamedValues, 'AutoFirst'); // do not localize + This.AutoFirst := BoldGetNamedValue(NamedValues, 'AutoFirst'); end; end; @@ -2726,7 +2728,7 @@ function TBoldComListHandleAdapter.GetData(DataFlags: Integer; Result := True; This := AsListHandle; if dataflags = DF_HANDLEID then - NamedValues := BoldCreateNamedValues(['HandleId'], [integer(this)]) // do not localize + NamedValues := BoldCreateNamedValues(['HandleId'], [integer(this)]) else begin BoldComCreateAdapter(This.Value, False, IBoldElement, Value); @@ -2742,17 +2744,17 @@ function TBoldComListHandleAdapter.GetData(DataFlags: Integer; BoldComCreateAdapter(This.List, False, IBoldList, BoldList); BoldComCreateAdapter(This.ListElementType, False, IBoldElementTypeInfo, ListElementType); NamedValues := BoldCreateNamedValues( - ['HandleId', // do not localize - 'StaticSystemHandle', // do not localize - 'Enabled', // do not localize - 'RootHandle', // do not localize - 'RootTypeName', // do not localize - 'Subscribe', // do not localize - 'Count', // do not localize - 'CurrentIndex', // do not localize - 'AutoFirst', // do not localize - 'Expression', // do not localize - 'EvaluateInPS'], // do not localize + ['HandleId', + 'StaticSystemHandle', + 'Enabled', + 'RootHandle', + 'RootTypeName', + 'Subscribe', + 'Count', + 'CurrentIndex', + 'AutoFirst', + 'Expression', + 'EvaluateInPS'], [Integer(This), Integer(This.StaticSystemHandle), This.Enabled, @@ -2777,7 +2779,7 @@ function TBoldComListHandleAdapter.SetData(DataFlags: Integer; This := AsListHandle; if (DataFlags and DF_STATICSYSTEMHANDLE) <> 0 then begin - HandleId := BoldGetNamedValue(NamedValues, 'StaticSystemHandle'); // do not localize + HandleId := BoldGetNamedValue(NamedValues, 'StaticSystemHandle'); if HandleId = 0 then This.StaticSystemHandle := nil else @@ -2786,7 +2788,7 @@ function TBoldComListHandleAdapter.SetData(DataFlags: Integer; if (DataFlags and DF_ROOTHANDLE) <> 0 then begin - HandleId := BoldGetNamedValue(NamedValues, 'RootHandle'); // do not localize + HandleId := BoldGetNamedValue(NamedValues, 'RootHandle'); if HandleId = 0 then This.RootHandle := nil else @@ -2795,40 +2797,41 @@ function TBoldComListHandleAdapter.SetData(DataFlags: Integer; if (DataFlags and DF_ROOTTYPENAME) <> 0 then begin - This.RootTypeName := BoldGetNamedValue(NamedValues, 'RootTypeName'); // do not localize + This.RootTypeName := BoldGetNamedValue(NamedValues, 'RootTypeName'); end; if (DataFlags and DF_SUBSCRIBE) <> 0 then begin - This.Subscribe := BoldGetNamedValue(NamedValues, 'Subscribe'); // do not localize + This.Subscribe := BoldGetNamedValue(NamedValues, 'Subscribe'); end; if (DataFlags and DF_EXPRESSION) <> 0 then begin - This.Expression := BoldGetNamedValue(NamedValues, 'Expression'); // do not localize + This.Expression := BoldGetNamedValue(NamedValues, 'Expression'); end; if (DataFlags and DF_ENABLED) <> 0 then begin - This.Enabled := BoldGetNamedValue(NamedValues, 'Enabled'); // do not localize + This.Enabled := BoldGetNamedValue(NamedValues, 'Enabled'); end; if (DataFlags and DF_CURRENTINDEX) <> 0 then begin - NewIndex := BoldGetNamedValue(NamedValues,'CurrentIndex'); // do not localize + NewIndex := BoldGetNamedValue(NamedValues,'CurrentIndex'); if assigned(this.list) and (NewIndex < this.list.Count) and (newIndex >= -1) then This.CurrentIndex := NewIndex; end; if (DataFlags and DF_AUTOFIRST) <> 0 then begin - This.AutoFirst := BoldGetNamedValue(NamedValues,'AutoFirst'); // do not localize + This.AutoFirst := BoldGetNamedValue(NamedValues,'AutoFirst'); end; if (DataFlags and DF_EVALUATEINPS) <> 0 then begin - This.EvaluateInPs := BoldGetNamedValue(NamedValues,'EvaluateInPS'); // do not localize + This.EvaluateInPs := BoldGetNamedValue(NamedValues,'EvaluateInPS'); end; + end; {-- TBoldComReferenceHandleAdapter --------------------------------------------} @@ -2860,7 +2863,7 @@ function TBoldComReferenceHandleAdapter.GetData(DataFlags: Integer; Result := True; This := AsReferenceHandle; if dataflags = DF_HANDLEID then - NamedValues := BoldCreateNamedValues(['HandleId'], [integer(this)]) // do not localize + NamedValues := BoldCreateNamedValues(['HandleId'], [integer(this)]) else begin BoldComCreateAdapter(This.Value, False, IBoldElement, Value); @@ -2873,9 +2876,9 @@ function TBoldComReferenceHandleAdapter.GetData(DataFlags: Integer; BoldList := nil; ListElementType := nil; NamedValues := BoldCreateNamedValues( - ['HandleId', // do not localize - 'StaticSystemHandle', // do not localize - 'StaticValueTypeName'], // do not localize + ['HandleId', + 'StaticSystemHandle', + 'StaticValueTypeName'], [Integer(This), Integer(This.StaticSystemHandle), This.StaticValueTypeName]); @@ -2896,7 +2899,7 @@ function TBoldComReferenceHandleAdapter.SetData(DataFlags: Integer; if (DataFlags and DF_STATICSYSTEMHANDLE) <> 0 then begin - HandleId := BoldGetNamedValue(NamedValues, 'StaticSystemHandle'); // do not localize + HandleId := BoldGetNamedValue(NamedValues, 'StaticSystemHandle'); if HandleId = 0 then This.StaticSystemHandle := nil else @@ -2905,7 +2908,7 @@ function TBoldComReferenceHandleAdapter.SetData(DataFlags: Integer; if (DataFlags and DF_STATICVALUETYPENAME) <> 0 then begin - This.StaticValueTypeName := BoldGetNamedValue(NamedValues, 'StaticValueTypeName'); // do not localize + This.StaticValueTypeName := BoldGetNamedValue(NamedValues, 'StaticValueTypeName'); end; end; @@ -2938,7 +2941,7 @@ function TBoldComSQLHandleAdapter.GetData(DataFlags: Integer; Result := True; This := AsSQLHandle; if dataflags = DF_HANDLEID then - NamedValues := BoldCreateNamedValues(['HandleId'], [integer(this)]) // do not localize + NamedValues := BoldCreateNamedValues(['HandleId'], [integer(this)]) else begin BoldComCreateAdapter(This.Value, False, IBoldElement, Value); @@ -2951,12 +2954,12 @@ function TBoldComSQLHandleAdapter.GetData(DataFlags: Integer; BoldList := nil; ListElementType := nil; NamedValues := BoldCreateNamedValues( - ['HandleId', // do not localize - 'StaticSystemHandle', // do not localize - 'ClassExpressionName', // do not localize - 'ClearBeforeExecute', // do not localize - 'SQLOrderByClause', // do not localize - 'SQLWhereClause'], // do not localize + ['HandleId', + 'StaticSystemHandle', + 'ClassExpressionName', + 'ClearBeforeExecute', + 'SQLOrderByClause', + 'SQLWhereClause'], [Integer(This), Integer(This.StaticSystemHandle), This.ClassExpressionName, @@ -2976,16 +2979,16 @@ function TBoldComSQLHandleAdapter.SetData(DataFlags: Integer; This := AsSQLHandle; if DataFlags = -1 then begin - Action := BoldGetnamedValue(NamedValues, 'Action'); // do not localize - if SameText(Action, 'ExecuteSQL') then // do not localize + Action := BoldGetnamedValue(NamedValues, 'Action'); + if SameText(Action, 'ExecuteSQL') then this.ExecuteSQL - else if SameText(Action, 'ClearList') then // do not localize + else if SameText(Action, 'ClearList') then this.ClearList end else begin if (DataFlags and DF_STATICSYSTEMHANDLE) <> 0 then begin - HandleId := BoldGetNamedValue(NamedValues, 'StaticSystemHandle'); // do not localize + HandleId := BoldGetNamedValue(NamedValues, 'StaticSystemHandle'); if HandleId = 0 then This.StaticSystemHandle := nil else @@ -2993,19 +2996,19 @@ function TBoldComSQLHandleAdapter.SetData(DataFlags: Integer; end; if (DataFlags and DF_CLASSEXPRESSIONNAME) <> 0 then begin - This.ClassExpressionName := BoldGetNamedValue(NamedValues, 'ClassExpressionName'); // do not localize + This.ClassExpressionName := BoldGetNamedValue(NamedValues, 'ClassExpressionName'); end; if (DataFlags and DF_CLEARBEFOREEXECUTE) <> 0 then begin - This.ClearBeforeExecute := BoldGetNamedValue(NamedValues, 'ClearBeforeExecute'); // do not localize + This.ClearBeforeExecute := BoldGetNamedValue(NamedValues, 'ClearBeforeExecute'); end; if (DataFlags and DF_SQLORDERBYCLAUSE) <> 0 then begin - This.SQLOrderByClause := BoldGetNamedValue(NamedValues, 'SQLOrderByClause'); // do not localize + This.SQLOrderByClause := BoldGetNamedValue(NamedValues, 'SQLOrderByClause'); end; if (DataFlags and DF_SQLWHERECLAUSE) <> 0 then begin - This.SQLWhereClause := BoldGetNamedValue(NamedValues, 'SQLWhereClause'); // do not localize + This.SQLWhereClause := BoldGetNamedValue(NamedValues, 'SQLWhereClause'); end; end; end; @@ -3039,7 +3042,7 @@ function TBoldComVariableHandleAdapter.GetData(DataFlags: Integer; Result := True; This := AsVariableHandle; if dataflags = DF_HANDLEID then - NamedValues := BoldCreateNamedValues(['HandleId'], [integer(this)]) // do not localize + NamedValues := BoldCreateNamedValues(['HandleId'], [integer(this)]) else begin BoldComCreateAdapter(This.Value, False, IBoldElement, Value); @@ -3052,10 +3055,10 @@ function TBoldComVariableHandleAdapter.GetData(DataFlags: Integer; BoldList := nil; ListElementType := nil; NamedValues := BoldCreateNamedValues( - ['HandleId', // do not localize - 'StaticSystemHandle', // do not localize - 'ValueTypeName', // do not localize - 'InitialValues'], // do not localize + ['HandleId', + 'StaticSystemHandle', + 'ValueTypeName', + 'InitialValues'], [Integer(This), Integer(This.StaticSystemHandle), This.ValueTypeName, @@ -3073,7 +3076,7 @@ function TBoldComVariableHandleAdapter.SetData(DataFlags: Integer; This := AsVariableHandle; if (DataFlags and DF_STATICSYSTEMHANDLE) <> 0 then begin - HandleId := BoldGetNamedValue(NamedValues, 'StaticSystemHandle'); // do not localize + HandleId := BoldGetNamedValue(NamedValues, 'StaticSystemHandle'); if HandleId = 0 then This.StaticSystemHandle := nil else @@ -3081,13 +3084,13 @@ function TBoldComVariableHandleAdapter.SetData(DataFlags: Integer; end; if (DataFlags and DF_VALUETYPENAME) <> 0 then begin - This.ValueTypeName := BoldGetNamedValue(NamedValues, 'ValueTypeName'); // do not localize + This.ValueTypeName := BoldGetNamedValue(NamedValues, 'ValueTypeName'); end; if (DataFlags and DF_INITIALVALUES) <> 0 then begin Temp := TStringList.Create; try - BoldVariantToStrings(BoldGetNamedValue(NamedValues, 'InitialValues'),Temp); // do not localize + BoldVariantToStrings(BoldGetNamedValue(NamedValues, 'InitialValues'),Temp); This.InitialValues.Assign(Temp); finally Temp.Free; @@ -3180,7 +3183,6 @@ function TBoldComObjectReferenceAdapter.QueryInterface(const IId: TGUID; initialization BoldComRegisterAdapter(TBoldComElementAdapter,TBoldElement); - // type info BoldComRegisterAdapter(TBoldComMetaElementAdapter,TBoldMetaElement); BoldComRegisterAdapter(TBoldComElementTypeInfoAdapter,TBoldElementTypeInfo); BoldComRegisterAdapter(TBoldComTypeTypeInfoAdapter,TBoldTypeTypeInfo); @@ -3189,7 +3191,6 @@ initialization BoldComRegisterAdapter(TBoldComListTypeInfoAdapter,TBoldListTypeInfo); BoldComRegisterAdapter(TBoldComAttributeTypeInfoAdapter,TBoldAttributeTypeInfo); BoldComRegisterAdapter(TBoldComSystemTypeInfoAdapter,TBoldSystemTypeInfo); - // domain & system BoldComRegisterAdapter(TBoldComDomainElementAdapter,TBoldDomainElement); BoldComRegisterAdapter(TBoldComObjectAdapter,TBoldObject); BoldComRegisterAdapter(TBoldComMemberAdapter,TBoldMember); @@ -3199,9 +3200,7 @@ initialization BoldComRegisterAdapter(TBoldComObjectListAdapter,TBoldObjectList); BoldComRegisterAdapter(TBoldComMemberListAdapter,TBoldMemberList); BoldComRegisterAdapter(TBoldComSystemAdapter,TBoldSystem); - // attributes BoldComRegisterAdapter(TBoldComBlobAdapter,TBABlob); - // handles BoldComRegisterAdapter(TBoldComElementHandleAdapter,TBoldElementHandle); BoldComRegisterAdapter(TBoldComSystemHandleAdapter,TBoldSystemHandle); BoldComRegisterAdapter(TBoldComDerivedHandleAdapter,TBoldDerivedHandle); diff --git a/Source/ObjectSpace/COM/BoldComObjectSpace_TLB.pas b/Source/ObjectSpace/COM/BoldComObjectSpace_TLB.pas index 22c6d320..e7ae5898 100644 --- a/Source/ObjectSpace/COM/BoldComObjectSpace_TLB.pas +++ b/Source/ObjectSpace/COM/BoldComObjectSpace_TLB.pas @@ -1,44 +1,39 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComObjectSpace_TLB; -// ************************************************************************ // -// WARNING -// ------- -// The types declared in this file were generated from data read from a -// Type Library. If this type library is explicitly or indirectly (via -// another type library referring to this type library) re-imported, or the -// 'Refresh' command of the Type Library Editor activated while editing the -// Type Library, the contents of this file will be regenerated and all -// manual modifications will be lost. -// ************************************************************************ // - -// PASTLWTR : 1.1 -// File generated on 2002-05-02 15:54:08 from Type Library described below. - -// ************************************************************************ // -// Type Lib: D:\bold\BfD\Source\ObjectSpace\COM\BoldComObjectSpace.tlb (1) -// LIBID: {D28A8F60-C8DD-11D3-89A9-444553540000} -// LCID: 0 -// Helpfile: -// DepndLst: -// (1) v2.0 stdole, (C:\WINNT\System32\stdole2.tlb) -// (2) v4.0 StdVCL, (C:\WINNT\System32\STDVCL40.DLL) -// ************************************************************************ // -{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. + + + + + + + + + + + + + + + + + + + +{$TYPEDADDRESS OFF} interface uses Windows, ActiveX, Classes, Graphics, OleCtrls, StdVCL; - - -// *********************************************************************// -// GUIDS declared in the TypeLibrary. Following prefixes are used: -// Type Libraries : LIBID_xxxx -// CoClasses : CLASS_xxxx -// DISPInterfaces : DIID_xxxx -// Non-DISP interfaces: IID_xxxx -// *********************************************************************// + + + + + + const - // TypeLibrary Major and minor versions BoldComObjectSpaceMajorVersion = 1; BoldComObjectSpaceMinorVersion = 0; @@ -67,9 +62,7 @@ interface IID_IBoldElementHandle: TGUID = '{71446D80-01C9-4E3C-95A7-D74445C0776C}'; type -// *********************************************************************// -// Forward declaration of types defined in TypeLibrary -// *********************************************************************// + IBoldElement = interface; IBoldElementDisp = dispinterface; IBoldMetaElement = interface; @@ -113,11 +106,9 @@ interface IBoldElementHandle = interface; IBoldElementHandleDisp = dispinterface; -// *********************************************************************// -// Interface: IBoldElement -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {E8E2859A-0BAA-4DD9-8B26-A0AE5DEC87DF} -// *********************************************************************// + + + IBoldElement = interface(IDispatch) ['{E8E2859A-0BAA-4DD9-8B26-A0AE5DEC87DF}'] procedure AddSmallSubscription(const ClientId: WideString; SubscriberId: Integer; @@ -178,11 +169,9 @@ interface property HasAdaptee: WordBool read Get_HasAdaptee; end; -// *********************************************************************// -// DispIntf: IBoldElementDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {E8E2859A-0BAA-4DD9-8B26-A0AE5DEC87DF} -// *********************************************************************// + + + IBoldElementDisp = dispinterface ['{E8E2859A-0BAA-4DD9-8B26-A0AE5DEC87DF}'] procedure AddSmallSubscription(const ClientId: WideString; SubscriberId: Integer; @@ -232,11 +221,9 @@ interface property HasAdaptee: WordBool readonly dispid 129; end; -// *********************************************************************// -// Interface: IBoldMetaElement -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {78994402-CA6E-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldMetaElement = interface(IBoldElement) ['{78994402-CA6E-11D3-89A9-444553540000}'] function Get_DelphiName: WideString; safecall; @@ -247,11 +234,9 @@ interface property ModelName: WideString read Get_ModelName; end; -// *********************************************************************// -// DispIntf: IBoldMetaElementDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {78994402-CA6E-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldMetaElementDisp = dispinterface ['{78994402-CA6E-11D3-89A9-444553540000}'] property DelphiName: WideString readonly dispid 201; @@ -304,11 +289,9 @@ interface property HasAdaptee: WordBool readonly dispid 129; end; -// *********************************************************************// -// Interface: IBoldElementTypeInfo -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {78994404-CA6E-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldElementTypeInfo = interface(IBoldMetaElement) ['{78994404-CA6E-11D3-89A9-444553540000}'] function ConformsTo(const ElementTypeInfo: IBoldElementTypeInfo): WordBool; safecall; @@ -318,11 +301,9 @@ interface property SystemTypeInfo: IBoldSystemTypeInfo read Get_SystemTypeInfo; end; -// *********************************************************************// -// DispIntf: IBoldElementTypeInfoDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {78994404-CA6E-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldElementTypeInfoDisp = dispinterface ['{78994404-CA6E-11D3-89A9-444553540000}'] function ConformsTo(const ElementTypeInfo: IBoldElementTypeInfo): WordBool; dispid 301; @@ -378,20 +359,16 @@ interface property HasAdaptee: WordBool readonly dispid 129; end; -// *********************************************************************// -// Interface: IBoldTypeTypeInfo -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {68A9FC6D-D646-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldTypeTypeInfo = interface(IBoldElementTypeInfo) ['{68A9FC6D-D646-11D3-89A9-444553540000}'] end; -// *********************************************************************// -// DispIntf: IBoldTypeTypeInfoDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {68A9FC6D-D646-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldTypeTypeInfoDisp = dispinterface ['{68A9FC6D-D646-11D3-89A9-444553540000}'] function ConformsTo(const ElementTypeInfo: IBoldElementTypeInfo): WordBool; dispid 301; @@ -447,11 +424,9 @@ interface property HasAdaptee: WordBool readonly dispid 129; end; -// *********************************************************************// -// Interface: IBoldClassTypeInfo -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {969E6924-D4A6-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldClassTypeInfo = interface(IBoldElementTypeInfo) ['{969E6924-D4A6-11D3-89A9-444553540000}'] function LeastCommonSuperClass(const ClassTypeInfo: IBoldClassTypeInfo): IBoldClassTypeInfo; safecall; @@ -481,11 +456,9 @@ interface property TopSortedIndex: Integer read Get_TopSortedIndex; end; -// *********************************************************************// -// DispIntf: IBoldClassTypeInfoDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {969E6924-D4A6-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldClassTypeInfoDisp = dispinterface ['{969E6924-D4A6-11D3-89A9-444553540000}'] function LeastCommonSuperClass(const ClassTypeInfo: IBoldClassTypeInfo): IBoldClassTypeInfo; dispid 401; @@ -554,20 +527,16 @@ interface property HasAdaptee: WordBool readonly dispid 129; end; -// *********************************************************************// -// Interface: IBoldNilTypeInfo -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {969E6926-D4A6-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldNilTypeInfo = interface(IBoldClassTypeInfo) ['{969E6926-D4A6-11D3-89A9-444553540000}'] end; -// *********************************************************************// -// DispIntf: IBoldNilTypeInfoDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {969E6926-D4A6-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldNilTypeInfoDisp = dispinterface ['{969E6926-D4A6-11D3-89A9-444553540000}'] function LeastCommonSuperClass(const ClassTypeInfo: IBoldClassTypeInfo): IBoldClassTypeInfo; dispid 401; @@ -636,22 +605,18 @@ interface property HasAdaptee: WordBool readonly dispid 129; end; -// *********************************************************************// -// Interface: IBoldListTypeInfo -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {969E6928-D4A6-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldListTypeInfo = interface(IBoldElementTypeInfo) ['{969E6928-D4A6-11D3-89A9-444553540000}'] function Get_ListElementTypeInfo: IBoldElementTypeInfo; safecall; property ListElementTypeInfo: IBoldElementTypeInfo read Get_ListElementTypeInfo; end; -// *********************************************************************// -// DispIntf: IBoldListTypeInfoDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {969E6928-D4A6-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldListTypeInfoDisp = dispinterface ['{969E6928-D4A6-11D3-89A9-444553540000}'] property ListElementTypeInfo: IBoldElementTypeInfo readonly dispid 401; @@ -708,22 +673,18 @@ interface property HasAdaptee: WordBool readonly dispid 129; end; -// *********************************************************************// -// Interface: IBoldAttributeTypeInfo -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {969E692A-D4A6-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldAttributeTypeInfo = interface(IBoldElementTypeInfo) ['{969E692A-D4A6-11D3-89A9-444553540000}'] function Get_SuperAttributeTypeInfo: IBoldAttributeTypeInfo; safecall; property SuperAttributeTypeInfo: IBoldAttributeTypeInfo read Get_SuperAttributeTypeInfo; end; -// *********************************************************************// -// DispIntf: IBoldAttributeTypeInfoDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {969E692A-D4A6-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldAttributeTypeInfoDisp = dispinterface ['{969E692A-D4A6-11D3-89A9-444553540000}'] property SuperAttributeTypeInfo: IBoldAttributeTypeInfo readonly dispid 401; @@ -780,11 +741,9 @@ interface property HasAdaptee: WordBool readonly dispid 129; end; -// *********************************************************************// -// Interface: IBoldSystemTypeInfo -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {969E6922-D4A6-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldSystemTypeInfo = interface(IBoldElementTypeInfo) ['{969E6922-D4A6-11D3-89A9-444553540000}'] function Get_AttributeTypeInfoByExpressionName(const Name: WideString): IBoldAttributeTypeInfo; safecall; @@ -827,11 +786,9 @@ interface property ValueTypeNameList: IUnknown read Get_ValueTypeNameList; end; -// *********************************************************************// -// DispIntf: IBoldSystemTypeInfoDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {969E6922-D4A6-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldSystemTypeInfoDisp = dispinterface ['{969E6922-D4A6-11D3-89A9-444553540000}'] property AttributeTypeInfoByExpressionName[const Name: WideString]: IBoldAttributeTypeInfo readonly dispid 401; @@ -906,11 +863,9 @@ interface property HasAdaptee: WordBool readonly dispid 129; end; -// *********************************************************************// -// Interface: IBoldDomainElement -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {78994406-CA6E-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldDomainElement = interface(IBoldElement) ['{78994406-CA6E-11D3-89A9-444553540000}'] function Get_BoldDirty: WordBool; safecall; @@ -923,11 +878,9 @@ interface property OwningElement: IBoldDomainElement read Get_OwningElement; end; -// *********************************************************************// -// DispIntf: IBoldDomainElementDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {78994406-CA6E-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldDomainElementDisp = dispinterface ['{78994406-CA6E-11D3-89A9-444553540000}'] property BoldDirty: WordBool readonly dispid 201; @@ -981,11 +934,9 @@ interface property HasAdaptee: WordBool readonly dispid 129; end; -// *********************************************************************// -// Interface: IBoldObject -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {7C5C21FF-D247-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldObject = interface(IBoldDomainElement) ['{7C5C21FF-D247-11D3-89A9-444553540000}'] procedure BoldMakePersistent; safecall; @@ -1022,11 +973,9 @@ interface property SessionId: OleVariant read Get_SessionId; end; -// *********************************************************************// -// DispIntf: IBoldObjectDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {7C5C21FF-D247-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldObjectDisp = dispinterface ['{7C5C21FF-D247-11D3-89A9-444553540000}'] procedure BoldMakePersistent; dispid 301; @@ -1099,11 +1048,9 @@ interface property HasAdaptee: WordBool readonly dispid 129; end; -// *********************************************************************// -// Interface: IBoldMember -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {7C5C2201-D247-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldMember = interface(IBoldDomainElement) ['{7C5C2201-D247-11D3-89A9-444553540000}'] function Clone: IBoldMember; safecall; @@ -1126,11 +1073,9 @@ interface property OwningObject: IBoldObject read Get_OwningObject; end; -// *********************************************************************// -// DispIntf: IBoldMemberDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {7C5C2201-D247-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldMemberDisp = dispinterface ['{7C5C2201-D247-11D3-89A9-444553540000}'] function Clone: IBoldMember; dispid 301; @@ -1195,11 +1140,9 @@ interface property HasAdaptee: WordBool readonly dispid 129; end; -// *********************************************************************// -// Interface: IBoldAttribute -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {7C5C25A5-D247-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldAttribute = interface(IBoldMember) ['{7C5C25A5-D247-11D3-89A9-444553540000}'] procedure SetToNull; safecall; @@ -1211,11 +1154,9 @@ interface property IsNull: WordBool read Get_IsNull; end; -// *********************************************************************// -// DispIntf: IBoldAttributeDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {7C5C25A5-D247-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldAttributeDisp = dispinterface ['{7C5C25A5-D247-11D3-89A9-444553540000}'] procedure SetToNull; dispid 401; @@ -1284,11 +1225,9 @@ interface property HasAdaptee: WordBool readonly dispid 129; end; -// *********************************************************************// -// Interface: IBoldObjectReference -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {7C5C2608-D247-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldObjectReference = interface(IBoldMember) ['{7C5C2608-D247-11D3-89A9-444553540000}'] function CanSet(const NewObject: IBoldObject): WordBool; safecall; @@ -1299,11 +1238,9 @@ interface property BoldRoleRTInfo: IUnknown read Get_BoldRoleRTInfo; end; -// *********************************************************************// -// DispIntf: IBoldObjectReferenceDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {7C5C2608-D247-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldObjectReferenceDisp = dispinterface ['{7C5C2608-D247-11D3-89A9-444553540000}'] function CanSet(const NewObject: IBoldObject): WordBool; dispid 401; @@ -1371,11 +1308,9 @@ interface property HasAdaptee: WordBool readonly dispid 129; end; -// *********************************************************************// -// Interface: IBoldListCore -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {4153813B-4DE9-4A17-B747-7091A839BBFA} -// *********************************************************************// + + + IBoldListCore = interface(IBoldMember) ['{4153813B-4DE9-4A17-B747-7091A839BBFA}'] procedure AddList(const List: IBoldListCore); safecall; @@ -1398,11 +1333,9 @@ interface property DuplicateMode: Integer read Get_DuplicateMode write Set_DuplicateMode; end; -// *********************************************************************// -// DispIntf: IBoldListCoreDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {4153813B-4DE9-4A17-B747-7091A839BBFA} -// *********************************************************************// + + + IBoldListCoreDisp = dispinterface ['{4153813B-4DE9-4A17-B747-7091A839BBFA}'] procedure AddList(const List: IBoldListCore); dispid 401; @@ -1481,11 +1414,9 @@ interface property HasAdaptee: WordBool readonly dispid 129; end; -// *********************************************************************// -// Interface: IBoldList -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {798895F6-E991-432B-9F37-7998BA769199} -// *********************************************************************// + + + IBoldList = interface(IBoldListCore) ['{798895F6-E991-432B-9F37-7998BA769199}'] procedure Add(const Element: IBoldElement); safecall; @@ -1502,11 +1433,9 @@ interface property Elements[Index: Integer]: IBoldElement read Get_Elements write Set_Elements; end; -// *********************************************************************// -// DispIntf: IBoldListDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {798895F6-E991-432B-9F37-7998BA769199} -// *********************************************************************// + + + IBoldListDisp = dispinterface ['{798895F6-E991-432B-9F37-7998BA769199}'] procedure Add(const Element: IBoldElement); dispid 501; @@ -1595,11 +1524,9 @@ interface property HasAdaptee: WordBool readonly dispid 129; end; -// *********************************************************************// -// Interface: IBoldObjectList -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {75A31152-D30E-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldObjectList = interface(IBoldList) ['{75A31152-D30E-11D3-89A9-444553540000}'] function Get_BoldObjects(Index: Integer): IBoldObject; safecall; @@ -1612,11 +1539,9 @@ interface property SubscribeToObjectsInList: WordBool read Get_SubscribeToObjectsInList write Set_SubscribeToObjectsInList; end; -// *********************************************************************// -// DispIntf: IBoldObjectListDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {75A31152-D30E-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldObjectListDisp = dispinterface ['{75A31152-D30E-11D3-89A9-444553540000}'] property BoldObjects[Index: Integer]: IBoldObject dispid 601; @@ -1708,11 +1633,9 @@ interface property HasAdaptee: WordBool readonly dispid 129; end; -// *********************************************************************// -// Interface: IBoldMemberList -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {75A31154-D30E-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldMemberList = interface(IBoldList) ['{75A31154-D30E-11D3-89A9-444553540000}'] function Get_BoldMembers(Index: Integer): IBoldMember; safecall; @@ -1720,11 +1643,9 @@ interface property BoldMembers[Index: Integer]: IBoldMember read Get_BoldMembers write Set_BoldMembers; end; -// *********************************************************************// -// DispIntf: IBoldMemberListDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {75A31154-D30E-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldMemberListDisp = dispinterface ['{75A31154-D30E-11D3-89A9-444553540000}'] property BoldMembers[Index: Integer]: IBoldMember dispid 601; @@ -1814,11 +1735,9 @@ interface property HasAdaptee: WordBool readonly dispid 129; end; -// *********************************************************************// -// Interface: IBoldSystem -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {8A530C40-D017-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldSystem = interface(IBoldDomainElement) ['{8A530C40-D017-11D3-89A9-444553540000}'] function CreateNewMember(const ExpressionName: WideString): IBoldMember; safecall; @@ -1840,11 +1759,9 @@ interface property LoadedObjects: IBoldObjectList read Get_LoadedObjects; end; -// *********************************************************************// -// DispIntf: IBoldSystemDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {8A530C40-D017-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldSystemDisp = dispinterface ['{8A530C40-D017-11D3-89A9-444553540000}'] function CreateNewMember(const ExpressionName: WideString): IBoldMember; dispid 301; @@ -1911,20 +1828,16 @@ interface property HasAdaptee: WordBool readonly dispid 129; end; -// *********************************************************************// -// Interface: IBoldBlob -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {68A9F8C2-D646-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldBlob = interface(IBoldAttribute) ['{68A9F8C2-D646-11D3-89A9-444553540000}'] end; -// *********************************************************************// -// DispIntf: IBoldBlobDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {68A9F8C2-D646-11D3-89A9-444553540000} -// *********************************************************************// + + + IBoldBlobDisp = dispinterface ['{68A9F8C2-D646-11D3-89A9-444553540000}'] procedure SetToNull; dispid 401; @@ -1993,11 +1906,9 @@ interface property HasAdaptee: WordBool readonly dispid 129; end; -// *********************************************************************// -// Interface: IBoldElementHandle -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {71446D80-01C9-4E3C-95A7-D74445C0776C} -// *********************************************************************// + + + IBoldElementHandle = interface(IDispatch) ['{71446D80-01C9-4E3C-95A7-D74445C0776C}'] procedure AddSmallSubscription(const ClientId: WideString; SubscriberId: Integer; @@ -2015,11 +1926,9 @@ interface function SetData(DataFlags: Integer; const Value: IBoldElement; NamedValues: OleVariant): WordBool; safecall; end; -// *********************************************************************// -// DispIntf: IBoldElementHandleDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {71446D80-01C9-4E3C-95A7-D74445C0776C} -// *********************************************************************// + + + IBoldElementHandleDisp = dispinterface ['{71446D80-01C9-4E3C-95A7-D74445C0776C}'] procedure AddSmallSubscription(const ClientId: WideString; SubscriberId: Integer; diff --git a/Source/ObjectSpace/COM/BoldComponentValidatorCom.pas b/Source/ObjectSpace/COM/BoldComponentValidatorCom.pas index 4159ee50..28e3cff0 100644 --- a/Source/ObjectSpace/COM/BoldComponentValidatorCom.pas +++ b/Source/ObjectSpace/COM/BoldComponentValidatorCom.pas @@ -1,6 +1,7 @@ -unit BoldComponentValidatorCom; -// this unit is currently only an empty replacement of BoldComponentValidator +{ Global compiler directives } +{$include bold.inc} +unit BoldComponentValidatorCom; interface @@ -14,4 +15,6 @@ TBoldComponentValidatorCom = class implementation +initialization + end. diff --git a/Source/ObjectSpace/Core/BoldCoreConsts.pas b/Source/ObjectSpace/Core/BoldCoreConsts.pas index 19fd8702..2d3e11aa 100644 --- a/Source/ObjectSpace/Core/BoldCoreConsts.pas +++ b/Source/ObjectSpace/Core/BoldCoreConsts.pas @@ -87,6 +87,7 @@ interface sDeleteWithLinks = 'Can''t delete object with links to others'; sNoMemberNamed = 'Class %s has no member named %s'; sMemberNotPartofSystem = 'Member not part of system'; + sIsEqualUnknownType = '%s.IsEqual: Unknown comparetype'; sNullValueNotAllowed = 'Null Value Not Allowed for Attribute'; sNullEqualError = 'NullEqual is void of meaning'; sRelinkBadCall = 'Internal error: Only Callable for TBoldSinglelink and TBoldMultiLink'; @@ -98,6 +99,7 @@ interface sTypeError = 'type error'; sObjectNotInMultiLink = 'Attempt to remove object not in multilink'; sCallToAbstractMethodOnCustomMapper = '%s.%s: This method is abstract, implement custom method as %s.%s'; + sStringIsNotAnsiString = 'String contains invalid characters'; //BoldAttributes sInvalidValue = 'Invalid value'; @@ -433,3 +435,4 @@ interface implementation end. + diff --git a/Source/ObjectSpace/Core/BoldElements.pas b/Source/ObjectSpace/Core/BoldElements.pas index 21fc0174..cd195c71 100644 --- a/Source/ObjectSpace/Core/BoldElements.pas +++ b/Source/ObjectSpace/Core/BoldElements.pas @@ -1,5 +1,8 @@ -unit BoldElements; +{ Global compiler directives } +{$include bold.inc} +unit BoldElements; + interface uses @@ -26,22 +29,34 @@ interface BoldDefaultRegionModeShift = 24; BoldDefaultRegionModeMask = 7 shl BoldDefaultRegionModeShift; // 00000111 - used in TBoldRoleRTInfo - {flags for BoldElement} befImmutable = BoldElementFlag0; befHasModifiedValueHolder = BoldElementFlag1; - {flags for BusinessElement} + {flags for DomainElement} befPersistent = BoldElementFlag2; befTouched = BoldElementFlag3; + {flags for BoldSystem} + befRollbackAreaAssigned = BoldElementFlag4; + befIsDestroying = BoldElementFlag5; + befIsCommitting = BoldElementFlag6; + befIsRollingBack = BoldElementFlag7; + befIsUpdatingDatabase = BoldElementFlag8; + befDirtyObjectsInvalid = BoldElementFlag9; + {flags for BoldObject} befInDirtyList = BoldElementFlag4; befMemberModified = BoldElementFlag5; befMemberModifiedKnown = BoldElementFlag6; befObjectReadOnly = BoldElementFlag7; befObjectWasCreatedNew = BoldElementFlag8; - befStoresTimeStamp = BoldElementFlag9; + befIsHistoricVersion = BoldElementFlag10; + befIsEffectiveInvalid = BoldElementFlag11; + befIsEffectiveInvalidKnown = BoldElementFlag12; + befInDelayDestructionList = BoldElementFlag13; + befDiscarding = BoldElementFlag14; + befDeleting = BoldElementFlag15; {flags for BoldMember} befIsNull = BoldElementFlag4; @@ -51,15 +66,15 @@ interface befHasRtInfo = BoldElementFlag8; befEnsuringCurrent = BoldElementFlag9; befOwnedByObject = BoldElementFlag10; - + befPreFetched = BoldElementFlag11; {flags for BoldObjectList} - befAdjusted = BoldElementFlag11; - befSubscribeToObjectsInList = BoldElementFlag12; - befSubscribeToLocatorsInList = BoldElementFlag13; + befAdjusted = BoldElementFlag12; + befSubscribeToObjectsInList = BoldElementFlag13; + befSubscribeToLocatorsInList = BoldElementFlag14; {flags for BoldObjectReference} - befHasOldValues = BoldElementFlag11; + befHasOldValues = BoldElementFlag12; {flags for BoldElementTypeInfo} BoldValueTypeShift = 24; @@ -95,25 +110,26 @@ interface befMemberPersistent = BoldElementFlag2; befDelayedFetch = BoldElementFlag3; befIsStoredInObject = BoldElementFlag4; - befIsMultiRole = BoldElementFlag5; - befIsSingleRole = BoldElementFlag6; - befIsDerived = BoldElementFlag7; // always false for roles... - befIsReverseDerived = BoldElementFlag8; - befIsNonVersionedInVersionedClass = BoldElementFlag9; - befMemberToBeRemoved = BoldElementFlag10; + befIsAttribute = BoldElementFlag5; + befIsMultiRole = BoldElementFlag6; + befIsSingleRole = BoldElementFlag7; + befIsDerived = BoldElementFlag8; + befIsReverseDerived = BoldElementFlag9; + befIsNonVersionedInVersionedClass = BoldElementFlag10; + befMemberToBeRemoved = BoldElementFlag11; {Flags for BoldRoleRTInfo} - befIsIndirect = BoldElementFlag11; - befIsNavigable = BoldElementFlag12; - befIsOrdered = BoldElementFlag13; - befOtherEndOrdered = BoldElementFlag14; - befMandatory = BoldElementFlag15; - befForceOtherEnd = BoldElementFlag16; - befQualifiedMulti = BoldElementFlag17; + befIsIndirect = BoldElementFlag12; + befIsNavigable = BoldElementFlag13; + befIsOrdered = BoldElementFlag14; + befOtherEndOrdered = BoldElementFlag15; + befMandatory = BoldElementFlag16; + befForceOtherEnd = BoldElementFlag17; + befQualifiedMulti = BoldElementFlag18; {Flags for BoldAttributeRTInfo} - befHasInitalvalue = BoldElementFlag11; - befAllowNull = BoldElementFlag12; + befHasInitalvalue = BoldElementFlag12; + befAllowNull = BoldElementFlag13; type {forward declarations of all classes} @@ -121,6 +137,7 @@ TBoldEvaluator = class; TBoldElement = class; TBoldMetaElement = class; TBoldElementTypeInfo = class; + TBoldListTypeInfo = class; TBoldIndirectElement = class; TBoldDirectElement = TBoldElement; TBoldExternalVariable = class; @@ -134,11 +151,11 @@ TBoldElementClass = class of TBoldElement; IBoldOCLComponent = interface ['{60D40422-8710-11D3-A2C8-EA14D4000000}'] function GetContextType: TBoldElementTypeInfo; - procedure SetExpression(Expression: String); + procedure SetExpression(const Value: TBoldExpression); function GetVariableList: TBoldExternalVariableList; - function GetExpression: String; + function GetExpression: TBoldExpression; property ContextType: TBoldElementTypeInfo read GetContextType; - property Expression: String read GetExpression write SetExpression; + property Expression: TBoldExpression read GetExpression write SetExpression; property VariableList: TBoldExternalVariableList read GetVariableList; end; @@ -146,44 +163,73 @@ TBoldElementClass = class of TBoldElement; TBoldExternalVariable = class(TBoldMemoryManagedObject) private fName: String; + fEvaluator: TBoldEvaluator; protected function GetValue: TBoldElement; virtual; abstract; function GetValueType: TBoldElementTypeInfo; virtual; abstract; public constructor Create(const Name: String); + destructor Destroy; override; property Value: TBoldElement read GetValue; property Name: String read fName; property ValueType: TBoldElementTypeInfo read GetValueType; + property Evaluator: TBoldEvaluator read fEvaluator write fEvaluator; + end; + + TBoldExternalVariableListTraverser = class(TBoldArrayTraverser) + public + function GetCurrent: TBoldExternalVariable; + property Current: TBoldExternalVariable read GetCurrent; end; { TBoldExternalVariableList } TBoldExternalVariableList = class(TBoldObjectArray) private function GetVariables(index: integer): TBoldExternalVariable; + function GetVariableByName(const aName: string): TBoldExternalVariable; + function GetAsCommaText: string; public - constructor create; - procedure Add(Variable: TBoldExternalVariable); + constructor Create(aOwnsVariables: boolean = true); + class function CreateWithStringVariable(AName: string; AValue: string): TBoldExternalVariableList; + class function CreateWithElementVariable(AName: string; AValue: TBoldElement): TBoldExternalVariableList; + function GetEnumerator: TBoldExternalVariableListTraverser; + procedure Add(Variable: TBoldExternalVariable); overload; + procedure Add(AName: string; AValue: string); overload; + procedure Add(AName: string; AValue: TBoldElement); overload; + function RefersToVariable(const Ocl: string): boolean; property Variables[index: integer]: TBoldExternalVariable read GetVariables; default; + property VariableByName[const aName: string]: TBoldExternalVariable read GetVariableByName; + property AsCommaText: string read GetAsCommaText; end; {---TBoldEvaluator---} TBoldEvaluator = class(TBoldMemoryManagedObject) + protected + function GetVariableCount: integer; virtual; abstract; + function GetVariable(index: integer): TBoldIndirectElement; virtual; abstract; + function GetVariableByName(const aName: string): TBoldIndirectElement; virtual; abstract; public - procedure DefineVariable(const VariableName: string; VarValue: TBoldElement; VariableType: TBoldElementTypeInfo; OwnValue: Boolean); virtual; abstract; - procedure Evaluate(Ocl: string; Root: TBoldElement; Subscriber: TBoldSubscriber; ResubscribeAll: Boolean; resultElement: TBoldIndirectElement; EvaluateInPS: Boolean = false; const VariableList: TBoldExternalVariableList = nil); virtual; abstract; + procedure DefineVariable(const VariableName: string; VarValue: TBoldElement; VariableType: TBoldElementTypeInfo; OwnValue, IsConstant: Boolean); overload; virtual; abstract; + procedure DefineVariable(const VariableName: string; Variable: TBoldExternalVariable ); overload; virtual; abstract; + procedure UndefineVariable(Variable: TBoldExternalVariable); virtual; abstract; + procedure Evaluate(Ocl: string; Root: TBoldElement; Subscriber: TBoldSubscriber = nil; ResubscribeAll: Boolean = false; resultElement: TBoldIndirectElement = nil; EvaluateInPS: Boolean = false; const VariableList: TBoldExternalVariableList = nil); virtual; abstract; function ExpressionType(const Ocl: string; Context: TBoldElementTypeInfo; ReRaise: Boolean; const VariableList: TBoldExternalVariableList = nil): TBoldElementTypeInfo; virtual; abstract; procedure SetLookupOclDefinition(value: TBoldLookUpOclDefinition); virtual; abstract; + property Variables[index: integer]: TBoldIndirectElement read GetVariable; + property VariableByName[const aName: string]: TBoldIndirectElement read GetVariableByName; + property VariableCount: integer read GetVariableCount; end; {---TBoldElement---} TBoldElement = class(TBoldSubscribableObject) - private + strict private function GetModifiedValueHolder: TObject; procedure SetModifiedValueHolder(Value: TObject); - function GetMutable: Boolean; + function GetMutable: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected + function GetDisplayName: String; virtual; function GetStringRepresentation(Representation: TBoldRepresentation): string; virtual; - procedure SetStringRepresentation(Representation: TBoldRepresentation; Value: string); virtual; + procedure SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); virtual; procedure CompareError(BoldElement: TBoldElement); procedure AssignError(BoldElement: TBoldElement); procedure MutableError(const NewValue: string); @@ -191,40 +237,52 @@ TBoldElement = class(TBoldSubscribableObject) function GetEvaluator: TBoldEvaluator; virtual; function GetBoldType: TBoldElementTypeInfo; virtual; abstract; function CloneIfPossible: TBoldElement; virtual; + function GetContextString: string; override; + function GetIsPartOfSystem: Boolean; virtual; public + constructor CreateWithTypeInfo(ElementTypeInfo: TBoldElementTypeInfo); virtual; destructor Destroy; override; procedure DefaultSubscribe(Subscriber: TBoldSubscriber; RequestedEvent: TBoldEvent = breReEvaluate); virtual; abstract; procedure PrepareToDestroy; function GetAsVariant: Variant; virtual; - procedure SetAsVariant(const Value: Variant); virtual; + procedure SetAsVariant(const Value: Variant); virtual; function IsEqual(BoldElement: TBoldElement): Boolean; function CompareTo(BoldElement: TBoldElement): Integer; function CompareToAs(CompareType: TBoldCompareType; BoldElement: TBoldElement): Integer; virtual; function IsEqualAs(CompareType: TBoldCompareType; BoldElement: TBoldElement): Boolean; virtual; procedure Assign(Source: TBoldElement); virtual; function ValidateCharacter(C: Char; Representation: TBoldRepresentation): Boolean; virtual; - function ValidateString(Value: string; Representation: TBoldRepresentation): Boolean; virtual; + function ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; virtual; + function ValidateVariant(const Value: Variant; Representation: TBoldRepresentation = brDefault): Boolean; virtual; procedure EnsureValidString(const Value: string; Representation: TBoldRepresentation); procedure SubscribeToStringRepresentation(Representation: TBoldRepresentation; Subscriber: TBoldSubscriber; RequestedEvent: TBoldEvent = breReEvaluate); virtual; function ObserverMayModify(Observer: TObject): Boolean; virtual; function ObserverMayModifyAsString(Representation: TBoldRepresentation; observer: TBoldSubscriber): Boolean; virtual; - procedure RegisterModifiedValueHolder(observer: TObject); - procedure UnRegisterModifiedValueHolder(observer: TObject); - procedure MakeImmutable; + procedure RegisterModifiedValueHolder(observer: TObject); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure UnRegisterModifiedValueHolder(observer: TObject); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure MakeImmutable; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure GetAsList(ResultList: TBoldIndirectElement); virtual; abstract; procedure GetAsValue(resultElement: TBoldIndirectElement); virtual; procedure SubscribeToExpression(const Expression: TBoldExpression; Subscriber: TBoldSubscriber; Resubscribe: Boolean = false; EvaluateInPS: Boolean = false; const VariableList: TBoldExternalVariableList = nil); procedure EvaluateExpression(const Expression: TBoldExpression; resultElement: TBoldIndirectElement; EvaluateInPS: Boolean = false; const VariableList: TBoldExternalVariableList = nil); function EvaluateExpressionAsDirectElement(const Expression: TBoldExpression; const VariableList: TBoldExternalVariableList = nil): TBoldElement; procedure EvaluateAndSubscribeToExpression(const Expression: TBoldExpression; Subscriber: TBoldSubscriber; resultElement: TBoldIndirectElement; Resubscribe: Boolean = false; EvaluateInPS: Boolean = false; const VariableList: TBoldExternalVariableList = nil); - function EvaluateExpressionAsString(const Expression: TBoldExpression; Representation: TBoldRepresentation; EvaluateInPS: Boolean = false; const VariableList: TBoldExternalVariableList = nil): string; + function EvaluateExpressionAsString(const Expression: TBoldExpression; Representation: TBoldRepresentation = brDefault; EvaluateInPS: Boolean = false; const VariableList: TBoldExternalVariableList = nil): string; + function EvaluateExpressionAsBoolean(const Expression: TBoldExpression; EvaluateInPS: Boolean = false; const VariableList: TBoldExternalVariableList = nil): Boolean; + function EvaluateExpressionAsInteger(const Expression: TBoldExpression; EvaluateInPS: Boolean = false; const VariableList: TBoldExternalVariableList = nil): Integer; + function EvaluateExpressionAsFloat(const Expression: TBoldExpression; EvaluateInPS: Boolean = false; const VariableList: TBoldExternalVariableList = nil): Double; + function EvaluateExpressionAsCurrency(const Expression: TBoldExpression; EvaluateInPS: Boolean = false; const VariableList: TBoldExternalVariableList = nil): Currency; + function EvaluateExpressionAsDateTime(const Expression: TBoldExpression; EvaluateInPS: Boolean = false; const VariableList: TBoldExternalVariableList = nil): TDateTime; function EvaluateExpressionAsNewElement(const Expression: TBoldExpression; EvaluateInPS: Boolean = false; const VariableList: TBoldExternalVariableList = nil): TBoldElement; property Evaluator: TBoldEvaluator read GetEvaluator; property BoldType: TBoldElementTypeInfo read GetBoldType; property StringRepresentation[Representation: TBoldRepresentation]: string read GetStringRepresentation write SetStringRepresentation; property AsString: string index brDefault read GetStringRepresentation write SetStringRepresentation; + property AsVariant: variant read GetAsVariant write SetAsVariant; property ModifiedValueHolder: TObject read GetModifiedValueHolder; property Mutable: Boolean read GetMutable; + property DisplayName: String read GetDisplayName; + property IsPartOfSystem: Boolean read GetIsPartOfSystem; end; {---TBoldMetaElement---} @@ -235,6 +293,7 @@ TBoldMetaElement = class(TBoldElement) fExpressionName: string; protected function GetStringRepresentation(Representation: TBoldRepresentation): string; override; + function GetDisplayName: String; override; public function IsEqualAs(CompareType: TBoldCompareType; BoldElement: TBoldElement): Boolean; override; constructor Create(const ModelName: string; const ExpressionName: string; const DelphiName: string); @@ -248,25 +307,47 @@ TBoldMetaElement = class(TBoldElement) {---TBoldElementTypeInfo---} TBoldElementTypeInfo = class(TBoldMetaElement) private - fSystemTypeInfo: TBoldElementTypeInfo; // FixMe this shouldn't be stored in every ValueTypeINfo + fSystemTypeInfo: TBoldElementTypeInfo; function GetValueType: TBoldValueTypeSet; protected function GetEvaluator: TBoldEvaluator; override; procedure SetValueType(NewValue: TBoldValueTypeSet); + function GetListTypeInfo: TBoldListTypeInfo; virtual; public constructor Create(const ModelName: string; const ExpressionName: string; const DelphiName: string; SystemTypeInfo: TBoldElementTypeInfo); procedure GetAsList(ResultList: TBoldIndirectElement); override; function ConformsTo(Element: TBoldElementTypeInfo): Boolean; virtual; abstract; + function ElementClass: TBoldElementClass; virtual; + function CreateElement: TBoldElement; virtual; property SystemTypeInfo: TBoldElementTypeInfo read fSystemTypeInfo; property BoldValueType: TBoldValueTypeSet read GetValueType; + property ListTypeInfo: TBoldListTypeInfo read GetListTypeInfo; + end; + + {---TBoldListTypeInfo---} + TBoldListTypeInfo = class(TBoldElementTypeInfo) + private + fListClass: TClass; + fListElementTypeInfo: TBoldElementTypeInfo; + protected + function GetBoldType: TBoldElementTypeInfo; override; + function GetStringRepresentation(Representation: TBoldRepresentation): string; override; + function GetListTypeInfo: TBoldListTypeInfo; override; + public + constructor Create(ListElementTypeInfo: TBoldElementTypeInfo; SystemTypeInfo: TBoldElementTypeInfo; ListClass: TClass); + function ConformsTo(CompareElement: TBoldElementTypeInfo): Boolean; override; + function CreateElement: TBoldElement; override; + property ListClass: TClass read fListClass; + property ListElementTypeInfo: TBoldElementTypeInfo read fListElementTypeInfo; end; {---TBoldIndirectElement---} TBoldIndirectElement = class(TBoldFlaggedObject) private fValue: TBoldElement; - function GetValue: TBoldElement; property WriteableOwnsValue: Boolean index befOwnsValue read GetElementFlag write SetElementFlag; + protected + function ContextObject: TObject; override; public destructor Destroy; override; procedure SetReferenceValue(NewValue: TBoldElement); @@ -274,7 +355,7 @@ TBoldIndirectElement = class(TBoldFlaggedObject) procedure TransferValue(Target: TBoldIndirectElement); function RelinquishValue: TBoldElement; property OwnsValue: Boolean index befOwnsValue read GetElementFlag; - property Value: TBoldElement read GetValue; + property Value: TBoldElement read fValue; end; {---TBoldSubscribableComponentViaBoldElem---} @@ -284,18 +365,25 @@ TBoldSubscribableComponentViaBoldElem = class(TBoldSubscribableComponent) implementation uses - SysUtils, - BoldUtils, + BoldExternalizedReferences, BoldOclError, - Typinfo, BoldTypeList, // circular reference BoldElements->BoldTypelist->BoldSystem->BoldElements - BoldExternalizedReferences, - BoldCoreConsts; + BoldAttributes, + BoldOclVariables, + BoldUtils, + SysUtils, + Variants, + Windows, + Typinfo, + Classes; +const + sOCLResultError = 'Expression: ''%s '' returned incorrect result. Expected: %s. Currently: %s.'; + beModifiedValueHolderDestroying = 303; var G_ExternalModifiedValueHolders: TBoldExternalizedReferenceList; -function TBoldElement.EvaluateExpressionAsString(const Expression: TBoldExpression; Representation: TBoldRepresentation; EvaluateInPS: Boolean = false; const VariableList: TBoldExternalVariableList = nil): string; +function TBoldElement.EvaluateExpressionAsString(const Expression: TBoldExpression; Representation: TBoldRepresentation = brDefault; EvaluateInPS: Boolean = false; const VariableList: TBoldExternalVariableList = nil): string; var E: TBoldIndirectElement; begin @@ -326,6 +414,69 @@ procedure TBoldElement.EvaluateExpression(const Expression: TBoldExpression; res EvaluateAndSubscribeToExpression(Expression, nil, resultElement, False, EvaluateInPS, VariableList); end; +function TBoldElement.EvaluateExpressionAsBoolean( + const Expression: TBoldExpression; EvaluateInPS: Boolean; + const VariableList: TBoldExternalVariableList): Boolean; +var + E: TBoldIndirectElement; +begin + Result := False; + E := TBoldIndirectElement.Create; + try + EvaluateExpression(Expression, E, EvaluateInPS, VariableList); + if Assigned(E.Value) then + if E.Value is TBABoolean then + Result := TBABoolean(E.Value).AsBoolean + else + raise EBold.CreateFmt(sOCLResultError, [Expression, + TBABoolean.ClassName, E.Value.ClassName]) + finally + E.Free; + end; +end; + +function TBoldElement.EvaluateExpressionAsCurrency( + const Expression: TBoldExpression; EvaluateInPS: Boolean; + const VariableList: TBoldExternalVariableList): Currency; +var + E: TBoldIndirectElement; +begin + Result := 0; + E := TBoldIndirectElement.Create; + try + EvaluateExpression(Expression, E, EvaluateInPS, VariableList); + if Assigned(E.Value) then + if E.Value is TBACurrency then + Result := TBACurrency(E.Value).AsCurrency + else + raise EBold.CreateFmt(sOCLResultError, [Expression, + TBACurrency.ClassName, E.Value.ClassName]) + finally + E.Free; + end; +end; + +function TBoldElement.EvaluateExpressionAsDateTime( + const Expression: TBoldExpression; EvaluateInPS: Boolean; + const VariableList: TBoldExternalVariableList): TDateTime; +var + E: TBoldIndirectElement; +begin + Result := 0; + E := TBoldIndirectElement.Create; + try + EvaluateExpression(Expression, E, EvaluateInPS, VariableList); + if Assigned(E.Value) then + if E.Value is TBADateTime then + Result := TBADateTime(E.Value).AsDateTime + else + raise EBold.CreateFmt(sOCLResultError, [Expression, + TBADateTime.ClassName, E.Value.ClassName]) + finally + E.Free; + end; +end; + function TBoldElement.EvaluateExpressionAsDirectElement(const Expression: TBoldExpression; const VariableList: TBoldExternalVariableList = nil): TBoldElement; var E: TBoldIndirectElement; @@ -342,6 +493,49 @@ function TBoldElement.EvaluateExpressionAsDirectElement(const Expression: TBoldE end; end; +function TBoldElement.EvaluateExpressionAsFloat( + const Expression: TBoldExpression; + EvaluateInPS: Boolean; const VariableList: TBoldExternalVariableList): Double; +var + E: TBoldIndirectElement; +begin + Result := 0; + E := TBoldIndirectElement.Create; + try + EvaluateExpression(Expression, E, EvaluateInPS, VariableList); + if Assigned(E.Value) then + if E.Value is TBAFloat then + Result := TBAFloat(E.Value).AsFloat + else + raise EBold.CreateFmt(sOCLResultError, [Expression, + TBAFloat.ClassName, E.Value.ClassName]) + finally + E.Free; + end; +end; + +function TBoldElement.EvaluateExpressionAsInteger( + const Expression: TBoldExpression; + EvaluateInPS: Boolean; + const VariableList: TBoldExternalVariableList): Integer; +var + E: TBoldIndirectElement; +begin + Result := 0; + E := TBoldIndirectElement.Create; + try + EvaluateExpression(Expression, E, EvaluateInPS, VariableList); + if Assigned(E.Value) then + if E.Value is TBAInteger then + Result := TBAInteger(E.Value).AsInteger + else + raise EBold.CreateFmt(sOCLResultError, [Expression, + TBAInteger.ClassName, E.Value.ClassName]) + finally + E.Free; + end; +end; + {---TBoldElement---} function TBoldElement.GetEvaluator: TBoldEvaluator; @@ -349,8 +543,9 @@ function TBoldElement.GetEvaluator: TBoldEvaluator; if assigned(BoldType) then Result := BoldType.Evaluator else - raise EBold.CreateFmt(sCannotGetEvaluatorWithoutType, [classname]); + raise EBold.CreateFmt('%s.GetEvaluator: Element has no type, can not get evaluator', [classname]); end; + destructor TBoldElement.Destroy; begin PrepareToDestroy; @@ -365,12 +560,14 @@ procedure TBoldElement.PrepareToDestroy; function TBoldElement.GetStringRepresentation(Representation: TBoldRepresentation): string; begin - raise EBold.CreateFmt(sRepresentationNotSupported, [ClassName, Representation]); + raise EBold.CreateFmt('%s.GetStringRepresentation: Representation %d not supported', + [ClassName, Representation]); end; -procedure TBoldElement.SetStringRepresentation(Representation: TBoldRepresentation; Value: string); +procedure TBoldElement.SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); begin - raise EBold.CreateFmt(sRepresentationNotSupported, [ClassName, Representation]); + raise EBold.CreateFmt('%s.SetStringRepresentation: Representation %d not supported', + [ClassName, Representation]); end; procedure TBoldElement.SubscribeToStringRepresentation(Representation: TBoldRepresentation; Subscriber: TBoldSubscriber; RequestedEvent: TBoldEvent); @@ -382,7 +579,7 @@ function TBoldElement.ValidateCharacter(C: Char; Representation: TBoldRepresenta Result := True; end; -function TBoldElement.ValidateString(Value: string; Representation: TBoldRepresentation): Boolean; +function TBoldElement.ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; var I: Integer; begin @@ -395,9 +592,17 @@ function TBoldElement.ValidateString(Value: string; Representation: TBoldReprese end; end; +function TBoldElement.ValidateVariant(const Value: Variant; + Representation: TBoldRepresentation): Boolean; +begin + result := ValidateString(VarToStr(Value), Representation); +end; + function TBoldElement.ObserverMayModify(Observer: TObject): Boolean; begin - Result := False; + Result := Mutable and + ((ModifiedValueHolder = nil) or + (ModifiedValueHolder = Observer)); end; function TBoldElement.ObserverMayModifyAsString(Representation: TBoldRepresentation; Observer: TBoldSubscriber): Boolean; @@ -406,71 +611,109 @@ function TBoldElement.ObserverMayModifyAsString(Representation: TBoldRepresentat end; procedure TBoldElement.RegisterModifiedValueHolder(observer: TObject); + + procedure InternalRaise(Self: TBoldElement; Value: TObject); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + var + LockedBy: string; + begin + if Value is TBoldMemoryManagedObject then + LockedBy := TBoldMemoryManagedObject(Value).DebugInfo + else + if Value is TComponent then + begin + LockedBy := TComponent(Value).Name; + if LockedBy = '' then + LockedBy := Value.ClassName; + end + else + LockedBy := Value.ClassName; + raise EBold.CreateFmt('%s: Member already under modification by %s', [self.DisplayName, LockedBy]) + end; + +var + Value: TObject; begin - if Assigned(ModifiedValueHolder) and (ModifiedValueHolder <> observer) then - raise EBold.CreateFmt(sMemberAlreadyModified, [ClassName]) + if GetElementFlag(befHasModifiedValueHolder) then + begin + Value := ModifiedValueHolder; + if Assigned(Value) and (Value <> observer) then + InternalRaise(Self, Observer); + end else SetModifiedValueHolder(observer); end; procedure TBoldElement.UnRegisterModifiedValueHolder(observer: TObject); begin - // FIXME grid if (ModifiedValueHolder <> observer) then - // raise EBoldInternal.Create('Internal Error') - // else SetModifiedValueHolder(nil); end; function TBoldElement.IsEqual(BoldElement: TBoldElement): Boolean; begin - Result := IsEqualAs(ctDefault, BoldElement); + Result := (self = BoldElement) or IsEqualAs(ctDefault, BoldElement); end; function TBoldElement.IsEqualAs(CompareType: TBoldCompareType; BoldElement: TBoldElement): Boolean; begin - Result := CompareToAs(CompareType, BoldElement) = 0; + Result := (self = BoldElement) or (CompareToAs(CompareType, BoldElement) = 0); end; function TBoldElement.CompareTo(BoldElement: TBoldElement): Integer; begin - Result := CompareToAs(ctDefault, BoldElement); + if (self = BoldElement) then + result := 0 + else + result := CompareToAs(ctDefault, BoldElement); end; function TBoldElement.CompareToAs(CompareType: TBoldCompareType; BoldElement: TBoldElement): Integer; begin - raise EBold.CreateFmt(sLocatedAbstractError, [ClassName, 'CompareToAs']); // do not localize + raise EBold.CreateFmt('%s.CompareToAs is abstract', [ClassName]); end; procedure TBoldElement.Assign(Source: TBoldElement); begin if assigned(Source) then - raise EBold.CreateFmt(sAssignNotSupported, [ClassName, Source.ClassName]) + raise EBold.CreateFmt('%s.Assign does not support assigning from %s', [ClassName, Source.ClassName]) else - raise EBold.CreateFmt(sAssignNilNotSupported, [ClassName]) + raise EBold.CreateFmt('%s.Assign does not support assigning nil', [ClassName]) end; procedure TBoldElement.CompareError(BoldElement: TBoldElement); begin if Assigned(BoldElement) then - raise EBold.CreateFmt(sCompareNotSupported, [ClassName, BoldElement.ClassName]) + raise EBold.CreateFmt('%s: Cannot compare with a %s', [ClassName, BoldElement.ClassName]) else - raise EBold.CreateFmt(sCompareNilNotSupported, [ClassName]); + raise EBold.CreateFmt('%s: Cannot compare to nil', [ClassName]); end; procedure TBoldElement.AssignError(BoldElement: TBoldElement); begin if Assigned(BoldElement) then - raise EBold.CreateFmt(sAssignNotSupported, [ClassName, BoldElement.ClassName]) + raise EBold.CreateFmt('%s: Cannot assign a %s', [ClassName, BoldElement.ClassName]) else - raise EBold.CreateFmt(sAssignNilNotSupported, [ClassName]); + raise EBold.CreateFmt('%s: Cannot assign nil', [ClassName]); end; procedure TBoldElement.CompareTypeError(CompType: TBoldCompareType; BoldElement: TBoldElement); +var + ElementName: string; begin - raise EBold.CreateFmt(sInvalidCompareType, + if Assigned(BoldElement) + then + ElementName := BoldElement.ClassName + else + ElementName := 'nil'; + raise EBold.CreateFmt('%s: Comparetype ''%s'' not supported when comparing to %s', [ClassName, GetEnumName(TypeInfo(TBoldCompareType), Ord(CompType)), - BoldElement.ClassName]); + ElementName]); +end; + +constructor TBoldElement.CreateWithTypeInfo( + ElementTypeInfo: TBoldElementTypeInfo); +begin + end; procedure TBoldElement.MakeImmutable; @@ -480,7 +723,7 @@ procedure TBoldElement.MakeImmutable; procedure TBoldElement.MutableError(const NewValue: string); begin - raise EBold.CreateFmt(sTriedToChangeImmutableElement, [ClassName, AsString, NewValue]); + raise EBold.CreateFmt('%s: Tried to change the value of an immutable element from ''%s'' to ''%s''', [ClassName, AsString, NewValue]); end; procedure TBoldElement.GetAsValue(resultElement: TBoldIndirectElement); @@ -492,7 +735,7 @@ procedure TBoldElement.EnsureValidString(const Value: string; Representation: TBoldRepresentation); begin if not ValidateString(Value, Representation) then - raise EBoldAssertionFailed.Create(sStringValidationFailed); + raise EBoldAssertionFailed.CreateFmt('%s.EnsureValidString: String validation failed', [Classname]); end; function TBoldElement.GetAsVariant: Variant; @@ -500,16 +743,34 @@ function TBoldElement.GetAsVariant: Variant; Result := AsString; end; +function TBoldElement.GetContextString: string; +begin + result := DisplayName; +end; + +function TBoldElement.GetDisplayName: String; +begin + if Assigned(BoldType) then + result := BoldType.AsString + else + result := ClassName; +end; + procedure TBoldElement.SetAsVariant(const Value: Variant); begin AsString := Value; end; +function TBoldElement.GetIsPartOfSystem: Boolean; +begin + result := true; // always true for System and Objects, and overriden for Member +end; + {---TBoldMetaElement---} procedure TBoldMetaElement.DefaultSubscribe(Subscriber: TBoldSubscriber; RequestedEvent: TBoldEvent = breReEvaluate); begin if Mutable then - raise EBold.CreateFmt(sCannotSubscribeToMutableMetaElements, [ClassName]); + raise EBold.CreateFmt('%s.DefaultSubscribe: Subscription on mutable MetaElements is not possible', [ClassName]); end; constructor TBoldMetaElement.Create(const ModelName: string; const ExpressionName: string; const DelphiName: string); @@ -528,7 +789,12 @@ function TBoldMetaElement.GetStringRepresentation(Representation: TBoldRepresent procedure TBoldMetaElement.GetAsList(ResultList: TBoldIndirectElement); begin - raise EBoldFeatureNotImplementedYet.Create(sMetaElementGetAsListNotImplemented); + raise EBoldFeatureNotImplementedYet.Create('TBoldMetaElement.GetAsList has not been implemented yet.'); +end; + +function TBoldMetaElement.GetDisplayName: String; +begin + result := ExpressionName; end; {---TBoldElementTypeInfo---} @@ -538,6 +804,18 @@ constructor TBoldElementTypeInfo.Create(const ModelName: string; const Expressio fSystemTypeInfo := SystemTypeInfo; end; +function TBoldElementTypeInfo.ElementClass: TBoldElementClass; +begin + result := nil; +end; + +function TBoldElementTypeInfo.CreateElement: TBoldElement; +const + sInvalidBoldType = '%s.CreateElement: Invalid BoldType (%s)'; +begin + raise EBold.CreateFmt(sInvalidBoldType, [ClassName, asString]) +end; + procedure TBoldElementTypeInfo.GetAsList(ResultList: TBoldIndirectElement); var list: TBoldTypeList; @@ -552,10 +830,16 @@ function TBoldElementTypeInfo.GetEvaluator: TBoldEvaluator; Result := SystemTypeInfo.GetEvaluator; end; +function TBoldElementTypeInfo.GetListTypeInfo: TBoldListTypeInfo; +begin + raise EBold.CreateFmt('%s.GetListTypeInfo is not overriden, implement it.', [classname]); +end; + {---TBoldIndirectElement---} + destructor TBoldIndirectElement.Destroy; begin - if OwnsValue then + if OwnsValue and not fValue.IsPartOfSystem then FreeAndNil(fValue) else fValue := nil; @@ -577,7 +861,7 @@ procedure TBoldIndirectElement.SetReferenceValue(NewValue: TBoldElement); end else if OwnsValue then - raise EBold.CreateFmt(sNewValueAlreadyOwned, [ClassName]); + raise EBold.Create('TBoldInDirectElement.SetReferenceValue: New value alread owned!'); WriteableOwnsValue := False; end; @@ -617,9 +901,9 @@ function TBoldIndirectElement.RelinquishValue: TBoldElement; WriteableOwnsValue := False; end; -function TBoldIndirectElement.GetValue: TBoldElement; +function TBoldIndirectElement.ContextObject: TObject; begin - Result := fValue; + result := fValue; end; function TBoldElement.GetModifiedValueHolder: TObject; @@ -652,9 +936,9 @@ procedure TBoldElement.EvaluateAndSubscribeToExpression( AddSmallSubscription(Subscriber, [beDestroying], breReSubscribe); except on E: EBoldOCLAbort do - raise EBold.CreateFmt(sOCLExpressionError, [E.Ocl, E.Message]); + raise EBold.CreateFmt('OCL Expression: %s' + BOLDCRLF + 'Error: %s' + BOLDCRLF, [E.Ocl, E.Message]); on E: EBoldOCLError do - raise EBold.CreateFmt(sOCLExpressionError, [E.Ocl, E.Message]); + raise EBold.CreateFmt('OCL Expression: %s' + BOLDCRLF + 'Error: %s' + BOLDCRLF, [E.Ocl, E.Message]); end; end; @@ -676,6 +960,14 @@ constructor TBoldExternalVariable.Create(const Name: String); fName := Name; end; +destructor TBoldExternalVariable.Destroy; +begin + if Assigned(fEvaluator) then + fEvaluator.UndefineVariable(self); + fEvaluator := nil; + inherited; +end; + { TBoldExternalOclVariableList } procedure TBoldExternalVariableList.Add(Variable: TBoldExternalVariable); @@ -683,9 +975,71 @@ procedure TBoldExternalVariableList.Add(Variable: TBoldExternalVariable); inherited Add(Variable); end; -constructor TBoldExternalVariableList.create; +procedure TBoldExternalVariableList.Add(AName, AValue: string); +begin + Add(TBoldOclVariable.CreateStringVariable(AName, AValue)); +end; + +procedure TBoldExternalVariableList.Add(AName: string; AValue: TBoldElement); +begin + Add(TBoldOclVariable.Create(AName, AValue)); +end; + +constructor TBoldExternalVariableList.Create(aOwnsVariables: boolean = true); +begin + if aOwnsVariables then + inherited create(4, [bcoDataOwner]) + else + inherited create(4, []); +end; + +class function TBoldExternalVariableList.CreateWithElementVariable( + AName: string; AValue: TBoldElement): TBoldExternalVariableList; +begin + result := TBoldExternalVariableList.Create; + result.Add(TBoldOclVariable.Create(AName, AValue)); +end; + +class function TBoldExternalVariableList.CreateWithStringVariable(AName, + AValue: string): TBoldExternalVariableList; +begin + result := TBoldExternalVariableList.Create; + result.Add(TBoldOclVariable.CreateStringVariable(AName, AValue)); +end; + +function TBoldExternalVariableList.GetAsCommaText: string; +var + i: integer; + sl: TStringList; +begin + result := ''; + sl:= TStringList.Create; + try + for I := 0 to Count - 1 do + sl.Add(Variables[i].Name); + result := sl.CommaText; + finally + sl.free; + end; +end; + +function TBoldExternalVariableList.GetEnumerator: TBoldExternalVariableListTraverser; begin - inherited create(4, [bcoDataOwner]); + result := TBoldExternalVariableListTraverser.Create(self); +end; + +function TBoldExternalVariableList.GetVariableByName( + const aName: string): TBoldExternalVariable; +var + i: integer; +begin + result := nil; + for I := 0 to Count - 1 do + if CompareText(Variables[i].Name, aName) = 0 then + begin + result := Variables[i]; + break; + end; end; function TBoldExternalVariableList.GetVariables(index: integer): TBoldExternalVariable; @@ -693,6 +1047,17 @@ function TBoldExternalVariableList.GetVariables(index: integer): TBoldExternalVa result := Items[index] as TBoldExternalVariable; end; +function TBoldExternalVariableList.RefersToVariable(const Ocl: string): boolean; +var + i: integer; +begin + result := true; + for i := 0 to Count-1 do + if BoldCaseIndependentPos(Variables[i].Name, Ocl) > 0 then + exit; + result := false; +end; + function TBoldMetaElement.IsEqualAs(CompareType: TBoldCompareType; BoldElement: TBoldElement): Boolean; begin @@ -728,13 +1093,79 @@ function TBoldElement.CloneIfPossible: TBoldElement; Result := nil; end; +{---TBoldListTypeInfo---} +constructor TBoldListTypeInfo.Create(ListElementTypeInfo: TBoldElementTypeInfo; SystemTypeInfo: TBoldElementTypeInfo; ListClass: TClass); +begin + if assigned(ListElementTypeInfo) then + inherited Create(ListElementTypeInfo.ModelName + 'List', + 'Collection(' + ListElementTypeInfo.ExpressionName + ')', + ListElementTypeInfo.Delphiname + 'List', SystemTypeInfo) + else + inherited Create('Collection()', 'Collection()', 'Collection()', SystemTypeInfo); + fListElementTypeInfo := ListElementTypeInfo; + SetValueType(bvtList); + fListClass := ListClass; +end; + +function TBoldListTypeInfo.CreateElement: TBoldElement; +begin + result := TBoldElementClass(ListClass).CreateWithTypeInfo(self); +end; + +function TBoldListTypeInfo.ConformsTo(CompareElement: TBoldElementTypeInfo): Boolean; +var + CompareListTypeInfo: TBoldListTypeInfo; +begin + if CompareElement is TBoldListTypeInfo then + begin + CompareListTypeInfo := TBoldListTypeInfo(CompareElement); + Result := not assigned(CompareListTypeInfo.ListElementTypeInfo) or + (assigned(ListElementTypeInfo) and + ListElementTypeInfo.ConformsTo(CompareListTypeInfo.ListElementTypeInfo)); + end + else + Result := False; +end; + +function TBoldListTypeInfo.GetStringRepresentation(Representation: TBoldRepresentation): string; +begin + if assigned(ListElementTypeInfo) then + Result := 'Collection(' + ListElementTypeInfo.AsString + ')' + else + Result := 'Collection()'; +end; + +function TBoldListTypeInfo.GetBoldType: TBoldElementTypeInfo; +begin + result := SystemTypeInfo.BoldType; +end; + +function TBoldListTypeInfo.GetListTypeInfo: TBoldListTypeInfo; +begin + result := self; +end; + +procedure InitDebugMethods; +var + List: TBoldExternalVariableList; +begin + exit; + List := nil; + List.AsCommaText; +end; + +{ TBoldExternalVariableListTraverser } + +function TBoldExternalVariableListTraverser.GetCurrent: TBoldExternalVariable; +begin + result := ObjectArray[index] as TBoldExternalVariable; +end; + initialization G_ExternalModifiedValueHolders := TBoldExternalizedReferenceList.Create; + InitDebugMethods; finalization G_ExternalModifiedValueHolders.free; end. - - - diff --git a/Source/ObjectSpace/Core/BoldMetaElementList.pas b/Source/ObjectSpace/Core/BoldMetaElementList.pas index 1e283735..8034cf9d 100644 --- a/Source/ObjectSpace/Core/BoldMetaElementList.pas +++ b/Source/ObjectSpace/Core/BoldMetaElementList.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldMetaElementList; interface @@ -11,15 +14,25 @@ interface TBoldMetaElementList = class; TBoldElementTypeInfoList = class; + TBoldMetaElementListTraverser = class(TBoldIndexableListTraverser) + public + function GetCurrent: TBoldMetaElement; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + property Current: TBoldMetaElement read GetCurrent; + end; + { TBoldMetaElementList } TBoldMetaElementList = class(TBoldIndexableList) private - function GetItem(index: Integer): TBoldMetaElement; - function GetItemByExpressionName(const ExpressionName: string): TBoldMetaElement; - function GetItemByDelphiName(const DelphiName: string): TBoldMetaElement; - function GetItemByModelName(const ModelName: string): TBoldMetaElement; + function GetItem(index: Integer): TBoldMetaElement; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByExpressionName(const ExpressionName: string): TBoldMetaElement; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByDelphiName(const DelphiName: string): TBoldMetaElement; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByModelName(const ModelName: string): TBoldMetaElement; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + class var IX_ExpressionName: integer; + class var IX_DelphiName: integer; + class var IX_ModelName: integer; public constructor Create; + function GetEnumerator: TBoldMetaElementListTraverser; procedure Add(Item: TBoldMetaElement); property Items[index: Integer]: TBoldMetaElement read GetItem; default; property ItemsByExpressionName[const ExpressionName: string]: TBoldMetaElement read GetItemByExpressionName; @@ -27,14 +40,21 @@ TBoldMetaElementList = class(TBoldIndexableList) property ItemsByModelName[const ModelName: string]: TBoldMetaElement read GetItemByModelName; end; + TBoldElementTypeInfoListTraverser = class(TBoldIndexableListTraverser) + public + function GetCurrent: TBoldElementTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + property Current: TBoldElementTypeInfo read GetCurrent; + end; + { TBoldElementTypeInfoList } TBoldElementTypeInfoList = class(TBoldMetaElementList) private - function GetItem(index: Integer): TBoldElementTypeInfo; - function GetItemByExpressionName(const ExpressionName: string): TBoldElementTypeInfo; - function GetItemByDelphiName(const DelphiName: string): TBoldElementTypeInfo; - function GetItemByModelName(const ModelName: string): TBoldElementTypeInfo; + function GetItem(index: Integer): TBoldElementTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByExpressionName(const ExpressionName: string): TBoldElementTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByDelphiName(const DelphiName: string): TBoldElementTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByModelName(const ModelName: string): TBoldElementTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public + function GetEnumerator: TBoldElementTypeInfoListTraverser; procedure Add(Item: TBoldElementTypeInfo); property Items[index: Integer]: TBoldElementTypeInfo read GetItem; default; property ItemsByExpressionName[const ExpressionName: string]: TBoldElementTypeInfo read GetItemByExpressionName; @@ -45,14 +65,8 @@ TBoldElementTypeInfoList = class(TBoldMetaElementList) implementation uses - SysUtils, BoldHashIndexes, - BoldUtils; - -var - IX_ExpressionName: integer = -1; - IX_DelphiName: integer = -1; - IX_ModelName: integer = -1; + BoldRev; type {---TExpressionNameIndex---} @@ -102,6 +116,11 @@ constructor TBoldMetaElementList.Create; SetIndexVariable(IX_ModelName, AddIndex(TModelNameIndex.Create)); end; +function TBoldMetaElementList.GetEnumerator: TBoldMetaElementListTraverser; +begin + result := CreateTraverser as TBoldMetaElementListTraverser; +end; + function TBoldMetaElementList.GetItem(index: Integer): TBoldMetaElement; begin Result := TBoldMetaElement(inherited Items[index]); @@ -109,12 +128,12 @@ function TBoldMetaElementList.GetItem(index: Integer): TBoldMetaElement; function TBoldMetaElementList.GetItemByExpressionName(const ExpressionName: string): TBoldMetaElement; begin - Result := TBoldMetaElement(TBoldValueTypeNameIndex(Indexes[IX_ExpressionName]).FindByString(ExpressionName)); + Result := TBoldMetaElement(TBoldStringHashIndex(Indexes[IX_ExpressionName]).FindByString(ExpressionName)); end; function TBoldMetaElementList.GetItemByDelphiName(const DelphiName: string): TBoldMetaElement; begin - Result := TBoldMetaElement(TDelphiNameIndex(Indexes[IX_DelphiName]).FindByString(DelphiName)); + Result := TBoldMetaElement(TBoldStringHashIndex(Indexes[IX_DelphiName]).FindByString(DelphiName)); end; procedure TBoldMetaElementList.Add(Item: TBoldMetaElement); @@ -124,7 +143,7 @@ procedure TBoldMetaElementList.Add(Item: TBoldMetaElement); function TBoldMetaElementList.GetItemByModelName(const ModelName: string): TBoldMetaElement; begin - Result := TBoldMetaElement(TModelNameIndex(Indexes[IX_ModelName]).FindByString(ModelName)); + Result := TBoldMetaElement(TBoldStringHashIndex(Indexes[IX_ModelName]).FindByString(ModelName)); end; { TBoldElementTypeInfoList } @@ -134,6 +153,11 @@ procedure TBoldElementTypeInfoList.Add(Item: TBoldElementTypeInfo); inherited add(item); end; +function TBoldElementTypeInfoList.GetEnumerator: TBoldElementTypeInfoListTraverser; +begin + result := CreateTraverser as TBoldElementTypeInfoListTraverser; +end; + function TBoldElementTypeInfoList.GetItem(index: Integer): TBoldElementTypeInfo; begin result := TBoldElementTypeInfo(inherited GetItem(index)); @@ -154,4 +178,25 @@ function TBoldElementTypeInfoList.GetItemByModelName(const ModelName: string): T result := TBoldElementTypeInfo(inherited GetItemByModelName(ModelName)); end; +{ TBoldMetaElementListTraverser } + +function TBoldMetaElementListTraverser.GetCurrent: TBoldMetaElement; +begin + result := inherited GetItem as TBoldMetaElement; +end; + +{ TBoldElementTypeInfoListTraverser } + +function TBoldElementTypeInfoListTraverser.GetCurrent: TBoldElementTypeInfo; +begin + result := inherited GetItem as TBoldElementTypeInfo; +end; + + +initialization + TBoldMetaElementList.IX_ExpressionName := -1; + TBoldMetaElementList.IX_DelphiName := -1; + TBoldMetaElementList.IX_ModelName := -1; + end. + diff --git a/Source/ObjectSpace/IDE/AttributeWizard/BoldAttributeWizard.pas b/Source/ObjectSpace/IDE/AttributeWizard/BoldAttributeWizard.pas index 72e7b8c6..fb2b00a9 100644 --- a/Source/ObjectSpace/IDE/AttributeWizard/BoldAttributeWizard.pas +++ b/Source/ObjectSpace/IDE/AttributeWizard/BoldAttributeWizard.pas @@ -1,6 +1,7 @@ -unit BoldAttributeWizard; -// NB! The attribute wizard is disabled in BCB. Check the Register-procedure +{ Global compiler directives } +{$include bold.inc} +unit BoldAttributeWizard; interface @@ -10,7 +11,7 @@ interface BoldTemplateExpander; type - { TAttributeWizard } + TAttributeWizard = class(TProjectWizard, IUnitGenerator) private procedure GenerateUnit(const UnitName: string; Template: TBoldTemplateHolder); @@ -34,25 +35,22 @@ implementation BoldWAdatamodule, BoldWAMainForm, BoldIDEMenus, - dialogs, - BoldCoreConsts; + dialogs; var AttributeWizardInitialized: Boolean = false; procedure Register; begin - {$IFDEF BOLD_DELPHI} InitExpert; RegisterPackageWizard(AttributeWizard); - {$ENDIF} end; procedure InitExpert; begin dmAttributeWizard := TdmAttributeWizard.Create(nil); - AttributeWizard := TAttributeWizard.Create('Bold.AttributeWizard', sBoldAttributeWizard, [], 3, 'Bold'); // do not localize - BoldMenuExpert; // ensure "Bold" menu has been created + AttributeWizard := TAttributeWizard.Create('Bold.AttributeWizard', 'Bold Attribute Wizard', [], 3, 'Bold'); + BoldMenuExpert; AttributeWizard.AddMenuItem(dmAttributeWizard.AttributeWizardMenu); AttributeWizardInitialized := true; end; @@ -64,7 +62,7 @@ procedure DoneExpert; AttributeWizardInitialized := false; end; - { TAttributeWizard } +{ TAttributeWizard } procedure TAttributeWizard.Execute; begin MainForm := TMainForm.Create(nil); @@ -75,46 +73,38 @@ procedure TAttributeWizard.Execute; procedure TAttributeWizard.GenerateUnit(const UnitName: string; Template: TBoldTemplateHolder); var -// CurrentProject: IOTAProject; Creator: TUnitCreator; NewModule: IOTAModule; SourceEditor: IOTASourceEditor; aUnitName, aFileName, aClassName: string; FullName: string; begin -// GetCurrentProject(CurrentProject); - //create a module, needs an IOTACreator + Creator := TUnitCreator.Create; - //get a new file and unit name from Delphi (BorlandIDEServices as IOTAModuleServices).GetNewModuleAndClassName('', aUnitName, aClassName, aFileName); - //use the new unitname if user has not specified one. if (length(UnitName) <> 0) then aUnitName := UnitName; - Template.Variables.SetVariable('UNITNAME', aUnitName); // do not localize + Template.Variables.SetVariable('UNITNAME', aUnitName); NewModule := nil; try FullName := Format('%s%s',[ExtractFilePath(aFileName), aUnitName]); -// NewModule := Creator.CreateUnit(Format('%s%s',[ExtractFilePath(aFileName), aUnitName]), Template.ExpandedTemplate.Text, CurrentProject as IOTAModule); NewModule := Creator.CreateUnit(FullName, Template.ExpandedTemplate.Text, nil); except on e: Exception do - MessageDlg(Format(sUnableToCreateUnit, [FullName, e.Message]), mtError, [mbOk], 0); + MessageDlg(Format('Unable to create unit %s, check unit name (Reason: %s)', [FullName, e.Message]), mtError, [mbOk], 0); end; - // save file -// NewModule.Save(true, true); - //add to project -// if Assigned(CurrentProject) then -// CurrentProject.AddFile(NewModule.GetFileName, true); - // show in editor + + + + + if assigned(NewModule) then begin SourceEditor := NewModule.GetModuleFileEditor(0) as IOTASourceEditor; (SourceEditor as IOTAEditor).Show; end; - // show the source editor, bring it to front - //!!Delphi4 -// (BorlandIDEServices as IOTAEditorServices).GetTopView.GetEditWindow.Form.show; + end; initialization diff --git a/Source/ObjectSpace/IDE/AttributeWizard/BoldOTACodeGen.pas b/Source/ObjectSpace/IDE/AttributeWizard/BoldOTACodeGen.pas index aa979cec..bdcee631 100644 --- a/Source/ObjectSpace/IDE/AttributeWizard/BoldOTACodeGen.pas +++ b/Source/ObjectSpace/IDE/AttributeWizard/BoldOTACodeGen.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOTACodeGen; interface @@ -23,13 +26,11 @@ TUnitCreator = class(TNotifierObject, IOTACreator, IOTAModuleCreator) fSource: string; public constructor Create; - // IOTACreator methods function GetCreatorType: string; function GetExisting: Boolean; function GetFileSystem: string; function GetOwner: IOTAModule; function GetUnnamed: Boolean; - //IOTAModuleCreator methods function GetAncestorName: string; function GetImplFileName: string; function GetIntfFileName: string; @@ -144,7 +145,6 @@ function TUnitCreator.NewIntfSource(const ModuleIdent, FormIdent, AncestorIdent: procedure TUnitCreator.FormCreated(const FormEditor: IOTAFormEditor); begin -// end; function TUnitCreator.CreateUnit(const FileName, Source: string; Owner: IOTAModule): IOTAModule; @@ -171,4 +171,6 @@ function TUnitFile.GetAge: TDateTime; Result:= -1; end; +initialization + end. diff --git a/Source/ObjectSpace/IDE/AttributeWizard/BoldVclUtils.pas b/Source/ObjectSpace/IDE/AttributeWizard/BoldVclUtils.pas index ffcdfede..ddfec09c 100644 --- a/Source/ObjectSpace/IDE/AttributeWizard/BoldVclUtils.pas +++ b/Source/ObjectSpace/IDE/AttributeWizard/BoldVclUtils.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldVclUtils; interface @@ -30,7 +33,6 @@ procedure ExchangeRows(var StringGrid: TStringGrid; a, b: Integer); i: Integer; begin if ((a < StringGrid.RowCount) AND (b < StringGrid.RowCount) AND (a <> 0) AND (b <> 0)) then - //ExchangeRows for i:= 0 to StringGrid.ColCount - 1 do StringGrid.Cols[i].Exchange(a,b); end; @@ -74,7 +76,6 @@ procedure ShiftDown(var StringGrid: TStringGrid; StartRow: Integer); begin if ((StartRow >= StringGrid.FixedRows) AND (StartRow < StringGrid.RowCount)) then begin - // append an empty to the stringgrid AppendRow(StringGrid); for i := (StringGrid.RowCount -1) downto (StartRow + 1) do ExchangeRows(StringGrid,i, i - 1); @@ -85,7 +86,6 @@ procedure SelectCell(var StringGrid: TStringGrid; const Col, Row: integer); var t: TGridRect; begin - // Selecting a cell in the stringGrid t.Left := Col ; t.Right := Col ; t.Top := Row; @@ -95,7 +95,6 @@ procedure SelectCell(var StringGrid: TStringGrid; const Col, Row: integer); procedure AppendRow(var StringGrid: TStringGrid); begin - // append an empty to the stringgrid if not IsEmptyStr(Trim(StringGrid.Rows[StringGrid.RowCount - 1].Text)) then begin StringGrid.RowCount := StringGrid.RowCount + 1; @@ -120,4 +119,6 @@ function IsEmptyStr(const str: string): Boolean; Result := (length(trim(str)) = 0); end; +initialization + end. diff --git a/Source/ObjectSpace/IDE/AttributeWizard/BoldWAClassInfo.pas b/Source/ObjectSpace/IDE/AttributeWizard/BoldWAClassInfo.pas index 38f1a535..fb4ec9e8 100644 --- a/Source/ObjectSpace/IDE/AttributeWizard/BoldWAClassInfo.pas +++ b/Source/ObjectSpace/IDE/AttributeWizard/BoldWAClassInfo.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWAClassInfo; interface @@ -60,13 +63,13 @@ constructor TClassInfo.Create(id: string); inherited Create; Create; fDelphiName := id; - Parent := 'TObject'; // do not localize + Parent := 'TObject'; end; destructor TClassInfo.Destroy; begin FreeAndNil(fmethods); - inherited Destroy; + inherited destroy; end; function TClassInfo.getMethods(const Visibility: TVisibility;var Item: TMethodInfo; var I: Integer): Boolean; @@ -167,4 +170,6 @@ procedure TClassInfoList.Clear; Remove(TClassInfo(fList[Index])); end; +initialization + end. diff --git a/Source/ObjectSpace/IDE/AttributeWizard/BoldWACustomAttr.pas b/Source/ObjectSpace/IDE/AttributeWizard/BoldWACustomAttr.pas index d2094d0d..43f75f60 100644 --- a/Source/ObjectSpace/IDE/AttributeWizard/BoldWACustomAttr.pas +++ b/Source/ObjectSpace/IDE/AttributeWizard/BoldWACustomAttr.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWACustomAttr; interface @@ -64,13 +67,12 @@ implementation function StrToAccessType(str: string): TAccessType; begin - if (AnsiCompareText(str,'READONLY') = 0) then // do not localize + if (AnsiCompareText(str,'READONLY') = 0) then Result := atReadOnly - else if (AnsiCompareText(str,'WRITEONLY') = 0) then // do not localize + else if (AnsiCompareText(str,'WRITEONLY') = 0) then Result := atWriteOnly - else if (AnsiCompareText(str,'READ/WRITE') = 0) then // do not localize + else if (AnsiCompareText(str,'READ/WRITE') = 0) then Result := atReadWrite - // default in ReadOnly else Result := atReadOnly ; end; @@ -112,17 +114,15 @@ procedure TCustomAttribute.AssignMethodsToTemplate(var Template: TBoldTemplateHo function BooleanToStr(value: Boolean): string; begin if value then - Result := 'true' // do not localize + Result := 'true' else - Result := 'false'; // do not localize + Result := 'false'; end; begin - // init count array if Methods.Count = 0 then Exit; for v:= stPrivate to stPublished do aCount[v]:= 0; - // get new methods for i:= 0 to Methods.Count - 1 do begin Item := Methods[i]; @@ -130,8 +130,8 @@ procedure TCustomAttribute.AssignMethodsToTemplate(var Template: TBoldTemplateHo vasString := Item.TVisibilityToStr(Item.Visibility); if Item.IsOverriden then begin - Template.Variables.Add(Format('%s',[Item.Name]), 'true', []); // do not localize - Template.Variables.Add(Format('%s',[vasString]), 'true', []); // do not localize + Template.Variables.Add(Format('%s',[Item.Name]), 'true', []); + Template.Variables.Add(Format('%s',[vasString]), 'true', []); end else begin @@ -139,18 +139,18 @@ procedure TCustomAttribute.AssignMethodsToTemplate(var Template: TBoldTemplateHo Signature := Item.Params + ': ' + Item.ReturnType + ';' else Signature := Item.Params + ';'; - Template.Variables.Add(format('%sMETHODTYPE.%d',[vAsString,aCount[v]]), Item.methodTypeAsString, []); // do not localize - Template.Variables.Add(format('%sMETHODNAME.%d',[vAsString,aCount[v]]), Item.Name, []); // do not localize - Template.Variables.Add(format('%sMETHODSIGNATURE.%d',[vAsString,aCount[v]]), Signature , []); // do not localize + Template.Variables.Add(format('%sMETHODTYPE.%d',[vAsString,aCount[v]]), Item.methodTypeAsString, []); + Template.Variables.Add(format('%sMETHODNAME.%d',[vAsString,aCount[v]]), Item.Name, []); + Template.Variables.Add(format('%sMETHODSIGNATURE.%d',[vAsString,aCount[v]]), Signature , []); if mdOverride in Methods[i].mDirectives then - Template.Variables.Add(format('%sMETHODDIRECTIVES.%d', [vAsString,aCount[v]]), ' override;', []); // do not localize - Template.Variables.Add(Format('%s',[vasString]), 'true', []); // do not localize + Template.Variables.Add(format('%sMETHODDIRECTIVES.%d', [vAsString,aCount[v]]), ' override;', []); + Template.Variables.Add(Format('%s',[vasString]), 'true', []); Inc(aCount[v]); end; - end;// for + end; for v:= stPrivate to stPublished do begin - Template.Variables.Add(TMethodInfo.TVisibilityToStr(v)+'METHODCOUNT', IntToStr(aCount[v]), []); // do not localize + Template.Variables.Add(TMethodInfo.TVisibilityToStr(v)+'METHODCOUNT', IntToStr(aCount[v]), []); Template.Variables.Add(TMethodInfo.TVisibilityToStr(v), BooleanToStr(aCount[v] <> 0), []); end; end; @@ -233,4 +233,6 @@ procedure TPropertyInfoList.Clear; Remove(TPropertyInfo(fList[Index])); end; +initialization + end. diff --git a/Source/ObjectSpace/IDE/AttributeWizard/BoldWACustomAttrForm1.pas b/Source/ObjectSpace/IDE/AttributeWizard/BoldWACustomAttrForm1.pas index 8a274f6b..6cd65795 100644 --- a/Source/ObjectSpace/IDE/AttributeWizard/BoldWACustomAttrForm1.pas +++ b/Source/ObjectSpace/IDE/AttributeWizard/BoldWACustomAttrForm1.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWACustomAttrForm1; interface @@ -26,14 +29,11 @@ interface const YES = '1'; NO = '0'; - // StringGridMethods columns COL_METHOD_VISIBILITY = 0; COL_METHOD_TYPE = 1; COL_METHOD_NAME = 2; COL_METHOD_PARAMS = 3; COL_METHOD_RETURNTYPE = 4; - - //StringGridProperties columns COL_PROPERTY_NAME = 0; COL_PROPERTY_TYPE = 1; COL_PROPERTY_ACCESSTYPE = 2; @@ -114,7 +114,7 @@ TCustomAttrForm1 = class(TForm, IWizardForm) procedure StringGridMethodsDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); procedure FormDestroy(Sender: TObject); - function getTypeDictionary: TBoldTypeNameDictionary; + function getTypeDictionary: TBoldTypeNameDictionary; procedure edUnitnameChange(Sender: TObject); function DelphiToBDEType(const DelphiType: string): string; function DelphiToAccessorType(const DelphiType: string): string; @@ -159,7 +159,7 @@ TCustomAttrForm1 = class(TForm, IWizardForm) function GetDefaultMapperName(const ClassName: string; const NumOfProperties: integer): string; property SteppedBack: Boolean read GetSteppedBack default false; property UnitGenerator: IUnitGenerator read getUnitGeneratorIntf write setUnitGeneratorIntf; - property EnableNext: TEnableNextEvent write setEnableNext; // CallBack function + property EnableNext: TEnableNextEvent write setEnableNext; end; function BooleanToStr(value: Boolean): string; @@ -182,9 +182,9 @@ implementation function BooleanToStr(value: Boolean): string; begin if value then - Result := 'true' // do not localize + Result := 'true' else - Result := 'false'; // do not localize + Result := 'false'; end; procedure TCustomAttrForm1.EnableNextBtn(const Enable: Boolean); @@ -210,13 +210,12 @@ destructor TCustomAttrForm1.Destroy; begin FreeAndNil(fMgrStringGridProperties); FreeAndNil(fMgrStringGridMethods); - inherited Destroy; + inherited destroy; end; procedure TCustomAttrForm1.Initialize; begin Align := alClient; - // hide all control fields cbPropertyTypes.Visible := false; cbAccessTypes.Visible := false; cbMethodTypes.Visible := false; @@ -227,11 +226,11 @@ procedure TCustomAttrForm1.Initialize; edMethodSignature.Visible := false; { StringGridMethods } - StringGridMethods.Cells[COL_METHOD_TYPE,0] := 'Method type'; // do not localize - StringGridMethods.Cells[COL_METHOD_NAME,0] := 'Name'; // do not localize - StringGridMethods.Cells[COL_METHOD_PARAMS,0] := 'Parameters'; // do not localize - StringGridMethods.Cells[COL_METHOD_RETURNTYPE,0] := 'Return Type'; // do not localize - StringGridMethods.Cells[COL_METHOD_VISIBILITY,0] := 'Visibility'; // do not localize + StringGridMethods.Cells[COL_METHOD_TYPE,0] := 'Method type'; + StringGridMethods.Cells[COL_METHOD_NAME,0] := 'Name'; + StringGridMethods.Cells[COL_METHOD_PARAMS,0] := 'Parameters'; + StringGridMethods.Cells[COL_METHOD_RETURNTYPE,0] := 'Return Type'; + StringGridMethods.Cells[COL_METHOD_VISIBILITY,0] := 'Visibility'; fMgrStringGridMethods.addCtrlForColumn(cbMethodTypes, TComboBox, COL_METHOD_TYPE); fMgrStringGridMethods.addCtrlForColumn(edMethodName, TEdit, COL_METHOD_NAME); fMgrStringGridMethods.addCtrlForColumn(edMethodSignature, TEdit, COL_METHOD_PARAMS); @@ -239,21 +238,18 @@ procedure TCustomAttrForm1.Initialize; fMgrStringGridMethods.addCtrlForColumn(cbVisibility, TComboBox, COL_METHOD_VISIBILITY); { StringGridProperties } - StringGridProperties.Cells[COL_PROPERTY_NAME,0] := 'Name'; // do not localize - StringGridProperties.Cells[COL_PROPERTY_TYPE,0] := 'Type'; // do not localize - StringGridProperties.Cells[COL_PROPERTY_ACCESSTYPE,0] := 'Access type'; // do not localize + StringGridProperties.Cells[COL_PROPERTY_NAME,0] := 'Name'; + StringGridProperties.Cells[COL_PROPERTY_TYPE,0] := 'Type'; + StringGridProperties.Cells[COL_PROPERTY_ACCESSTYPE,0] := 'Access type'; fMgrStringGridProperties.addCtrlForColumn(edPropertyName, TEdit, COL_PROPERTY_NAME); fMgrStringGridProperties.addCtrlForColumn(cbPropertyTypes, TComboBox, COL_PROPERTY_TYPE); fMgrStringGridProperties.addCtrlForColumn(cbAccessTypes, TComboBox, COL_PROPERTY_ACCESSTYPE); fOverrideMethodsParser := TClassParser.Create(TStringStream.Create(MemoMethodsToOverride.Lines.Text)); fOverrideMethodsParser.Start; - - // display base classes GetBaseClasses(cbParent.Items); DisplayOverrideMethods(CheckListBoxOverride.Items); - //set proper view PageControl1.ActivePage := tsClassDef; end; @@ -280,7 +276,6 @@ function TCustomAttrForm1.Next: integer; if PageControl1.ActivePage = tsClassDef then begin Result := wfaNext; - //check the class definition if IsValidClassDef then begin PageControl1.ActivePage := tsProperties; @@ -325,31 +320,28 @@ procedure TCustomAttrForm1.Finish; UnitNamePrefix := NewAttribute.ExpressionName else UnitNamePrefix := NewAttribute.UnitName; - PMapperUnitName := Format('%sPMapper',[UnitNamePrefix]); // do not localize - InterfaceUnitName := Format('%sInterface',[UnitNamePrefix]); // do not localize - InterfaceName := Format('I%s',[NewAttribute.ExpressionName]); // do not localize - MapperName :=Format('%sPMapper',[NewAttribute.DelphiName]); // do not localize + PMapperUnitName := Format('%sPMapper',[UnitNamePrefix]); + InterfaceUnitName := Format('%sInterface',[UnitNamePrefix]); + InterfaceName := Format('I%s',[NewAttribute.ExpressionName]); + MapperName :=Format('%sPMapper',[NewAttribute.DelphiName]); try - // set the attribute template variables with attrdatamodule.AttributeTemplate do begin - Variables.Add('UNITNAME', NewAttribute.UnitName, []); // do not localize - Variables.Add('EXPRESSIONNAME', NewAttribute.ExpressionName, []); // do not localize - Variables.Add('DELPHINAME', NewAttribute.DelphiName, []); // do not localize - Variables.Add('SUPERCLASS', NewAttribute.Parent, []); // do not localize - Variables.Add('INTERFACENAME', InterfaceName, []); // do not localize - Variables.Add('INTERFACEUNITNAME', InterfaceUnitName, []); // do not localize + Variables.Add('UNITNAME', NewAttribute.UnitName, []); + Variables.Add('EXPRESSIONNAME', NewAttribute.ExpressionName, []); + Variables.Add('DELPHINAME', NewAttribute.DelphiName, []); + Variables.Add('SUPERCLASS', NewAttribute.Parent, []); + Variables.Add('INTERFACENAME', InterfaceName, []); + Variables.Add('INTERFACEUNITNAME', InterfaceUnitName, []); if (NewAttribute.Properties.Count > 0) then begin - // new mapper and interface classes - Variables.Add('MAPPERNAME',MapperName,[]); // do not localize - Variables.Add('CONTENTNAME', Format('ContentName_%s', [NewAttribute.ExpressionName]), []); // do not localize + Variables.Add('MAPPERNAME',MapperName,[]); + Variables.Add('CONTENTNAME', Format('ContentName_%s', [NewAttribute.ExpressionName]), []); end else begin - // parent's mapper and interface classes - Variables.Add('MAPPERNAME',Format('',[NewAttribute.Parent]),[]); // do not localize - Variables.Add('CONTENTNAME', Format('', [NewAttribute.Parent]), []); // do not localize + Variables.Add('MAPPERNAME',Format('',[NewAttribute.Parent]),[]); + Variables.Add('CONTENTNAME', Format('', [NewAttribute.Parent]), []); end end; NewAttribute.AssignMethodsToTemplate(attrdatamodule.AttributeTemplate); @@ -358,29 +350,27 @@ procedure TCustomAttrForm1.Finish; begin with attrdatamodule.InterfaceTemplate do begin - Variables.Add('SUPERINTERFACENAME', BaseInterfaceName, []); // do not localize - Variables.Add('INTERFACENAME',InterfaceName, []); // do not localize - Variables.Add('UNITNAME',InterfaceUnitName, []); // do not localize - Variables.Add('INTERFACEGUID',BoldCreateGUIDAsString, []); // do not localize - Variables.Add('FREESTANDINGDELPHINAME','TBFS' + NewAttribute.ExpressionName,[]); // do not localize - Variables.Add('FREESTANDINGSUPERCLASS','TBoldFreeStandingNullableValue',[]); // do not localize - Variables.Add('INTERFACEUNITNAME',Format('%sInterface',[NewAttribute.UnitName]), []); // do not localize - Variables.Add('EXPRESSIONNAME', NewAttribute.ExpressionName, []); // do not localize + Variables.Add('SUPERINTERFACENAME', BaseInterfaceName, []); + Variables.Add('INTERFACENAME',InterfaceName, []); + Variables.Add('UNITNAME',InterfaceUnitName, []); + Variables.Add('INTERFACEGUID',BoldCreateGUIDAsString, []); + Variables.Add('FREESTANDINGDELPHINAME','TBFS' + NewAttribute.ExpressionName,[]); + Variables.Add('FREESTANDINGSUPERCLASS','TBoldFreeStandingNullableValue',[]); + Variables.Add('INTERFACEUNITNAME',Format('%sInterface',[NewAttribute.UnitName]), []); + Variables.Add('EXPRESSIONNAME', NewAttribute.ExpressionName, []); end; AssignProperties(NewAttribute, attrdatamodule.InterfaceTemplate); - //set the PMapper template's variables with attrdatamodule.MapperTemplate do begin - Variables.Add('MAPPERNAME',NewAttribute.DelphiName+ 'PMapper',[]); // do not localize - Variables.Add('SUPERMAPPERNAME',getDefaultMapperName(NewAttribute.parent, NewAttribute.Properties.Count) ,[]); // do not localize - Variables.Add('STREAMCONSTANT', 'StreamName',[]); // do not localize - Variables.Add('INTERFACEUNITNAME',InterfaceUnitName, []); // do not localize - Variables.Add('UNITNAME', PMapperUnitName, []); // do not localize - Variables.Add('INTERFACENAME',InterfaceName, []); // do not localize + Variables.Add('MAPPERNAME',NewAttribute.DelphiName+ 'PMapper',[]); + Variables.Add('SUPERMAPPERNAME',getDefaultMapperName(NewAttribute.parent, NewAttribute.Properties.Count) ,[]); + Variables.Add('STREAMCONSTANT', 'StreamName',[]); + Variables.Add('INTERFACEUNITNAME',InterfaceUnitName, []); + Variables.Add('UNITNAME', PMapperUnitName, []); + Variables.Add('INTERFACENAME',InterfaceName, []); end; AssignProperties(NewAttribute, attrdatamodule.MapperTemplate); end; - // Generate Code if Assigned(UnitGenerator) then UnitGenerator.GenerateUnit(NewAttribute.UnitName, attrdatamodule.AttributeTemplate); if (NewAttribute.Properties.Count > 0) then @@ -454,8 +444,7 @@ procedure TCustomAttrForm1.GetNewAttribute(var NewAttribute: TCustomAttribute); ExpressionName := edExpressionName.Text; UnitName := trim(edUnitname.Text); Properties.Clear; - // Properties - // row 0 is for the column titles + for i:= 1 to StringGridProperties.RowCount - 1 do if not IsEmptyStr(StringGridProperties.Rows[i].Text) then begin @@ -463,27 +452,25 @@ procedure TCustomAttrForm1.GetNewAttribute(var NewAttribute: TCustomAttribute); StrToAccessType(StringGridProperties.Cells[2,i]))); end; Methods.Clear; - //new methods - // row 0 is for the column titles + for i := 1 to StringGridMethods.RowCount - 1 do if not IsEmptyStr(StringGridMethods.Rows[i].Text) then begin NewMethod := TMethodInfo.Create; -// NewMethod.methodType := StrToMethodType(Trim(StringGridMethods.Cells[COL_METHOD_TYPE,i])); -// NewMethod.Name := Trim(StringGridMethods.Cells[COL_METHOD_NAME,i]); -// NewMethod.Params := Trim(StringGridMethods.Cells[COL_METHOD_PARAMS,i]) ; -// if (Newmethod.Params[1] <> '(') then -// NewMethod.Params := Format('(%s',[NewMethod.Params]); -// if (NewMethod.Params[length(NewMethod.Params)] <> ')') then -// NewMethod.Params := Format('%s)',[NewMethod.Params]); -// NewMethod.ReturnType := Trim(StringGridMethods.Cells[COL_METHOD_RETURNTYPE, i]); -// NewMethod.Visibility := StrToVisibility(Trim(StringGridMethods.Cells[COL_METHOD_VISIBILITY, i])); + + + + + + + + NewMethod.Assign(TMethodInfo.StrToMethodType(Trim(StringGridMethods.Cells[COL_METHOD_TYPE,i])), Trim(StringGridMethods.Cells[COL_METHOD_NAME,i]), Trim(StringGridMethods.Cells[COL_METHOD_PARAMS,i]), Trim(StringGridMethods.Cells[COL_METHOD_RETURNTYPE, i]), TMethodInfo.StrToVisibility(Trim(StringGridMethods.Cells[COL_METHOD_VISIBILITY, i])), []); Methods.Add(NewMethod); - end; //if - // get override methods + end; + for i:= 0 to CheckListBoxOverride.Items.Count - 1 do if CheckListBoxOverride.Checked[i] then begin @@ -493,7 +480,7 @@ procedure TCustomAttrForm1.GetNewAttribute(var NewAttribute: TCustomAttribute); temp.Visibility, [mdOverride]); Methods.Add(NewMethod); end; - end; //with + end; end; { FormCreate } @@ -555,39 +542,37 @@ procedure TCustomAttrForm1.AssignProperties(var NewAttribute: TCustomAttribute; i: integer; aProperty: TPropertyInfo; begin - //set the properties for i:= 0 to NewAttribute.Properties.Count - 1 do begin aProperty := NewAttribute.Properties[i]; - Template.Variables.Add(Format('FIELDNAME.%d',[i]), aProperty.Name, []); // do not localize - Template.Variables.Add(Format('FIELDTYPE.%d',[i]), aProperty.pType, []); // do not localize - Template.Variables.Add(Format('FIELDBDETYPE.%d',[i]), DelphiToBDEType(aProperty.pType), []); // do not localize - Template.Variables.Add(Format('FIELDACCESSORTYPE.%d',[i]), DelphiToAccessorType(aProperty.pType), []); // do not localize + Template.Variables.Add(Format('FIELDNAME.%d',[i]), aProperty.Name, []); + Template.Variables.Add(Format('FIELDTYPE.%d',[i]), aProperty.pType, []); + Template.Variables.Add(Format('FIELDBDETYPE.%d',[i]), DelphiToBDEType(aProperty.pType), []); + Template.Variables.Add(Format('FIELDACCESSORTYPE.%d',[i]), DelphiToAccessorType(aProperty.pType), []); if (aProperty.AccessType = atWriteOnly) then - Template.Variables.Add(Format('FIELDREADABLE.%d',[i]), NO, []) // do not localize + Template.Variables.Add(Format('FIELDREADABLE.%d',[i]), NO, []) else - Template.Variables.Add(Format('FIELDREADABLE.%d',[i]), YES, []); // do not localize + Template.Variables.Add(Format('FIELDREADABLE.%d',[i]), YES, []); if (aProperty.AccessType = atReadOnly) then - Template.Variables.Add(Format('FIELDWRITABLE.%d',[i]), NO, []) // do not localize + Template.Variables.Add(Format('FIELDWRITABLE.%d',[i]), NO, []) else - Template.Variables.Add(Format('FIELDWRITABLE.%d',[i]), YES, []); // do not localize - end; //for - Template.Variables.Add('FIELDCOUNT', IntToStr(NewAttribute.Properties.Count), []); // do not localize + Template.Variables.Add(Format('FIELDWRITABLE.%d',[i]), YES, []); + end; + Template.Variables.Add('FIELDCOUNT', IntToStr(NewAttribute.Properties.Count), []); if (NewAttribute.Properties.Count > 0) then begin - Template.Variables.SetVariable('PUBLIC', 'true'); // do not localize - Template.Variables.SetVariable('PRIVATE', 'true'); // do not localize - Template.Variables.SetVariable('PROTECTED', 'true'); // do not localize - Template.Variables.Add('INTERFACEDCLASS',YES, []); // do not localize + Template.Variables.SetVariable('PUBLIC', 'true'); + Template.Variables.SetVariable('PRIVATE', 'true'); + Template.Variables.SetVariable('PROTECTED', 'true'); + Template.Variables.Add('INTERFACEDCLASS',YES, []); end else - Template.Variables.Add('INTERFACEDCLASS', NO, []); // do not localize + Template.Variables.Add('INTERFACEDCLASS', NO, []); end; procedure TCustomAttrForm1.GetBaseClasses(list: TStrings); var i: integer; -// ClassInfo: TClassInfo; begin { // create parser object, free in finalizer, classes hard coded fAttributeClassParser := TClassParser.Create(TStringStream.Create(MemoBoldClasses.Lines.Text)); @@ -596,8 +581,6 @@ procedure TCustomAttrForm1.GetBaseClasses(list: TStrings); while fAttributeClassParser.getClasses(ClassInfo, i) do if Assigned(ClassInfo) then cbParent.Items.Add(ClassInfo.DelphiName);} - - // get base classes from a TypeNameDictionary TypeDictionary.AddDefaultMappings; list.BeginUpdate; list.Clear; @@ -660,6 +643,7 @@ procedure TCustomAttrForm1.ActionStringGridInsertExecute(Sender: TObject); fMgrStringGridMethods.Add else MessageDlg('Invalid method entry', mtInformation, [mbOk], 0); + end; procedure TCustomAttrForm1.ActionStringGridDeleteExecute(Sender: TObject); @@ -670,6 +654,7 @@ procedure TCustomAttrForm1.ActionStringGridDeleteExecute(Sender: TObject); fMgrStringGridMethods.Delete; end; + procedure TCustomAttrForm1.cbParentChange(Sender: TObject); var i: integer; @@ -818,42 +803,42 @@ procedure TCustomAttrForm1.edUnitnameChange(Sender: TObject); function TCustomAttrForm1.DelphiToBDEType(const DelphiType: string): string; begin - if (CompareText(DelphiType,'integer') = 0)then // do not localize - Result := 'ftInteger' // do not localize - else if (CompareText(DelphiType,'real') = 0) then // do not localize - Result := 'ftFloat' // do not localize - else if (CompareText(DelphiType,'extended') = 0) then // do not localize - Result := 'ftFloat' // do not localize - else if (CompareText(DelphiType,'cardinal')= 0) then // do not localize - Result := 'ftInteger' // do not localize - else if (CompareText(DelphiType,'char') = 0) then // do not localize - Result := 'ftFixedChar' // do not localize - else if (CompareText(DelphiType,'string')= 0) then // do not localize - Result := 'ftString' // do not localize - else if (CompareText(DelphiType,'boolean')= 0) then // do not localize - Result := 'ftBoolean' // do not localize + if (CompareText(DelphiType,'integer') = 0)then + Result := 'ftInteger' + else if (CompareText(DelphiType,'real') = 0) then + Result := 'ftFloat' + else if (CompareText(DelphiType,'extended') = 0) then + Result := 'ftFloat' + else if (CompareText(DelphiType,'cardinal')= 0) then + Result := 'ftInteger' + else if (CompareText(DelphiType,'char') = 0) then + Result := 'ftFixedChar' + else if (CompareText(DelphiType,'string')= 0) then + Result := 'ftString' + else if (CompareText(DelphiType,'boolean')= 0) then + Result := 'ftBoolean' else - Result := ''; // do not localize + Result := ''; end; function TCustomAttrForm1.DelphiToAccessorType(const DelphiType: string): string; begin - if (CompareText(DelphiType,'integer') = 0) then // do not localize - Result := 'Integer' // do not localize - else if (CompareText(DelphiType,'real') = 0) then // do not localize - Result := 'Double' // do not localize - else if (CompareText(DelphiType,'extended') = 0) then // do not localize - Result := 'Double' // do not localize - else if (CompareText(DelphiType,'cardinal') = 0) then // do not localize - Result := 'Integer' // do not localize - else if (CompareText(DelphiType, 'char') = 0) then // do not localize - Result := 'Char' // do not localize - else if (CompareText(DelphiType,'string') = 0) then // do not localize - Result := 'String' // do not localize - else if (CompareText(DelphiType,'boolean') = 0) then // do not localize - Result := 'Boolean' // do not localize + if (CompareText(DelphiType,'integer') = 0) then + Result := 'Integer' + else if (CompareText(DelphiType,'real') = 0) then + Result := 'Double' + else if (CompareText(DelphiType,'extended') = 0) then + Result := 'Double' + else if (CompareText(DelphiType,'cardinal') = 0) then + Result := 'Integer' + else if (CompareText(DelphiType, 'char') = 0) then + Result := 'Char' + else if (CompareText(DelphiType,'string') = 0) then + Result := 'String' + else if (CompareText(DelphiType,'boolean') = 0) then + Result := 'Boolean' else - Result := ''; // do not localize + Result := ''; end; procedure TCustomAttrForm1.tsOverrideShow(Sender: TObject); diff --git a/Source/ObjectSpace/IDE/AttributeWizard/BoldWAInputFormUnit.pas b/Source/ObjectSpace/IDE/AttributeWizard/BoldWAInputFormUnit.pas index e128f862..02de31f0 100644 --- a/Source/ObjectSpace/IDE/AttributeWizard/BoldWAInputFormUnit.pas +++ b/Source/ObjectSpace/IDE/AttributeWizard/BoldWAInputFormUnit.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWAInputFormUnit; interface @@ -7,7 +10,7 @@ interface Messages, Classes, Graphics, - Controls, + Controls, Forms, Dialogs, StdCtrls, @@ -111,4 +114,6 @@ procedure TInputForm.FormCloseQuery(Sender: TObject; CanClose := true; end; +initialization + end. diff --git a/Source/ObjectSpace/IDE/AttributeWizard/BoldWAInterfaces.pas b/Source/ObjectSpace/IDE/AttributeWizard/BoldWAInterfaces.pas index 7b41ef7d..8cf92493 100644 --- a/Source/ObjectSpace/IDE/AttributeWizard/BoldWAInterfaces.pas +++ b/Source/ObjectSpace/IDE/AttributeWizard/BoldWAInterfaces.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWAInterfaces; interface @@ -33,7 +36,7 @@ interface procedure setEnableNext(Value: TEnableNextEvent); property SteppedBack: Boolean read GetSteppedBack; property UnitGenerator: IUnitGenerator read getUnitGeneratorIntf write setUnitGeneratorIntf; - property EnableNext: TEnableNextEvent write setEnableNext; //CallBack function + property EnableNext: TEnableNextEvent write setEnableNext; end; IUnitGenerator = interface @@ -42,4 +45,7 @@ interface implementation + +initialization + end. diff --git a/Source/ObjectSpace/IDE/AttributeWizard/BoldWAMainForm.pas b/Source/ObjectSpace/IDE/AttributeWizard/BoldWAMainForm.pas index 82b07eec..e25a5da5 100644 --- a/Source/ObjectSpace/IDE/AttributeWizard/BoldWAMainForm.pas +++ b/Source/ObjectSpace/IDE/AttributeWizard/BoldWAMainForm.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWAMainForm; interface @@ -139,7 +142,6 @@ procedure TMainForm.FormCreate(Sender: TObject); HelpFile := ATTRIBUTEWIZARDHELPFILE; attrdatamodule := Tattrdatamodule.Create(MainForm); Initialize; - //create input form InputForm := TInputForm.Create(MainForm); end; @@ -184,7 +186,7 @@ function TMainForm.GetWizFormIntf(Selection: TUserSelection): IWizardForm; begin Result := nil; end; - end; //case + end; PreviousSelection := Selection; end; @@ -198,6 +200,6 @@ procedure TMainForm.FormDestroy(Sender: TObject); FreeAndNil(InputForm); end; -end. - +initialization +end. diff --git a/Source/ObjectSpace/IDE/AttributeWizard/BoldWAMethodInfo.pas b/Source/ObjectSpace/IDE/AttributeWizard/BoldWAMethodInfo.pas index 11cc4aa9..66007d6b 100644 --- a/Source/ObjectSpace/IDE/AttributeWizard/BoldWAMethodInfo.pas +++ b/Source/ObjectSpace/IDE/AttributeWizard/BoldWAMethodInfo.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWAMethodInfo; interface @@ -132,10 +135,10 @@ procedure TMethodInfo.Assign(amethodType: TMethodType; amethodName, aParams, aRe function TMethodInfo.MethodTypeAsString: string; begin case methodType of - mtProcedure: Result := 'procedure'; // do not localize - mtFunction: Result := 'function'; // do not localize - mtConstructor: Result := 'constructor'; // do not localize - mtDestructor: Result := 'destructor'; // do not localize + mtProcedure: Result := 'procedure'; + mtFunction: Result := 'function'; + mtConstructor: Result := 'constructor'; + mtDestructor: Result := 'destructor'; else Result := ''; end; end; @@ -144,17 +147,17 @@ function TMethodInfo.mDirectivesAsString: string; begin Result := ''; if mdVirtual in mDirectives then - Result := Result + 'virtual; '; // do not localize + Result := Result + 'virtual; '; if mdAbstract in mDirectives then - Result := Result + 'abstract; '; // do not localize + Result := Result + 'abstract; '; if mdDynamic in mDirectives then - Result := Result + 'dynamic; '; // do not localize + Result := Result + 'dynamic; '; if mdOverride in mDirectives then - Result := Result + 'override; '; // do not localize + Result := Result + 'override; '; if mdOverload in mDirectives then - Result := Result + 'overload; '; // do not localize + Result := Result + 'overload; '; if mdReintroduce in mDirectives then - Result := Result + 'reintroduce; '; // do not localize + Result := Result + 'reintroduce; '; end; function TMethodInfo.IsOverriden: Boolean; @@ -164,13 +167,13 @@ function TMethodInfo.IsOverriden: Boolean; class function TMethodInfo.StrToMethodType(str: string): TMethodType; begin - if (UpperCase(str) = UpperCase('procedure'))then // do not localize + if (UpperCase(str) = UpperCase('procedure'))then Result := mtProcedure - else if (UpperCase(str) = UpperCase('function')) then // do not localize + else if (UpperCase(str) = UpperCase('function')) then Result := mtFunction - else if (UpperCase(str) = UpperCase('constructor')) then // do not localize + else if (UpperCase(str) = UpperCase('constructor')) then Result := mtConstructor - else if (UpperCase(str) = UpperCase('destructor')) then // do not localize + else if (UpperCase(str) = UpperCase('destructor')) then Result := mtDestructor else Result := mtNone; @@ -179,23 +182,23 @@ class function TMethodInfo.StrToMethodType(str: string): TMethodType; class function TMethodInfo.TVisibilityToStr(v: TVisibility): string; begin case v of - stPublic: Result := 'public'; // do not localize - stPrivate: Result := 'private'; // do not localize - stPublished: Result := 'published'; // do not localize - stProtected: Result := 'protected'; // do not localize + stPublic: Result := 'public'; + stPrivate: Result := 'private'; + stPublished: Result := 'published'; + stProtected: Result := 'protected'; else raise Exception.Create('Error: Visiblity of method not specified'); end; end; class function TMethodInfo.StrToVisibility(v: string): TVisibility; begin - if (Trim(v) = 'private') then // do not localize + if (Trim(v) = 'private') then Result := stprivate - else if (Trim(v) = 'protected') then // do not localize + else if (Trim(v) = 'protected') then Result := stprotected - else if (Trim(v) = 'public') then // do not localize + else if (Trim(v) = 'public') then Result := stpublic - else if (Trim(v) = 'published') then // do not localize + else if (Trim(v) = 'published') then Result := stpublished else raise Exception.Create('TVisibility: Error converting string'); end; @@ -287,5 +290,5 @@ procedure TMethodInfoList.Clear; initialization finalization - FreeAndNil(G_VirtualMethods); + FreeAndNil(G_VirtualMethods); end. diff --git a/Source/ObjectSpace/IDE/AttributeWizard/BoldWAStringGridManager.pas b/Source/ObjectSpace/IDE/AttributeWizard/BoldWAStringGridManager.pas index 741cc070..577eb1f7 100644 --- a/Source/ObjectSpace/IDE/AttributeWizard/BoldWAStringGridManager.pas +++ b/Source/ObjectSpace/IDE/AttributeWizard/BoldWAStringGridManager.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWAStringGridManager; interface @@ -55,7 +58,7 @@ destructor TGridColumnControl.Destroy; Control := nil; ControlClass := nil; AssociatedColumn := 0; - inherited Destroy; + inherited destroy; end; constructor TStringGridManager.Create(aStringGrid: TStringGrid); @@ -156,12 +159,11 @@ procedure TStringGridManager.EditCell(var StringGrid: TStringGrid; ACol, ARow: I if (Ctrl is TComboBox) then with (Ctrl as TComboBox) do begin - // disable the combo box's ChangeEvent ChangeEvent := OnChange; OnChange := nil; - if (IsEmptyStr(fStringGrid.Cells[ACol, ARow]) and (CompareText(Ctrl.Name, 'cbAccessTypes') = 0)) // do not localize + if (IsEmptyStr(fStringGrid.Cells[ACol, ARow]) and (CompareText(Ctrl.Name, 'cbAccessTypes') = 0)) then - ItemIndex := 0 // set a default value + ItemIndex := 0 else ItemIndex := Items.IndexOf(fStringGrid.Cells[ACol, ARow]); SetFocus; @@ -201,10 +203,10 @@ procedure TStringGridManager.ControlOnExit(Sender: TObject); procedure TStringGridManager.GetCtrlSelection(Ctrl: TWinControl; Hide: Boolean); begin - if (Ctrl is TComboBox) then //if control is a TComboBox + if (Ctrl is TComboBox) then with (Ctrl as TComboBox) do begin - if ((ItemIndex = -1) and not IsEmptyStr(Text)) then //Get the edited text and display in the grid + if ((ItemIndex = -1) and not IsEmptyStr(Text)) then fStringGrid.Cells[fStringGrid.Selection.right, fStringGrid.Selection.top] := Text else fStringGrid.Cells[fStringGrid.Selection.right, fStringGrid.Selection.top] := Items[ItemIndex]; @@ -226,7 +228,6 @@ procedure TStringGridManager.Add; Break; end; AppendRow(fStringGrid); - // select the first column of the inserted row SelectCell(fStringGrid, 0, fStringGrid.RowCount - 1); Edit; end; @@ -285,4 +286,6 @@ procedure TStringGridManager.Edit; end; end; +initialization + end. diff --git a/Source/ObjectSpace/IDE/AttributeWizard/BoldWASubClassForm1.pas b/Source/ObjectSpace/IDE/AttributeWizard/BoldWASubClassForm1.pas index 7da4ab55..7351edad 100644 --- a/Source/ObjectSpace/IDE/AttributeWizard/BoldWASubClassForm1.pas +++ b/Source/ObjectSpace/IDE/AttributeWizard/BoldWASubClassForm1.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWASubClassForm1; interface @@ -61,7 +64,7 @@ TSubClassForm1 = class(TForm, IWizardForm) procedure EnableNextBtn(const Enable: Boolean); public { Public declarations } - constructor Create(AOwner: TComponent); override; + constructor create(AOwner: TComponent); override; procedure AssignParent(aParent: TWinControl); procedure ClearParent; procedure Initialize; @@ -75,7 +78,7 @@ TSubClassForm1 = class(TForm, IWizardForm) property MethodCount: Integer read getMethodCount; property UnitGenerator: IUnitGenerator read getUnitGeneratorIntf write setUnitGeneratorIntf; property SteppedBack: Boolean read GetSteppedBack default false; - property EnableNext: TEnableNextEvent write setEnableNext; //CallBack function + property EnableNext: TEnableNextEvent write setEnableNext; end; var @@ -109,11 +112,9 @@ procedure TSubClassForm1.Initialize; Align := alClient; fBoldClassParser := TClassParser.Create(TStringStream.Create(MemoBoldClasses.Lines.Text)); fBoldClassParser.Start; - // display class names in combo box i:= 0; while fBoldClassParser.getClasses(Item, i) do if Assigned(Item) then cbParent.Items.Add(Item.DelphiName); - //set proper view PageControl1.ActivePage := tsClassDef; end; @@ -169,7 +170,6 @@ procedure TSubClassForm1.cbParentChange(Sender: TObject); Item: TMethodInfo; ListItem: TListItem; begin - // display class methods in CheckListBox EnableNextBtn(IsValidClassDef); ClassName := cbParent.Text; if IsEmptyStr(Trim(ClassName)) then Exit; @@ -214,7 +214,6 @@ function TSubClassForm1.Next: integer; if PageControl1.ActivePage = tsClassDef then begin Result := wfaNext; - //check the class definition if IsValidClassDef then begin PageControl1.ActivePage := tsOverride; @@ -236,17 +235,15 @@ procedure TSubClassForm1.Finish; NewAttribute := TCustomAttribute.Create; try getNewAttribute(NewAttribute); - // set template variables with attrdatamodule.SubClassedAttrTemplate do begin - Variables.Add('UNITNAME', NewAttribute.UnitName, []); // do not localize - Variables.Add('EXPRESSIONNAME', NewAttribute.ExpressionName, []); // do not localize - Variables.Add('DELPHINAME', NewAttribute.DelphiName, []); // do not localize - Variables.Add('SUPERCLASS', NewAttribute.Parent, []); // do not localize - Variables.Add('METHODCOUNT', InttoStr(NewAttribute.Methods.Count), []); // do not localize + Variables.Add('UNITNAME', NewAttribute.UnitName, []); + Variables.Add('EXPRESSIONNAME', NewAttribute.ExpressionName, []); + Variables.Add('DELPHINAME', NewAttribute.DelphiName, []); + Variables.Add('SUPERCLASS', NewAttribute.Parent, []); + Variables.Add('METHODCOUNT', InttoStr(NewAttribute.Methods.Count), []); end; NewAttribute.AssignMethodsToTemplate(attrdatamodule.SubClassedAttrTemplate); - // generate code UnitGenerator.GenerateUnit(NewAttribute.UnitName, attrdatamodule.SubClassedAttrTemplate); finally FreeAndNil(NewAttribute); @@ -288,13 +285,11 @@ procedure TSubClassForm1.GetNewAttribute(var NewAttribute: TCustomAttribute); begin with NewAttribute do begin - //get class definition ExpressionName := Trim(edExpressionName.Text); UnitName := trim(edUnitname.Text); DelphiName := Trim(edDelphiName.Text); Parent := Trim(cbParent.Text); Methods.Clear; - // get override methods CurrentClass := fBoldClassParser.getClassbyName(Parent); for i:= 0 to ListViewOverride.Items.Count - 1 do if ListViewOverride.Items[i].Checked then @@ -307,8 +302,8 @@ procedure TSubClassForm1.GetNewAttribute(var NewAttribute: TCustomAttribute); NewMethod.Visibility := CurrentClass.Methods[i].Visibility ; NewMethod.mDirectives := [mdOverride]; Methods.Add(NewMethod); - end; //if checked - end; //with + end; + end; end; procedure TSubClassForm1.edDelphiNameChange(Sender: TObject); @@ -328,4 +323,6 @@ procedure TSubClassForm1.edUnitnameChange(Sender: TObject); fUnitName_Locked := (Trim(edExpressionName.text) = Trim(edUnitName.Text)); end; +initialization + end. diff --git a/Source/ObjectSpace/IDE/AttributeWizard/BoldWAValueSetDlg.pas b/Source/ObjectSpace/IDE/AttributeWizard/BoldWAValueSetDlg.pas index a990d3aa..7f2fad6c 100644 --- a/Source/ObjectSpace/IDE/AttributeWizard/BoldWAValueSetDlg.pas +++ b/Source/ObjectSpace/IDE/AttributeWizard/BoldWAValueSetDlg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWAValueSetDlg; interface @@ -54,7 +57,6 @@ implementation function TValueSetDlg.IsValidInput: Boolean; begin - //validate input Result := not((IsEmptyStr(Trim(edValueName.Text)) or IsEmptyStr(Trim(Memo1.Lines.Text)))) end; @@ -122,7 +124,6 @@ function TValueSetDlg.Edit(const Old_Name, Old_Reps: string;var New_Name, New_Re ShowModal; Result := (fOk); New_Name := Trim(edValueName.Text); - // get rid of empty lines tempList := TStringList.Create(); for i:= 0 to Memo1.Lines.Count - 1 do if (length(Memo1.Lines[i]) <> 0) then @@ -147,4 +148,6 @@ procedure TValueSetDlg.FormCreate(Sender: TObject); fOk := false; end; +initialization + end. diff --git a/Source/ObjectSpace/IDE/AttributeWizard/BoldWAValueSetForm1.pas b/Source/ObjectSpace/IDE/AttributeWizard/BoldWAValueSetForm1.pas index d3b4e159..23a8afb7 100644 --- a/Source/ObjectSpace/IDE/AttributeWizard/BoldWAValueSetForm1.pas +++ b/Source/ObjectSpace/IDE/AttributeWizard/BoldWAValueSetForm1.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWAValueSetForm1; interface @@ -74,7 +77,7 @@ TValueSetForm1 = class(TForm, IWizardForm) procedure edDelphiNameChange(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure edUnitNameChange(Sender: TObject); - procedure tsValuesShow(Sender: TObject); // init template and generate unit + procedure tsValuesShow(Sender: TObject); private { Private declarations } fStage: TStageType; @@ -89,7 +92,7 @@ TValueSetForm1 = class(TForm, IWizardForm) public { Public declarations } constructor Create(AOwner: TComponent); override; - procedure AssignParent(aParent: TWinControl); + procedure AssignParent(aParent: TWinControl); procedure ClearParent; procedure Initialize; function Next: integer; @@ -101,7 +104,7 @@ TValueSetForm1 = class(TForm, IWizardForm) property Stage: TStageType read fStage; property SteppedBack: Boolean read GetSteppedBack default false ; property UnitGenerator: IUnitGenerator read getUnitGeneratorIntf write setUnitGeneratorIntf; - property EnableNext: TEnableNextEvent write setEnableNext; //CallBack function + property EnableNext: TEnableNextEvent write setEnableNext; end; var @@ -121,9 +124,9 @@ implementation function BooleanToStr(value: Boolean): string; begin if value then - Result := 'true' // do not localize + Result := 'true' else - Result := 'false'; // do not localize + Result := 'false'; end; constructor TValueSetForm1.Create(AOwner: TComponent); @@ -188,7 +191,6 @@ procedure TValueSetForm1.DeleteValue; item: TListItem; index: integer; begin - //delete selected item if Assigned(ListViewValues.Selected) and (ListViewValues.Items.Count <> 0) then begin item := ListViewValues.Selected; @@ -261,7 +263,6 @@ function TValueSetForm1.Next: integer; if PageControl1.ActivePage = tsClassDef then begin Result := wfaNext; - // check input if IsValidClassDef then begin PageControl1.ActivePage := tsValues; @@ -287,40 +288,35 @@ procedure TValueSetForm1.Finish; i, j, NumberOfValues: Integer; Values: TStringList; begin - // get class definition ExpressionName := Trim(edExpressionName.Text); UnitName := Trim(edUnitName.Text) ; DelphiName := Trim(edDelphiName.Text); ValuePrefix := Trim(edValuePrefix.Text); NumberOfValues := ListViewValues.Items.Count; - // set template variables with attrdatamodule.ValueSetTemplate do begin - Variables.Add('UNITNAME', UnitName, []); // do not localize - Variables.Add('EXPRESSIONNAME', ExpressionName, []); // do not localize - Variables.Add('DELPHINAME', DelphiName, []); // do not localize -// Variables.Add('VALUEPREFIX', ValuePrefix, []); // do not localize - Variables.Add('VALUECOUNT', InttoStr(NumberOfValues), []); // do not localize - // get the values + Variables.Add('UNITNAME', UnitName, []); + Variables.Add('EXPRESSIONNAME', ExpressionName, []); + Variables.Add('DELPHINAME', DelphiName, []); + Variables.Add('VALUECOUNT', InttoStr(NumberOfValues), []); Values := TStringList.Create; try - Variables.Add('VALUES', BooleanToStr(ListViewValues.Items.Count > 0), []); // do not localize + Variables.Add('VALUES', BooleanToStr(ListViewValues.Items.Count > 0), []); for i:= 0 to ListViewValues.Items.Count - 1 do begin Values.CommaText := ListViewValues.Items[i].SubItems[0]; - Variables.Add(format('VALUENAME.%d',[i]), ListViewValues.Items[i].Caption, []); // do not localize - Variables.Add(format('VALUEREPRESENTATIONCOUNT.%d',[i]), IntToStr(Values.Count), []); // do not localize + Variables.Add(format('VALUENAME.%d',[i]), ListViewValues.Items[i].Caption, []); + Variables.Add(format('VALUEREPRESENTATIONCOUNT.%d',[i]), IntToStr(Values.Count), []); for j:= 0 to Values.Count - 1 do begin Rep := PChar(Values[j]); - Variables.Add(format('VALUEREPRESENTATION.%d.%d',[i,j]), AnsiExtractQuotedStr(Rep, ''''), []); // do not localize + Variables.Add(format('VALUEREPRESENTATION.%d.%d',[i,j]), AnsiExtractQuotedStr(Rep, ''''), []); end; end; finally FreeAndNil(Values); end; end; - // generate code UnitGenerator.GenerateUnit(UnitName, attrdatamodule.ValueSetTemplate); end; @@ -361,7 +357,6 @@ procedure TValueSetForm1.Initialize; begin Align := alClient; self.TabOrder := 0; - //set the proper view PageControl1.ActivePage := tsClassDef; end; @@ -385,7 +380,7 @@ procedure TValueSetForm1.ActionInsertExecute(Sender: TObject); begin fEditMode := emInsert; InsertValue; - EnableNextBtn(ListViewValues.Items.Count > 0); + EnableNextBtn(ListViewValues.Items.Count > 0); end; procedure TValueSetForm1.ActionDeleteExecute(Sender: TObject); @@ -447,7 +442,9 @@ procedure TValueSetForm1.edUnitNameChange(Sender: TObject); procedure TValueSetForm1.tsValuesShow(Sender: TObject); begin bbInsert.SetFocus; - tsValues.Parent.HelpContext := tsValues.HelpContext; + tsValues.Parent.HelpContext := tsValues.HelpContext; end; +initialization + end. diff --git a/Source/ObjectSpace/IDE/AttributeWizard/BoldWAdatamodule.pas b/Source/ObjectSpace/IDE/AttributeWizard/BoldWAdatamodule.pas index af91ccc7..91baffd1 100644 --- a/Source/ObjectSpace/IDE/AttributeWizard/BoldWAdatamodule.pas +++ b/Source/ObjectSpace/IDE/AttributeWizard/BoldWAdatamodule.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWAdatamodule; interface @@ -28,6 +31,12 @@ TdmAttributeWizard = class(TDataModule) implementation +uses + SysUtils, + BoldUtils; + {$R *.dfm} +initialization + end. diff --git a/Source/ObjectSpace/IDE/AttributeWizard/BoldWAdmTemplates.pas b/Source/ObjectSpace/IDE/AttributeWizard/BoldWAdmTemplates.pas index e850aa2b..4c11878a 100644 --- a/Source/ObjectSpace/IDE/AttributeWizard/BoldWAdmTemplates.pas +++ b/Source/ObjectSpace/IDE/AttributeWizard/BoldWAdmTemplates.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWAdmTemplates; interface @@ -25,8 +28,6 @@ Tattrdatamodule = class(TDataModule) implementation -uses - BoldRev; {$R *.dfm} diff --git a/Source/ObjectSpace/IDE/AttributeWizard/BoldWCodeInformer.pas b/Source/ObjectSpace/IDE/AttributeWizard/BoldWCodeInformer.pas index fe7fd4a0..6346c2ad 100644 --- a/Source/ObjectSpace/IDE/AttributeWizard/BoldWCodeInformer.pas +++ b/Source/ObjectSpace/IDE/AttributeWizard/BoldWCodeInformer.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWCodeInformer; interface @@ -110,13 +113,13 @@ function TClassParser.getMethodbyTreeIndex(MethodIndex: integer): TMethodInfo; function TClassParser.IsProcedure(Scanner: TScanner): Boolean; begin Result := True; - if Scanner.IsIdentifier('procedure') then // do not localize + if Scanner.IsIdentifier('procedure') then fMethodType := mtProcedure - else if Scanner.IsIdentifier('function') then // do not localize + else if Scanner.IsIdentifier('function') then fMethodType := mtFunction - else if Scanner.IsIdentifier('constructor') then // do not localize + else if Scanner.IsIdentifier('constructor') then fMethodType := mtConstructor - else if Scanner.IsIdentifier('destructor') then // do not localize + else if Scanner.IsIdentifier('destructor') then fMethodType := mtDestructor else Result := false; @@ -137,7 +140,6 @@ procedure TClassParser.ScannerToken(Sender: TObject); procedure AddMethod; begin - //Add Method with Sender as TScanner do begin if Trim(fParam) = COLUMN then fParam := ''; @@ -151,20 +153,20 @@ procedure TClassParser.ScannerToken(Sender: TObject); fCurrentClass.addMethod(TMethodInfo.Create(fMethodType,fProcName, fParam, fReturnType, fVisibility, Pointer(fCurrentClass))) ; fCodeType := ctNone; end - end; + end; end; begin with Sender as TScanner do begin str := token; - if IsIdentifier('implementation') then // do not localize + if IsIdentifier('implementation') then begin fInImplementation := true; fInInterface := false; fCodeType := ctNone; end - else if IsIdentifier('interface') then // do not localize + else if IsIdentifier('interface') then begin fInImplementation := false; fInInterface := true; @@ -172,15 +174,15 @@ procedure TClassParser.ScannerToken(Sender: TObject); end else if fInInterface then begin - if IsIdentifier('public') then // do not localize + if IsIdentifier('public') then fVisibility := stPublic - else if IsIdentifier('protected') then // do not localize + else if IsIdentifier('protected') then fVisibility := stProtected - else if IsIdentifier('published') then // do not localize + else if IsIdentifier('published') then fVisibility := stPublished - else if IsIdentifier('private') then // do not localize + else if IsIdentifier('private') then fVisibility := stPrivate - else if IsIdentifier('end') then // do not localize + else if IsIdentifier('end') then fCodeType := ctIdentifier else if {NewLine and }IsProcedure(TScanner(Sender)) then begin @@ -223,15 +225,14 @@ procedure TClassParser.ScannerToken(Sender: TObject); end else if (fCodeType = ctReturnType) then AddMethod - else if (fCodeType = ctClass) and IsIdentifier('of') then // do not localize + else if (fCodeType = ctClass) and IsIdentifier('of') then fCodeType := ctNone else if (fCodeType = ctIdentifier) and (TokenType = '=') then fCodeType := ctEqual - else if (fCodeType = ctEqual) and IsIdentifier('class') then // do not localize + else if (fCodeType = ctEqual) and IsIdentifier('class') then fCodeType := ctClass else if (fCodeType = ctClass) and (TokenType <> ';') then begin - //Add Class fClasses.Add(TClassInfo.Create(fClassToken)); fCodeType := ctNone; end @@ -260,4 +261,6 @@ procedure TClassParser.Start; end; end; +initialization + end. diff --git a/Source/ObjectSpace/IDE/AttributeWizard/BoldWProjectWizard.pas b/Source/ObjectSpace/IDE/AttributeWizard/BoldWProjectWizard.pas index 56363a22..64d97763 100644 --- a/Source/ObjectSpace/IDE/AttributeWizard/BoldWProjectWizard.pas +++ b/Source/ObjectSpace/IDE/AttributeWizard/BoldWProjectWizard.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWProjectWizard; interface @@ -71,7 +74,6 @@ function TProjectWizard.GetCurrentProject(var Project: IOTAProject): Boolean; Result := false; Project := nil; ModuleServices := (BorlandIDEServices as IOTAModuleServices); - // get the current module CurrentModule:= ModuleServices.CurrentModule; if Assigned(CurrentModule) then begin @@ -80,17 +82,16 @@ function TProjectWizard.GetCurrentProject(var Project: IOTAProject): Boolean; Project := CurrentModule as IOTAProject; Result := true; end; - // go one level up to owners if not Result then - if (CurrentModule.OwnerCount > 0) then + if (CurrentModule.GetOwnerCount > 0) then for i:= 0 to CurrentModule.OwnerCount - 1 do - if (CurrentModule.Owners[i].QueryInterface(IOTAProject, Project) = S_OK) then + if (CurrentModule.GetOwner(i).QueryInterface(IOTAProject, Project) = S_OK) then begin - Project := CurrentModule.Owners[i] as IOTAProject; + Project := CurrentModule.GetOwner(i) as IOTAProject; Result := true; Break; - end; //if - // find a project amongst the open modules + end; + if not Result then if (ModuleServices.ModuleCount > 0) then for i:=0 to ModuleServices.GetModuleCount - 1 do @@ -100,20 +101,17 @@ function TProjectWizard.GetCurrentProject(var Project: IOTAProject): Boolean; Result := true; Break; end; - end; //if + end; end; procedure TProjectWizard.CreateModule; begin end; -//procedure TProjectWizard.GetcomponentProps(Props: TListBox); -//begin -//end; -//function TProjectWizard.GetAttributes: TStringList; -//begin -//end; + + + {TOTAProject} @@ -130,14 +128,12 @@ function TOTAProject.GetModuleCount: Integer; procedure TOTAProject.AddFile(const AFileName: string; IsUnitOrForm: Boolean); begin - //!!Delphi4 -// IProject.AddFile(AFileName, IsUnitOrForm); + end; procedure TOTAProject.RemoveFile(const AFileName: string); begin - //!!Delphi4 -// IProject.RemoveFile(AFileName); + end; function TOTAProject.GetModule(Index: Integer): IOTAModuleInfo; @@ -147,8 +143,7 @@ function TOTAProject.GetModule(Index: Integer): IOTAModuleInfo; function TOTAProject.CloseModule(ForceClosed: Boolean): Boolean; begin - //!!Delphi4 -// Result := IProject.CloseModule(ForceClosed); + Result := false; end; @@ -183,8 +178,8 @@ function TOTAProject.IsForm(Index: Integer): Boolean; begin ModuleInfo := IProject.GetModule(Index); Result := false; -/// Result := (ModuleInfo.GetModuleType = 0); end; -end. +initialization +end. diff --git a/Source/ObjectSpace/IDE/AttributeWizard/BoldWScanner.pas b/Source/ObjectSpace/IDE/AttributeWizard/BoldWScanner.pas index 885e3a57..d34efbb8 100644 --- a/Source/ObjectSpace/IDE/AttributeWizard/BoldWScanner.pas +++ b/Source/ObjectSpace/IDE/AttributeWizard/BoldWScanner.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWScanner; interface @@ -125,7 +128,7 @@ procedure TScanner.SkipComment(CommentType: Char); ; '/': begin - while GetChar(Ch) and not (Ch in [BOLDLF, BOLDCR]) do + while GetChar(Ch) and not CharInSet(Ch, [BOLDLF, BOLDCR]) do ; Dec(fBufptr); end; @@ -207,7 +210,7 @@ procedure TScanner.GetString(Delim: Char); while GetChar(Ch) do begin fToken := fToken + Ch; - if Ch in [BOLDLF, BOLDCR] then + if CharInSet(Ch, [BOLDLF, BOLDCR]) then begin Dec(fBufPtr); Exit; @@ -236,7 +239,7 @@ procedure TScanner.GetIdentifier(FirstChar: Char); fTokenType := ttIdentifier; while GetChar(Ch) do begin - if not (Ch in ['a'..'z', 'A'..'Z', '0'..'9', '_', '.']) then + if not CharInSet(Ch, ['a'..'z', 'A'..'Z', '0'..'9', '_', '.']) then begin { put it back} Dec(fBufPtr); @@ -290,24 +293,24 @@ procedure TScanner.GetNumber(FirstChar: Char); begin fToken := FirstChar; fTokenType := ttInteger; - while GetChar(Ch) and (Ch in ['0'..'9']) do + while GetChar(Ch) and CharInSet(Ch, ['0'..'9']) do fToken := fToken + Ch; if Ch = '.' then begin fTokenType := ttFloat; fToken := fToken + Ch; - while GetChar(Ch) and (Ch in ['0'..'9']) do + while GetChar(Ch) and CharInSet(Ch, ['0'..'9']) do fToken := fToken + Ch; end; - if Ch in ['e', 'E'] then + if CharInSet(Ch, ['e', 'E']) then begin fTokenType := ttFloat; fToken := fToken + Ch; - if GetChar(Ch) and (Ch in ['+', '-']) then + if GetChar(Ch) and CharInSet(Ch, ['+', '-']) then fToken := fToken + Ch; - while Ch in ['0'..'9'] do + while CharInSet(Ch, ['0'..'9']) do begin fToken := fToken + Ch; if not GetChar(Ch) then @@ -387,4 +390,6 @@ procedure TScanner.Scan(Stream: TStream); end; end; +initialization + end. diff --git a/Source/ObjectSpace/IDE/BoldComponentValidatorIDE.pas b/Source/ObjectSpace/IDE/BoldComponentValidatorIDE.pas index 85890073..b8550dfe 100644 --- a/Source/ObjectSpace/IDE/BoldComponentValidatorIDE.pas +++ b/Source/ObjectSpace/IDE/BoldComponentValidatorIDE.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComponentValidatorIDE; interface @@ -18,8 +21,8 @@ TBoldComponentValidatorIDE = class(TBoldComponentValidator) fMenuItemCurrent: TMenuItem; procedure ChangeFocus; public - constructor Create; - destructor Destroy; override; + constructor create; + destructor destroy; override; procedure ValidateIOTAModule(Module: IOTAModule); procedure ValidateFormEditor(FormEditor: IOTAFormEditor); procedure ValidateIOTAModules; @@ -39,8 +42,7 @@ implementation BoldLogHandler, BoldGuard, BoldIDEMenus, - BoldEnvironment, - BoldCoreConsts; + BoldEnvironment; var G_BoldComponentValidatorIDE: TBoldComponentValidatorIDE = nil; @@ -50,15 +52,16 @@ procedure Register; G_BoldComponentValidatorIDE := TBoldComponentValidatorIDE.Create; end; + { TBoldComponentValidatorIDE } constructor TBoldComponentValidatorIDE.create; begin - fMenuItemAll := BoldMenuExpert.AddMenuItem('mnuValidateAllForms', // do not localize - sValidateAllForms, + fMenuItemAll := BoldMenuExpert.AddMenuItem('mnuValidateAllForms', + 'Validate All Forms', ValidateAllMenuAction, True); - fMenuItemCurrent := BoldMenuExpert.AddMenuItem('mnuValidateCurrentForm', // do not localize - sValidateCurrentForm, + fMenuItemCurrent := BoldMenuExpert.AddMenuItem('mnuValidateCurrentForm', + 'Validate Current Form', ValidateCurrentMenuAction, True); end; @@ -92,7 +95,7 @@ procedure TBoldComponentValidatorIDE.ValidateIOTAModule(Module: IOTAModule); Editor := Module.GetModuleFileEditor(i); if Editor.QueryInterface(IOTAFormEditor, FormEditor) = S_OK then begin - BoldLog.LogFmtIndent(sValidatingForm, [FormEditor.FileName]); + BoldLog.LogFmtIndent('Validating form %s', [FormEditor.FileName]); ValidateFormEditor(FormEditor); HasEditor := True; BoldLog.Dedent; @@ -100,10 +103,10 @@ procedure TBoldComponentValidatorIDE.ValidateIOTAModule(Module: IOTAModule); end; except on e: Exception do - BoldLog.LogFmt(sFailedToValidate, [Module.FileName, e.Message]); + BoldLog.LogFmt('Failed to validate %s. %s', [Module.FileName, e.Message]); end; if not HasEditor then - BoldLog.LogFmt(sNothingToValidate, [Module.FileName]); + BoldLog.LogFmt('Nothing to validate in %s', [Module.FileName]); end; procedure TBoldComponentValidatorIDE.ValidateIOTAModules; @@ -117,11 +120,10 @@ procedure TBoldComponentValidatorIDE.ValidateIOTAModules; FileNames: TStringList; Guard: IBoldGuard; begin - // Filenames of open modules are stored and not revalidated later. Guard := TBoldGuard.Create(FileNames); FileNames := TStringList.Create; ModuleServices := (BorlandIDEServices as IOTAModuleServices); - BoldLog.LogIndent(sValidatingAllOpenModules); + BoldLog.LogIndent('Validating all open modules'); BoldLog.ProgressMax := ModuleServices.GetModuleCount; ChangeFocus; for i := 0 to ModuleServices.GetModuleCount - 1 do @@ -133,13 +135,13 @@ procedure TBoldComponentValidatorIDE.ValidateIOTAModules; BoldLog.Dedent; ChangeFocus; - BoldLog.LogIndent(sLookingForDefaultProject); + BoldLog.LogIndent('Starting looking project group with default project'); for i := 0 to ModuleServices.GetModuleCount - 1 do begin if ModuleServices.GetModule(i).QueryInterface(IOTAProjectGroup, ProjectGroup) = S_OK then begin Project := ProjectGroup.ActiveProject; - BoldLog.LogFmt(sDefaultProject, [Project.FileName]); + BoldLog.LogFmt('Default project: %s', [Project.FileName]); Break; end; end; @@ -148,12 +150,12 @@ procedure TBoldComponentValidatorIDE.ValidateIOTAModules; ChangeFocus; if not Assigned(Project) then begin - BoldLog.LogIndent(sLookingForAnyProject); + BoldLog.LogIndent('Starting looking for any project'); for i := 0 to ModuleServices.GetModuleCount - 1 do begin if ModuleServices.GetModule(i).QueryInterface(IOTAProject, Project) = S_OK then begin - BoldLog.LogFmt(sFoundProject, [Project.FileName]); + BoldLog.LogFmt('Found project: %s', [Project.FileName]); Break; end; end; @@ -209,8 +211,6 @@ procedure TBoldComponentValidatorIDE.ValidateIOTAComponent(Component: IOTACompon if assigned(RealComponent) then ValidateComponent(RealComponent, NamePrefix); - //if not ValidateComponent(RealComponent, NamePrefix) then - // fLastFailedComponent := Component; for i := 0 to Component.GetComponentCount - 1 do ValidateIOTAComponent(Component.GetComponent(i), NamePrefix + ComponentName + '.'); @@ -242,7 +242,7 @@ procedure TBoldComponentValidatorIDE.ValidateCurrentMenuAction(Sender: TObject); CompleteLog; end else - raise Exception.Create(sNoValidateableModuleAvailable); + raise Exception.Create('No module available for validation'); end; procedure TBoldComponentValidatorIDE.ChangeFocus; @@ -256,4 +256,3 @@ finalization FreeAndNil(G_BoldComponentValidatorIDE); end. - diff --git a/Source/ObjectSpace/IDE/BoldExternalObjectSpaceEventHandlerReg.RES b/Source/ObjectSpace/IDE/BoldExternalObjectSpaceEventHandlerReg.RES new file mode 100644 index 00000000..3311a7b0 Binary files /dev/null and b/Source/ObjectSpace/IDE/BoldExternalObjectSpaceEventHandlerReg.RES differ diff --git a/Source/ObjectSpace/IDE/BoldExternalObjectSpaceEventHandlerReg.pas b/Source/ObjectSpace/IDE/BoldExternalObjectSpaceEventHandlerReg.pas index 006dcc99..5e3ba6cf 100644 --- a/Source/ObjectSpace/IDE/BoldExternalObjectSpaceEventHandlerReg.pas +++ b/Source/ObjectSpace/IDE/BoldExternalObjectSpaceEventHandlerReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldExternalObjectSpaceEventHandlerReg; interface @@ -6,7 +9,7 @@ procedure Register; implementation -{.$R *.res} +{$R *.res} uses SysUtils, @@ -36,3 +39,4 @@ procedure Register; end; end. + diff --git a/Source/ObjectSpace/IDE/BoldExternalObjectSpaceEventHandlerReg.rc b/Source/ObjectSpace/IDE/BoldExternalObjectSpaceEventHandlerReg.rc index a5f2439b..6134951b 100644 --- a/Source/ObjectSpace/IDE/BoldExternalObjectSpaceEventHandlerReg.rc +++ b/Source/ObjectSpace/IDE/BoldExternalObjectSpaceEventHandlerReg.rc @@ -1 +1 @@ -TBOLDEXTERNALOBJECTSPACEEVENTHANDLER BITMAP LOADONCALL TBoldExternalObjectSpaceEventHandler.bmp +TBOLDEXTERNALOBJECTSPACEEVENTHANDLER BITMAP LOADONCALL ..\..\..\Images\Components\TBoldExternalObjectSpaceEventHandler.bmp diff --git a/Source/ObjectSpace/IDE/BoldWSimpleMenuWizard.pas b/Source/ObjectSpace/IDE/BoldWSimpleMenuWizard.pas index 32c7a10c..7d89f27a 100644 --- a/Source/ObjectSpace/IDE/BoldWSimpleMenuWizard.pas +++ b/Source/ObjectSpace/IDE/BoldWSimpleMenuWizard.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWSimpleMenuWizard; interface @@ -21,20 +24,20 @@ TSimpleMenuWizard = class(TNotifierObject,IOTAWizard, IOTANotifier) fState: TWizardState; fParentMenuName: string; fMenuItemIndex: integer; - function GetIDString: string; // IOTAWizard + function GetIDString: string; function GetName: string; function GetState: TWizardState; procedure InsertMenuItem(Action: TInsertAction; InsertPosition: Integer; targetName: string; var PopupMenu: TPopUpMenu); function IsInIDE: boolean; protected - procedure Initialize; virtual; //add initialization code here, called in constructor + procedure Initialize; virtual; public constructor Create(const vname, vIDString: string; const vState: TWizardState; const InsertPosition: integer; const vParentMenuName: string); procedure AddMenuItem(var PopupMenu: TPopupMenu); procedure Execute; virtual; - procedure AfterSave; virtual; // IOTANotifier + procedure AfterSave; virtual; procedure BeforeSave; virtual; procedure Modified; virtual; procedure Destroyed; virtual; @@ -117,7 +120,6 @@ procedure TSimpleMenuWizard.InsertMenuItem(Action: TInsertAction; InsertPosition ACaption: string; begin if not IsInIDE then Exit; -// for compatibility with Delphi4 targetItem := nil; ACaption := StripHotkey(targetName); for I := 0 to (BorlandIDEServices as INTAServices).getMainMenu.Items.Count - 1 do @@ -126,29 +128,22 @@ procedure TSimpleMenuWizard.InsertMenuItem(Action: TInsertAction; InsertPosition targetItem := (BorlandIDEServices as INTAServices).getMainMenu.Items[I]; System.Break; end; -// targetItem := (BorlandIDEServices as INTAServices).getMainMenu.Items.Find(targetName); if Assigned(targetItem) then begin - //get the parent item if (Action = iaChild) then begin - //create a child of the target item parentItem := targetItem; end else begin - //get the target's parent parentItem := targetItem.Parent; if (Action = iaAfter) then Inc(InsertPosition); end; - //insert for I := PopupMenu.Items.Count - 1 downto 0 do begin - //remove the item from the popup menu Item := PopupMenu.Items[i]; PopupMenu.Items.Delete(i); - // then add it to delphi's menu if Assigned(parentItem) then begin fMenuItem := Item; @@ -171,32 +166,8 @@ function TSimpleMenuWizard.IsInIDE: boolean; procedure TSimpleMenuWizard.Initialize; begin -// end; -end. - - - - - - - - - - - - - - - - - - - - - - - - +initialization +end. diff --git a/Source/ObjectSpace/Interfaces/BoldUndoInterfaces.pas b/Source/ObjectSpace/Interfaces/BoldUndoInterfaces.pas index 8f798aba..04098589 100644 --- a/Source/ObjectSpace/Interfaces/BoldUndoInterfaces.pas +++ b/Source/ObjectSpace/Interfaces/BoldUndoInterfaces.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUndoInterfaces; interface @@ -5,6 +8,13 @@ interface uses BoldValueSpaceInterfaces; +const +// from BoldSubscription + beUndoBlock = 60; + beRedoBlock = 61; + beUndoSetCheckpoint = 62; + beUndoChanged = 63; + type { forward declarations } IBoldUndoBlock = interface; @@ -18,53 +28,59 @@ interface function GetName: string; function GetValueSpace: IBoldValueSpace; function GetContainsChanges: Boolean; + function GetContent: String; + function GetCreated: TDateTime; property Name: string read GetName; property ValueSpace: IBoldValueSpace read GetValueSpace; property ContainsChanges: Boolean read GetContainsChanges; + property Content: String read GetContent; + property Created: TDateTime read GetCreated; end; IBoldUndoList = interface ['{C4FF7FBB-C14A-4B2D-82C5-BED76B80D81B}'] function GetCount: Integer; - function GetItems(Index: integer): IBoldUndoBlock; - function GetItemsByName(Name: string): IBoldUndoBlock; + function GetItem(Index: integer): IBoldUndoBlock; + function GetItemByName(const Name: string): IBoldUndoBlock; function GetTopBlock: IBoldUndoBlock; - function IndexOf(BlockName: string): integer; + function IndexOf(const BlockName: string): integer; function CanMoveBlock(CurIndex, NewIndex: integer): Boolean; - procedure MergeBlocks(DestinationBlockName, SourceBlockName: string); - procedure MoveToTop(BlockName: string); + procedure MergeBlocks(const DestinationBlockName, SourceBlockName: string); + procedure MoveToTop(const BlockName: string); procedure MoveBlock(CurIndex, NewIndex: integer); - procedure RenameBlock(OldName, NewName: string); - function RemoveBlock(BlockName: string): Boolean; + procedure RenameBlock(const OldName, NewName: string); + function RemoveBlock(const BlockName: string): Boolean; property Count: Integer read GetCount; - property Items[Index: integer]: IBoldUndoBlock read GetItems; default; - property ItemsByName[Name: string]: IBoldUndoBlock read GetItemsByName; + property Items[Index: integer]: IBoldUndoBlock read GetItem; default; + property ItemByName[const Name: string]: IBoldUndoBlock read GetItemByName; property TopBlock: IBoldUndoBlock read GetTopBlock; + function GetContainsChanges: Boolean; + property ContainsChanges: Boolean read GetContainsChanges; end; IBoldUndoHandler = interface ['{FCAC02E0-0067-41F1-B755-C6F162EA40E7}'] function GetUndoList: IBoldUndoList; function GetRedoList: IBoldUndoList; - function GetUniqueBlockName(SuggestedName: string): string; - function CanUndoBlock(BlockName: string): Boolean; - function CanRedoBlock(BlockName: string):Boolean; + function GetUniqueBlockName(const SuggestedName: string): string; + function CanUndoBlock(const BlockName: string): Boolean; + function CanRedoBlock(const BlockName: string):Boolean; function GetEnabled: Boolean; procedure SetEnabled(value: Boolean); procedure UndoLatest; procedure RedoLatest; - procedure UndoBlock(BlockName: string); - procedure RedoBlock(BlockName: string); - procedure SetNamedCheckPoint(CheckPointName: string); + procedure UndoBlock(const BlockName: string); + procedure RedoBlock(const BlockName: string); + procedure SetNamedCheckPoint(const CheckPointName: string); procedure SetCheckPoint; procedure ClearAllUndoBlocks; + function GetCurrentUndoBlockHasChanges: boolean; property UndoList: IBoldUndoList read GetUndoList; property RedoList: IBoldUndoList read GetRedoList; property Enabled: Boolean read GetEnabled write SetEnabled; - // add state here + property CurrentUndoBlockHasChanges: boolean read GetCurrentUndoBlockHasChanges; end; - implementation end. diff --git a/Source/ObjectSpace/Ocl/BoldORed.pas b/Source/ObjectSpace/Ocl/BoldORed.pas index 11b50872..2ea69ae4 100644 --- a/Source/ObjectSpace/Ocl/BoldORed.pas +++ b/Source/ObjectSpace/Ocl/BoldORed.pas @@ -1,6 +1,6 @@ -// as long as the distribution question of sandstone libs is not solved, -// this unit is used as an include file by BoldOCL +{ Global compiler directives } +{$include bold.inc} unit BoldORed; interface @@ -24,6 +24,7 @@ implementation type TBoldOclCollectionType = (tboNoCollection, tboBag, tboSet, tboSequence, tboCollection, tboCopyArg1, tboMinCollection); + {$I BoldOclConstructors.inc} constructor AYaccStackElement.Create; @@ -96,31 +97,31 @@ function AYaccClass.Reduce(TheProduction, TheSize: Longint): SSYaccStackElement; AYaccexpressionAnd: { expression -> expression AND expression } - result := Make2Operation('and', stack(0), stack(2), stack(1).lexeme.offset); // do not localize + result := Make2Operation('and', stack(0), stack(2), stack(1).lexeme.offset); AYaccexpressionOr: { expression -> expression OR expression } - result := Make2Operation('or', stack(0), stack(2), stack(1).lexeme.offset); // do not localize + result := Make2Operation('or', stack(0), stack(2), stack(1).lexeme.offset); AYaccexpressionXor: { expression -> expression XOR expression } - result := Make2Operation('xor', stack(0), stack(2), stack(1).lexeme.offset); // do not localize + result := Make2Operation('xor', stack(0), stack(2), stack(1).lexeme.offset); AYaccexpressionImp: { expression -> expression IMPLIES expression } - result := Make2Operation('implies', stack(0), stack(2), stack(1).lexeme.offset); // do not localize + result := Make2Operation('implies', stack(0), stack(2), stack(1).lexeme.offset); AYaccexpressionEQ: { expression -> expression = expression } - result := Make2Operation('=', stack(0), stack(2), stack(1).lexeme.offset); // do not localize + result := Make2Operation('=', stack(0), stack(2), stack(1).lexeme.offset); AYaccexpressionLT: { expression -> expression < expression } - result := Make2Operation('<', stack(0), stack(2), stack(1).lexeme.offset); // do not localize + result := Make2Operation('<', stack(0), stack(2), stack(1).lexeme.offset); AYaccexpressionGT: { expression -> expression > expression } - result := Make2Operation('>', stack(0), stack(2), stack(1).lexeme.offset); // do not localize + result := Make2Operation('>', stack(0), stack(2), stack(1).lexeme.offset); AYaccexpressionLE: @@ -158,11 +159,11 @@ function AYaccClass.Reduce(TheProduction, TheSize: Longint): SSYaccStackElement; AYaccexpressionNOT: { expression -> NOT expression } - result := Make1Operation('not', stack(1), stack(0).lexeme.offset); // do not localize + result := Make1Operation('not', stack(1), stack(0).lexeme.offset); AYaccifExpression: { ifExpression -> if expression then expression else expression endif } - result := Make3Operation('if', stack(1), stack(3), stack(5), stack(0).lexeme.offset); // do not localize + result := Make3Operation('if', stack(1), stack(3), stack(5), stack(0).lexeme.offset); AYaccpostFixFirst: { postFixExpression -> primaryExpression } @@ -318,7 +319,6 @@ function AYaccClass.Reduce(TheProduction, TheSize: Longint): SSYaccStackElement; AYacccollectionKind_Collection: { collectionKind -> Collection } -// Result := MakeCollectionKind(tboCollection, stack(0).lexeme.offset); raise EBoldOCLAbort.CreateFmt(boeCollectionNotValidLiteral, [stack(0).lexeme.offset]); @@ -332,11 +332,11 @@ function AYaccClass.Reduce(TheProduction, TheSize: Longint): SSYaccStackElement; AYaccexpressionDivI: { expression -> expression IntDIV expression } - result := Make2Operation('div', stack(0), stack(2), stack(1).lexeme.offset); // do not localize + result := Make2Operation('div', stack(0), stack(2), stack(1).lexeme.offset); AYaccexpressionMod: { expression -> expression MOD expression } - result := Make2Operation('mod', stack(0), stack(2), stack(1).lexeme.offset); // do not localize + result := Make2Operation('mod', stack(0), stack(2), stack(1).lexeme.offset); AYaccfeatureCallParameters1: { featureCallParameters -> (actualParameterList) } @@ -385,4 +385,6 @@ function AYaccClass.Reduce(TheProduction, TheSize: Longint): SSYaccStackElement; end; end; +initialization + end. diff --git a/Source/ObjectSpace/Ocl/BoldOcl.pas b/Source/ObjectSpace/Ocl/BoldOcl.pas index 7b0604b1..1a4732ea 100644 --- a/Source/ObjectSpace/Ocl/BoldOcl.pas +++ b/Source/ObjectSpace/Ocl/BoldOcl.pas @@ -1,19 +1,27 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOcl; interface uses Classes, + vcl.ExtCtrls, BoldBase, BoldSystemRT, BoldOclClasses, BoldElements, BoldSystem, + BoldAttributes, BoldIndexableList, BoldLogHandler, BoldOclRTDebug, BoldSubscription; +var + _BoldOCLPSEvaluationConditionBlockSize: Integer = -1; + type { forward declaration } TBoldOclEntry = class; @@ -32,6 +40,9 @@ TBoldOclEntry = class(TBoldMemoryManagedObject) OwnedByDictionary: Boolean; Ocl: TBoldOclNode; UsedByOtherEvaluation: Boolean; + Evaluations: Integer; + AccumulatedTicks: Int64; + LastWarnedTicks: Int64; constructor Create(const Str: string; OclNode: TBoldOclNode); destructor Destroy; override; end; @@ -39,7 +50,8 @@ TBoldOclEntry = class(TBoldMemoryManagedObject) { TBoldOClDictionary } TBoldOClDictionary = class(TBoldIndexableList) private - function GetOcl(const Expr: string): TBoldOclEntry; + class var IX_OCLEntry: integer; + function GetOcl(const Expr: string): TBoldOclEntry; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public constructor Create; procedure AddOcl(ENTRY: TBoldOclEntry); @@ -49,6 +61,7 @@ TBoldOClDictionary = class(TBoldIndexableList) { TBoldOcl } TBoldOcl = class(TBoldRTEvaluator) private + fMaxMemberNameArray: array of Integer; fOclDictionary: TBoldOClDictionary; fSymbolTable: TBoldSymbolDictionary; fSystemTypeInfo: TBoldSystemTypeInfo; @@ -60,23 +73,60 @@ TBoldOcl = class(TBoldRTEvaluator) fBooleanType: TBoldAttributeTypeInfo; fDateType: TBoldAttributeTypeInfo; fTimeType: TBoldAttributeTypeInfo; + fDateTimeType: TBoldAttributeTypeInfo; + fTrueBool: TBABoolean; fCanEvaluate: Boolean; fOnLookUpOclDefinition: TBoldLookUpOclDefinition; - function SyntacticParse(const Ocl: string; StoreInDictionary: Boolean; var ResultEntry: TBoldOclEntry; Context: TBoldElementTypeInfo): TBoldIndirectElement; - function SemanticCheck(Ocl: string; Context: TBoldElementTypeInfo; StoreInDictionary: Boolean; var ResultEntry: TBoldOclEntry; Env: TBoldOclEnvironment): TBoldIndirectElement; + fTodayVar: TBADate; + fNowVar: TBADateTime; + fTodayTimer, fNowTimer: TTimer; + fParses: Integer; + fDictionaryHits: Integer; + fExpresionTypeCount: Integer; + fExpressionTypeTicks: Int64; + fEvaluationCount: Integer; + fEvaluationTicks: Int64; + procedure CalculateMaxMemberNameLength; + function SyntacticParse(const Ocl: string; StoreInDictionary: Boolean; Context: TBoldElementTypeInfo): TBoldOclEntry; function LookupOclDefinition(const name: string):string; procedure PSEvaluation(const Expr: string; Root: TBoldElement; ResultEntry: TBoldOclEntry; Env: TBoldOclEnvironment); procedure AddVarsToEnv(Env: TBoldOCLEnvironment; const VariableList: TBoldExternalVariableList; Initializevalues: Boolean); + function GetGlobalEnv: TBoldOclEnvironment; + procedure TodayTimerEvent(Sender: TObject); + procedure NowTimerEvent(Sender: TObject); + protected + function GetVariableCount: integer; override; + function GetVariable(index: integer): TBoldIndirectElement; override; + function GetVariableByName(const aName: string): TBoldIndirectElement; override; public constructor Create(SystemTypeInfo: TBoldSystemTypeInfo; BoldSystem: TBoldSystem); destructor Destroy; override; + property GlobalEnv: TBoldOclEnvironment read GetGlobalEnv; property SymbolTable: TBoldSymbolDictionary read fsymbolTable; property BoldSystem: TBoldSystem read fBoldSystem; - procedure DefineVariable(const VariableName: String; VarValue: TBoldElement; VariableType: TBoldElementTypeInfo; OwnValue: Boolean); override; - procedure Evaluate(Ocl: string; Root: TBoldElement; Subscriber: TBoldSubscriber; ResubscribeAll: Boolean; resultElement: TBoldIndirectElement; EvaluateInPS: Boolean = false; const VariableList: TBoldExternalVariableList = nil); override; + property Parses: Integer read fParses; + property ExpresionTypeCount: Integer read fExpresionTypeCount; + property ExpressionTypeTicks: Int64 read fExpressionTypeTicks; + property EvaluationCount: Integer read fEvaluationCount; + property EvaluationTicks: Int64 read fEvaluationTicks; + property DictionaryHits: Integer read fDictionaryHits; + function SemanticCheck(Ocl: string; Context: TBoldElementTypeInfo; const VariableList: TBoldExternalVariableList = nil; StoreInDictionary: Boolean = true; Env: TBoldOclEnvironment = nil): TBoldOclEntry; + procedure DoneWithEntry(var oclEntry: TBoldOclEntry); + procedure DefineVariable(const VariableName: String; VarValue: TBoldElement; + VariableType: TBoldElementTypeInfo; OwnValue, IsConstant: Boolean); override; + procedure DefineVariable(const VariableName: string; Variable: TBoldExternalVariable ); override; + procedure UndefineVariable(Variable: TBoldExternalVariable); override; + procedure Evaluate(Ocl: string; Root: TBoldElement; Subscriber: TBoldSubscriber = nil; ResubscribeAll: Boolean = false; resultElement: TBoldIndirectElement = nil; EvaluateInPS: Boolean = false; const VariableList: TBoldExternalVariableList = nil); override; function ExpressionType(const Ocl: string; Context: TBoldElementTypeInfo; ReRaise: Boolean; const VariableList: TBoldExternalVariableList = nil): TBoldElementTypeInfo; override; - function RTInfo(const Ocl: string; Context: TBoldElementTypeInfo; ReRaise: Boolean): TBoldMemberRTInfo; override; + function RTInfo(const Ocl: string; Context: TBoldElementTypeInfo; ReRaise: Boolean; const VariableList: TBoldExternalVariableList = nil): TBoldMemberRTInfo; override; procedure SetLookupOclDefinition(value: TBoldLookUpOclDefinition); override; + property StringType: TBoldAttributeTypeInfo read fStringType; + property IntegerType: TBoldAttributeTypeInfo read fIntegerType; + property FloatType: TBoldAttributeTypeInfo read fFloatType; + property BooleanType: TBoldAttributeTypeInfo read fBooleanType; + property DateType: TBoldAttributeTypeInfo read fDateType; + property TimeType: TBoldAttributeTypeInfo read fTimeType; + property DateTimeType: TBoldAttributeTypeInfo read fDateTimeType; end; var @@ -86,51 +136,57 @@ TBoldOcl = class(TBoldRTEvaluator) BoldOCLRTDebugger: TBoldOCLRTDebugger = nil; BoldOclParserTablePath: String = ''; -procedure BoldOCLLog(const s: string); +procedure BoldOCLLog(aRoot: TBoldElement; const s: string; aResult: TBoldIndirectElement); procedure BoldForceNelCompatibility; +{$IFDEF OCLDummyValueBug} +type + TDummyValueDifferentResultEvent = procedure(const Expression: string; Context: TBoldElement; ResultWithDummy, ResultWithoutDummy: TBoldIndirectElement) of object; +var + OnDummyValueDifferentResult: TDummyValueDifferentResultEvent; +{$ENDIF} + implementation uses + // VCL SysUtils, - BoldAttributes, + DateUtils, + Math, + + // Bold + BoldUtils, BoldCondition, BoldDefs, - BoldOclSymbolImplementations, + BoldHashIndexes, BoldOclError, + BoldOclEvaluator, BoldOclLightWeightNodeMaker, BoldOclLightWeightNodes, - BoldOclEvaluator, BoldOclSemantics, + BoldOclSymbolImplementations, + BoldORed, + BoldMath, + BoldSSExcept, BoldSSLexU, BoldSSYaccU, - BoldSSExcept, - BoldORed, - BoldHashIndexes, - BoldCoreConsts; - -{.$R *.res} + BoldGuard; var - IX_OCLEntry: integer = -1; G_OclScannerTable: SSLexTable = nil; G_OclParserTable: SSYaccTable = nil; function OclScannerTable: SSLexTable; begin if not assigned(G_OclScannerTable) then - begin - G_OclScannerTable := SSLexTable.CreateResource(HInstance, 'OCLSCANNERTABLE', 'SCANNERTABLE'); // do not localize - end; + G_OclScannerTable := SSLexTable.Create; result := G_OclScannerTable; end; function OclParserTable: SSYaccTable; begin if not assigned(G_OclParserTable) then - begin - G_OclParserTable := SSYaccTable.CreateResource(HInstance, 'OCLPARSERTABLE', 'PARSERTABLE'); // do not localize - end; + G_OclParserTable := SSYaccTable.Create; result := G_OclParserTable; end; @@ -144,14 +200,35 @@ TOCLIndex = class(TBoldCaseSensitiveStringHashIndex) { TOCLIndex } function TOCLIndex.ItemAsKeyString(Item: TObject): string; begin - Result := TBoldOclEntry(Item).OclString; + with TBoldOclEntry(Item) do + if Assigned(Context) then + Result := Context.ExpressionName + ':' + OclString + else + Result := OclString +end; + +procedure TBoldOcl.CalculateMaxMemberNameLength; +var + i,j: integer; + ClassInfo: TBoldClassTypeInfo; + vLength: integer; +begin + SetLength(fMaxMemberNameArray, fSystemTypeInfo.TopSortedClasses.Count); + for i := 0 to fSystemTypeInfo.TopSortedClasses.Count - 1 do + begin + ClassInfo := fSystemTypeInfo.TopSortedClasses[i]; + vLength := 0; + for j := 0 to ClassInfo.AllMembersCount - 1 do + vLength := Max(vLength, Length(ClassInfo.AllMembers[j].ExpressionName)); + fMaxMemberNameArray[i] := vLength; + end; end; constructor TBoldOcl.Create(SystemTypeInfo: TBoldSystemTypeInfo; BoldSystem: TBoldSystem); var TrueConst: TBABoolean; FalseConst: TBABoolean; - MaxTimeStamp: TBAInteger; // this type must mirror the type of TBoldTimeStampType + MaxTimeStamp: TBAInteger; begin fSystemTypeInfo := SystemTypeInfo; fBoldSystem := BoldSystem; @@ -159,26 +236,43 @@ constructor TBoldOcl.Create(SystemTypeInfo: TBoldSystemTypeInfo; BoldSystem: TBo fCanEvaluate := true; fSymbolTable := TBoldSymbolDictionary.Create(SystemTypeInfo, BoldSystem, fCanEvaluate); InitializeSymbolTable(fSymbolTable); - fStringType := fSystemTYpeInfo.AttributeTypeInfoByExpressionName['String']; // do not localize - fIntegerType := fSystemTYpeInfo.AttributeTypeInfoByExpressionName['Integer']; // do not localize - fFloatType := fSystemTYpeInfo.AttributeTypeInfoByExpressionName['Float']; // do not localize - fBooleanType := fSystemTYpeInfo.AttributeTypeInfoByExpressionName['Boolean']; // do not localize - fTimeType := fSystemTYpeInfo.AttributeTypeInfoByExpressionName['Time']; // do not localize - fDateType := fSystemTYpeInfo.AttributeTypeInfoByExpressionName['Date']; // do not localize - - TrueConst := TBoldMemberFactory.CreateMemberFromBoldType(fBooleanType) as TBABoolean; - trueConst.AsBoolean := true; - DefineVariable('true', TrueConst, fBooleanType, true); // do not localize + fStringType := fSystemTypeInfo.AttributeTypeInfoByExpressionName['String']; + fIntegerType := fSystemTypeInfo.AttributeTypeInfoByExpressionName['Integer']; + fFloatType := fSystemTypeInfo.AttributeTypeInfoByExpressionName['Float']; + fBooleanType := fSystemTypeInfo.AttributeTypeInfoByExpressionName['Boolean']; + fTimeType := fSystemTypeInfo.AttributeTypeInfoByExpressionName['Time']; + fDateType := fSystemTypeInfo.AttributeTypeInfoByExpressionName['Date']; + fDateTimeType := fSystemTypeInfo.AttributeTypeInfoByExpressionName['DateTime']; // do not localize + + fTrueBool := TBoldMemberFactory.CreateMemberFromBoldType(fBooleanType) as TBABoolean; + fTrueBool.AsBoolean := true; + DefineVariable('true', fTrueBool, fBooleanType, True, True); // do not localize FalseConst := TBoldMemberFactory.CreateMemberFromBoldType(fBooleanType) as TBABoolean;; FalseConst.AsBoolean := False; - DefineVariable('false', FalseConst, fBooleanType, true); // do not localize + DefineVariable('false', FalseConst, fBooleanType, True, True); // do not localize + + DefineVariable('nil', nil, SystemTypeInfo.NilTypeInfo, False, True); // do not localize MaxTimeStamp := TBoldMemberFactory.CreateMemberFromBoldType(fIntegerType) as TBAInteger; MaxTimeStamp.AsInteger := BOLDMAXTIMESTAMP; - DefineVariable('timeStampNow', MaxTimeStamp, fIntegerType, true); // do not localize - - DefineVariable('nil', nil, SystemTypeInfo.NilTypeInfo, false); // do not localize + DefineVariable('timeStampNow', MaxTimeStamp, fIntegerType, True, False); // do not localize + + fTodayVar := TBoldMemberFactory.CreateMemberFromBoldType(fDateType) as TBADate; + fTodayTimer := TTimer.Create(nil); + fTodayTimer.OnTimer := TodayTimerEvent; + fTodayTimer.Enabled := True; + TodayTimerEvent(nil); + DefineVariable('today', fTodayVar, fDateType, True, False); // do not localize + + // Now is rounded to full minutes and is only refreshed once per minute + fNowVar := TBoldMemberFactory.CreateMemberFromBoldType(fDateTimeType) as TBADateTime; + fNowTimer := TTimer.Create(nil); + fNowTimer.OnTimer := NowTimerEvent; + fNowTimer.Enabled := True; + NowTimerEvent(nil); + DefineVariable('now', fNowVar, fDateTimeType, True, False); // do not localize + CalculateMaxMemberNameLength; end; destructor TBoldOcl.Destroy; @@ -186,24 +280,30 @@ destructor TBoldOcl.Destroy; FreeAndNil(fOclDictionary); FreeAndNil(fSymbolTable); FreeAndNil(fGlobalEnv); + FreeAndNil(fTodayTimer); + FreeAndNil(fNowTimer); inherited; end; { TBoldOCL } -procedure TBoldOcl.DefineVariable(const VariableName: String; VarValue: TBoldElement; VariableType: TBoldElementTypeInfo; OwnValue: Boolean); +procedure TBoldOcl.DefineVariable(const VariableName: String; VarValue: + TBoldElement; VariableType: TBoldElementTypeInfo; OwnValue, IsConstant: + Boolean); var NewVar: TBoldOCLVariableBinding; begin - if not assigned(fGlobalEnv) then - fGlobalEnv := TBoldOclEnvironment.Create(nil); - - NewVar := fGlobalEnv.Lookup(Uppercase(VariableName)); + NewVar := GlobalEnv.Find(VariableName); + if NewVar is TBoldOclVariableBindingExternal then + begin + GlobalEnv.RemoveBinding(NewVar); + FreeAndNil(NewVar); + end; if not assigned(NewVar) then begin NewVar := TBoldOclVariableBinding.Create; - NewVar.VariableName := VariableName; - fGlobalEnv.pushBinding(NewVar); + NewVar.VariableName := LowerCase(Copy(VariableName,1,1)) + Copy(VariableName,2,MaxInt); + GlobalEnv.pushBinding(NewVar); end; if assigned(VariableType) then @@ -215,9 +315,56 @@ procedure TBoldOcl.DefineVariable(const VariableName: String; VarValue: TBoldEle NewVar.SetOwnedValue(VarValue) else NewVar.SetReferenceValue(VarValue); + + // Variables like true, false, nil are always the same + if IsConstant then begin + NewVar.IsConstant := True; + if Assigned(NewVar.Value) then begin + NewVar.Value.MakeImmutable; + end; + end; +end; + +procedure TBoldOcl.DefineVariable(const VariableName: string; + Variable: TBoldExternalVariable); +var + LookupVar: TBoldOCLVariableBinding; + NewVar: TBoldOclVariableBindingExternal; + vName: string; +begin + if self = fSystemTypeInfo.Evaluator then + raise EBold.CreateFmt('%s: Variable can not be registered with meta evaluator.', [VariableName]); + if Assigned(Variable.Evaluator) and (Variable.Evaluator <> self) then + raise EBold.CreateFmt('%s: Variable already registered with another evaluator.', [VariableName]); + vName := LowerCase(Copy(VariableName,1,1)) + Copy(VariableName,2,MaxInt); + LookupVar := GlobalEnv.Find(vName); + if not assigned(LookupVar) then + begin + NewVar := TBoldOclVariableBindingExternal.Create; + NewVar.VariableName := vName; + GlobalEnv.pushBinding(NewVar); + end + else + if not (LookupVar is TBoldOclVariableBindingExternal) then + begin + NewVar := TBoldOclVariableBindingExternal.Create; + NewVar.VariableName := vName; + GlobalEnv.ReplaceBinding(vName, NewVar); + end + else + begin + NewVar := LookupVar as TBoldOclVariableBindingExternal; + end; + NewVar.ExternalVariable := Variable; + Variable.Evaluator := self; +end; + +procedure TBoldOcl.UndefineVariable(Variable: TBoldExternalVariable); +begin + GlobalEnv.RemoveVariable(Variable); end; -function TBoldOcl.SyntacticParse(const Ocl: string; StoreInDictionary: Boolean; var ResultEntry: TBoldOclEntry; Context: TBoldElementTypeInfo): TBoldIndirectElement; +function TBoldOcl.SyntacticParse(const Ocl: string; StoreInDictionary: Boolean; Context: TBoldElementTypeInfo): TBoldOclEntry; var Lexer: SSLex; Parser: AYaccClass; @@ -228,7 +375,7 @@ function TBoldOcl.SyntacticParse(const Ocl: string; StoreInDictionary: Boolean; begin FixedExpr := ocl; for i := 1 to length(FixedExpr) do - if FixedExpr[i] in [#9, BOLDLF, #12, BOLDCR] then + if CharInSet(FixedExpr[i], [#9, BOLDLF, #12, BOLDCR]) then FixedExpr[i] := ' '; if (pos('«', FixedExpr) <> 0) or (pos('»', FixedExpr) <> 0) then begin @@ -237,39 +384,38 @@ function TBoldOcl.SyntacticParse(const Ocl: string; StoreInDictionary: Boolean; begin case Ocl[i] of '''': begin - //QuotePos := i; // assignment never read, reset further down. + // QuotePos := i; InQuote := not InQuote; end; '«', '»': if not InQuote then - raise EBoldOclAbort.CreateFmt(sExpressionNotComplete, [i]); + raise EBoldOclAbort.CreateFmt('%d: Expression not complete', [i]); end; end; end; + if Assigned(Context) then + Result := fOclDictionary.OclEntryByExpressionString[Context.ExpressionName + ':' + Ocl] + else + Result := fOclDictionary.OclEntryByExpressionString[Ocl]; - // ---------------------- BEGIN MUTEX to make OCLEvaluator threadsafe - - ResultEntry := fOclDictionary.OclEntryByExpressionString[Ocl]; - - if assigned(ResultEntry) then + if assigned(Result) then begin - if resultEntry.Ocl.IsConstant or (not ResultEntry.UsedByOtherEvaluation and (ResultEntry.Context = Context)) then + if Result.Ocl.IsConstant or (not Result.UsedByOtherEvaluation) then begin - ResultEntry.UsedByOtherEvaluation := true; - Result := ResultEntry.Ocl; + Result.UsedByOtherEvaluation := true; + inc(fDictionaryHits); exit; - end - else - begin - ResultEntry := nil; - StoreInDictionary := false; - end + end; + StoreInDictionary := false; end; - // ------------------------- END MUTEX - + inc(fParses); Result := nil; + {$IFDEF BOLD_UNICODE} + Consumer := SSLexStringConsumer.Create(PAnsiChar(AnsiString(FixedExpr))); + {$ELSE} Consumer := SSLexStringConsumer.Create(PChar(FixedExpr)); + {$ENDIF} Lexer := ALexClass.Create(Consumer, OclScannerTable); Parser := AYaccClass.CreateLex(Lexer, OclParserTable); @@ -289,16 +435,16 @@ function TBoldOcl.SyntacticParse(const Ocl: string; StoreInDictionary: Boolean; QuotePos := 0; ParenPos := 0; - if Pos('SSLex0105e: Invalid token,', e.message) <> 0 then // do not localize + if Pos('SSLex0105e: Invalid token,', e.message) <> 0 then for i := 1 to Length(Ocl) do begin if Ocl[i] = '''' then InQuote := not InQuote; - if not InQuote and not (Ocl[i] in [' ', #9, BOLDCR, '0'..'9', 'a'..'z', 'A'..'Z', '_', '[', ']', '{', '}', + if not InQuote and not CharInSet(Ocl[i], [' ', #9, BOLDCR, '0'..'9', 'a'..'z', 'A'..'Z', '_', '[', ']', '{', '}', '(', ')', '+', '-', '*', '/', '=', '>', '<', ',', '.', '@', '|', '''', ':', '#', '«', '»']) then raise EBoldOclAbort.CreateFmt(boeInvalidcharacter,[i - 1]); end; - if Pos('SSYacc0105e: SyncErr failed, no valid token', e.message) <> 0 then // do not localize + if Pos('SSYacc0105e: SyncErr failed, no valid token', e.message) <> 0 then begin Paren := 0; for i := 1 to Length(Ocl) do @@ -322,7 +468,7 @@ function TBoldOcl.SyntacticParse(const Ocl: string; StoreInDictionary: Boolean; if InQuote then raise EBoldOclAbort.CreateFmt(boeunterminatedQoute, [QuotePos - 1]); end; - raise EBoldOclAbort.CreateFmt('%d:' + e.message, [e.Position]); // do not localize + raise EBoldOclAbort.CreateFmt('%d:' + e.message, [e.Position]); end; on e: EBoldOclAbort do begin @@ -338,7 +484,7 @@ function TBoldOcl.SyntacticParse(const Ocl: string; StoreInDictionary: Boolean; end; on e: Exception do begin - raise; // EBoldOclAbort.CreateFmt('%d:' + E.message, [-1]); + raise; end; end; finally @@ -346,83 +492,95 @@ function TBoldOcl.SyntacticParse(const Ocl: string; StoreInDictionary: Boolean; Lexer.Free; if assigned(Parser.finalvalue) then begin - ResultEntry := TBoldOclEntry.Create(Ocl, Parser.finalvalue.Node); - ResultEntry.UsedByOtherEvaluation := true; - Result := ResultEntry.Ocl; + Result := TBoldOclEntry.Create(Ocl, Parser.finalvalue.Node); + Result.UsedByOtherEvaluation := true; + Result.Context := Context; end; Parser.Free; end; if StoreInDictionary then begin - fOclDictionary.AddOcl(ResultEntry); - ResultEntry.OwnedByDictionary := True; + fOclDictionary.AddOcl(Result); + Result.OwnedByDictionary := True; end; end; -function TBoldOcl.SemanticCheck(Ocl: string; Context: TBoldElementTypeInfo; StoreInDictionary: Boolean; var ResultEntry: TBoldOclEntry; Env: TBoldOclEnvironment): TBoldIndirectElement; +function TBoldOcl.SemanticCheck(Ocl: string; Context: TBoldElementTypeInfo; const VariableList: TBoldExternalVariableList = nil; StoreInDictionary: Boolean = true; Env: TBoldOclEnvironment = nil): TBoldOclEntry; var Visitor: TBoldOclSemanticsVisitor; EnvSize: Integer; + HasVariables: boolean; + Guard: IBoldGuard; begin + Result := nil; + HasVariables := Assigned(VariableList) and VariableList.RefersToVariable(Ocl); + if not Assigned(Env) then + begin + if HasVariables then + begin + Guard := TBoldGuard.Create(Env); + Env := TBoldOclEnvironment.Create(GlobalEnv) + end + else + Env := GlobalEnv; + end; + AddVarsToEnv(Env, VariableList, true); + StoreInDictionary := StoreInDictionary and not HasVariables; // do not store in dict if there are variables (until subscriptions are implemented) + try if ocl[1] = '%' then ocl := LookupOclDefinition(copy(ocl, 2, maxint)); - SyntacticParse(Ocl, StoreInDictionary, ResultEntry, Context); + Result := SyntacticParse(Ocl, StoreInDictionary, Context); + - // The reason for the last part in this if-statement is that the evaluation of a nil-root to a nil-value is - // dependant on the raising of an exception in the semantic check, so therefor we can not skip it through the - // shortcut below. If the previous evaluation was made with a nil-context we still need to get the exception - // to be caught in the evaluator. - if (not ResultEntry.firstSemanticPass and + + if (not Result.firstSemanticPass and assigned(Context) and - context.ConformsTo(ResultEntry.Context)) or - (assigned(ResultEntry.Ocl) and ResultEntry.ocl.IsConstant) then + context.ConformsTo(Result.Context)) or + (assigned(Result.Ocl) and Result.ocl.IsConstant) then begin - Result := ResultEntry.Ocl; exit; end; - ResultEntry.Context := Context; - ResultEntry.Model := fSystemTYpeInfo; + Result.Context := Context; + Result.Model := fSystemTYpeInfo; EnvSize := Env.Count; - ResultEntry.SelfVar.Free; - ResultEntry.SelfVar := TBoldOclVariableBinding.Create; - ResultEntry.SelfVar.VariableName := 'Self'; // do not localize + Result.SelfVar.Free; + Result.SelfVar := TBoldOclVariableBinding.Create; + Result.SelfVar.VariableName := 'Self'; - ResultEntry.SelfVar.BoldType := ResultEntry.Context; + Result.SelfVar.BoldType := Result.Context; - Env.pushBinding(ResultEntry.SelfVar); + Env.pushBinding(Result.SelfVar); - Visitor := TBoldOclSemanticsVisitor.Create(ResultEntry.Model, self, SymbolTable, Env); + Visitor := TBoldOclSemanticsVisitor.Create(Result.Model, self, SymbolTable, Env); if BoldNelCompatibility and (pos('(', ocl) <> 0) then Visitor.IgnoreNelCompatibility := true; - try try - Visitor.Traverse(ResultEntry.Ocl); + Visitor.Traverse(Result.Ocl); except on e: EBoldOclAbort do begin - e.Ocl := ResultEntry.OclString; - ResultEntry.Context := nil; + e.Ocl := Result.OclString; + Result.Context := nil; raise; end; on e: EBoldOclError do begin - e.Ocl := ResultEntry.OclString; - ResultEntry.Context := nil; + e.Ocl := Result.OclString; + Result.Context := nil; raise; end; on e: Exception do begin - // Parsträdet behöver inte raderas, det är ju syntaktiskt korrekt. - ResultEntry.Context := nil; - raise EBoldOclAbort.CreateFmt('%d: %s', [-1, e.message]); // do not localize + Result.Context := nil; + raise EBoldOclAbort.CreateFmt('%d: %s', [-1, e.message]); end; end; finally @@ -432,37 +590,44 @@ function TBoldOcl.SemanticCheck(Ocl: string; Context: TBoldElementTypeInfo; Stor raise EBoldOclInternalError.CreateFmt(boeEnvSizeError, [0, EnvSize, Env.Count]); end; - ResultEntry.firstSemanticPass := False; + Result.firstSemanticPass := False; - Result := ResultEntry.Ocl; except on e: EBoldOclAbort do begin e.Ocl := Ocl; e.FixError; + if Assigned(Result) and not result.OwnedByDictionary then + FreeAndNil(result); raise; end; on e: EBoldOclError do begin e.Ocl := Ocl; e.FixError; + if Assigned(Result) and not result.OwnedByDictionary then + FreeAndNil(result); + raise; + end + else + begin + if Assigned(Result) and not result.OwnedByDictionary then + FreeAndNil(result); raise; end; end; end; -function TBoldOcl.RTInfo(const Ocl: string; Context: TBoldElementTypeInfo; ReRaise: Boolean): TBoldMemberRTInfo; +function TBoldOcl.RTInfo(const Ocl: string; Context: TBoldElementTypeInfo; ReRaise: Boolean; const VariableList: TBoldExternalVariableList): TBoldMemberRTInfo; var ResultEntry: TBoldOclEntry; - Env: TBoldOclEnvironment; begin Result := nil; ResultEntry := nil; - Env := TBoldOclEnvironment.Create(fGlobalEnv); try try if ocl <> '' then - SemanticCheck(Ocl, Context, false, ResultEntry, Env); + ResultEntry := SemanticCheck(Ocl, Context, VariableList, false); if assigned(ResultEntry) and (ResultEntry.Ocl is TBoldOclMember) then Result := (ResultEntry.Ocl as TBoldOclMember).RTInfo; @@ -481,25 +646,16 @@ function TBoldOcl.RTInfo(const Ocl: string; Context: TBoldElementTypeInfo; ReRai end; end; finally - if assigned(ResultEntry) then - begin - if ResultEntry.OwnedByDictionary then - ResultEntry.UsedByOtherEvaluation := false - else - begin - ResultEntry.Free; - ResultEntry := nil; - end; - end; - Env.Free; + DoneWithEntry(ResultEntry); end; end; function TBoldOcl.ExpressionType(const Ocl: string; Context: TBoldElementTypeInfo; ReRaise: Boolean; const VariableList: TBoldExternalVariableList = nil): TBoldElementTypeInfo; var ResultEntry: TBoldOclEntry; - Env: TBoldOclEnvironment; + StartTicks, EndTicks: Int64; begin + StartTicks := UserTimeInTicks; Result := nil; ResultEntry := nil; if trim(ocl) = '' then @@ -508,11 +664,9 @@ function TBoldOcl.ExpressionType(const Ocl: string; Context: TBoldElementTypeInf end else begin - Env := TBoldOclEnvironment.Create(fGlobalEnv); - AddVarsToEnv(Env, VariableList, false); try try - SemanticCheck(Ocl, Context, false, ResultEntry, Env); + ResultEntry := SemanticCheck(Ocl, Context, VariableList); if assigned(ResultEntry) then Result := ResultEntry.Ocl.BoldType; except @@ -530,21 +684,36 @@ function TBoldOcl.ExpressionType(const Ocl: string; Context: TBoldElementTypeInf end; end; finally - if assigned(ResultEntry) then - begin - if ResultEntry.OwnedByDictionary then - ResultEntry.UsedByOtherEvaluation := false - else - begin - ResultEntry.Free; - ResultEntry := nil; - end; - end; - Env.Free; + DoneWithEntry(ResultEntry); + EndTicks := userTimeInTicks; + INC(fExpresionTypeCount); + fExpressionTypeTicks := fExpressionTypeTicks + EndTicks - StartTicks; end; end; end; +function TBoldOcl.GetGlobalEnv: TBoldOclEnvironment; +begin + if not assigned(fGlobalEnv) then + fGlobalEnv := TBoldOclEnvironment.Create(nil); + result := fGlobalEnv; +end; + +function TBoldOcl.GetVariable(index: integer): TBoldIndirectElement; +begin + result := GlobalEnv.Bindings[Index]; +end; + +function TBoldOcl.GetVariableByName(const aName: string): TBoldIndirectElement; +begin + result := GlobalEnv.Lookup(aName); +end; + +function TBoldOcl.GetVariableCount: integer; +begin + result := GlobalEnv.count; +end; + function MapResubscribe(Resubscribe: Boolean): TBoldRequestedEvent; begin if Resubscribe then @@ -556,16 +725,21 @@ function MapResubscribe(Resubscribe: Boolean): TBoldRequestedEvent; var OclCounter: integer; -procedure TBoldOcl.Evaluate(Ocl: string; ROOT: TBoldElement; Subscriber: TBoldSubscriber; ResubscribeAll: Boolean; resultElement: TBoldIndirectElement; EvaluateInPS: Boolean = false; const VariableList: TBoldExternalVariableList = nil); + +procedure TBoldOcl.Evaluate(Ocl: string; Root: TBoldElement; Subscriber: TBoldSubscriber = nil; ResubscribeAll: Boolean = false; resultElement: TBoldIndirectElement = nil; EvaluateInPS: Boolean = false; const VariableList: TBoldExternalVariableList = nil); + +procedure _Evaluate(Ocl: string; Root: TBoldElement; Subscriber: TBoldSubscriber = nil; ResubscribeAll: Boolean = false; resultElement: TBoldIndirectElement = nil; EvaluateInPS: Boolean = false; const VariableList: TBoldExternalVariableList = nil); var LocalContext : TBoldElementTypeInfo; EvaluatorVisitor: TBoldOclEvaluatorVisitor; ResultEntry: TBoldOclEntry; Env: TBoldOclEnvironment; CurrentComponentPath: String; + StartTicks, EndTicks, Ticks, Freq: Int64; begin + StartTicks := UserTimeInTicks; if not fCanEvaluate then - raise EBoldOclError.Create(sTypesMissingFromEvaluator); + raise EBoldOclError.Create('This evaluator can not be used for evaluation, since some types are missing'); ResultEntry := nil; Env := nil; @@ -578,10 +752,8 @@ procedure TBoldOcl.Evaluate(Ocl: string; ROOT: TBoldElement; Subscriber: TBoldSu else CurrentComponentPath := ''; - BoldOCLLog(Ocl); - try - Inc(OclCounter); + try if assigned(ROOT) then LocalContext := ROOT.BoldType else @@ -603,25 +775,32 @@ procedure TBoldOcl.Evaluate(Ocl: string; ROOT: TBoldElement; Subscriber: TBoldSu exit; end; + if assigned(ResultElement) and (Root is TBoldObject) + and (Length(Ocl) <= fMaxMemberNameArray[TBoldObject(Root).BoldClassTypeInfo.TopSortedIndex]) then + begin + ResultElement.SetReferenceValue(TBoldObject(Root).FindBoldMemberByExpressionName(ocl)); + if Assigned(ResultElement.Value) then + begin + if assigned(Subscriber) then + ResultElement.Value.DefaultSubscribe(Subscriber, MapResubscribe(ResubscribeAll)); + exit; + end; + end; + if assigned(BoldOclRTDebugger) and BoldOclRTDebugger.HasFixFor(ocl, LocalContext) then ocl := BoldOclRTDebugger.GetFixFor(Ocl, LocalContext); try try - Env := TBoldOclEnvironment.Create(fGlobalEnv); - AddVarsToEnv(Env, VariableList, true); -// try - SemanticCheck(Ocl, LocalContext, not assigned(VariableList), resultEntry, Env); -// finally -// Env.Free; -// end; + Env := TBoldOclEnvironment.Create(GlobalEnv); + resultEntry := SemanticCheck(Ocl, LocalContext, VariableList, true, Env); + except on e: EBoldOclAbort do begin if not assigned(ROOT) and assigned(ResultEntry) then begin - // ^no root ^but syntactically correct, semantically erroneous if assigned(ResultElement) then resultElement.SetReferenceValue(nil); exit; @@ -633,7 +812,6 @@ procedure TBoldOcl.Evaluate(Ocl: string; ROOT: TBoldElement; Subscriber: TBoldSu begin if not assigned(ROOT) and assigned(ResultEntry) then begin - // ^no root ^but syntactically correct, semantically erroneous if assigned(ResultElement) then resultElement.SetReferenceValue(nil); exit; @@ -656,7 +834,7 @@ procedure TBoldOcl.Evaluate(Ocl: string; ROOT: TBoldElement; Subscriber: TBoldSu end else begin - EvaluatorVisitor := TBoldOclEvaluatorVisitor.Create(Subscriber, ResubscribeAll, fSystemtypeInfo, BoldSystem, fStringType, fIntegerType, fFloatType, fDateType, fTimeType); + EvaluatorVisitor := TBoldOclEvaluatorVisitor.Create(Subscriber, ResubscribeAll, fSystemtypeInfo, BoldSystem, fTrueBool,fBooleanType,fStringType, fIntegerType, fFloatType, fDateType, fTimeType); try ResultEntry.Ocl.AcceptVisitor(EvaluatorVisitor); finally @@ -664,12 +842,16 @@ procedure TBoldOcl.Evaluate(Ocl: string; ROOT: TBoldElement; Subscriber: TBoldSu end; end; ResultEntry.EvaluatedOnce := True; - if assigned(ResultElement) then - begin - if ResultEntry.Ocl.IsConstant then - resultElement.SetReferenceValue(ResultEntry.Ocl.Value) - else + if assigned(ResultElement) then begin + if ResultEntry.Ocl.IsConstant and + // see finally below: when ResultEntry is freed, the ResultElement + // becomes invalid. In this case Value must be transferred in this place. + ResultEntry.OwnedByDictionary then + begin + resultElement.SetReferenceValue(ResultEntry.Ocl.Value); + end else begin ResultEntry.Ocl.TransferValue(ResultElement); + end; if BoldNelCompatibility and (ResultElement.Value is TBoldClassTypeInfo) and assigned(fBoldSystem) then @@ -728,19 +910,48 @@ procedure TBoldOcl.Evaluate(Ocl: string; ROOT: TBoldElement; Subscriber: TBoldSu end; finally + BoldOCLLog(ROOT, Ocl, resultElement); + Inc(OclCounter); Env.Free; - if assigned(ResultEntry) then + if Assigned(ResultEntry) then begin - if ResultEntry.OwnedByDictionary then - ResultEntry.UsedByOtherEvaluation := false - else + INC(ResultEntry.Evaluations); + INC(fEvaluationCount); + + EndTicks := UserTimeInTicks; + Ticks := EndTicks - StartTicks; + if Ticks > 0 then begin - ResultEntry.Free; - ResultEntry := nil; + fEvaluationTicks := fEvaluationTicks + Ticks; + ResultEntry.AccumulatedTicks:= ResultEntry.AccumulatedTicks + Ticks; end; end; + DoneWithEntry(ResultEntry); end; end; +{$IFDEF OCLDummyValueBug} +var + IE: TBoldIndirectElement; +{$ENDIF} +begin + OclUseTemporaryDummyValue := true; + _Evaluate(Ocl, ROOT, Subscriber, ResubscribeAll, resultElement, EvaluateInPS, VariableList); +{$IFDEF OCLDummyValueBug} + if Assigned(OnDummyValueDifferentResult) and Assigned(resultElement) then + try + IE := TBoldIndirectElement.Create; + OclUseTemporaryDummyValue := false; + _Evaluate(Ocl, ROOT, Subscriber, ResubscribeAll, IE, EvaluateInPS, VariableList); + if not (((Assigned(resultElement.Value) and Assigned(Ie.Value)) or (not Assigned(resultElement.Value) and not Assigned(Ie.Value)))) then + OnDummyValueDifferentResult(Ocl, Root, resultElement, Ie) + else + if not resultElement.Value.IsEqual(IE.Value) then + OnDummyValueDifferentResult(Ocl, Root, resultElement, Ie); + finally + ie.free; + end; +{$ENDIF} +end; { TBoldOClDictionary } constructor TBoldOClDictionary.Create; @@ -752,7 +963,7 @@ constructor TBoldOClDictionary.Create; function TBoldOClDictionary.GetOcl(const Expr: string): TBoldOclEntry; begin - Result := TBoldOclEntry(TOCLIndex(indexes[IX_OCLEntry]).FindByString(Expr)); + Result := TBoldOclEntry(TBoldCaseSensitiveStringHashIndex(indexes[IX_OCLEntry]).FindByString(Expr)); end; procedure TBoldOClDictionary.AddOcl(ENTRY: TBoldOclEntry); @@ -776,11 +987,24 @@ destructor TBoldOclEntry.Destroy; inherited; end; -procedure BoldOCLLog(const s: string); +procedure BoldOCLLog(aRoot: TBoldElement; const s: string; aResult: TBoldIndirectElement); +var + vRoot: string; + vResult: string; begin if assigned(BoldOCLLogHandler) then - BoldOclLogHandler.Log(formatDateTime('c: ', now)+ // do not localize - format('OCL %4d - %s', [OclCounter, trim(s)])); // do not localize + begin + if Assigned(aRoot) then + vRoot := aRoot.BoldType.AsString + else + vRoot := 'nil'; + if Assigned(aResult) and Assigned(aResult.Value) then + vResult := aResult.value.AsString + else + vResult := 'nil'; + BoldOclLogHandler.Log(formatDateTime('c: ', now)+ + format('OCL %4d - %s:%s:%s', [OclCounter, vRoot, trim(s), vResult])); + end; end; function TBoldOcl.LookupOclDefinition(const name: string): string; @@ -788,7 +1012,7 @@ function TBoldOcl.LookupOclDefinition(const name: string): string; if assigned(fOnLookUpOclDefinition) then result := fOnLookUpOclDefinition(Name) else - raise EBoldOCLError.CreateFmt(sCannotFindOCLDefinitionWithoutRepository, ['%'+Name]); + raise EBoldOCLError.CreateFmt('0: Can not find OCL definition for %s, no repository installed', ['%'+Name]); end; procedure TBoldOcl.SetLookupOclDefinition(value: TBoldLookUpOclDefinition); @@ -798,13 +1022,48 @@ procedure TBoldOcl.SetLookupOclDefinition(value: TBoldLookUpOclDefinition); procedure TBoldOcl.PSEvaluation(const Expr: string; Root: TBoldElement; ResultEntry: TBoldOclEntry; Env: TBoldOclEnvironment); var - OclCondition: TBoldOclCondition; - i: integer; - ClassTypeInfo: TBoldClassTypeInfo; LocalBoldSystem: TBoldSystem; + ClassTypeInfo: TBoldClassTypeInfo; OLWNodeMaker: TBoldOLWNodeMaker; resList: TBoldObjectList; + aResultType: TBoldElementTypeInfo; + bNoBlockPSEvaluation: Boolean; + + function ExecuteOclCondition(CurrentOLCondition: TBoldOclCondition): Boolean; + var + aResultConList: TBoldObjectList; + begin + Result := False; + if Assigned(CurrentOLCondition) then begin + CurrentOLCondition.RootNode := OLWNodeMaker.RootNode; + ClassTypeInfo := (aResultType as TBoldListTypeInfo).ListElementTypeInfo as TBoldClassTypeInfo; + CurrentOLCondition.TopSortedIndex := ClassTypeInfo.TopSortedIndex; + if bNoBlockPSEvaluation then begin + CurrentOLCondition.RootNode := OLWNodeMaker.RootNode; + ResList := TBoldMemberFactory.CreateMemberFromBoldType(aResultType) as TBoldObjectList; + LocalBoldSystem.GetAllWithCondition(resList, CurrentOLCondition); + resultEntry.Ocl.SetOwnedValue(ResList); + end else begin + aResultConList := TBoldMemberFactory.CreateMemberFromBoldType(aResultType) as TBoldObjectList; + try + LocalBoldSystem.GetAllWithCondition(aResultConList, CurrentOLCondition); + ResList.AddList(aResultConList); + finally + aResultConList.Free; + end; + end; + end; + end; + +var + OclCondition: TBoldOclCondition; + i: integer; RootAsList: TBoldObjectList; + ObjectCount: Integer; + Block: Integer; + Start, Stop: Integer; +const + sInvalidForSQLEvaluation = 'Root %s: %s is not allowed for SQL-evaluation'; begin LocalBoldSystem := BoldSystem; if not assigned(LocalBoldSystem) then @@ -830,28 +1089,65 @@ procedure TBoldOcl.PSEvaluation(const Expr: string; Root: TBoldElement; ResultEn OclCondition.Env.Add(TBoldOLWVariableBinding(OLWNodeMaker.ExternalVarBindings[i])); OLWNodeMaker.ExternalVarBindings.Clear; - if Root is TBoldObject then - OclCondition.Context.Add((Root as TBoldObject).BoldObjectLocator.BoldObjectID) - else if Root is TBoldObjectList then - begin - RootAsList := Root as TBoldObjectList; - RootAsList.EnsureObjects; - for i := 0 to RootAsList.Count - 1 do - OclCondition.Context.Add(RootAsList[i].BoldObjectLocator.BoldObjectID) - end - else if assigned(root) and not (Root is TBoldSystem) then - raise EBoldOclError.CreateFmt(sInvalidForSQLEvaluation, [Root.AsString, Root.ClassName]); + aResultType := ResultEntry.Ocl.BoldType; + if aResultType is TBoldClassTypeInfo then begin + aResultType := TBoldClassTypeInfo(aResultType).ListTypeInfo; + end; - OclCondition.RootNode := OLWNodeMaker.RootNode; - ResList := TBoldMemberFactory.CreateMemberFromBoldType(ResultEntry.Ocl.BoldType) as TBoldObjectList; - ClassTypeInfo := (ResultEntry.Ocl.BoldType as TBoldListTypeInfo).ListElementTypeInfo as TBoldClassTypeInfo; - OclCondition.TopSortedIndex := ClassTypeInfo.TopSortedIndex; - LocalBoldSystem.GetAllWithCondition(resList, OclCondition); - resultEntry.Ocl.SetOwnedValue(ResList); + bNoBlockPSEvaluation := + (_BoldOCLPSEvaluationConditionBlockSize = -1) OR + ((Root is TBoldObjectList) and + ((Pos(UpperCase('->orderBy'), UpperCase(Expr)) > 0) or + (Pos(UpperCase('->orderDescending'), UpperCase(Expr)) > 0) or + (Pos(UpperCase('->difference'), UpperCase(Expr)) > 0) or + (Pos(UpperCase('->symmetricDifference'), UpperCase(Expr)) > 0) + ) + ); + + if bNoBlockPSEvaluation then begin + if Root is TBoldObject then + OclCondition.Context.Add((Root as TBoldObject).BoldObjectLocator.BoldObjectID) + else if Root is TBoldObjectList then + begin + RootAsList := Root as TBoldObjectList; + RootAsList.EnsureObjects; + for i := 0 to RootAsList.Count - 1 do + OclCondition.Context.Add(RootAsList[i].BoldObjectLocator.BoldObjectID) + end + else if assigned(root) and not (Root is TBoldSystem) then + raise EBoldOclError.CreateFmt(sInvalidForSQLEvaluation, [Root.AsString, Root.ClassName]); + + ExecuteOclCondition(OclCondition); + end else begin + ResList := TBoldMemberFactory.CreateMemberFromBoldType(aResultType) as TBoldObjectList; + if Root is TBoldObject then begin + OclCondition.Context.Add((Root as TBoldObject).BoldObjectLocator.BoldObjectID); + ExecuteOclCondition(OclCondition); + end else if Root is TBoldObjectList then begin + RootAsList := Root as TBoldObjectList; + RootAsList.EnsureObjects; + ObjectCount := RootAsList.Count - 1; + for Block := 0 to (ObjectCount div _BoldOCLPSEvaluationConditionBlockSize) do + begin + Start := Block * _BoldOCLPSEvaluationConditionBlockSize; + Stop := MinIntValue([Pred(Succ(Block) * _BoldOCLPSEvaluationConditionBlockSize), ObjectCount]); + OclCondition.Context.Clear; + for i := Start to Stop do begin + OclCondition.Context.Add(RootAsList[i].BoldObjectLocator.BoldObjectID); + end; + ExecuteOclCondition(OclCondition); + end; + end else if assigned(root) and not (Root is TBoldSystem) then begin + raise EBoldOclError.CreateFmt(sInvalidForSQLEvaluation, [Root.AsString, Root.ClassName]); + end else begin + ExecuteOclCondition(OclCondition); + end; + resultEntry.Ocl.SetOwnedValue(ResList); + end; - end - else + end else begin raise EBoldOclError.CreateFmt('%d:%s', [OLWNodeMaker.FailurePosition, OLWNodeMaker.FailureReason]); // do not localize + end; finally OclCondition.Free; @@ -879,6 +1175,39 @@ procedure TBoldOcl.AddVarsToEnv(Env: TBoldOCLEnvironment; end; end; +procedure TBoldOcl.DoneWithEntry(var oclEntry: TBoldOclEntry); +begin + if Assigned(oclEntry) then + begin + if oclEntry.OwnedByDictionary then + oclEntry.UsedByOtherEvaluation := false + else + begin + oclEntry.Free; + oclEntry := nil; + end; + end; +end; + +procedure TBoldOcl.TodayTimerEvent(Sender: TObject); +begin + fTodayTimer.Interval := MilliSecondsBetween( Now, Today+1 ); + fTodayVar.AsDate := Today; +end; + +procedure TBoldOcl.NowTimerEvent(Sender: TObject); +var + vTime: TDateTime; +begin + vTime := RecodeMilliSecond(now, 0); + vTime := RecodeSecond(vTime, 0); + fNowVar.AsDateTime := vTime; + vTime := IncMinute(vTime); + fNowTimer.Interval := MilliSecondsBetween( Now, vTime ); + if (fNowTimer.Interval = 0) or (fNowTimer.Interval > MSecsPerSec * SecsPerMin) then + fNowTimer.Interval := MSecsPerSec * SecsPerMin +end; + procedure BoldForceNelCompatibility; begin BoldNelCompatibility := true; @@ -886,6 +1215,7 @@ procedure BoldForceNelCompatibility; end; initialization + TBoldOClDictionary.IX_OCLEntry := -1; finalization FreeAndNil(G_OclParserTable); diff --git a/Source/ObjectSpace/Ocl/BoldOclClasses.pas b/Source/ObjectSpace/Ocl/BoldOclClasses.pas index a211f083..89b6dbcf 100644 --- a/Source/ObjectSpace/Ocl/BoldOclClasses.pas +++ b/Source/ObjectSpace/Ocl/BoldOclClasses.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOclClasses; interface @@ -12,12 +15,13 @@ interface BoldSystemRT; type + TBOCollectionKind = (OCLSet, OCLBag, OCLSequence); TBoldOCLIteratorSpecifier = (OclNoIterator, OclSelect, OclReject, OCLCollect, OclIterate, OclExists, OclForAll, OclOrderBy, OclOrderDescending, OclUnique); TBoldOclDeduceMethod = (tbodNo, tbodCopyLoopVar, tbodCopyArg1, tbodCopyArg1Elem, tbodCopyArg2, tbodCopyArg3, tbodLCC, tbodLCC23, tbodListofArg2, TbodObjectlist, - tbodType, tbodTypecast, tbodArg1AsList, tbodListFromArg2); + tbodType, tbodTypecast, tbodArg1Type, tbodArg1AsList, tbodListFromArg2); TBoldOCL_Operation = procedure (Args: array of TBoldIndirectElement; Result: TBoldIndirectElement); @@ -54,26 +58,7 @@ {//} TBoldOclSymbolParameters = record {//} SystemTypeInfo: TBoldSystemTypeInfo; {//} end; - -{ TBoldOclNodeList } - TBoldOclNodeList = class(TBoldMemoryManagedObject) - private - FList: TList; - function GetItem(index: Integer): TBoldOclNode; - procedure PutItem(index: Integer; Value: TBoldOclNode); - public - property Items[index: Integer]: TBoldOclNode read GetItem write PutItem; default; - constructor Create; - destructor Destroy; override; - function Add(Item: TBoldOclNode): Integer; - procedure Clear; - procedure ClearAndFree; - procedure Delete(index: Integer); - procedure Insert(index: Integer; Item: TBoldOclNode); - procedure Move(CurIndex, NewIndex: Integer); - function Remove(Item: TBoldOclNode): Integer; - function Count: Integer; - end; + TBoldOclNodeList = array of TBoldOclNode; { TBoldOclEnvironment } TBoldOclEnvironment = class(TBoldMemoryManagedObject) @@ -83,17 +68,23 @@ TBoldOclEnvironment = class(TBoldMemoryManagedObject) fList: TList; function GetCount: integer; function GetBindings(Index: integer): TBoldOclVariableBinding; + function GetBindingsAsCommaText: string; public constructor Create(OuterScope: TBoldOclEnvironment); property Count: integer read GetCount; - destructor Destroy; override; + destructor destroy; override; procedure pushBinding(B: TBoldOclVariableBinding); function popBinding: TBoldOclVariableBinding; - function Lookup(S: string): TBoldOclVariableBinding; + procedure ReplaceBinding(name: string; Binding: TBoldOclVariableBinding); + procedure RemoveBinding(Binding: TBoldOclVariableBinding); + procedure RemoveVariable(Variable: TBoldExternalVariable); + function Lookup(const S: string): TBoldOclVariableBinding; function lookupSelf: TBoldOclVariableBinding; + function Find(const S: string): TBoldOclVariableBinding; function CurrentImplicitVariable: TBoldOclVariableBinding; function MakeGenSymName: string; property Bindings[Index: integer]: TBoldOclVariableBinding read GetBindings; default; + property BindingsAsCommaText: string read GetBindingsAsCommaText; end; { TBoldOclVisitor } @@ -101,7 +92,7 @@ TBoldOclVisitor = class(TBoldMemoryManagedObject) public procedure VisitTBoldOclNode(N: TBoldOclNode); virtual; procedure VisitTBoldOclListCoercion(N: TBoldOclListCoercion); virtual; - procedure VisitTBoldOclCollectionLiteral(N: TBoldOclCollectionLIteral); virtual; + procedure VisitTBoldOclCollectionLIteral(N: TBoldOclCollectionLIteral); virtual; procedure VisitTBoldOclOperation(N: TBoldOclOperation); virtual; procedure VisitTBoldOclIteration(N: TBoldOclIteration); virtual; procedure VisitTBoldOclMember(N: TBoldOclMember); virtual; @@ -109,7 +100,7 @@ TBoldOclVisitor = class(TBoldMemoryManagedObject) procedure VisitTBoldOclLiteral(N: TBoldOclLiteral); virtual; procedure VisitTBoldOclStrLiteral(N: TBoldOclStrLiteral); virtual; procedure VisitTBoldOclNumericLiteral(N: TBoldOclNumericLiteral); virtual; - procedure VisitTBoldOclEnumLiteral(N: TBoldOclEnumLiteral); virtual; + procedure VisitTBoldOclENumLiteral(N: TBoldOclEnumLiteral); virtual; procedure VisitTBoldOclIntLiteral(N: TBoldOclIntLiteral); virtual; procedure VisitTBoldOclMomentLiteral(N: TBoldOclMomentLiteral); virtual; procedure VisitTBoldOclDateLiteral(N: TBoldOclDateLiteral); virtual; @@ -124,16 +115,16 @@ TBoldOclNode = class(TBoldIndirectElement) protected fBoldType: TBoldElementTypeInfo; procedure SetBoldType(NewType: TBoldElementTypeInfo); - function GetBoldType: TBoldElementTypeInfo; + function GetBoldType: TBoldElementTypeInfo; virtual; public Position: Integer; - constructor Create; + constructor Create; virtual; procedure AcceptVisitor(V: TBoldOclVisitor); virtual; property BoldType: TBoldElementTypeInfo read GetBoldType write SetBoldType; property NeedsListCoercion: Boolean index befNeedsListCoercion read GetElementFlag write SetElementFlag; property IsConstant: Boolean index befIsConstant read GetElementFlag write SetElementFlag; property Resubscribe: boolean index befResubscribe read GetElementFlag write SetElementFlag; - property HastemporaryDummyValue: boolean index befHastemporaryDummyValue read GetElementFlag write SetElementFlag; + property HasTemporaryDummyValue: boolean index befHastemporaryDummyValue read GetElementFlag write SetElementFlag; end; { TBoldOclTypeNode } @@ -147,7 +138,7 @@ TBoldOclTypeNode = class(TBoldOclNode) TBoldOCLListCoercion = class(TBoldOCLNode) public Child: TBoldOCLNode; - destructor Destroy; override; + destructor destroy; override; procedure AcceptVisitor(V: TBoldOclVisitor); override; end; @@ -180,7 +171,7 @@ TBoldOclMember = class(TBoldOclNode) MemberIndex: Integer; Qualifier: TBoldOclNodeList; RTInfo: TBoldMemberRTInfo; - constructor Create; + constructor Create; override; destructor Destroy; override; procedure AcceptVisitor(V: TBoldOclVisitor); override; end; @@ -198,18 +189,26 @@ TBoldOclMethod = class(TBoldOclOperation) TBoldOclVariableBinding = class(TBoldOclNode) public VariableName: string; - TypeNameList: TStringList; //For temporary use only. The parser stores the type - //info from a select(i:Person|i<>self.employer) - //but this must be moved to the oclNode.ExpressionType + TypeNameList: TStringList; destructor Destroy; override; procedure AcceptVisitor(V: TBoldOclVisitor); override; end; + TBoldOclVariableBindingExternal = class(TBoldOclVariableBinding) + private + fExternalVariable: TBoldExternalVariable; + protected + function GetBoldType: TBoldElementTypeInfo; override; + public + destructor Destroy; override; + property ExternalVariable: TBoldExternalVariable read fExternalVariable write fExternalVariable; + end; + { TBoldOclVariableReference } TBoldOclVariableReference = class(TBoldOclNode) public VariableName: string; - VariableBinding: TBoldOclVariableBinding; // Not to be traversed... + VariableBinding: TBoldOclVariableBinding; procedure AcceptVisitor(V: TBoldOclVisitor); override; end; @@ -290,11 +289,12 @@ TBoldOclEnumLiteral = class(TBoldOclLiteral) TBoldSymbolDictionary = class(TBoldIndexableList) private fhelp: TBoldOclSymbolHelp; - function GetSymbol(const Name: string): TBoldOclSymbol; + function GetSymbol(const Name: string): TBoldOclSymbol; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetSymbolByIndex(index: Integer): TBoldOclSymbol; + class var IX_SymbolName: integer; public constructor Create(SystemTypeInfo: TBoldSystemTypeInfo; BoldSystem: TBoldSystem; var ErrorsEncountered: Boolean); - destructor Destroy; override; + destructor destroy; override; property help: TBoldOclSymbolHelp read fHelp; property SymbolByName[const name: string]: TBoldOclSymbol read GetSymbol; property Symbols[i: Integer]: TBoldOclSymbol read GetSymbolByIndex; @@ -321,11 +321,12 @@ TBoldOclSymbolHelp = class(TBoldMemoryManagedObject) fNumericListType, fMomentListType, fStringListType, + fIntegerListType, fTypeListType: TBoldListTypeInfo; fSystemTypeInfo: tBoldSystemTypeInfo; - procedure fMakeNew(el: TBoldIndirectElement; NewType: TBoldElementTypeInfo); public constructor create(SystemTypeInfo: tBoldSystemTypeInfo; BoldSystem: TBoldSystem; var ErrorsEncountered: Boolean); + procedure MakeNew(el: TBoldOCLNode; NewType: TBoldElementTypeInfo); function CreateNewMember(BoldType: TBoldElementTypeInfo): TBoldMember; property SystemTypeInfo: TBoldSystemTypeInfo read fSystemTypeInfo; property NumericType: TBoldAttributeTypeInfo read fNumericType; @@ -345,25 +346,29 @@ TBoldOclSymbolHelp = class(TBoldMemoryManagedObject) property NumericListType: TBoldListTypeInfo read fNumericListType; property MomentListType: TBoldListTypeInfo read fMomentListType; property StringListType: TBoldListTypeInfo read fStringListType; + property IntegerListType: TBoldListTypeInfo read fIntegerListType; property TypeListType: TBoldListTypeInfo read fTypeListType; property ObjectListType: TBoldListTypeInfo read fObjectListType; - procedure MakeNewNumeric(El: TBoldIndirectElement; value: Double); - procedure MakeNewTime(El: TBoldIndirectElement; value: TDateTime); - procedure MakeNewDateTime(El: TBoldIndirectElement; value: TDateTime); - procedure MakeNewDate(El: TBoldIndirectElement; value: TDateTime); - procedure MakeNewBoolean(El: TBoldIndirectElement; value: Boolean); - procedure MakeNewInteger(El: TBoldIndirectElement; value: integer); - procedure MakeNewString(El: TBoldIndirectElement; const value: string); - procedure MakeNewCurrency(El: TBoldIndirectElement; value: currency); + procedure MakeNewNumeric(El: TBoldOCLNode; value: Double); + procedure MakeNewTime(El: TBoldOCLNode; value: TDateTime); + procedure MakeNewDateTime(El: TBoldOCLNode; value: TDateTime); + procedure MakeNewDate(El: TBoldOCLNode; value: TDateTime); + procedure MakeNewBoolean(El: TBoldOCLNode; value: Boolean); + procedure MakeNewInteger(El: TBoldOCLNode; value: integer); + procedure MakeNewString(El: TBoldOCLNode; const value: string); + procedure MakeNewCurrency(El: TBoldOCLNode; value: currency); + procedure MakeNewNull(el: TBoldOCLNode; NewType: TBoldElementTypeInfo); procedure TransferOrClone(source, dest: TBoldIndirectElement); end; + ShortCircuitType = (csNone, csAnd, csOr, csIf); + { TBoldOclSymbol } TBoldOclSymbol = class(TBoldMemoryManagedObject) private fHelp: TBoldOCLSymbolHelp; fSymbolName: String; - fFormalArguments: TList; + fFormalArguments: array of TBoldElementTypeInfo; fDeduceMethod: TBoldOclDeduceMethod; fResultType: TBoldElementTypeInfo; fIsDotNotation: Boolean; @@ -372,27 +377,28 @@ TBoldOclSymbol = class(TBoldMemoryManagedObject) fArgsNeedCommonType: Boolean; protected procedure InternalInit(const Name: string; - const Args: array of TBoldElementTypeInfo; + Args: array of TBoldElementTypeInfo; DeduceMethod: TBoldOclDeduceMethod; resultType: TBoldElementTypeInfo; IsPostfix: Boolean; HelpContext: integer; ArgsNeedCommonType: Boolean = false); - function GetFormalArguments(index: integer): TBoldElementTypeInfo; - function GetNumberOfArgs: integer; + function GetFormalArguments(index: integer): TBoldElementTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetNumberOfArgs: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure Init; virtual; abstract; - function XBoolean(Elem: TBoldElement): Boolean; - function XCurrency(Elem: TBoldElement): Currency; - function XInteger(Elem: TBoldElement): Integer; - function XList(Elem: TBoldElement): tBoldList; - function XDateTime(Elem: TBoldElement): TDateTime; - function XNumeric(Elem: TBoldElement): Double; - function XString(Elem: TBoldElement): String; - function XType(Elem: TBoldElement): TBoldElementTypeInfo; + class function XBoolean(Elem: TBoldElement): Boolean; static; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + class function XCurrency(Elem: TBoldElement): Currency; static; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + class function XInteger(Elem: TBoldElement): Integer; static; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + class function XList(Elem: TBoldElement): tBoldList; static; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + class function XDateTime(Elem: TBoldElement): TDateTime; static; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + class function XNumeric(Elem: TBoldElement): Double; static; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + class function XString(Elem: TBoldElement): String; static; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + class function XType(Elem: TBoldElement): TBoldElementTypeInfo; static; {$IFDEF BOLD_INLINE} inline; {$ENDIF} property Help: TBoldOclSymbolHelp read fHelp; public constructor Create(Help: TBoldOclSymbolHelp); destructor Destroy; override; + function GetShortCircuitType: ShortCircuitType; virtual; procedure Evaluate(const Params: TBoldOclSymbolParameters); virtual; abstract; procedure SQL(const Args: Array of String; var result: String); virtual; property DeduceMethod: tBoldOclDeduceMethod read fDeduceMethod; @@ -413,90 +419,10 @@ implementation BoldHashIndexes, BoldDefs, BoldOclError, - BoldAttributes, - BoldCoreConsts; - -var - IX_SymbolName: integer = -1; - -constructor TBoldOclNodeList.Create; -begin - inherited; - FList := TList.Create; -end; - -destructor TBoldOclNodeList.Destroy; -begin - FreeAndNil(FList); - inherited; -end; - -function TBoldOclNodeList.GetItem(index: Integer): TBoldOclNode; -begin - Assert((not Assigned(FList[index])) or (tObject(FList[index]) is TBoldOCLNode)); - Result := TBoldOCLNode(FList[index]); -end; - -procedure TBoldOclNodeList.PutItem(index: Integer; Value: TBoldOclNode); -begin - FList[index] := Value; -end; - -function TBoldOclNodeList.Add(Item: TBoldOclNode): Integer; -begin - Result := FList.Add(Item); -end; - -procedure TBoldOclNodeList.Clear; -begin - FList.Clear; -end; - -procedure TBoldOclNodeList.ClearAndFree; -var - I: Integer; -begin - for I := Count - 1 downto 0 do - begin - Items[I].Free; - items[i] := nil; - end; - FList.Clear; -end; - -procedure TBoldOclNodeList.Delete(index: Integer); -begin - FList.Delete(index); - FList.Pack; -end; - -procedure TBoldOclNodeList.Insert(index: Integer; Item: TBoldOclNode); -begin - FList.Insert(index, Item); -end; - -procedure TBoldOclNodeList.Move(CurIndex, NewIndex: Integer); -begin - FList.Move(CurIndex, NewIndex); -end; - -function TBoldOclNodeList.Remove(Item: TBoldOclNode): Integer; -begin - Result := FList.Remove(Item); -end; - -function TBoldOclNodeList.Count: Integer; -begin - Result := FList.Count -end; - -//======================================================================= -//== TBoldOCLNodes and decendants constructors and destructors -//======================================================================= + BoldAttributes; procedure TBoldOclNode.AcceptVisitor(V: TBoldOclVisitor); begin - // Do nothing end; constructor TBoldOclNode.Create; @@ -506,39 +432,33 @@ constructor TBoldOclNode.Create; end; destructor TBoldOclMember.Destroy; +var + i: Integer; begin FreeAndNil(MemberOf); - if assigned(Qualifier) then - Qualifier.Clearandfree; - FreeAndNil(Qualifier); + for i := 0 to Length(Qualifier)- 1 do + Qualifier[i].Free; inherited; end; destructor TBoldOCLCollectionLiteral.Destroy; +var + i: Integer; begin FreeAndNil(RangeStart); FreeAndNil(RangeStop); - if assigned(elements) then - begin - Elements.Clearandfree; - FreeAndNil(Elements) - end; + for i := 0 to Length(Elements) - 1 do + Elements[i].Free; inherited; end; destructor TBoldOclOperation.Destroy; -var I: Integer; +var + I: Integer; begin - if assigned(Args) then - begin - for I := 0 to Args.Count - 1 do - begin - TBoldOclNode(Args[I]).Free; - Args[I] := nil; - end; - FreeAndNil(Args); - end; + for I := 0 to Length(Args) - 1 do + Args[I].Free; inherited; end; @@ -568,9 +488,7 @@ constructor TBoldOclMember.Create; RTInfo := nil; end; -//======================================================================= -//== TBoldOCLNode and descendants Visitor mechanism -//======================================================================= + procedure TBoldOclTypeNode.AcceptVisitor(V: TBoldOclVisitor); begin @@ -662,9 +580,6 @@ procedure TBoldOclVisitor.VisitTBoldOclMomentLiteral(N: TBoldOclMomentLiteral); procedure TBoldOclVisitor.VisitTBoldOclTimeLiteral(N: TBoldOclTimeLiteral); begin end; -//======================================================================= -//== TBoldOCLEnvironment -//======================================================================= constructor TBoldOclEnvironment.Create(OuterScope: TBoldOclEnvironment); begin @@ -674,7 +589,7 @@ constructor TBoldOclEnvironment.Create(OuterScope: TBoldOclEnvironment); fList := TList.Create; end; -destructor TBoldOCLEnvironment.Destroy; +destructor TBoldOCLEnvironment.destroy; var tempBinding: TBoldOclVariableBinding; begin @@ -694,7 +609,6 @@ function TBoldOCLEnvironment.GetCount: integer; procedure TBoldOclEnvironment.pushBinding(B: TBoldOclVariableBinding); begin - b.variableName := uppercase(b.variableName); fList.Add(B); end; @@ -704,14 +618,55 @@ function TBoldOclEnvironment.popBinding: TBoldOclVariableBinding; fList.Delete(Count - 1); end; -function TBoldOclEnvironment.Lookup(S: string): TBoldOclVariableBinding; -var I: Integer; +procedure TBoldOclEnvironment.ReplaceBinding(name: string; + Binding: TBoldOclVariableBinding); +var + i: integer; begin I := fList.Count - 1; - s := uppercase(s); while I >= 0 do begin - if Bindings[I].VariableName = S then + if CompareText(Bindings[I].VariableName, name) = 0 then + begin + TObject(fList.Items[i]).free; + fList.Items[i] := Binding; + exit; + end; + Dec(I); + end; +end; + +procedure TBoldOclEnvironment.RemoveBinding(Binding: TBoldOclVariableBinding); +begin + fList.Remove(Binding); +end; + +procedure TBoldOclEnvironment.RemoveVariable(Variable: TBoldExternalVariable); +var + i: integer; +begin + I := fList.Count - 1; + while I >= 0 do + begin + if Bindings[I] is TBoldOclVariableBindingExternal and (TBoldOclVariableBindingExternal(Bindings[I]).ExternalVariable = Variable) then + begin + Variable.Evaluator := nil; + TObject(fList[i]).free; + fList.Delete(i); + exit; + end; + Dec(I); + end; +end; + +function TBoldOclEnvironment.Find(const S: string): TBoldOclVariableBinding; +var + I: Integer; +begin + I := fList.Count - 1; + while I >= 0 do + begin + if CompareText(Bindings[I].VariableName, s) = 0 then begin Result := Bindings[i]; exit; @@ -724,9 +679,39 @@ function TBoldOclEnvironment.Lookup(S: string): TBoldOclVariableBinding; Result := nil; end; +function TBoldOclEnvironment.Lookup(const S: string): TBoldOclVariableBinding; +var + I: Integer; + ResolvedBinding: TBoldOclVariableBinding; + ExternalVariable: TBoldExternalVariable; +begin + I := fList.Count - 1; + while I >= 0 do + begin + if CompareText(Bindings[I].VariableName, s) = 0 then + begin + Result := Bindings[i]; + if result is TBoldOclVariableBindingExternal then + begin + ExternalVariable := TBoldOclVariableBindingExternal(result).ExternalVariable; + if Assigned(ExternalVariable) then + result.SetReferenceValue(ExternalVariable.Value) + else + result.SetReferenceValue(nil); + end; + exit; + end; + Dec(I); + end; + if assigned(fOuterScope) then + result := fOuterScope.Lookup(S) + else + Result := nil; +end; + function TBoldOclEnvironment.lookupSelf: TBoldOclVariableBinding; begin - Result := Lookup('SELF'); // do not localize + Result := Lookup('SELF'); end; function TBoldOclEnvironment.CurrentImplicitVariable: TBoldOclVariableBinding; @@ -736,7 +721,7 @@ function TBoldOclEnvironment.CurrentImplicitVariable: TBoldOclVariableBinding; function TBoldOclEnvironment.MakeGenSymName: string; begin - Result := IntToStr(GenSymCounter) + '#GenSym'; // do not localize + Result := IntToStr(GenSymCounter) + '#GenSym'; Inc(GenSymCounter); end; @@ -764,16 +749,16 @@ procedure InstallAttribute(const Name: String; var AttrTypeInfo: TBoldAttributeT begin AttrTypeInfo := SystemTypeInfo.AttributeTypeInfoByExpressionName[Name]; if not assigned(AttrTypeINfo) then - SignalError(sMissingOCLType, [Name]); + SignalError('Missing required OCL-type: %s. Update your TypeNameHandle', [Name]); if not assigned(AttrTypeInfo.AttributeClass) then - SignalError(sMissingDelphiType, [Name, AttrTypeInfo.DelphiName]) + SignalError('Missing DelphiType of %s (please install %s)', [Name, AttrTypeInfo.DelphiName]) else begin case exact of true: if AttrTypeInfo.AttributeClass <> AttrClass then - SignalError(sTypeMustBeX, [Name, AttrClass.ClassName, AttrTypeInfo.AttributeClass.ClassName]); + SignalError('The %s type must BE %s (was: %s). Update your TypeNameHandle', [Name, AttrClass.ClassName, AttrTypeInfo.AttributeClass.ClassName]); false: if not AttrTypeInfo.AttributeClass.InheritsFrom(AttrClass) then - SignalError(sTypeMustInheritFromX, [Name, AttrClass.ClassName, AttrTypeInfo.AttributeClass.ClassName]); + SignalError('The %s type must inherit from %s (%s doesn''t).', [Name, AttrClass.ClassName, AttrTypeInfo.AttributeClass.ClassName]); end; end; end; @@ -782,17 +767,17 @@ procedure InstallAttribute(const Name: String; var AttrTypeInfo: TBoldAttributeT inherited create; fSystemTypeInfo := SystemTypeInfo; fTypeType := SystemTypeInfo.BoldType as TBoldTypeTypeInfo; - InstallAttribute('Numeric', fNumericType, TBANumeric, true); // do not localize - InstallAttribute('Float', fRealType, TBAFloat, false); // do not localize - InstallAttribute('String', fStringType, TBAString, false); // do not localize - InstallAttribute('Integer', fIntegerType, TBAInteger, false); // do not localize - InstallAttribute('Boolean', fBooleanType, TBABoolean, false); // do not localize - InstallAttribute('Currency', fCurrencyType, TBACurrency, false); // do not localize - InstallAttribute('Moment', fMomentType, TBAMoment, false); // do not localize - InstallAttribute('Constraint', fConstraintType, TBAConstraint, false); // do not localize - InstallAttribute('Date', fDateType, TBADate, false); // do not localize - InstallAttribute('DateTime', fDateTimeType, TBADateTime, false); // do not localize - InstallAttribute('Time', fTimeType, TBATime, false); // do not localize + InstallAttribute('Numeric', fNumericType, TBANumeric, true); + InstallAttribute('Float', fRealType, TBAFloat, false); + InstallAttribute('String', fStringType, TBAString, false); + InstallAttribute('Integer', fIntegerType, TBAInteger, false); + InstallAttribute('Boolean', fBooleanType, TBABoolean, false); + InstallAttribute('Currency', fCurrencyType, TBACurrency, false); + InstallAttribute('Moment', fMomentType, TBAMoment, false); + InstallAttribute('Constraint', fConstraintType, TBAConstraint, false); + InstallAttribute('Date', fDateType, TBADate, false); + InstallAttribute('DateTime', fDateTimeType, TBADateTime, false); + InstallAttribute('Time', fTimeType, TBATime, false); fObjectType := SystemTypeInfo.RootClassTypeInfo; fListType := SystemTypeInfo.ListTypeInfoByElement[nil]; @@ -801,78 +786,87 @@ procedure InstallAttribute(const Name: String; var AttrTypeInfo: TBoldAttributeT fTypeListType := SystemTypeInfo.ListTypeInfoByElement[TypeType]; fObjectListType := SystemTypeInfo.ListTypeInfoByElement[ObjectType]; fStringListType := SystemTypeInfo.ListTypeInfoByElement[StringType]; + fIntegerListType := SystemTypeInfo.ListTypeInfoByElement[IntegerType]; end; -procedure TBoldOclSymbolHelp.fMakeNew(el: TBoldIndirectElement; NewType: TBoldElementTypeInfo); +procedure TBoldOclSymbolHelp.MakeNew(el: TBoldOCLNode; NewType: TBoldElementTypeInfo); begin - // if we do not own it, or it is not there, then create new element - if not el.OwnsValue or not assigned(el.Value) then + if el.OwnsValue and assigned(el.Value) then + begin + if el.value is TBoldAttribute then + TBoldAttribute(el.Value).RecycleValue; + end + else + begin - if (el is TBoldOCLNode) and - assigned(TBoldOclNode(el).BoldType) and - TBoldOclNode(el).BoldType.ConformsTo(NewType) then - el.SetOwnedValue(CreateNewMember(TBoldOclNode(el).BoldType)) + if assigned(el.BoldType) and + el.BoldType.ConformsTo(NewType) then + el.SetOwnedValue(CreateNewMember(el.BoldType)) else el.SetOwnedValue(CreateNewMember(NewType)) end - else - // always recycle the value, we must tell the rest of the world that this is now a new vlaue. - if el.value is TBoldAttribute then - TBoldAttribute(el.Value).RecycleValue; end; -procedure TBoldOclSymbolHelp.MakeNewNumeric(El: TBoldIndirectElement; value: Double); +procedure TBoldOclSymbolHelp.MakeNewNull(el: TBoldOCLNode; + NewType: TBoldElementTypeInfo); begin - fMakeNew(el, RealType); + MakeNew(el, NewType); + if (el.Value is TBoldAttribute) then + (el.Value as TBoldAttribute).SetToNull; +end; + +procedure TBoldOclSymbolHelp.MakeNewNumeric(El: TBoldOCLNode; value: Double); +begin + MakeNew(el, RealType); Assert(El.Value is TBAFloat); TBAFloat(El.Value).AsFloat := Value; end; -procedure TBoldOclSymbolHelp.MakeNewCurrency(El: TBoldIndirectElement; value: currency); +procedure TBoldOclSymbolHelp.MakeNewCurrency(El: TBoldOCLNode; value: currency); begin - fMakeNew(el, CurrencyType); + MakeNew(el, CurrencyType); Assert(El.Value is TBACurrency); TBACurrency(El.Value).Ascurrency := Value; end; -procedure TBoldOclSymbolHelp.MakeNewString(El: TBoldIndirectElement; const value: String); +procedure TBoldOclSymbolHelp.MakeNewString(El: TBoldOCLNode; const value: String); begin - fMakeNew(el, StringType); + MakeNew(el, StringType); Assert(El.Value is TBAString); TBAString(El.Value).AsString := Value; end; -procedure TBoldOclSymbolHelp.MakeNewInteger(El: TBoldIndirectElement; value: integer); +procedure TBoldOclSymbolHelp.MakeNewInteger(El: TBoldOCLNode; value: integer); begin - fMakeNew(el, Integertype); + MakeNew(el, Integertype); Assert(El.Value is TBAInteger); TBAInteger(El.Value).AsInteger := Value; end; -procedure TBoldOclSymbolHelp.MakeNewTime(El: TBoldIndirectElement; value: TDateTime); +procedure TBoldOclSymbolHelp.MakeNewTime(El: TBoldOCLNode; value: TDateTime); begin - fMakeNew(el, TimeType); + MakeNew(el, TimeType); Assert(El.Value is TBATime); TBATime(El.Value).AsTime := Value; end; -procedure TBoldOclSymbolHelp.MakeNewDateTime(El: TBoldIndirectElement; value: TDateTime); +procedure TBoldOclSymbolHelp.MakeNewDateTime(El: TBoldOCLNode; value: TDateTime); begin - fMakeNew(el, DateTimeType); + MakeNew(el, DateTimeType); Assert(El.Value is TBADateTime); TBADateTime(El.Value).AsDateTime := Value; end; -procedure TBoldOclSymbolHelp.MakeNewDate(El: TBoldIndirectElement; value: TDateTime); +procedure TBoldOclSymbolHelp.MakeNewDate(El: TBoldOCLNode; value: TDateTime); begin - fMakeNew(el, DateType); + MakeNew(el, DateType); Assert(El.Value is TBADate); TBADate(El.Value).AsDate := Value; end; -procedure TBoldOclSymbolHelp.MakeNewBoolean(El: TBoldIndirectElement; value: Boolean); +procedure TBoldOclSymbolHelp.MakeNewBoolean(El: TBoldOCLNode; value: Boolean); begin - fMakeNew(el, BooleanType); + MakeNew(el, BooleanType); Assert(El.Value is TBABoolean); TBABoolean(El.Value).AsBoolean := Value; end; @@ -892,20 +886,20 @@ procedure TBoldOclSymbolHelp.TransferorClone(source, dest: TBoldIndirectElement) {-- TBoldOclSymbol -- } procedure TBoldOclSymbol.InternalInit(const Name: string; - const Args: array of TBoldElementTypeInfo; + Args: array of TBoldElementTypeInfo; DeduceMethod: TBoldOclDeduceMethod; resultType: TBoldElementTypeInfo; IsPostfix: Boolean; HelpContext: Integer; ArgsNeedCommonType: Boolean = false); var - i: integer; + i:Integer; begin fSymbolName := Name; fHelpContext := HelpContext; - for i := 0 to High(Args) do - fFormalArguments.Add(Args[i]); - + SetLength(fFormalArguments, Length(args)); + for i := 0 to Length(args) - 1 do + fFormalArguments[i] := args[i]; if assigned(ResultType) then fResultType := ResultType else @@ -916,12 +910,17 @@ procedure TBoldOclSymbol.InternalInit(const Name: string; function TBoldOclSymbol.GetFormalArguments(index: integer): TBoldElementTypeInfo; begin - result := TBoldElementTypeInfo(fFormalArguments[index]); + result := fFormalArguments[index]; end; function TBoldOclSymbol.GetNumberOfArgs: integer; begin - result := fFormalArguments.Count; + result := Length(fFormalArguments); +end; + +function TBoldOclSymbol.GetShortCircuitType: ShortCircuitType; +begin + Result := csNone; end; procedure TBoldOclSymbol.SQL(const Args: Array of String; var result: String); @@ -933,7 +932,6 @@ constructor TBoldOclSymbol.Create(Help: TBoldOclSymbolHelp); begin Inherited create; fHelp := help; - fFormalArguments := TList.create; Init; fIsDotNotation := isPostFix and (not assigned(FormalArguments[0]) or @@ -942,11 +940,10 @@ constructor TBoldOclSymbol.Create(Help: TBoldOclSymbolHelp); destructor TBoldOclSymbol.Destroy; begin - FreeAndNil(fFormalArguments); inherited; end; -function TBoldOclSymbol.XBoolean(Elem: TBoldElement): Boolean; +class function TBoldOclSymbol.XBoolean(Elem: TBoldElement): Boolean; begin if elem is TBABoolean then result := TBABoolean(Elem).AsBoolean @@ -954,7 +951,7 @@ function TBoldOclSymbol.XBoolean(Elem: TBoldElement): Boolean; result := false; end; -function TBoldOclSymbol.XInteger(Elem: TBoldElement): Integer; +class function TBoldOclSymbol.XInteger(Elem: TBoldElement): Integer; begin if (elem is TBAInteger) and not TBAInteger(elem).IsNull then result := TBAInteger(Elem).AsInteger @@ -962,7 +959,7 @@ function TBoldOclSymbol.XInteger(Elem: TBoldElement): Integer; result := 0; end; -function TBoldOclSymbol.XDateTime(Elem: TBoldElement): TDateTime; +class function TBoldOclSymbol.XDateTime(Elem: TBoldElement): TDateTime; begin if elem is TBADate then result := TBADate(Elem).AsDate @@ -974,7 +971,7 @@ function TBoldOclSymbol.XDateTime(Elem: TBoldElement): TDateTime; result := 0; end; -function TBoldOclSymbol.XNumeric(Elem: TBoldElement): Double; +class function TBoldOclSymbol.XNumeric(Elem: TBoldElement): Double; begin if elem is TBANumeric then result := TBANumeric(Elem).AsFloat @@ -982,7 +979,7 @@ function TBoldOclSymbol.XNumeric(Elem: TBoldElement): Double; result := 0; end; -function TBoldOclSymbol.Xcurrency(Elem: TBoldElement): currency; +class function TBoldOclSymbol.Xcurrency(Elem: TBoldElement): currency; begin if elem is TBACurrency then result := TBACurrency(Elem).Ascurrency @@ -990,7 +987,7 @@ function TBoldOclSymbol.Xcurrency(Elem: TBoldElement): currency; result := 0; end; -function TBoldOclSymbol.XString(Elem: TBoldElement): String; +class function TBoldOclSymbol.XString(Elem: TBoldElement): String; begin if assigned(elem) then result := Elem.AsString @@ -998,7 +995,7 @@ function TBoldOclSymbol.XString(Elem: TBoldElement): String; result := ''; end; -function TBoldOclSymbol.XType(Elem: TBoldElement): TBoldElementTypeInfo; +class function TBoldOclSymbol.XType(Elem: TBoldElement): TBoldElementTypeInfo; begin if elem is TBoldElementTypeInfo then result := TBoldElementTypeInfo(Elem) @@ -1006,7 +1003,7 @@ function TBoldOclSymbol.XType(Elem: TBoldElement): TBoldElementTypeInfo; result := nil; end; -function TBoldOclSymbol.XList(Elem: TBoldElement): tBoldList; +class function TBoldOclSymbol.XList(Elem: TBoldElement): tBoldList; begin if elem is TBoldList then result := TBoldList(Elem) @@ -1036,7 +1033,7 @@ constructor TBoldSymbolDictionary.Create(SystemTypeInfo: TBoldSystemTypeInfo; Bo SetIndexVariable(IX_SymbolName, AddIndex(TSymbolNameIndex.Create)); end; -destructor TBoldSymbolDictionary.Destroy; +destructor TBoldSymbolDictionary.destroy; begin FreeAndNil(fHelp); inherited; @@ -1044,7 +1041,7 @@ destructor TBoldSymbolDictionary.Destroy; function TBoldSymbolDictionary.GetSymbol(const Name: string): TBoldOclSymbol; begin - Result := TBoldOclSymbol(TSymbolNameIndex(indexes[IX_SymbolName]).FindByString(Name));; + Result := TBoldOclSymbol(TBoldStringHashIndex(indexes[IX_SymbolName]).FindByString(Name)); end; function TBoldSymbolDictionary.GetSymbolByIndex(index: Integer): TBoldOclSymbol; @@ -1066,6 +1063,18 @@ function TBoldOclEnvironment.GetBindings( result := TBoldOclVariableBinding(fList[index]) end; +function TBoldOclEnvironment.GetBindingsAsCommaText: string; +var + i: integer; + sl: TStringList; +begin + sl := TStringList.Create; + for I := 0 to Count - 1 do + Sl.Add(Bindings[i].VariableName); + result := sl.commaText; + sl.free; +end; + { TBoldOCLMomentLiteral } procedure TBoldOCLMomentLiteral.AcceptVisitor(V: TBoldOclVisitor); @@ -1107,10 +1116,39 @@ procedure TBoldOclTimeLiteral.SetDateTimeValue(const Value: TDateTime); fDateTimeValue := Value; end; -destructor TBoldOCLListCoercion.Destroy; +destructor TBoldOCLListCoercion.destroy; begin FreeAndNil(Child); inherited; end; +{ TBoldOclVariableBindingExternal } + +destructor TBoldOclVariableBindingExternal.Destroy; +begin + inherited; +end; + +function TBoldOclVariableBindingExternal.GetBoldType: TBoldElementTypeInfo; +begin + if Assigned(ExternalVariable) then + result := ExternalVariable.ValueType + else + result := nil; +end; + +{$WARNINGS OFF} +procedure InitDebugMethods; +var + env: TBoldOclEnvironment; +begin + Exit; + env.BindingsAsCommaText; // This is used to force compiler to include BindingsAsCommaText +end; +{$WARNINGS ON} + +initialization + TBoldSymbolDictionary.IX_SymbolName := -1; + InitDebugMethods; + end. diff --git a/Source/ObjectSpace/Ocl/BoldOclConstructors.inc b/Source/ObjectSpace/Ocl/BoldOclConstructors.inc index 5914d028..7adabf1d 100644 --- a/Source/ObjectSpace/Ocl/BoldOclConstructors.inc +++ b/Source/ObjectSpace/Ocl/BoldOclConstructors.inc @@ -2,22 +2,22 @@ function MakeList( First : AYaccStackElement; Offs : integer ) : AYaccStackElement; begin - result := AYaccStackElement.CreateOffs( offs ); - result.List := TList.Create; - Result.List.Add( First.Clone ); + result := AYaccStackElement.CreateOffs( offs ); + result.List := TList.Create; + Result.List.Add( First.Clone ); end; function PushList( First, List : AYaccStackElement; Offs : integer ) : AYaccStackElement; begin - result := AYaccStackElement.CreateOffs( Offs ); - result.list := list.list; - result.list.insert( 0, first.clone ); + result := AYaccStackElement.CreateOffs( Offs ); + result.list := list.list; + result.list.insert( 0, first.clone ); end; function MakeEmptyList : AYaccStackElement; begin - result := AYaccStackElement.CreateOffs( 0 ); - result.List := TList.Create; + result := AYaccStackElement.CreateOffs( 0 ); + result.List := TList.Create; end; procedure ReleaseList( List : AYaccStackElement ); @@ -28,61 +28,70 @@ procedure ReleaseList( List : AYaccStackElement ); var i : integer; begin - if assigned( LIst.LIst ) then begin - for i := 0 to list.list.count-1 do begin - AYaccStackElement( List.List[i] ).free; - end; - list.list.free; - end; + if assigned( LIst.LIst ) then begin + for i := 0 to list.list.count-1 do begin + AYaccStackElement( List.List[i] ).free; + end; + list.list.free; + end; end; procedure RetrieveNodeList( ParseList : AYaccStackElement; var NodeList : TBoldOCLNodeList ); var - i : integer; + i, OldLength : integer; begin - if not assigned( ParseList ) then exit; - if assigned( ParseList.List ) then begin - if not assigned( Nodelist ) then - Nodelist := TBoldOCLNodeList.create; - for i := 0 to ParseList.List.Count-1 do - Nodelist.Add( AYaccStackElement( ParseList.List[i] ).Node ); - ReleaseList( ParseList ); - end; + if not assigned( ParseList ) then exit; + if assigned( ParseList.List ) then + begin + OldLength := Length(Nodelist); + SetLength(NodeList, OldLength + ParseList.List.Count); + for i := 0 to ParseList.List.Count-1 do + Nodelist[i+OldLength] := AYaccStackElement( ParseList.List[i] ).Node ; + ReleaseList( ParseList ); + end; end; function Make1Operation( const OpName : String; arg1 : AYaccStackElement; Offs : integer ) : AYaccStackElement; +var + OP: TBoldOclOperation; begin - result := AYaccStackElement.CreateOffs( Arg1.Offset ); - result.Node := TBoldOclOperation.Create; - Result.Node.Position := Offs; - TBoldOclOperation( result.Node ).args := TBoldOCLNodeList.create; - TBoldOclOperation( result.Node ).args.add( arg1.Node ); - TBoldOclOperation( result.Node ).OperationName := OpName; + result := AYaccStackElement.CreateOffs( Arg1.Offset ); + OP:= TBoldOclOperation.Create; + result.Node := OP; + Result.Node.Position := Offs; + SetLength(OP.args,1); + OP.args[0] := arg1.Node; + OP.OperationName := OpName; end; function Make2Operation(const OpName : String; arg1, arg2 : AYaccStackElement; Offs : integer ) : AYaccStackElement; +var + OP: TBoldOclOperation; begin - result := AYaccStackElement.CreateOffs( offs ); - result.Node := TBoldOclOperation.Create; - Result.Node.Position := Offs; - TBoldOclOperation( result.Node ).args := TBoldOClNodeList.create; - TBoldOclOperation( result.Node ).args.add( arg1.Node ); - TBoldOclOperation( result.Node ).args.add( arg2.Node ); - TBoldOclOperation( result.Node ).OperationName := OpName; + result := AYaccStackElement.CreateOffs( offs ); + OP:= TBoldOclOperation.Create; + result.Node := OP; + Result.Node.Position := Offs; + SetLength(OP.args,2); + OP.args[0] := arg1.Node; + OP.args[1] := arg2.Node; + OP.OperationName := OpName; end; function Make3Operation(const OpName : String; arg1, arg2, arg3 : AYaccStackElement; Offs : integer ) : AYaccStackElement; +var + OP: TBoldOclOperation; begin - result := AYaccStackElement.CreateOffs( offs ); - result.Node := TBoldOclOperation.Create; - Result.Node.Position := Offs; - - TBoldOclOperation( result.Node ).args := TBoldOCLNodeList.create; - TBoldOclOperation( result.Node ).args.add( arg1.Node ); - TBoldOclOperation( result.Node ).args.add( arg2.Node ); - TBoldOclOperation( result.Node ).args.add( arg3.Node ); - TBoldOclOperation( result.Node ).OperationName := OpName; + result := AYaccStackElement.CreateOffs( offs ); + OP:= TBoldOclOperation.Create; + result.Node := OP; + Result.Node.Position := Offs; + SetLength(OP.args,3); + OP.args[0] := arg1.Node; + OP.args[1] := arg2.Node; + OP.args[2] := arg3.Node; + OP.OperationName := OpName; end; function MakeUnaryMinus(const OpName : String; arg1 : AYaccStackElement; Offs : integer ) : AYaccStackElement; @@ -120,16 +129,25 @@ end; function MakeName( Name : AYaccStackElement; Offs : integer ) : AYaccStackElement; begin - result := AYaccStackElement.CreateOffs( Offs ); - Result.Name := BoldSharedStringManager.GetSharedString(Name.Lexeme.Buffer); - if Result.Name[1] in ['A'..'Z'] then Result.NameIsType := true; + result := AYaccStackElement.CreateOffs( Offs ); + {$IFDEF BOLD_UNICODE} + Result.Name := BoldSharedStringManager.GetSharedString(string(AnsiString(Name.Lexeme.Buffer))); + if CharInSet(Result.Name[1], ['A'..'Z']) then Result.NameIsType := true; + {$ELSE} + Result.Name := BoldSharedStringManager.GetSharedString(Name.Lexeme.Buffer); + if Result.Name[1] in ['A'..'Z'] then Result.NameIsType := true; + {$ENDIF} end; function MakeDeclarator( VarName, VarType : AYaccStackElement; Offs : integer ) : AYaccStackElement; begin result := AYaccStackElement.CreateOffs( Offs ); if assigned( varName ) then - result.Name := BoldSharedStringManager.GetSharedString(VarName.Lexeme.Buffer); + {$IFDEF BOLD_UNICODE} + result.Name := BoldSharedStringManager.GetSharedString(string(AnsiString(VarName.Lexeme.Buffer))); + {$ELSE} + result.Name := BoldSharedStringManager.GetSharedString(string(AnsiString(VarName.Lexeme.Buffer))); + {$ENDIF} if assigned( varType ) then begin result.DeclaratorTypeList := VarType.List; result.SimpleTypeSpecifierIsEnum := VarType.SimpleTypeSpecifierIsEnum; @@ -157,7 +175,6 @@ begin LiteralCollection.RangeStop := ExprListOrRange.Stop; end else begin LiteralCollection.IsRange := false; - LiteralCollection.Elements := TBoldOCLNodeList.Create; RetrieveNodeList( ExprListOrRange, LiteralCollection.Elements ); end; @@ -198,9 +215,13 @@ begin // value := TBAString.Create(nil); if assigned( Str ) then begin + {$IFDEF BOLD_UNICODE} + s := string(AnsiString(Str.Lexeme.Buffer)); + {$ELSE} s := Str.Lexeme.Buffer; - s := StringReplace(s, '\''', '''', [rfReplaceAll]); - s := StringReplace(s, '\\', '\', [rfReplaceAll]); + {$ENDIF} + s := StringReplace(s, '\''', '''', [rfReplaceAll]); + s := StringReplace(s, '\\', '\', [rfReplaceAll]); Node.StrValue := BoldSharedStringManager.GetSharedString(s); end else @@ -218,7 +239,11 @@ begin node := TBoldOCLIntLiteral.create; // value := TBAInteger.Create(nil); try + {$IFDEF BOLD_UNICODE} + Node.IntValue := StrToInt( string(AnsiString(Int.Lexeme.Buffer)) ); + {$ELSE} Node.IntValue := StrToInt( Int.Lexeme.Buffer ); + {$ENDIF} // value.MakeImmutable; except on eConvertError do @@ -232,13 +257,23 @@ end; function MakeLiteralDate(Date: AYaccStackElement; Offs: integer ) : AYaccStackElement; var node : TBoldOCLDateLiteral; + {$IFDEF BOLD_UNICODE} + sDate: string; + {$ENDIF} y, m, d: integer; begin result := AYaccStackElement.CreateOffs( offs ); node := TBoldOCLDateLiteral.create; + {$IFDEF BOLD_UNICODE} + sDate := string(AnsiString(Date.lexeme.buffer)); + y := StrToInt(copy(sDate, 2, 4)); + m := StrToInt(copy(sDate, 7, 2)); + d := StrToInt(copy(sDate, 10, 2)); + {$ELSE} y := StrToInt(copy(Date.lexeme.buffer, 2, 4)); m := StrToInt(copy(Date.lexeme.buffer, 7, 2)); d := StrToInt(copy(Date.lexeme.buffer, 10, 2)); + {$ENDIF} try Node.DateValue := EncodeDate(y, m, d); except @@ -251,16 +286,26 @@ end; function MakeLiteralTime(Time: AYaccStackElement; Offs: integer ) : AYaccStackElement; var - node : TBoldOCLDateLiteral; + node : TBoldOCLTimeLiteral; + {$IFDEF BOLD_UNICODE} + sTime: string; + {$ENDIF} h, m, s: integer; begin result := AYaccStackElement.CreateOffs( offs ); - node := TBoldOCLDateLiteral.create; + node := TBoldOCLTimeLiteral.create; + {$IFDEF BOLD_UNICODE} + sTime := string(AnsiString(Time.lexeme.buffer)); + h := StrToInt(copy(sTime, 2, 2)); + m := StrToInt(copy(sTime, 5, 2)); + s := StrToIntDef(copy(sTime, 8, 2), 0); + {$ELSE} h := StrToInt(copy(Time.lexeme.buffer, 2, 2)); m := StrToInt(copy(Time.lexeme.buffer, 5, 2)); s := StrToIntDef(copy(Time.lexeme.buffer, 8, 2), 0); + {$ENDIF} try - Node.DateValue := EncodeTime(h, m, s, 0); + Node.TimeValue := EncodeTime(h, m, s, 0); except on eConvertError do raise EBoldOCLAbort.CreateFmt( boeConversionError, [offs, Time.Lexeme.Buffer, 'Time']); @@ -281,12 +326,19 @@ begin node := TBoldOCLNumericLiteral.create; // value := TBAFloat.Create(nil); try + {$IFDEF BOLD_UNICODE} + TempFloatString := string(AnsiString(Float.Lexeme.Buffer)); + {$ELSE} TempFloatString := Float.Lexeme.Buffer; - if FormatSettings.DecimalSeparator <> '.' then TempFloatString[POs('.', TempFloatString)] := FormatSettings.DecimalSeparator; + {$ENDIF} + if {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}DecimalSeparator <> '.' then + begin + TempFloatString[POs('.', TempFloatString)] := {$IFDEF BOLD_DELPHI16_OR_LATER}FormatSettings.{$ENDIF}DecimalSeparator; + end; Node.FloatValue := StrTofloat( TempFloatString ); except on eConvertError do begin - raise EBoldOCLAbort.CreateFmt( boeConversionError, [offs, Float.Lexeme.Buffer, 'real']); + raise EBoldOCLAbort.CreateFmt( boeConversionError, [offs, Float.Lexeme.Buffer, 'real']); end; end; result.node := node; @@ -449,10 +501,10 @@ begin ReleaseList( Name ); end; - TBoldOclOperation( Result.Node ).args := TBoldOCLNodeList.Create; + SetLength(TBoldOclOperation( Result.Node ).args, 1); if assigned( Context ) then - TBoldoclOperation( Result.Node ).Args.Add( Context.Node ) + TBoldoclOperation( Result.Node ).Args[0] := Context.Node else raise EBoldOCLAbort.CreateFmt( boeOperationWithOutContext, [offs]); diff --git a/Source/ObjectSpace/Ocl/BoldOclError.pas b/Source/ObjectSpace/Ocl/BoldOclError.pas index 97ceafc9..cd893386 100644 --- a/Source/ObjectSpace/Ocl/BoldOclError.pas +++ b/Source/ObjectSpace/Ocl/BoldOclError.pas @@ -1,10 +1,12 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOclError; interface uses SysUtils, - Classes, BoldDefs; resourceString @@ -42,7 +44,6 @@ interface boeVariableNotAssigned = '%d:This variable (%s) has no value or type'; boeSubscribeBeforeEval = '%d:You can not subscribe to an expression that has not been evaluated'; boeCollectionNotValidLiteral = '%d:You can not create a literal of type "Collection", try Set, Sequence or Bag instead'; -// boeTryingMemberOfNilPtr = '%d:Trying to take a member of a nil-reference'; boeElementnotConformToCollection = '%d:All elements in a collection literal must conform to a common type, this one doesn''t'; boeRangeMustBeInt = '%d:Ranges can only consist of integers'; boeInvalidCharacter = '%d:Expression contains an invalid character'; @@ -58,6 +59,7 @@ interface boeMemberofType = '%d:Types can not have members (tried %s.%s)'; boeMemberofAttr = '%d:Attributes can not have members (tried %s.%s)'; boeEnvSizeError = '%d:Started with %d vars, ended up with %d...'; + boeEnumValueNotFound = '%d:Enum value (%s) not found in any registed ValueSet'; {//} boeunknownExprtypeinDeduce = '%d:Unable to deduce type of expression ' + BOLDCRLF + {//} 'Operation: %s ' + BOLDCRLF + {//} '%s' + BOLDCRLF + @@ -65,10 +67,7 @@ interface boeOperationNotOclable = '%d:Operation %s is not OCLCompatible'; - // BoldOCLRunTimeErrors -// borteFirstOnEmptyList = 'Tried to take first element of an empty list'; -// borteLastOnEmptyList = 'Tried to take last element of an empty list'; borteAtIndexOutOfBounds = '%d:Tried to take element #%d of a list with %d elements'; borteDivisionByZero = '%d:Division By Zero'; borteInvalidCast = '%d:Invalid OCL-cast, tried to cast a %s to a %s'; @@ -82,7 +81,6 @@ interface type EBoldOCLAbort = class(EAbort) -// EBoldOCLAbort = class(Exception) public Position: integer; Ocl: String; @@ -107,6 +105,7 @@ EBoldOclRunTimeError = class(EBoldOclError); implementation + procedure EBoldOClAbort.FixError; begin if not errorFixed then @@ -149,4 +148,3 @@ function EBoldOClError.ErrorPointer: String; end; end. - diff --git a/Source/ObjectSpace/Ocl/BoldOclEvaluator.pas b/Source/ObjectSpace/Ocl/BoldOclEvaluator.pas index c5e86e50..f1309024 100644 --- a/Source/ObjectSpace/Ocl/BoldOclEvaluator.pas +++ b/Source/ObjectSpace/Ocl/BoldOclEvaluator.pas @@ -1,9 +1,11 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOclEvaluator; interface uses - Classes, BoldSystem, BoldSystemRT, BoldElements, @@ -21,6 +23,8 @@ TBoldOclEvaluatorVisitor = class(TBoldOclVisitor) fTimeType: TBoldAttributeTypeInfo; fDateType: TBoldAttributeTypeInfo; fFloatType: TBoldAttributeTypeInfo; + fBooleanType: TBoldAttributeTypeInfo; + fTrueBool: TBABoolean; CurrentSystem: tBoldSystem; fResubscribeAll: Boolean; function MakeNewString: TBAString; @@ -30,7 +34,7 @@ TBoldOclEvaluatorVisitor = class(TBoldOclVisitor) function MakeNewFloat: TBAFloat; function CreateNewMember(BoldType: TBoldElementTypeInfo): TBoldMember; public - constructor Create(Subscriber: TBoldSubscriber; ResubscribeAll: Boolean; SystemTypeInfo: TBoldSystemTypeInfo; BoldSystem: TBoldSystem; StringType, IntegerType, FloatType, DateType, TimeType: TBoldAttributeTypeInfo); + constructor Create(Subscriber: TBoldSubscriber; ResubscribeAll: Boolean; SystemTypeInfo: TBoldSystemTypeInfo; BoldSystem: TBoldSystem; TrueBool: TBABoolean; BooleanType, StringType, IntegerType, FloatType, DateType, TimeType: TBoldAttributeTypeInfo); procedure VisitTBoldOclListCoercion(N: TBoldOclListCoercion); override; procedure VisitTBoldOclMethod(N: TBoldOclmethod); override; @@ -38,27 +42,31 @@ TBoldOclEvaluatorVisitor = class(TBoldOclVisitor) procedure VisitTBoldOclIteration(N: TBoldOclIteration); override; procedure VisitTBoldOclMember(N: TBoldOclMember); override; procedure VisitTBoldOclVariableReference(N: TBoldOclVariableReference); override; - procedure VisitTBoldOclEnumLiteral(N: TBoldOclEnumLiteral); override; + procedure VisitTBoldOclENumLiteral(N: TBoldOclEnumLiteral); override; procedure VisitTBoldOclStrLiteral(N: TBoldOclStrLiteral); override; procedure VisitTBoldOclNumericLiteral(N: TBoldOclNumericLiteral); override; procedure VisitTBoldOclDateLiteral(N: TBoldOclDateLiteral); override; procedure VisitTBoldOclTimeLiteral(N: TBoldOclTimeLiteral); override; procedure VisitTBoldOclIntLiteral(N: TBoldOclIntLiteral); override; - procedure VisitTBoldOclCollectionLiteral(N: TBoldOclCollectionLiteral); override; + procedure VisitTBoldOclCollectionLIteral(N: TBoldOclCollectionLiteral); override; procedure SubScribeToElem(N: TBoldOclNode); end; +var + OclUseTemporaryDummyValue: boolean = true; + implementation uses + Classes, SysUtils, - BoldUtils, BoldDefs, BoldOclError, - BoldBase, - BoldCoreConsts; + BoldContainers, + BoldBase; -constructor TBoldOclEvaluatorVisitor.Create(Subscriber: TBoldSubscriber; ResubscribeAll: Boolean; SystemTypeInfo: TBoldSystemTypeInfo; BoldSystem: TBoldSystem; StringType, IntegerType, FloatType, DateType, TimeType: TBoldAttributeTypeInfo); +constructor TBoldOclEvaluatorVisitor.Create(Subscriber: TBoldSubscriber; ResubscribeAll: Boolean; SystemTypeInfo: TBoldSystemTypeInfo; + BoldSystem: TBoldSystem; TrueBool: TBABoolean; BooleanType, StringType, IntegerType, FloatType, DateType, TimeType: TBoldAttributeTypeInfo); begin inherited Create; CurrentSubscriber := Subscriber; @@ -69,10 +77,12 @@ constructor TBoldOclEvaluatorVisitor.Create(Subscriber: TBoldSubscriber; Resubsc fFloatType := FloatType; fDAteType := DateType; fTimeType := TimeType; + fBooleanType := BooleanType; + fTrueBool := TrueBool; fResubscribeAll := ResubscribeAll; end; -function MapResubscribe(Resubscribe: Boolean): TBoldRequestedEvent; +function MapResubscribe(Resubscribe: Boolean): TBoldRequestedEvent; {$IFDEF BOLD_INLINE} inline; {$ENDIF} begin if Resubscribe then Result := breReSubscribe @@ -81,56 +91,91 @@ function MapResubscribe(Resubscribe: Boolean): TBoldRequestedEvent; end; type - TBoldOCLSortClass = class(TBoldMemoryManagedObject) + PBoldOCLSortData = ^TBoldOCLSortData; + TBoldOCLSortData = record SortArg: TBoldElement; SortObj: TBoldElement; end; + TBoldOCLSortArray = class(TBoldArray) + private + function Get(Index: Integer): TBoldOCLSortData; + procedure Put(Index: Integer; Item: TBoldOCLSortData); + protected + function GetItemSize: Integer; override; + public + property Items[Index: Integer]: TBoldOCLSortData read Get write Put; default; + end; + +function TBoldOCLSortArray.Get(Index: Integer): TBoldOCLSortData; +begin + inherited Get(Index,Result); +end; + +function TBoldOCLSortArray.GetItemSize: Integer; +begin + Result := SizeOf(TBoldOCLSortData); +end; + +procedure TBoldOCLSortArray.Put(Index: Integer; Item: TBoldOCLSortData); +begin + inherited Put(Index, Item); +end; + function BoldOCLInternalSortWrapper(Item1, Item2: Pointer): Integer; begin - Result := TBoldOCLSortClass(Item1).SortArg.CompareTo(TBoldOCLSortClass(Item2).SortArg); + Result := PBoldOCLSortData(Item1).SortArg.CompareTo(PBoldOCLSortData(Item2).SortArg); end; function BoldOCLInternalReverseSortWrapper(Item1, Item2: Pointer): Integer; begin - Result := - TBoldOCLSortClass(Item1).SortArg.CompareTo(TBoldOCLSortClass(Item2).SortArg); + Result := - PBoldOCLSortData(Item1).SortArg.CompareTo(PBoldOCLSortData(Item2).SortArg); end; procedure Sortlist(Node: TBoldOclIteration; BoldList: TBoldList; SortKeyHolder: TBoldIndirectElement; Order: TBoldOclIteratorSpecifier); var - Sortlist: TList; - SortObj: TBoldOCLSortClass; + SortList: TBoldOCLSortArray; + SortData: TBoldOCLSortData; i : Integer; arglist: TBoldList; NewList: TBoldList; begin - arglist := SortKeyHolder.Value as TBoldList; - Sortlist := TList.Create; - for i := 0 to BoldList.Count - 1 do begin - SortObj := TBoldOCLSortClass.Create; - SortObj.SortArg := arglist[i]; - SortObj.SortObj := BoldList[i]; - Sortlist.Add(Pointer(SortObj)); - end; + case BoldList.Count of + 0: ; + 1: (node.Value as TBoldList).Add(BoldList[0]); + else + begin + arglist := SortKeyHolder.Value as TBoldList; + SortList := TBoldOCLSortArray.Create(BoldList.Count, []); + try + SortList.Count := BoldList.Count; + for i := 0 to BoldList.Count - 1 do begin + SortData.SortArg := ArgList[i]; + SortData.SortObj := BoldList[i]; + SortList[i] := SortData; + end; - case Order of - OclOrderBy: Sortlist.SORT(BoldOCLInternalSortWrapper); - OclOrderDescending: Sortlist.SORT(BoldOCLInternalReverseSortWrapper); - end; + case Order of + OclOrderBy: SortList.Sort(BoldOCLInternalSortWrapper); + OclOrderDescending: SortList.Sort(BoldOCLInternalReverseSortWrapper); + end; - NewList := node.Value as TBoldLIst; + NewList := node.Value as TBoldLIst; - for i := 0 to BoldList.Count - 1 do begin - NewList.Add(TBoldOCLSortClass(Sortlist[i]).SortObj); - TBoldOCLSortClass(Sortlist[i]).Free; + for i := 0 to BoldList.Count - 1 do begin + SortData := SortList[i]; + NewList.Add(SortData.SortObj); + end; + finally + Sortlist.Free; + end; + end; end; - Sortlist.Free; end; procedure TBoldOclEvaluatorVisitor.SubScribeToElem(N: TBoldOclNode); begin - // to avoid putting a default-subscribe on objects (which will subscribe to all members - // if n.resubscribe and (n.value is TBoldObject) then exit; + if assigned(N.Value) and assigned(CurrentSubscriber) and not n.OwnsValue then N.Value.DefaultSubscribe(CurrentSubscriber, MapResubscribe(N.Resubscribe or fResubscribeAll)) end; @@ -171,56 +216,63 @@ procedure TBoldOclEvaluatorVisitor.VisitTBoldOclmethod(N: TBoldOclMethod); end; procedure TBoldOclEvaluatorVisitor.VisitTBoldOclOperation(N: TBoldOclOperation); + + procedure ClearIfReferenced(ie: TBoldIndirectElement); + begin + if not ie.OwnsValue then + ie.SetReferenceValue(nil); + + end; var i : Integer; backupResubscribeAll: Boolean; OperationParams: TBoldOclSymbolParameters; + ArgI: TBoldOclNode; begin - if SameText(N.OperationName, 'if') then // do not localize - begin - backupResubscribeAll := fResubscribeAll; - fResubscribeAll := True; - N.Args[0].AcceptVisitor(self); - fResubscribeAll := backupResubscribeAll; - if assigned(n.args[0].value) and (N.Args[0].Value as TBABoolean).AsBoolean then - N.Args[1].AcceptVisitor(self) - else - N.Args[2].AcceptVisitor(self); - end - else if SameText(N.OperationName, 'except') then // do not localize - begin - backupResubscribeAll := fResubscribeAll; - fResubscribeAll := True; - try + case N.Symbol.GetShortCircuitType of + csIf: + begin + backupResubscribeAll := fResubscribeAll; + fResubscribeAll := True; N.Args[0].AcceptVisitor(self); - N.Args[0].TransferValue(N); - except - // if an exception occurs, go for the alternative and silence the exception - N.Args[1].AcceptVisitor(self); - N.Args[1].TransferValue(N); + fResubscribeAll := backupResubscribeAll; + if assigned(n.args[0].value) and (N.Args[0].Value as TBABoolean).AsBoolean then + begin + N.Args[1].AcceptVisitor(self); + ClearIfReferenced(N.Args[2]); + end + else + begin + N.Args[2].AcceptVisitor(self); + ClearIfReferenced(N.Args[1]); + end; + end; + + csOr: + begin + fResubscribeAll := True; + N.Args[0].AcceptVisitor(self); + if (not assigned(n.args[0].value)) or not (N.Args[0].Value as TBABoolean).AsBoolean then + N.Args[1].AcceptVisitor(self) + else + ClearIfReferenced(N.Args[1]); + end; + + csAnd: + begin + fResubscribeAll := True; + N.Args[0].AcceptVisitor(self); + if assigned(n.args[0].value) and (N.Args[0].Value as TBABoolean).AsBoolean then + N.Args[1].AcceptVisitor(self) + else + ClearIfReferenced(N.Args[1]); + end; + + else + begin + for i := 0 to Length(N.Args) - 1 do + N.Args[i].AcceptVisitor(self); end; - fResubscribeAll := backupResubscribeAll; - SubScribeToElem(N); - exit; - end - else if SameText(N.OperationName, 'or') then // do not localize - begin - fResubscribeAll := True; - N.Args[0].AcceptVisitor(self); - if (not assigned(n.args[0].value)) or not (N.Args[0].Value as TBABoolean).AsBoolean then - N.Args[1].AcceptVisitor(self) - end - else if SameText(N.OperationName, 'and') then // do not localize - begin - fResubscribeAll := True; - N.Args[0].AcceptVisitor(self); - if assigned(n.args[0].value) and (N.Args[0].Value as TBABoolean).AsBoolean then - N.Args[1].AcceptVisitor(self) - end - else - begin - for i := 0 to N.Args.Count - 1 do - N.Args[i].AcceptVisitor(self); end; try @@ -228,35 +280,46 @@ procedure TBoldOclEvaluatorVisitor.VisitTBoldOclOperation(N: TBoldOclOperation); try for i := 0 to n.Symbol.numberOfArgs-1 do begin - if not assigned(n.args[i].value) and (n.args[i].BoldType is TBoldAttributeTypeInfo) and - not (n.args[i].BoldType as TBoldAttributeTypeInfo).IsAbstract then + Argi := n.args[i]; + if not assigned(Argi.value) and (Argi.BoldType is TBoldAttributeTypeInfo) and + not (Argi.BoldType as TBoldAttributeTypeInfo).IsAbstract then begin - n.args[i].SetOwnedValue(TBoldMemberFactory.CreateMemberFromBoldType(n.args[i].BoldType)); - n.args[i].HastemporaryDummyValue := true; - end; - if n.args[i].value is tBoldObjectReference then - OperationParams.values[i] := (n.args[i].value as tBoldObjectReference).BoldObject + if Argi.BoldType = fBooleanType then + Argi.SetReferenceValue(fTrueBool) + else + begin + if OclUseTemporaryDummyValue then + begin + Argi.SetOwnedValue(TBoldMemberFactory.CreateMemberFromBoldType(Argi.BoldType)); + Argi.HasTemporaryDummyValue := true; + end + else + Argi.SetReferenceValue(nil); + end; + end + else if Argi.value is TBoldObjectReference then + OperationParams.values[i] := (Argi.value as TBoldObjectReference).BoldObject else - OperationParams.values[i] := n.args[i].value; - OperationParams.Nodes[i] := n.args[i]; + OperationParams.values[i] := Argi.value; + OperationParams.Nodes[i] := Argi; end; OperationParams.Result := N; OperationParams.SubScriber := CurrentSubscriber; OperationParams.System := CurrentSystem; OperationParams.SystemTypeInfo := CurrentSystemTypeInfo; n.Symbol.Evaluate(OperationParams); - + if OPerationParams.result.OwnsValue and assigned(OPerationParams.result.value) then OPerationParams.result.Value.MakeImmutable; finally - // if-statements don't evaluate all arguments, so we must throw away the rest so that literals can be reevaluated the next time. for i := 0 to n.Symbol.numberOfArgs-1 do begin - if n.args[i].HastemporaryDummyValue then + Argi := n.args[i]; + if Argi.HasTemporaryDummyValue then begin - n.args[i].SetReferenceValue(nil); - n.args[i].HastemporaryDummyValue := false; + Argi.SetReferenceValue(nil); + Argi.HasTemporaryDummyValue := false; end; end; end; @@ -268,9 +331,8 @@ procedure TBoldOclEvaluatorVisitor.VisitTBoldOclOperation(N: TBoldOclOperation); end; end; - if assigned(n.value) and not assigned(n.value.Boldtype) then + if assigned(n.value) and not assigned(n.value.Boldtype) and not (n.Value is TBAValueSetValue) then // TBAValueSetValue does not have a type by design raise EBoldInternal.CreateFmt('Result of evaluation of operation %s has no type', [n.OperationName]); -// n.value.BoldType := n.ExpressionType; SubScribeToElem(N); end; @@ -324,8 +386,6 @@ procedure TBoldOclEvaluatorVisitor.VisitTBoldOclIteration(N: TBoldOclIteration); SortKeyHolder := TBoldOclNode.Create; SortKeys := TBoldMemberList.Create; SortKeys.DuplicateMode := bldmAllow; - - // if the sort argument is not a real member (has RTinfo) then we must clone it SortArgIsRTMember := (N.Args[1] is TBoldOclMember) and Assigned((N.Args[1] as TBoldOclMember).RTInfo); SortKeys.CloneMembers := not SortArgIsRTMember; @@ -345,8 +405,7 @@ procedure TBoldOclEvaluatorVisitor.VisitTBoldOclIteration(N: TBoldOclIteration); begin for i := Sortkeys.Count-1 downto 0 do begin - // if we had to create dummy-sortkeys that are not owned by the list, - // we must take care of them here + if not assigned(Sortkeys[i].OwningObject) then begin TempSortKey := SortKeys[i]; @@ -388,7 +447,7 @@ procedure TBoldOclEvaluatorVisitor.VisitTBoldOclIteration(N: TBoldOclIteration); List.EnsureRange(0, List.Count-1); for i := 0 to List.Count - 1 do begin - n.LoopVar.BoldType := nil; // reset static boldtype + n.LoopVar.BoldType := nil; N.LoopVar.SetReferenceValue(List[i]); N.Args[1].AcceptVisitor(self); OperationParams.values[0] := n.args[1].Value; @@ -413,7 +472,7 @@ procedure TBoldOclEvaluatorVisitor.VisitTBoldOclMember(N: TBoldOclMember); Role: TBoldObjectList; begin MemberList := TBoldMemberList.Create; - for i := 0 to n.Qualifier.count-1 do + for i := 0 to Length(n.Qualifier)-1 do MemberList.Add(n.Qualifier[i].value as TBoldMember); role := Obj.BoldMembers[n.MemberIndex] as TBoldObjectList; if assigned(CurrentSubscriber) then @@ -434,6 +493,7 @@ procedure TBoldOclEvaluatorVisitor.VisitTBoldOclMember(N: TBoldOclMember); Result := CreateNewMember(n.BoldType) as TBoldMemberList; Result.DuplicateMode := bldmAllow; index := N.memberindex; + Result.Capacity := OldObjectList.Count; for i := 0 to OldObjectList.Count - 1 do begin LoopObject := OldObjectList[i]; Result.Add(LoopObject.BoldMembers[index]); @@ -452,7 +512,7 @@ procedure TBoldOclEvaluatorVisitor.VisitTBoldOclMember(N: TBoldOclMember); function retrieveMultiLink: TBoldObjectList; var - i, j : Integer; + i : Integer; roleList: TBoldObjectList; tempSystem: TBoldSystem; begin @@ -467,7 +527,7 @@ procedure TBoldOclEvaluatorVisitor.VisitTBoldOclMember(N: TBoldOclMember); Result := CreateNewMember(n.BoldType) as TBoldObjectList; Result.DuplicateMode := bldmAllow; if assigned(n.Qualifier) then - for i := 0 to N.qualifier.Count - 1 do + for i := 0 to Length(N.qualifier) - 1 do N.Qualifier[i].AcceptVisitor(self); for i := 0 to OldObjectList.Count - 1 do @@ -480,9 +540,7 @@ procedure TBoldOclEvaluatorVisitor.VisitTBoldOclMember(N: TBoldOclMember); roleList := LoopObject.BoldMembers[N.memberindex] as TBoldObjectList; if assigned(CurrentSubscriber) then roleList.DefaultSubscribe(CurrentSubscriber, MapResubscribe(N.Resubscribe)); - - for J := 0 to roleList.Count - 1 do - Result.Add(roleList[J]); + Result.AddList(roleList); end; end; end; @@ -517,7 +575,7 @@ procedure TBoldOclEvaluatorVisitor.VisitTBoldOclMember(N: TBoldOclMember); begin N.MemberOf.AcceptVisitor(self); - if assigned(n.MemberOf.value) then begin + if assigned(n.MemberOf.value) then begin // and not ((n.MemberOf.Value is TBoldObjectReference) and (n.TBoldObjectReference(MemberOf.Value).BoldObject = nil)) case N.MemberOf.Value.BoldType.BoldValueType of bvtSystem: N.SetReferenceValue(retrieveClass); bvtClass: begin @@ -527,13 +585,13 @@ procedure TBoldOclEvaluatorVisitor.VisitTBoldOclMember(N: TBoldOclMember); else if N.MemberOf.Value is TBoldObject then Obj := TBoldObject(N.MemberOf.Value) else if assigned(n.Memberof.Value) then - raise EBold.CreateFmt(sUnknownTypeOfMemberOf,[N.MemberOf.Value.ClassName]); + raise EBold.CreateFmt('unknown type of memberof: %s',[N.MemberOf.Value.ClassName]); - if assigned(Obj) then + if assigned(Obj) and assigned(Obj.BoldObjectLocator) then begin if assigned(n.Qualifier) then begin - for i := 0 to N.qualifier.Count - 1 do + for i := 0 to Length(N.qualifier) - 1 do N.Qualifier[i].AcceptVisitor(self); n.SetReferenceValue(RetrieveQualifiedSingle(obj)); end else @@ -555,11 +613,11 @@ procedure TBoldOclEvaluatorVisitor.VisitTBoldOclMember(N: TBoldOclMember); bvtAttr: N.SetOwnedValue(retrieveAttribute); bvtClass: N.SetOwnedValue(RetrieveSingleLink); bvtList: N.SetOwnedValue(retrieveMultiLink) - else raise EBold.CreateFmt(sUnknownTypeOfMember,[N.MemberType.ClassName]); + else raise EBold.CreateFmt('unknown type of member: %s',[N.MemberType.ClassName]); end; end; else - raise EBold.CreateFmt(sUnknownTypeOfMember,[N.MemberOf.Value.BoldType.ClassName]); + raise EBold.CreateFmt('unknown type of member: %s',[N.MemberOf.Value.BoldType.ClassName]); end; SubScribeToElem(N); @@ -574,14 +632,15 @@ procedure TBoldOclEvaluatorVisitor.VisitTBoldOclVariableReference(N: TBoldOclVar VariableValue := N.VariableBinding.Value; N.SetReferenceValue(VariableValue); if assigned(currentSubscriber) and Assigned(VariableValue) then - VariableValue.DefaultSubscribe(CurrentSubscriber, MapResubscribe(N.Resubscribe or fResubscribeAll)); // CHECKME -// Har fattas väl ett abbonememang på variablen som sådan?? Går bra så länge variablerna är konstanter. -// Janne + VariableValue.DefaultSubscribe(CurrentSubscriber, MapResubscribe(N.Resubscribe or fResubscribeAll)); + + end; procedure TBoldOclEvaluatorVisitor.VisitTBoldOclENumLiteral(N: TBoldOclEnumLiteral); begin - + if not assigned(n.value) then + n.SetReferenceValue(CurrentSystemTypeInfo.FindValueSetByName(N.Name)); end; procedure TBoldOclEvaluatorVisitor.VisitTBoldOclCollectionLIteral(N: TBoldOclCollectionLiteral); @@ -605,13 +664,12 @@ procedure TBoldOclEvaluatorVisitor.VisitTBoldOclCollectionLIteral(N: TBoldOclCol raise EBoldOclRunTimeError.CreateFmt(boertRangeNotAssigned, [n.RangeStart.Position]); tempInteger := MakeNewInteger; -// TempInteger.BoldType := N.RangeStart.BoldType; for i := (N.RangeStart.Value as TBAInteger).AsInteger to (N.RangeStop.Value as TBAInteger).AsInteger do begin TempInteger.AsInteger := i; BoldList.Add(tempInteger); end; end else begin - for i := 0 to N.Elements.Count - 1 do begin + for i := 0 to Length(N.Elements) - 1 do begin N.Elements[i].AcceptVisitor(self); BoldList.Add(N.Elements[i].Value); end; @@ -705,4 +763,6 @@ function TBoldOclEvaluatorVisitor.MakeNewTime: TBATime; result := CreateNewMember(fTimeType) as TBATime; end; +initialization + end. diff --git a/Source/ObjectSpace/Ocl/BoldOclLightWeightNodeMaker.pas b/Source/ObjectSpace/Ocl/BoldOclLightWeightNodeMaker.pas index 2335a5bb..56a5a0e8 100644 --- a/Source/ObjectSpace/Ocl/BoldOclLightWeightNodeMaker.pas +++ b/Source/ObjectSpace/Ocl/BoldOclLightWeightNodeMaker.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOclLightWeightNodeMaker; interface @@ -62,8 +65,8 @@ implementation SysUtils, BoldDefs, BoldElements, - BoldCoreConsts, - BoldAttributes; + BoldAttributes, + BoldOcl; { TBoldOLWNodeMaker } @@ -77,13 +80,15 @@ constructor TBoldOLWNodeMaker.create(OclRootNode: TBoldOclNode; SystemTypeInfo: fEnv := Env; if not (OclRootNode.BoldType is TBoldListTypeInfo) or not OclRootNode.BoldType.ConformsTo(SystemTypeInfo.RootClassTypeInfo.ListTypeInfo) then - SetFailure(0, format(sPSResultMustBeObjectList, [OclRootNode.BoldType.AsString])); - + begin + if not (OclRootNode.BoldType is TBoldClassTypeInfo) or not OclRootNode.BoldType.ConformsTo(SystemTypeInfo.RootClassTypeInfo) then + SetFailure(0, format('Result of PS-evaluation must be an objectlist (was type: %s)', [OclRootNode.BoldType.AsString])); + end; if not assigned(System) then - SetFailure(0, sPSEvalrequiresSystem); + SetFailure(0, 'PS-evaluation can not be performed without a system'); end; -destructor TBoldOLWNodeMaker.Destroy; +destructor TBoldOLWNodeMaker.destroy; var i: integer; begin @@ -121,7 +126,7 @@ function TBoldOLWNodeMaker.OLWBindingForVarBinding( procedure TBoldOLWNodeMaker.VisitTBoldOclCollectionLIteral(N: TBoldOclCollectionLIteral); begin - SetFailure(n.Position, sCollectionLiteralsNotSupported); + SetFailure(n.Position, 'OLWNodes does not support CollectionLiterals'); end; procedure TBoldOLWNodeMaker.VisitTBoldOclEnumLiteral(N: TBoldOclEnumLiteral); @@ -143,7 +148,7 @@ procedure TBoldOLWNodeMaker.VisitTBoldOclIteration(N: TBoldOclIteration); OLWIteration := TBoldOLWIteration.create(n.Position, n.OperationName, RootNode as TBoldOLWVariableBinding); - for i := 0 to n.Args.Count-1 do + for i := 0 to Length(n.Args)-1 do begin n.Args[i].AcceptVisitor(self); OLWIteration.Args.Add(RootNode); @@ -172,7 +177,7 @@ procedure TBoldOLWNodeMaker.VisitTBoldOclMember(N: TBoldOclMember); begin inherited; n.MemberOf.AcceptVisitor(self); - IsBoolean := n.BoldType.ConformsTo(((n.BoldType.SystemTypeInfo) as TBoldSystemTypeInfo).AttributeTypeInfoByExpressionName['Boolean']); // do not localize + IsBoolean := n.BoldType.ConformsTo(TBoldOCL(n.BoldType.evaluator).BooleanType); OLWMember := TBoldOLWMember.Create(n.Position, n.MemberName, n.MemberIndex, RootNode, IsBoolean); if not n.RTInfo.Persistent then @@ -188,11 +193,11 @@ procedure TBoldOLWNodeMaker.VisitTBoldOclMember(N: TBoldOclMember); end; end; if not EffectivePersistent then - SetFailure(n.Position, format(sTransientMembersCannoteUsed, [n.RTInfo.ExpressionName])); + SetFailure(n.Position, format('Non persistent members (%s) can not be used in OLWNodes', [n.RTInfo.ExpressionName])); end; if assigned(n.Qualifier) then - for i := 0 to n.Qualifier.Count-1 do + for i := 0 to Length(n.Qualifier)-1 do begin n.Qualifier[i].AcceptVisitor(self); OLWMember.Qualifier.Add(RootNode); @@ -202,12 +207,11 @@ procedure TBoldOLWNodeMaker.VisitTBoldOclMember(N: TBoldOclMember); procedure TBoldOLWNodeMaker.VisitTBoldOclMethod(N: TBoldOclMethod); begin - SetFailure(n.Position, sMethodsNotSupported); + SetFailure(n.Position, 'OLWNodes does not support methods'); end; procedure TBoldOLWNodeMaker.VisitTBoldOclNode(N: TBoldOclNode); begin - // abstract class end; procedure TBoldOLWNodeMaker.VisitTBoldOclNumericLiteral(N: TBoldOclNumericLiteral); @@ -225,11 +229,12 @@ procedure TBoldOLWNodeMaker.VisitTBoldOclOperation(N: TBoldOclOperation); LiteralType: TBoldElementTypeInfo; BooleanType: TBoldAttributeTypeInfo; ValueSet: TBAValueSet; + ValueSetValue: TBAValueSetValue; begin if n.ClassType = TBoldOclOperation then begin OLWOperation := TBoldOLWOperation.create(n.Position, n.OperationName); - for i := 0 to n.Args.Count-1 do + for i := 0 to Length(n.Args)-1 do begin n.Args[i].AcceptVisitor(self); OLWOperation.Args.Add(RootNode); @@ -257,30 +262,39 @@ procedure TBoldOLWNodeMaker.VisitTBoldOclOperation(N: TBoldOclOperation); Literal := OLWOperation.args[1] as TBoldOLWEnumLiteral; end; - BooleanType := (n.Boldtype.SystemTypeInfo as TBoldSystemTypeInfo).AttributeTypeInfoByExpressionName['Boolean']; // do not localize + BooleanType := TBoldOCL(n.BoldType.evaluator).BooleanType; if n.args[0].BoldType.ConformsTo(BooleanType) and n.args[1].BoldType.ConformsTo(BooleanType) then - SetFailure(n.Position, sUseBooleanOperations); + SetFailure(n.Position, 'Can not compare two booleans to each other with "=" or "<>", use boolean operations instead'); if assigned(Literal) then begin if LiteralType.ConformsTo(BooleanType) then - SetFailure(n.Position, sUseBooleanOperationsWithLiterals); + SetFailure(n.Position, 'Can not compare boolean values to literals when converting to SQL, use boolean operations instead'); - if LiteralType.ConformsTo((LiteralType.SystemTypeInfo as TBoldSystemTypeInfo).AttributeTypeInfoByExpressionName['ValueSet']) then // do not localize + if LiteralType.ConformsTo((LiteralType.SystemTypeInfo as TBoldSystemTypeInfo).ValueSetTypeInfo) then begin ValueSet := TBoldMemberFactory.CreateMemberFromBoldType(LiteralType) as TBAValueSet; - if assigned(ValueSet.Values.FindByString(brDefault, LiteralName)) then - begin - ValueSet.AsString := LIteralName; - Literal.IntValue := ValueSet.AsInteger; - end - else - SetFailure(n.Position, format(sEnumNameNotValid, [LiteralName, LiteralType.ExpressionName])); + try + // Do not compare default representation on first place, because it is not + // well suited for a comparison. Instead first compare short representation, + // which should be used to represent the enum value itself, instead of a translation. + ValueSetValue := ValueSet.Values.FindByString(brShort, LiteralName); + if ValueSetValue = nil then begin + ValueSetValue := ValueSet.Values.FindByString(brDefault, LiteralName); + end; + if Assigned(ValueSetValue) then begin + Literal.IntValue := ValueSetValue.AsInteger; + end else begin + SetFailure(n.Position, format('EnumName (%s) not valid for %s', [LiteralName, LiteralType.ExpressionName])); + end; + finally + ValueSet.Free; + end; end else - SetFailure(n.Position, format(sEnumComparedToNonEnum, [LiteralName, LiteralType.ExpressionName])); + SetFailure(n.Position, format('Enum (%s) compared to a non Enum (%s)', [LiteralName, LiteralType.ExpressionName])); end; end; end; @@ -297,7 +311,7 @@ procedure TBoldOLWNodeMaker.VisitTBoldOclTypeNode(N: TBoldOclTypeNode); if n.Value is TBoldClassTypeInfo then fRootNode := TBoldOLWTypeNode.Create(n.Position, N.typeName, (n.Value as TBoldClassTypeInfo).TopSortedIndex) else - SetFailure(n.Position, Format(sTypeNotSupported, [n.TypeName])); + SetFailure(n.Position, 'OLWNodes does not support the type ' + n.TypeName); end; procedure TBoldOLWNodeMaker.VisitTBoldOclVariableBinding(N: TBoldOclVariableBinding); @@ -332,7 +346,7 @@ procedure TBoldOLWNodeMaker.VisitTBoldOclVariableBinding(N: TBoldOclVariableBind VarBind.ExternalVarvalue := -1; end else if n.Value is TBoldAttribute then - VarBind.ExternalVarvalue := n.Value.GetAsVariant; + VarBind.ExternalVarvalue := n.Value.AsVariant; Varbindings.Add(n); OLWvarBindings.Add(VarBind); @@ -343,7 +357,7 @@ procedure TBoldOLWNodeMaker.VisitTBoldOclVariableBinding(N: TBoldOclVariableBind else begin fRootNode := TBoldOLWVariableBinding.Create(N.Position, n.VariableName, -1); - setFailure(n.Position, Format(sLoopVariablesMustBeClassType, [n.BoldType.AsString])); + setFailure(n.Position, Format('LoopVariables can only have class type, not %s', [n.BoldType.AsString])); end; end; diff --git a/Source/ObjectSpace/Ocl/BoldOclLightWeightNodes.pas b/Source/ObjectSpace/Ocl/BoldOclLightWeightNodes.pas index 44418048..9e4c3cbb 100644 --- a/Source/ObjectSpace/Ocl/BoldOclLightWeightNodes.pas +++ b/Source/ObjectSpace/Ocl/BoldOclLightWeightNodes.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOclLightWeightNodes; interface @@ -67,15 +70,15 @@ TBoldOLWNodeList = class(TBoldNonRefCountedObject, IBoldStreamable) private fList: TList; fOwnsObjects: Boolean; - function GetItem(index: Integer): TBoldOLWNode; - procedure PutItem(index: Integer; Value: TBoldOLWNode); + function GetItem(index: Integer): TBoldOLWNode; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure PutItem(index: Integer; Value: TBoldOLWNode); {$IFDEF BOLD_INLINE}inline;{$ENDIF} function GetStreamName: string; - function GetCount: integer; - function GetIndexOf(Node: TBoldOLWNode): integer; + function GetCount: integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetIndexOf(Node: TBoldOLWNode): integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} public constructor Create; destructor Destroy; override; - function Add(Item: TBoldOLWNode): Integer; + function Add(Item: TBoldOLWNode): Integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure TraverseList(V: TBoldOLWNodeVisitor); virtual; property Items[index: Integer]: TBoldOLWNode read GetItem write PutItem; default; property Count: integer read GetCount; @@ -83,6 +86,7 @@ TBoldOLWNodeList = class(TBoldNonRefCountedObject, IBoldStreamable) property OwnsObjects: Boolean read fOwnsObjects write fOwnsObjects; end; + TBoldOLWNode = class(TBoldNonRefCountedObject, IBoldStreamable) private fPosition: integer; @@ -94,6 +98,7 @@ TBoldOLWNode = class(TBoldNonRefCountedObject, IBoldStreamable) property Position: Integer read fPosition; end; + TBoldOLWTypeNode = class(TBoldOLWNode) private fTypeName: String; @@ -213,7 +218,7 @@ TBoldOLWStrLiteral = class(TBoldOLWLiteral) end; TBoldOLWMomentLiteral = class(TBoldOLWLiteral) - private + protected fMomentValue: TDateTime; public constructor Create(Position: integer; MomentValue: TDateTime); @@ -221,24 +226,20 @@ TBoldOLWMomentLiteral = class(TBoldOLWLiteral) TBoldOLWDateLiteral = class(TBoldOLWMomentLiteral) private - function GetDateValue: TDateTime; - procedure SetDateValue(const Value: TDateTime); protected function GetStreamName: string; override; public procedure AcceptVisitor(V: TBoldOLWNodeVisitor); override; - property DateValue: TDateTime read GetDateValue write SetDateValue; + property DateValue: TDateTime read fMomentValue write fMomentValue; end; TBoldOLWTimeLiteral = class(TBoldOLWMomentLiteral) private - function GetTimeValue: TDateTime; - procedure SetTimeValue(const Value: TDateTime); protected function GetStreamName: string; override; public procedure AcceptVisitor(V: TBoldOLWNodeVisitor); override; - property TimeValue: TDateTime read GetTimeValue write SetTimeValue; + property TimeValue: TDateTime read fMomentValue write fMomentValue; end; @@ -282,10 +283,9 @@ implementation uses SysUtils, - MSXML_TLB, + {$IFDEF OXML}OXmlPDOM{$ELSE}Bold_MSXML_TLB{$ENDIF}, BoldXMLStreaming, BoldDefaultStreamNames, - BoldCoreConsts, BoldDefs; const @@ -309,7 +309,6 @@ implementation type TBoldXMLOCLConditionStreamer = class(TBoldXMLConditionWithClassStreamer) - // RootNode, Context, Env, OclExpr protected function GetStreamName: string; override; public @@ -329,14 +328,12 @@ TBoldXMLOLWNodeListStreamer = class(TBoldXMLObjectStreamer) TBoldXMLOLWNodeStreamer = class(TBoldXMLObjectStreamer) - // Position public procedure WriteObject(Obj: TBoldInterfacedObject; Node: TBoldXMLNode); override; procedure ReadObject(Obj: TObject; Node: TBoldXMLNode); override; end; TBoldXMLOLWTypeNodeStreamer = class(TBoldXMLOLWNodeStreamer) - // TypeName, TopSortedIndex protected function GetStreamName: string; override; public @@ -346,7 +343,6 @@ TBoldXMLOLWTypeNodeStreamer = class(TBoldXMLOLWNodeStreamer) end; TBoldXMLOLWListCoercionStreamer = class(TBoldXMLOLWNodeStreamer) - // Child protected function GetStreamName: string; override; public @@ -356,7 +352,6 @@ TBoldXMLOLWListCoercionStreamer = class(TBoldXMLOLWNodeStreamer) end; TBoldXMLOLWOperationStreamer = class(TBoldXMLOLWNodeStreamer) - // Args, OperationName protected function GetStreamName: string; override; public @@ -366,7 +361,6 @@ TBoldXMLOLWOperationStreamer = class(TBoldXMLOLWNodeStreamer) end; TBoldXMLOLWIterationStreamer = class(TBoldXMLOLWOperationStreamer) - // LoopVar protected function GetStreamName: string; override; public @@ -376,7 +370,6 @@ TBoldXMLOLWIterationStreamer = class(TBoldXMLOLWOperationStreamer) end; TBoldXMLOLWMemberStreamer = class(TBoldXMLOLWNodeStreamer) - // MemberIndex, MemberName, MemberOf, Qualifier, IsBoolean protected function GetStreamName: string; override; public @@ -386,7 +379,6 @@ TBoldXMLOLWMemberStreamer = class(TBoldXMLOLWNodeStreamer) end; TBoldXMLOLWVariableBindingStreamer = class(TBoldXMLOLWNodeStreamer) - // VariableName, TopSortedIndex, ExternalVarValue, IsLoopVar, RefCount protected function GetStreamName: string; override; public @@ -397,7 +389,6 @@ TBoldXMLOLWVariableBindingStreamer = class(TBoldXMLOLWNodeStreamer) TBoldXMLOLWVariableReferenceStreamer = class(TBoldXMLOLWNodeStreamer) - // VariableBinding protected function GetStreamName: string; override; public @@ -407,7 +398,6 @@ TBoldXMLOLWVariableReferenceStreamer = class(TBoldXMLOLWNodeStreamer) end; TBoldXMLOLWStrLiteralStreamer = class(TBoldXMLOLWNodeStreamer) - // StrValue protected function GetStreamName: string; override; public @@ -417,7 +407,6 @@ TBoldXMLOLWStrLiteralStreamer = class(TBoldXMLOLWNodeStreamer) end; TBoldXMLOLWFloatLiteralStreamer = class(TBoldXMLOLWNodeStreamer) - // FloatValue protected function GetStreamName: string; override; public @@ -427,7 +416,6 @@ TBoldXMLOLWFloatLiteralStreamer = class(TBoldXMLOLWNodeStreamer) end; TBoldXMLOLWIntLiteralStreamer = class(TBoldXMLOLWNodeStreamer) - // IntValue protected function GetStreamName: string; override; public @@ -437,7 +425,6 @@ TBoldXMLOLWIntLiteralStreamer = class(TBoldXMLOLWNodeStreamer) end; TBoldXMLOLWDateLiteralStreamer = class(TBoldXMLOLWNodeStreamer) - // DateValue protected function GetStreamName: string; override; public @@ -447,7 +434,6 @@ TBoldXMLOLWDateLiteralStreamer = class(TBoldXMLOLWNodeStreamer) end; TBoldXMLOLWTimeLiteralStreamer = class(TBoldXMLOLWNodeStreamer) - // TimeValue protected function GetStreamName: string; override; public @@ -459,7 +445,6 @@ TBoldXMLOLWTimeLiteralStreamer = class(TBoldXMLOLWNodeStreamer) TBoldXMLOLWEnumLiteralStreamer = class(TBoldXMLOLWNodeStreamer) - // name, IntValue protected function GetStreamName: string; override; public @@ -493,7 +478,7 @@ constructor TBoldOLWOperation.create(Position: integer; const OperationName: Str destructor TBoldOLWOperation.Destroy; begin FreeAndNil(fArgs); - inherited; + inherited; end; @@ -656,7 +641,7 @@ procedure TBoldOLWVariableBinding.AddRef; begin inc(fRefCount); if (fRefCount > 1) and not fIsLoopVar then - raise EBold.Create(sExternalVarsCanOnlyBeReferencedOnce); + raise EBold.Create('external variables (and self) can currently only be referenced once'); end; constructor TBoldOLWVariableBinding.Create(Position: integer; const VariableName: String; TopSortedIndex: integer); @@ -678,12 +663,14 @@ procedure TBoldOLWStrLiteral.AcceptVisitor(V: TBoldOLWNodeVisitor); v.VisitTBoldOLWStrLiteral(self); end; + constructor TBoldOLWStrLiteral.Create(Position: integer; const StrValue: String); begin inherited Create(Position); fStrValue := StrValue; end; + function TBoldOLWStrLiteral.GetStreamName: string; begin result := OLWStrLiteralStreamName; @@ -923,12 +910,12 @@ procedure TBoldXMLOCLConditionStreamer.ReadObject(Obj: TObject; Condition := Obj as TBoldOclCondition; Bindings := TBoldOLWNodeList.Create; Bindings.OwnsObjects := false; - Node.AddStateObject('Bindings', Bindings); // do not localize - Condition.fEnv := Node.ReadSubnodeObject('Env', OLWNodeListStreamName) as TBoldOLWNodeList; // do not localize - Condition.fRootNode := Node.ReadSubnodeObject('RootNode', '') as TBoldOLWNode; // do not localize - Condition.fContext := Node.ReadSubnodeObject('Context', BOLDOBJECTIDLISTNAME) as TBoldObjectidList; // do not localize - Condition.fOclExpr := Node.ReadSubNodeString('OCL'); // do not localize - Node.RemoveStateObject('Bindings'); // do not localize + Node.AddStateObject('Bindings', Bindings); + Condition.fEnv := Node.ReadSubnodeObject('Env', OLWNodeListStreamName) as TBoldOLWNodeList; + Condition.fRootNode := Node.ReadSubnodeObject('RootNode', '') as TBoldOLWNode; + Condition.fContext := Node.ReadSubnodeObject('Context', BOLDOBJECTIDLISTNAME) as TBoldObjectidList; + Condition.fOclExpr := Node.ReadSubNodeString('OCL'); + Node.RemoveStateObject('Bindings'); Bindings.Free; end; @@ -942,14 +929,14 @@ procedure TBoldXMLOCLConditionStreamer.WriteObject( Condition := Obj as TBoldOclCondition; Bindings := TBoldOLWNodeList.Create; Bindings.OwnsObjects := false; - Node.AddStateObject('Bindings', Bindings); // do not localize + Node.AddStateObject('Bindings', Bindings); - Node.WriteSubnodeObject('Env', OLWNodeListStreamName, Condition.fEnv); // do not localize - Node.WriteSubNodeObject('RootNode', '', Condition.fRootNode); // do not localize - Node.WriteSubnodeObject('Context', BOLDOBJECTIDLISTNAME, Condition.fContext); // do not localize - Node.WriteSubNodeString('OCL', Condition.fOclExpr); // do not localize + Node.WriteSubnodeObject('Env', OLWNodeListStreamName, Condition.fEnv); + Node.WriteSubNodeObject('RootNode', '', Condition.fRootNode); + Node.WriteSubnodeObject('Context', BOLDOBJECTIDLISTNAME, Condition.fContext); + Node.WriteSubNodeString('OCL', Condition.fOclExpr); - Node.RemoveStateObject('Bindings'); // do not localize + Node.RemoveStateObject('Bindings'); Bindings.free; end; @@ -964,7 +951,7 @@ procedure TBoldXMLOLWNodeStreamer.ReadObject(Obj: TObject; begin inherited; OLWNode := obj as TBoldOLWNode; - OLWNode.fPosition := Node.ReadSubNodeInteger('Position'); // do not localize + OLWNode.fPosition := Node.ReadSubNodeInteger('Position'); end; procedure TBoldXMLOLWNodeStreamer.WriteObject(Obj: TBoldInterfacedObject; @@ -974,7 +961,7 @@ procedure TBoldXMLOLWNodeStreamer.WriteObject(Obj: TBoldInterfacedObject; begin inherited; OLWNode := obj as TBoldOLWNode; - Node.WriteSubNodeInteger('Position', OLWNode.fPosition); // do not localize + Node.WriteSubNodeInteger('Position', OLWNode.fPosition); end; { TBoldXMLOLWTypeNodeStreamer } @@ -996,8 +983,8 @@ procedure TBoldXMLOLWTypeNodeStreamer.ReadObject(Obj: TObject; begin inherited; OLWTypeNode := Obj as TBoldOLWTypeNode; - OLWTypeNode.fTypeName := Node.ReadSubNodeString('TypeName'); // do not localize - OLWTypeNode.fTopSortedIndex := Node.ReadSubNodeInteger('TopSortedIndex'); // do not localize + OLWTypeNode.fTypeName := Node.ReadSubNodeString('TypeName'); + OLWTypeNode.fTopSortedIndex := Node.ReadSubNodeInteger('TopSortedIndex'); end; procedure TBoldXMLOLWTypeNodeStreamer.WriteObject( @@ -1007,8 +994,8 @@ procedure TBoldXMLOLWTypeNodeStreamer.WriteObject( begin inherited; OLWTypeNode := Obj as TBoldOLWTypeNode; - Node.WriteSubNodeString('TypeName', OLWTypeNode.TypeName); // do not localize - Node.WriteSubNodeInteger('TopSortedIndex', OLWTypeNode.TopSortedIndex); // do not localize + Node.WriteSubNodeString('TypeName', OLWTypeNode.TypeName); + Node.WriteSubNodeInteger('TopSortedIndex', OLWTypeNode.TopSortedIndex); end; { TBoldXMLOLWListCoercionStreamer } @@ -1030,7 +1017,7 @@ procedure TBoldXMLOLWListCoercionStreamer.ReadObject(Obj: TObject; begin inherited; ListCoercion := obj as TBoldOLWListCoercion; - LIstCoercion.fChild := Node.readSubNodeObject('Child', '') as TBoldOLWNode; // do not localize + LIstCoercion.fChild := Node.readSubNodeObject('Child', '') as TBoldOLWNode; end; procedure TBoldXMLOLWListCoercionStreamer.WriteObject( @@ -1040,7 +1027,7 @@ procedure TBoldXMLOLWListCoercionStreamer.WriteObject( begin inherited; ListCoercion := obj as TBoldOLWListCoercion; - Node.WriteSubNodeObject('Child', '', ListCoercion.fChild); // do not localize + Node.WriteSubNodeObject('Child', '', ListCoercion.fChild); end; { TBoldXMLOLWOperationStreamer } @@ -1062,8 +1049,8 @@ procedure TBoldXMLOLWOperationStreamer.ReadObject(Obj: TObject; begin inherited; OLWOperation := Obj as TBoldOLWOperation; - OLWOperation.fArgs := Node.readSubNodeObject('Args', '') as TBoldOLWNodeList; // do not localize - OLWOperation.fOperationName := Node.ReadSubNodeString('OperationName'); // do not localize + OLWOperation.fArgs := Node.readSubNodeObject('Args', '') as TBoldOLWNodeList; + OLWOperation.fOperationName := Node.ReadSubNodeString('OperationName'); end; procedure TBoldXMLOLWOperationStreamer.WriteObject( @@ -1073,8 +1060,8 @@ procedure TBoldXMLOLWOperationStreamer.WriteObject( begin inherited; OLWOperation := Obj as TBoldOLWOperation; - Node.WriteSubNodeObject('Args', '', OLWOperation.fArgs); // do not localize - Node.WriteSubNodeString('OperationName', OLWOperation.fOperationName); // do not localize + Node.WriteSubNodeObject('Args', '', OLWOperation.fArgs); + Node.WriteSubNodeString('OperationName', OLWOperation.fOperationName); end; { TBoldXMLOLWIterationStreamer } @@ -1094,12 +1081,12 @@ procedure WriteBindingToStream(Binding: TBoldOLWVariableBinding; Node: TBoldXMLN BindingIndex: integer; Bindings: TBoldOLWNodeList; begin - Bindings := Node.GetStateObject('Bindings') as TBoldOLWNodeList; // do not localize + Bindings := Node.GetStateObject('Bindings') as TBoldOLWNodeList; BindingIndex := Bindings.IndexOf[Binding]; - Node.WriteSubNodeInteger('BindingIndex', BindingIndex); // do not localize + Node.WriteSubNodeInteger('BindingIndex', BindingIndex); if BindingIndex = -1 then begin - Node.WriteSubNodeObject('Binding', OLWVariableBindingStreamName, Binding); // do not localize + Node.WriteSubNodeObject('Binding', OLWVariableBindingStreamName, Binding); Bindings.Add(Binding); end; end; @@ -1109,15 +1096,15 @@ function ReadBindingFromStream(Node: TBoldXMLNode): TBoldOLWVariableBinding; BindingIndex: integer; Bindings: TBoldOLWNodeList; begin - Bindings := Node.GetStateObject('Bindings') as TBoldOLWNodeList; // do not localize - BindingIndex := Node.ReadSubNodeInteger('BindingIndex'); // do not localize + Bindings := Node.GetStateObject('Bindings') as TBoldOLWNodeList; + BindingIndex := Node.ReadSubNodeInteger('BindingIndex'); if BindingIndex <> -1 then begin Result := Bindings[BindingIndex] as tBoldOLWVariableBinding; end else begin - Result := Node.ReadSubNodeObject('Binding', OLWVariableBindingStreamName) as TBoldOLWVariableBinding; // do not localize + Result := Node.ReadSubNodeObject('Binding', OLWVariableBindingStreamName) as TBoldOLWVariableBinding; Bindings.Add(result); end; end; @@ -1161,11 +1148,11 @@ procedure TBoldXMLOLWMemberStreamer.ReadObject(Obj: TObject; begin inherited; OLWMember := Obj as TBoldOLWMember; - OLWMember.fMemberIndex := Node.ReadSubNodeInteger('MemberIndex'); // do not localize - OLWMember.fMemberName := Node.ReadSubNodeString('MemberName'); // do not localize - OLWMember.fMemberOf := Node.ReadSubNodeObject('MemberOf', '') as TBoldOLWNode; // do not localize - OLWMember.fQualifier := Node.ReadSubNodeObject('Qualifier', OLWNodeListStreamName) as TBoldOLWNodeList; // do not localize - OLWMember.fIsBoolean := Node.ReadSubNodeBoolean('IsBoolean'); // do not localize + OLWMember.fMemberIndex := Node.ReadSubNodeInteger('MemberIndex'); + OLWMember.fMemberName := Node.ReadSubNodeString('MemberName'); + OLWMember.fMemberOf := Node.ReadSubNodeObject('MemberOf', '') as TBoldOLWNode; + OLWMember.fQualifier := Node.ReadSubNodeObject('Qualifier', OLWNodeListStreamName) as TBoldOLWNodeList; + OLWMember.fIsBoolean := Node.ReadSubNodeBoolean('IsBoolean'); end; procedure TBoldXMLOLWMemberStreamer.WriteObject(Obj: TBoldInterfacedObject; @@ -1175,11 +1162,11 @@ procedure TBoldXMLOLWMemberStreamer.WriteObject(Obj: TBoldInterfacedObject; begin inherited; OLWMember := Obj as TBoldOLWMember; - Node.WriteSubNodeInteger('MemberIndex', OLWMember.fMemberIndex); // do not localize - Node.WriteSubNodeString('MemberName', OLWMember.fMemberName); // do not localize - Node.WriteSubNodeObject('MemberOf', '', OLWMember.fMemberOf); // do not localize - Node.WriteSubNodeObject('Qualifier', OLWNodeListStreamName, OLWMember.fQualifier); // do not localize - Node.WriteSubNodeBoolean('IsBoolean', OLWMember.fIsBoolean); // do not localize + Node.WriteSubNodeInteger('MemberIndex', OLWMember.fMemberIndex); + Node.WriteSubNodeString('MemberName', OLWMember.fMemberName); + Node.WriteSubNodeObject('MemberOf', '', OLWMember.fMemberOf); + Node.WriteSubNodeObject('Qualifier', OLWNodeListStreamName, OLWMember.fQualifier); + Node.WriteSubNodeBoolean('IsBoolean', OLWMember.fIsBoolean); end; { TBoldXMLOLWVariableBindingStreamer } @@ -1201,11 +1188,11 @@ procedure TBoldXMLOLWVariableBindingStreamer.ReadObject(Obj: TObject; begin inherited; OLWBinding := Obj as TBoldOLWVariableBinding; - OLWBinding.fVariableName := Node.ReadSubNodeString('VariableName'); // do not localize - OLWBinding.fTopSortedIndex := Node.ReadSubNodeInteger('TopSortedIndex'); // do not localize - OLWBinding.fIsLoopVar := Node.ReadSubNodeBoolean('IsLoopVar'); // do not localize - OLWBinding.fRefCount := Node.ReadSubNodeInteger('RefCount'); // do not localize - OLWBinding.fExternalVarValue := Node.ReadSubNodeString('ExternalVarValue'); // FIXME // do not localize + OLWBinding.fVariableName := Node.ReadSubNodeString('VariableName'); + OLWBinding.fTopSortedIndex := Node.ReadSubNodeInteger('TopSortedIndex'); + OLWBinding.fIsLoopVar := Node.ReadSubNodeBoolean('IsLoopVar'); + OLWBinding.fRefCount := Node.ReadSubNodeInteger('RefCount'); + OLWBinding.fExternalVarValue := Node.ReadSubNodeString('ExternalVarValue'); end; procedure TBoldXMLOLWVariableBindingStreamer.WriteObject( @@ -1215,11 +1202,11 @@ procedure TBoldXMLOLWVariableBindingStreamer.WriteObject( begin inherited; OLWBinding := Obj as TBoldOLWVariableBinding; - Node.WriteSubNodeString('VariableName', OLWBinding.fVariableName); // do not localize - Node.WriteSubNodeInteger('TopSortedIndex', OLWBinding.fTopSortedIndex); // do not localize - Node.WriteSubNodeBoolean('IsLoopVar', OLWBinding.fIsLoopVar); // do not localize - Node.WriteSubNodeInteger('RefCount', OLWBinding.fRefCount); // do not localize - Node.WriteSubNodeString('ExternalVarValue', OLWBinding.fExternalVarValue); // FIXME // do not localize + Node.WriteSubNodeString('VariableName', OLWBinding.fVariableName); + Node.WriteSubNodeInteger('TopSortedIndex', OLWBinding.fTopSortedIndex); + Node.WriteSubNodeBoolean('IsLoopVar', OLWBinding.fIsLoopVar); + Node.WriteSubNodeInteger('RefCount', OLWBinding.fRefCount); + Node.WriteSubNodeString('ExternalVarValue', OLWBinding.fExternalVarValue); end; { TBoldXMLOLWVariableReferenceStreamer } @@ -1273,7 +1260,7 @@ procedure TBoldXMLOLWStrLiteralStreamer.ReadObject(Obj: TObject; begin inherited; StrLiteral := obj as TBoldOLWStrLiteral; - StrLiteral.fStrValue := Node.ReadSubNodeString('StrValue'); // do not localize + StrLiteral.fStrValue := Node.ReadSubNodeString('StrValue'); end; procedure TBoldXMLOLWStrLiteralStreamer.WriteObject( @@ -1283,7 +1270,7 @@ procedure TBoldXMLOLWStrLiteralStreamer.WriteObject( begin inherited; StrLiteral := obj as TBoldOLWStrLiteral; - Node.WriteSubNodeString('StrValue', StrLiteral.fStrValue); // do not localize + Node.WriteSubNodeString('StrValue', StrLiteral.fStrValue); end; { TBoldXMLOLWIntLiteralStreamer } @@ -1305,7 +1292,7 @@ procedure TBoldXMLOLWIntLiteralStreamer.ReadObject(Obj: TObject; begin inherited; IntLiteral := obj as TBoldOLWIntLiteral; - IntLiteral.fIntValue := Node.ReadSubNodeInteger('IntValue'); // do not localize + IntLiteral.fIntValue := Node.ReadSubNodeInteger('IntValue'); end; procedure TBoldXMLOLWIntLiteralStreamer.WriteObject( @@ -1315,7 +1302,7 @@ procedure TBoldXMLOLWIntLiteralStreamer.WriteObject( begin inherited; IntLiteral := obj as TBoldOLWIntLiteral; - Node.WriteSubNodeInteger('IntValue', IntLiteral.fIntValue); // do not localize + Node.WriteSubNodeInteger('IntValue', IntLiteral.fIntValue); end; { TBoldXMLOLWFloatLiteralStreamer } @@ -1337,7 +1324,7 @@ procedure TBoldXMLOLWFloatLiteralStreamer.ReadObject(Obj: TObject; begin inherited; FloatLiteral := obj as TBoldOLWFloatLiteral; - FloatLiteral.fFloatValue := Node.ReadSubNodeFloat('FloatValue'); // do not localize + FloatLiteral.fFloatValue := Node.ReadSubNodeFloat('FloatValue'); end; procedure TBoldXMLOLWFloatLiteralStreamer.WriteObject( @@ -1347,9 +1334,10 @@ procedure TBoldXMLOLWFloatLiteralStreamer.WriteObject( begin inherited; FloatLiteral := obj as TBoldOLWFloatLiteral; - Node.WriteSubNodeFloat('FloatValue', FloatLiteral.fFloatValue); // do not localize + Node.WriteSubNodeFloat('FloatValue', FloatLiteral.fFloatValue); end; + { TBoldXMLOLWEnumLiteralStreamer } function TBoldXMLOLWEnumLiteralStreamer.CreateObject: TObject; @@ -1369,8 +1357,8 @@ procedure TBoldXMLOLWEnumLiteralStreamer.ReadObject(Obj: TObject; begin inherited; EnumLiteral := obj as TBoldOLWEnumLiteral; - EnumLiteral.fName := Node.ReadSubNodeString('Name'); // do not localize - EnumLiteral.fIntValue := Node.ReadSubNodeInteger('IntValue'); // do not localize + EnumLiteral.fName := Node.ReadSubNodeString('Name'); + EnumLiteral.fIntValue := Node.ReadSubNodeInteger('IntValue'); end; procedure TBoldXMLOLWEnumLiteralStreamer.WriteObject( @@ -1380,8 +1368,8 @@ procedure TBoldXMLOLWEnumLiteralStreamer.WriteObject( begin inherited; EnumLiteral := obj as TBoldOLWEnumLiteral; - Node.WriteSubNodeString('Name', EnumLIteral.fName); // do not localize - Node.WriteSubNodeInteger('IntValue', EnumLIteral.fIntValue); // do not localize + Node.WriteSubNodeString('Name', EnumLIteral.fName); + Node.WriteSubNodeInteger('IntValue', EnumLIteral.fIntValue); end; { TBoldXMLOLWNodeListStreamer } @@ -1400,22 +1388,43 @@ procedure TBoldXMLOLWNodeListStreamer.ReadObject(Obj: TObject; Node: TBoldXMLNode); var OLWList: TBoldOLWNodeList; + {$IFDEF OXML} + aNodeEnumerator: TXMLChildNodeListEnumerator; + aNode: PXMLNode; + {$ELSE} aNodeList: IXMLDOMNodeList; aNode: IXMLDOMNode; + {$ENDIF} aSubNode: TBoldXMLNode; begin inherited; OLWList := Obj as TBoldOLWNodeList; + {$IFDEF OXML} + aNodeEnumerator := Node.XMLDomElement.ChildNodes.GetEnumerator; + try + while aNodeEnumerator.MoveNext do + begin + aNode := aNodeEnumerator.Current; + aSubNode := Node.MakeNodeForElement(aNode); + if aSubNode.Accessor = 'Node' then // do not localize + OLWList.Add(aSubNode.ReadObject('') as TBoldOLWNode); + aSubNode.Free; + end; + finally + aNodeEnumerator.Free; + end; + {$ELSE} aNodeList := Node.XMLDomElement.childNodes; aNode := aNodeList.nextNode; while assigned(aNode) do begin aSubNode := Node.MakeNodeForElement(aNode as IXMLDOMElement); - if aSubNode.Accessor = 'Node' then // do not localize + if aSubNode.Accessor = 'Node' then OLWList.Add(aSubNode.ReadObject('') as TBoldOLWNode); aSubNode.Free; aNode := aNodeList.nextNode; end; + {$ENDIF} end; procedure TBoldXMLOLWNodeListStreamer.WriteObject( @@ -1429,7 +1438,7 @@ procedure TBoldXMLOLWNodeListStreamer.WriteObject( OLWList := Obj as TBoldOLWNodeList; for i := 0 to OLWList.Count-1 do begin - aSubNode := Node.NewSubNode('Node'); // do not localize + aSubNode := Node.NewSubNode('Node'); aSubNode.WriteObject('', OLWList[i]); aSubNode.Free; end; @@ -1454,7 +1463,7 @@ procedure TBoldXMLOLWDateLiteralStreamer.ReadObject(Obj: TObject; begin inherited; DateLiteral := obj as TBoldOLWDateLiteral; - DateLiteral.DateValue := Node.ReadSubNodeDate('DateValue'); // do not localize + DateLiteral.DateValue := Node.ReadSubNodeDate('DateValue'); end; @@ -1465,7 +1474,7 @@ procedure TBoldXMLOLWDateLiteralStreamer.WriteObject( begin inherited; DateLiteral := obj as TBoldOLWDateLiteral; - Node.WriteSubNodeDate('DateValue', DateLIteral.DateValue); // do not localize + Node.WriteSubNodeDate('DateValue', DateLIteral.DateValue); end; { TBoldXMLOLWTimeLiteralStreamer } @@ -1487,7 +1496,7 @@ procedure TBoldXMLOLWTimeLiteralStreamer.ReadObject(Obj: TObject; begin inherited; TimeLiteral := obj as TBoldOLWTimeLiteral; - TimeLiteral.TimeValue := Node.ReadSubNodeTime('TimeValue'); // do not localize + TimeLiteral.TimeValue := Node.ReadSubNodeTime('TimeValue'); end; @@ -1498,7 +1507,7 @@ procedure TBoldXMLOLWTimeLiteralStreamer.WriteObject( begin inherited; TimeLiteral := obj as TBoldOLWTimeLiteral; - Node.WriteSubNodeTime('TimeValue', TimeLIteral.TimeValue); // do not localize + Node.WriteSubNodeTime('TimeValue', TimeLIteral.TimeValue); end; { TBoldOLWMomentLiteral } @@ -1518,21 +1527,11 @@ procedure TBoldOLWDateLiteral.AcceptVisitor(V: TBoldOLWNodeVisitor); v.VisitTBoldOLWDateLiteral(self); end; -function TBoldOLWDateLiteral.GetDateValue: TDateTime; -begin - result := fMomentValue; -end; - function TBoldOLWDateLiteral.GetStreamName: string; begin result := OLWDateLiteralStreamName; end; -procedure TBoldOLWDateLiteral.SetDateValue(const Value: TDateTime); -begin - fMomentValue := Value; -end; - { TBoldOLWTimeLiteral } procedure TBoldOLWTimeLiteral.AcceptVisitor(V: TBoldOLWNodeVisitor); @@ -1546,17 +1545,8 @@ function TBoldOLWTimeLiteral.GetStreamName: string; result := OLWTimeLiteralStreamName; end; -function TBoldOLWTimeLiteral.GetTimeValue: TDateTime; -begin - result := fMomentValue; -end; - -procedure TBoldOLWTimeLiteral.SetTimeValue(const Value: TDateTime); -begin - fMomentValue := Value; -end; - initialization + TBoldXMLStreamerRegistry.MainStreamerRegistry.RegisterStreamer(TBoldXMLOCLConditionStreamer.Create); TBoldXMLStreamerRegistry.MainStreamerRegistry.RegisterStreamer(TBoldXMLOLWNodeListStreamer.Create); TBoldXMLStreamerRegistry.MainStreamerRegistry.RegisterStreamer(TBoldXMLOLWTypeNodeStreamer.Create); diff --git a/Source/ObjectSpace/Ocl/BoldOclRTDebug.pas b/Source/ObjectSpace/Ocl/BoldOclRTDebug.pas index 1a011f50..b50f3106 100644 --- a/Source/ObjectSpace/Ocl/BoldOclRTDebug.pas +++ b/Source/ObjectSpace/Ocl/BoldOclRTDebug.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOclRTDebug; interface @@ -16,4 +19,5 @@ TBoldOclRTDebugger = class (TBoldMemoryManagedObject) implementation + end. diff --git a/Source/ObjectSpace/Ocl/BoldOclSemantics.pas b/Source/ObjectSpace/Ocl/BoldOclSemantics.pas index a834c1c6..228e167c 100644 --- a/Source/ObjectSpace/Ocl/BoldOclSemantics.pas +++ b/Source/ObjectSpace/Ocl/BoldOclSemantics.pas @@ -1,9 +1,11 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOclSemantics; interface uses - Classes, BoldSystemRT, BoldElements, BoldOclClasses; @@ -27,7 +29,7 @@ TBoldOclSemanticsVisitor = class(TBoldOclVisitor) procedure AddListCoercionOnArgs(N: TBoldOCLOperation); procedure CheckArgumentType(actArg: TBoldOCLNode; FormArg: TBoldElementTypeInfo); procedure DeduceBoldType(N: TBoldOCLOperation); - function FindSymbol(name: string): TBoldOclSymbol; + function FindSymbol(const name: string): TBoldOclSymbol; function LeastCommonSuperClass(C1, C2: TBoldClassTypeInfo): TBoldClassTypeInfo; function LeastCommonSuperType(AttributeTypeInfo1, AttributeTypeInfo2: TBoldAttributetypeInfo): TBoldAttributeTypeInfo; procedure PushResubscribe(var ReSubscribe, OldReSubscribe: Boolean); @@ -46,15 +48,15 @@ TBoldOclSemanticsVisitor = class(TBoldOclVisitor) procedure VisitTBoldOclOperation(N: TBoldOCLOperation); override; procedure VisitTBoldOclStrLiteral(N: TBoldOclStrLiteral); override; procedure VisitTBoldOclTypeNode(N: TBoldOclTypeNode); override; - procedure VisitTBoldOclVariableReference(N: TBoldOCLVariableReference); override; + procedure VisitTBoldOclVariablereference(N: TBoldOCLVariableReference); override; property IgnoreNelCompatibility: Boolean read fIgnoreNelCompatibility write fIgnoreNelCompatibility; end; implementation uses + Classes, SysUtils, - BoldCoreConsts, BoldUtils, BoldOclError, BoldOcl; @@ -64,7 +66,7 @@ implementation 'No DeduceMethod', 'Same type as loopvariable', 'Same type as arg1', 'Same type as listelement of arg1', 'Same type as arg2', 'Same type as arg3', 'Least common supertype of arg1 and arg2', 'Least common supertype of arg2 and arg3', - 'Same type as listelement of arg2', 'Type is ObjectList', 'Type is Metatype', 'Type is arg2 (typecast)', 'Arg1 as a list', 'a list with the type of Arg2'); + 'Same type as listelement of arg2', 'Type is ObjectList', 'Type is Metatype', 'Type is arg2 (typecast)', 'Type is arg1 ', 'Arg1 as a list', 'a list with the type of Arg2'); constructor TBoldOclSemanticsVisitor.Create(Model: TBoldSystemTypeInfo; Evaluator: TBoldEvaluator; SymTab: TBoldSymbolDictionary; Env: TBoldOclEnvironment); begin @@ -87,7 +89,7 @@ procedure TBoldOclSemanticsVisitor.CheckArgumentType(actArg: TBoldOCLNode; FormA begin if not actArg.BoldType.ConformsTo(FormArg) then raise EBoldOCLAbort.CreateFmt(boeNoConform, - [actArg.Position, actArg.BoldType.ExpressionName, FormArg.ExpressionName]); + [actArg.Position, actArg.BoldType.AsString, FormArg.AsString]); end; { else begin if actArg.BoldType is TBoldSystemtypeInfo then @@ -105,8 +107,7 @@ procedure TBoldOclSemanticsVisitor.Traverse(var Node: TBoldOCLNode); TempNode: TBoldOCLLIstCoercion; LocalReSubscribe: Boolean; begin - // It is not certain the listcoercion will be needed in the current context - // so we remove it here and then it might be reinserted again later. + if Node is TBoldOCLLIstCoercion then begin TempNode := TBoldOCLLIstCoercion(Node); @@ -120,7 +121,6 @@ procedure TBoldOclSemanticsVisitor.Traverse(var Node: TBoldOCLNode); Node.SetReferenceValue(nil); LocalReSubscribe := ReSubscribe; -// Node.Evaluator := fEvaluator; try Node.AcceptVisitor(self); ReSubscribe := LocalReSubscribe; @@ -143,8 +143,7 @@ procedure TBoldOclSemanticsVisitor.TraverseList(List: TBoldOCLNodeList; begin for I := Start to Stop do begin - // It is not certain the listcoercion will be needed in the current context - // so we remove it here and then it might be reinserted again later. + if List[I] is TBoldOCLLIstCoercion then begin TempNode := TBoldOCLLIstCoercion(List[I]); @@ -172,7 +171,7 @@ procedure TBoldOclSemanticsVisitor.TraverseList(List: TBoldOCLNodeList; end; end; -function TBoldOclSemanticsVisitor.FindSymbol(name: string): TBoldOclSymbol; +function TBoldOclSemanticsVisitor.FindSymbol(const name: string): TBoldOclSymbol; begin result := Symboltable.SymbolByName[name]; end; @@ -182,7 +181,7 @@ procedure TBoldOclSemanticsVisitor.AddListCoercionOnArgs(N: TBoldOCLOperation); I: Integer; CoercionNode: TBoldOCLLIstCoercion; begin - for I := 0 to N.Args.Count - 1 do + for I := 0 to Length(N.Args) - 1 do begin if N.Args[I].NeedsListCoercion then begin @@ -208,9 +207,6 @@ procedure FixImplicitCollect; i: integer; begin - // This is an implicit Collect. Change NodeType! - - // We really have to create a new node since the old one will be freed when replaced by the replacementNode!!! if n is TBoldOclMethod then begin @@ -222,7 +218,6 @@ procedure FixImplicitCollect; NewOperation := TBoldOclOperation.Create; OldNode0 := n.args[0]; - n.args.Delete(0); VarName := fEnv.MakeGenSymName; VarNode := TBoldOClVariableReference.Create; @@ -231,37 +226,33 @@ procedure FixImplicitCollect; NewOperation.OperationName := n.OperationName; NewOperation.Position := n.Position; - NewOperation.Args := TBoldOclNodeLIst.create; - NewOperation.Args.add(VarNode); - for i := 0 to n.args.count - 1 do + SetLength(NewOperation.Args, Length(n.args)); + NewOperation.Args[0] := VarNode; + for i := 1 to Length(n.args) - 1 do begin - NewOperation.args.Add(n.args[0]); - n.Args.Delete(0); + NewOperation.args[i] := n.args[i]; end; + SetLength(n.Args, 0); CollectNode := TBoldOclIteration.Create; collectNode.IteratorSpecifier := OclCollect; - CollectNode.OperationName := 'Collect'; // do not localize + CollectNode.OperationName := 'Collect'; collectNode.Position := n.Position; - CollectNode.Args := TBoldOClNodeList.create; - CollectNode.Args.Add(OldNode0); - CollectNode.Args.Add(NewOperation); + SetLength(CollectNode.Args, 2); + CollectNode.Args[0] := OldNode0; + CollectNode.Args[1] := NewOperation; VarBind := TBoldOCLVariableBinding.Create; VarBind.VariableName := VarName; CollectNode.LoopVar := VarBind; - // Now Traverse the node and make sure we put the correct node in the replacementNode-variable - - tempList := TBoldOclNodeList.create; - TempLIst.Add(CollectNode); + SetLength(TempList, 1); + TempList[0] := CollectNode; try - TraverseList(tempLIst, 0, 0); + TraverseList(TempList, 0, 0); finally - // even if things fail, it is better to have the new node than no node at all. - ReplacementNode := TempLIst[0]; - TempLIst[0] := nil; - TempList.Free; + ReplacementNode := TempList[0]; + SetLength(TempList, 0); end; end; @@ -279,10 +270,9 @@ procedure FixImplicitCollect; N.IsConstant := True; try - // boolean shortcut must force resubscribe on the shortcutting node - if SameText(N.OperationName, 'if') or // do not localize - SameText(N.OperationName, 'or') or // do not localize - SameText(N.OperationName, 'and') then // do not localize + if SameText(N.OperationName, 'if') or + SameText(N.OperationName, 'or') or + SameText(N.OperationName, 'and') then begin OldResubscribe := Resubscribe; Resubscribe := true; @@ -299,12 +289,12 @@ procedure FixImplicitCollect; exit; end; - if N.Args.Count <> N.Symbol.NumberOfArgs then - raise EBoldOCLAbort.CreateFmt(boeWrongnumberofargs, [N.Position, N.Symbol.NumberOfArgs, N.Args.Count]); + if Length(N.Args) <> N.Symbol.NumberOfArgs then + raise EBoldOCLAbort.CreateFmt(boeWrongnumberofargs, [N.Position, N.Symbol.NumberOfArgs, Length(N.Args)]); - TraverseList(N.Args, 1, N.Args.Count - 1); + TraverseList(N.Args, 1, Length(N.Args) - 1); - for I := 0 to N.Args.Count - 1 do + for I := 0 to Length(N.Args) - 1 do begin N.IsConstant := N.IsConstant and N.Args[I].IsConstant; CheckArgumentType(N.Args[I], N.Symbol.FormalArguments[i]); @@ -322,7 +312,7 @@ procedure FixImplicitCollect; if not Type2.ConformsTo(type1) and not Type1.ConformsTo(Type2) then - raise EBoldOCLAbort.CreateFmt(sArgumentsDoNotConform, [n.Position, n.Symbol.SymbolName, Type1.AsString, type2.AsString]); + raise EBoldOCLAbort.CreateFmt('%d: In "%s", one of the arguments must conform to the other (%s and %s does not)', [n.Position, n.Symbol.SymbolName, Type1.AsString, type2.AsString]); end; except on e: Exception do @@ -342,8 +332,8 @@ procedure TBoldOclSemanticsVisitor.VisitTBoldOclIteration(N: TBoldOclIteration); if not assigned(N.Symbol) then raise EBoldOCLAbort.CreateFmt(boeUndefinedOperation, [N.Position, N.OperationName]); - if N.Args.Count <> N.Symbol.NumberOfArgs then - raise EBoldOCLAbort.CreateFmt(boeWrongnumberofargs, [N.Position, N.Symbol.NumberOfArgs, N.Args.Count]); + if Length(N.Args) <> N.Symbol.NumberOfArgs then + raise EBoldOCLAbort.CreateFmt(boeWrongnumberofargs, [N.Position, N.Symbol.NumberOfArgs, Length(N.Args)]); PushResubscribe(ReSubscribe, OldReSubscribe); @@ -354,16 +344,13 @@ procedure TBoldOclSemanticsVisitor.VisitTBoldOclIteration(N: TBoldOclIteration); ReSubscribe := OldReSubscribe; if not assigned(N.LoopVar) then - // CHECKME N.LoopVar := TBoldOclVariableBinding.Create(n); N.LoopVar := TBoldOclVariableBinding.Create; if N.LoopVar.VariableName = '' then N.LoopVar.VariableName := fEnv.MakeGenSymName; - - // we must coerce the first arguement before using its type AddListCoercionOnArgs(N); - n.LoopVar.SetReferenceValue(nil); // reset dynamic boldtype + n.LoopVar.SetReferenceValue(nil); if not assigned(N.LoopVar.BoldType) then if n.args[0].BoldType is TBoldListTypeInfo then @@ -372,8 +359,8 @@ procedure TBoldOclSemanticsVisitor.VisitTBoldOclIteration(N: TBoldOclIteration); raise EBoldOCLInternalError.CreateFmt(boeUnKnownTypeOfLoopVar, [N.Position, N.Args[0].BoldType.ClassName]); fEnv.PushBinding(N.LoopVar); try - TraverseList(N.Args, 1, N.Args.Count - 1); - for I := 1 to N.Args.Count - 1 do + TraverseList(N.Args, 1, Length(N.Args) - 1); + for I := 1 to Length(N.Args) - 1 do begin N.IsConstant := N.IsConstant and N.Args[I].IsConstant; CheckArgumentType(N.Args[I], N.Symbol.FormalArguments[i]); @@ -395,6 +382,7 @@ procedure TBoldOclSemanticsVisitor.VisitTBoldOclIteration(N: TBoldOclIteration); function TBoldOclSemanticsVisitor.TestForOperation(n: TBoldOclNode): Boolean; var TempOperation: TBoldOCLOperation; + nAsMethod: TBoldOclMethod; i: integer; PossibleOperation: TBoldOclSymbol; OpName: String; @@ -406,7 +394,7 @@ function TBoldOclSemanticsVisitor.TestForOperation(n: TBoldOclNode): Boolean; else if n is TBoldOclMethod then OpName := TBoldOclMethod(n).OperationName else - raise EBoldOclInternalError.CreateFmt('%d:Illegal call for TestForOperation', [n.Position]); // do not localize + raise EBoldOclInternalError.CreateFmt('%d:Illegal call for TestForOperation', [n.Position]); PossibleOperation := FindSymbol(OpName); @@ -416,34 +404,31 @@ function TBoldOclSemanticsVisitor.TestForOperation(n: TBoldOclNode): Boolean; TempOperation.Symbol := PossibleOperation; TempOperation.ReSubscribe := Resubscribe; TempOperation.OperationName := OpName; - TempOperation.Args := TBoldOCLNodeList.Create; if n is TBoldOclMember then begin - TempOperation.args.add(TBoldOclMember(n).Memberof); + SetLength(TempOperation.Args, 1); + TempOperation.args[0] := TBoldOclMember(n).Memberof; TBoldOclMember(n).Memberof := nil; end else if n is TBoldOclMethod then begin - TempOperation.args.add(TBoldOclMethod(n).Methodof); - for i := 0 to TBoldOclMethod(n).args.count - 1 do + nAsMethod := TBoldOclMethod(n); + SetLength(TempOperation.Args, Length(nAsMethod.args)+1); + TempOperation.args[0] := nAsMethod.Methodof; + for i := 0 to Length(nAsMethod.args) - 1 do begin - TempOperation.args.add(TBoldOclMethod(n).args[i]); - TBoldOclMethod(n).args[i] := nil; + TempOperation.args[i+1] := nAsMethod.args[i]; + nAsMethod.args[i] := nil; end; - TBoldOclMethod(n).Methodof := nil; + nAsMethod.Methodof := nil; end; TempOperation.Position := n.Position; try - TempOperation.AcceptVisitor(self); // HAs to traverse the whole subtree again :-( + TempOperation.AcceptVisitor(self); finally - //Now, publish the operation to be exchanged to. if not assigned(ReplacementNode) then ReplacementNode := TempOperation else - // this occurs if the operation was also a part of an implicit collect such as - // Person.allInstances.constraints, in that case, the replacementnode will - // refer to a copy of the tempoperation, and the copy will have stolen the - // arguments already (see FixImplicitCollect) TempOperation.Free; end; Result := true; @@ -455,6 +440,7 @@ procedure TBoldOclSemanticsVisitor.VisitTBoldOclMethod(N: TBoldOclMethod); VarRef: TBoldOCLVariableReference; MethodRTInfo: TBoldMethodRTInfo; ClassTypeInfo: TBoldClassTypeInfo; + I, L: Integer; begin if not assigned(N.MethodOf) then begin @@ -476,7 +462,11 @@ procedure TBoldOclSemanticsVisitor.VisitTBoldOclMethod(N: TBoldOclMethod); if not n.MethodOf_AddedToArgs then begin - n.Args.Insert(0, n.MethodOf); + L := Length(n.Args); + SetLength(n.Args, (L+1)); + for I := 0 to L-1 do + n.Args[i+1] := n.Args[I]; + n.Args[0] := n.MethodOf; n.MethodOf_AddedToArgs := true; end; @@ -489,14 +479,13 @@ procedure TBoldOclSemanticsVisitor.VisitTBoldOclMethod(N: TBoldOclMethod); ClassTypeInfo := TBoldListTypeInfo(n.MethodOf.BoldType).ListElementTypeInfo as TBoldClassTypeInfo; if not assigned(classTypeInfo) then - raise EBoldOclInternalError.CreateFmt(sMethodNotoperatingOnClass, [N.Position, N.OperationName]); + raise EBoldOclInternalError.CreateFmt('%d: Method (%s) is not operating on a class...', [N.Position, N.OperationName]); MethodRTInfo := ClassTypeInfo.Methods.ItemsByExpressionName[n.OperationName]; if not assigned(MethodRTInfo) then raise EBoldOCLAbort.CreateFmt(boeUndefinedOperation, [N.Position, N.OperationName]); N.Symbol := nil; -// N.Symbol := MethodRTInfo.OclSymbol as TBoldOclSymbol; if not assigned(N.Symbol) then raise EBoldOCLAbort.CreateFmt(boeOperationNotOclable, [N.Position, N.OperationName]); @@ -536,7 +525,6 @@ procedure TBoldOclSemanticsVisitor.VisitTBoldOclMember(N: TBoldOclMember); end else begin - // The Current node will be replaced with a var-reference inside Traverse VarRef := TBoldOCLVariableReference.Create; Varref.VariableBinding := Binding; Varref.VariableName := N.Membername; @@ -558,10 +546,9 @@ procedure TBoldOclSemanticsVisitor.VisitTBoldOclMember(N: TBoldOclMember); if not assigned(ElementType) then - // this is most likely due to absence of a context. Current member is assumed to have - // an implicit Self-var-reference, but it has no context. - // It also occurs when trying to evaluate an empty single-link and is then taken care of by - // the TBoldOCL.CheckSemantics + + + raise EBoldOCLAbort.CreateFmt(boeVariableNotAssigned, [N.Position, '']); case ElementType.BoldValueType of @@ -573,7 +560,7 @@ procedure TBoldOclSemanticsVisitor.VisitTBoldOclMember(N: TBoldOclMember); if not assigned(ClassTypeInfo) then raise EBoldOCLAbort.CreateFmt(boeUnknownclass, [N.Position, N.Membername]); N.BoldType := CurrentSystemTypeInfo.ListTypeInfoByElement[ClassTypeInfo]; - n.MemberType := nil; // needed if the expression has been evaluated in another context previously + n.MemberType := nil; end; end; bvtClass: begin @@ -610,23 +597,21 @@ procedure TBoldOclSemanticsVisitor.VisitTBoldOclMember(N: TBoldOclMember); roleRTInfo := nil; if not assigned(RoleRTInfo) then - raise EBoldOclAbort.CreateFmt(sOnlyRolesCanBeQualified, [n.position]); + raise EBoldOclAbort.CreateFmt('%d: Only roles may be qualified', [n.position]); if not RoleRTInfo.IsQualified then - raise EBoldOclAbort.CreateFmt(sXIsNotAQualifiedRole, [n.position, ClassTypeInfo.ExpressionName, RoleRTInfo.ExpressionName]); - if N.Qualifier.Count <> RoleRTInfo.Qualifiers.count then - raise EBoldOCLAbort.CreateFmt(boeWrongnumberofargs, [N.Position, RoleRTInfo.Qualifiers.count, N.Qualifier.Count]); + raise EBoldOclAbort.CreateFmt('%d: %s.%s is not a qualified role', [n.position, ClassTypeInfo.ExpressionName, RoleRTInfo.ExpressionName]); + if Length(N.Qualifier) <> RoleRTInfo.Qualifiers.count then + raise EBoldOCLAbort.CreateFmt(boeWrongnumberofargs, [N.Position, RoleRTInfo.Qualifiers.count, Length(N.Qualifier)]); if RoleRTInfo.IsQualifiedMulti or - // qualified access starting from an objectlist (assigned(n.MemberOf) and (n.MemberOf.BoldType is TBoldListTypeInfo)) then begin -// raise EBoldOclAbort.CreateFmt('%d: %s.%s - Qualified relations with multiplicity > 1 not supported', [n.position, ClassTypeInfo.ExpressionName, RoleRTInfo.ExpressionName]); n.BoldType := n.MemberType end else n.BoldType := RoleRTInfo.ClassTypeInfoOfOtherEnd; - TraverseList(N.qualifier, 0, N.Qualifier.Count - 1); + TraverseList(N.qualifier, 0, Length(N.Qualifier) - 1); for i := 0 to RoleRTInfo.Qualifiers.count - 1 do CheckArgumentType(n.Qualifier[i], RoleRTInfo.Qualifiers[i].BoldType); @@ -660,7 +645,7 @@ procedure TBoldOclSemanticsVisitor.VisitTBoldOclVariablereference(N: TBoldOCLVar N.BoldType := N.VariableBinding.BoldType; if not assigned(N.BoldType) then - raise EBoldOCLAbort.CreateFmt(boeVariableNotAssigned, [N.Position, n.VariableName]); + raise EBoldOCLAbort.CreateFmt(boeVariableNotAssigned, [N.Position, n.VariableName]); end; procedure TBoldOCLSemanticsVisitor.VisitTBoldOCLTypeNode(n: TBoldOclTypeNode); @@ -711,7 +696,7 @@ procedure TBoldOCLSemanticsVisitor.VisitTBoldOCLTypeNode(n: TBoldOclTypeNode); procedure TBoldOclSemanticsVisitor.VisitTBoldOclStrLiteral(N: TBoldOclStrLiteral); begin - N.BoldType := CurrentSystemTypeInfo.AttributeTypeInfoByExpressionName['String']; // do not localize + N.BoldType := TBoldOcl(fEvaluator).StringType; N.IsConstant := True; end; @@ -735,8 +720,7 @@ function TBoldOclSemanticsVisitor.LeastCommonSuperType(AttributeTypeInfo1, Attri else if AttributeTypeInfo2.BoldIsA(AttributeTypeInfo1) then Result := AttributeTypeInfo1 else if AttributeTypeInfo2.AttributeClass=AttributeTypeInfo1.AttributeClass then - // attributes with the same delphitype will conform to each other, but they will not support BoldIsA - // either attribute will do as good as result from here + result := AttributeTypeInfo1 else Result := LeastCommonSuperType(AttributeTypeInfo1.SuperAttributeTypeInfo, AttributeTypeInfo2); @@ -753,7 +737,7 @@ procedure TBoldOclSemanticsVisitor.VisitTBoldOclCollectionLiteral(N: TBoldOclCol begin Traverse(N.rangeStart); Traverse(N.rangeStop); - IntType := CurrentSystemTypeInfo.AttributeTypeInfoByExpressionName['Integer']; // do not localize + IntType := TBoldOcl(fEvaluator).IntegerType; if not N.rangeStart.BoldType.ConformsTo(IntType) then raise EBoldOCLAbort.CreateFmt(boeRangeMustBeInt, [N.rangeStart.Position]); if not N.rangeStop.BoldType.ConformsTo(IntType) then @@ -763,18 +747,18 @@ procedure TBoldOclSemanticsVisitor.VisitTBoldOclCollectionLiteral(N: TBoldOclCol end else begin - if N.Elements.Count = 0 then + if Length(N.Elements) = 0 then begin N.BoldType := CurrentSystemTypeInfo.ListTypeInfoByElement[nil]; end else begin - TraverseList(N.Elements, 0, N.Elements.Count - 1); + TraverseList(N.Elements, 0, Length(N.Elements) - 1); N.IsConstant := N.Elements[0].IsConstant; if N.Elements[0].BoldType is TBoldClasstypeInfo then begin TopClass := N.Elements[0].BoldType as TBoldClassTypeInfo; - for I := 1 to N.Elements.Count - 1 do + for I := 1 to Length(N.Elements) - 1 do begin N.IsConstant := N.IsConstant and N.Elements[I].IsConstant; if not (N.Elements[I].BoldType is TBoldClassTypeInfo) then @@ -786,7 +770,7 @@ procedure TBoldOclSemanticsVisitor.VisitTBoldOclCollectionLiteral(N: TBoldOclCol else begin TopType := N.Elements[0].BoldType as TBoldAttributetypeInfo; - for I := 1 to N.Elements.Count - 1 do + for I := 1 to Length(N.Elements) - 1 do begin if not (N.Elements[I].BoldType is TBoldAttributeTypeInfo) then raise EBoldOCLAbort.CreateFmt(boeElementnotConformToCollection, [N.Elements[I].Position]); @@ -799,24 +783,28 @@ procedure TBoldOclSemanticsVisitor.VisitTBoldOclCollectionLiteral(N: TBoldOclCol end; end; end; - // n.IsConstant := False; // Needed as long as values are transfered out of the OCL-nodes end; procedure TBoldOclSemanticsVisitor.VisitTBoldOclNumericLiteral(N: TBoldOclNumericLiteral); begin - N.BoldType := CurrentSystemTypeInfo.AttributeTypeInfoByExpressionName['Float']; // do not localize + N.BoldType := TBoldOcl(fEvaluator).FloatType; N.IsConstant := True; end; procedure TBoldOclSemanticsVisitor.VisitTBoldOclEnumLiteral(N: TBoldOclEnumLiteral); +var + vElement: TBoldElement; + vTypeInfo: TBoldElementTypeInfo; begin - N.BoldType := CurrentSystemTypeInfo.AttributeTypeInfoByExpressionName['ValueSet']; // do not localize + if not CurrentSystemTypeInfo.FindValueSetAndTypeByName(N.Name, vElement, vTypeInfo) then + raise EBoldOCLAbort.CreateFmt(boeEnumValueNotFound, [N.Position, N.Name]); + N.BoldType := vTypeInfo; //CurrentSystemTypeInfo.ValueSetTypeInfo; N.IsConstant := True; end; procedure TBoldOclSemanticsVisitor.VisitTBoldOclIntLiteral(N: TBoldOclIntLiteral); begin - N.BoldType := CurrentSystemTypeInfo.AttributeTypeInfoByExpressionName['Integer']; // do not localize + N.BoldType := TBoldOcl(fEvaluator).IntegerType; N.IsConstant := True; end; @@ -841,10 +829,8 @@ procedure TBoldOclSemanticsVisitor.DeduceBoldType(N: TBoldOCLOperation); else N.BoldType := CurrentSystemTypeInfo.ListTypeInfoByElement[N.Args[0].BoldType]; -// tbodBoolean: N.BoldType := CurrentModel.AttributeTypeByExpressionName['Boolean']; -// tbodInteger: N.BoldType := CurrentModel.AttributeTypeByExpressionName['Integer']; -// tbodreal: N.BoldType := CurrentModel.AttributeTypeByExpressionName['Float']; -// tbodString: N.BoldType := CurrentModel.AttributeTypeByExpressionName['String']; + + tbodListofArg2: begin if N.Args[1].BoldType.BoldValueType = bvtList then @@ -899,6 +885,14 @@ procedure TBoldOclSemanticsVisitor.DeduceBoldType(N: TBoldOCLOperation); else N.BoldType := nil; + if not assigned(N.BoldType) then + begin + if arg1 is TBoldNilTypeInfo then + N.BoldType := arg2 + else + if arg2 is TBoldNilTypeInfo then + N.BoldType := arg1 + end; if not assigned(N.BoldType) then raise EBoldOCLAbort.CreateFmt(boeNoCommonSuperclass, [N.Position, arg1.ExpressionName, arg2.ExpressionName]); @@ -908,6 +902,7 @@ procedure TBoldOclSemanticsVisitor.DeduceBoldType(N: TBoldOCLOperation); end; tbodType: n.BoldType := N.Args[0].BoldType.BoldType; tbodTypeCast: n.BoldType := n.Args[1].value as TBoldElementTypeInfo; + tbodArg1Type: n.BoldType := n.Args[0].value as TBoldElementTypeInfo; tbodObjectList: if assigned(n.args[0].Value) then n.BoldType := CurrentSystemTypeInfo.ListTypeInfoByElement[n.args[0].Value as TBoldElementTypeInfo]; @@ -916,8 +911,8 @@ procedure TBoldOclSemanticsVisitor.DeduceBoldType(N: TBoldOCLOperation); if not assigned(n.BoldType) then begin ArgTypes := TStringList.Create; - for i := 0 to n.args.count - 1 do - ArgTypes.Add(Format('Arg %s: %s', [IntToStr(i + 1), n.args[i].BoldType.AsString])); // do not localize + for i := 0 to Length(n.args) - 1 do + ArgTypes.Add(Format('Arg %s: %s', [IntToStr(i + 1), n.args[i].BoldType.AsString])); ContextStr := BoldSeparateStringList(ArgTypes, ', ', '', ''); ArgTypes.Free; @@ -927,13 +922,13 @@ procedure TBoldOclSemanticsVisitor.DeduceBoldType(N: TBoldOCLOperation); procedure TBoldOclSemanticsVisitor.VisitTBoldOclDateLiteral(N: TBoldOclDateLiteral); begin - N.BoldType := CurrentSystemTypeInfo.AttributeTypeInfoByExpressionName['Date']; // do not localize + N.BoldType := TBoldOcl(fEvaluator).DateType; N.IsConstant := True; end; procedure TBoldOclSemanticsVisitor.VisitTBoldOclTimeLiteral(N: TBoldOclTimeLiteral); begin - N.BoldType := CurrentSystemTypeInfo.AttributeTypeInfoByExpressionName['Time']; // do not localize + N.BoldType := TBoldOcl(fEvaluator).TimeType; N.IsConstant := True; end; diff --git a/Source/ObjectSpace/Ocl/BoldOclSymbolImplementations.pas b/Source/ObjectSpace/Ocl/BoldOclSymbolImplementations.pas index 05e29875..0fa0bae9 100644 --- a/Source/ObjectSpace/Ocl/BoldOclSymbolImplementations.pas +++ b/Source/ObjectSpace/Ocl/BoldOclSymbolImplementations.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOclSymbolImplementations; interface @@ -12,6 +15,7 @@ implementation uses SysUtils, + DateUtils, BoldElements, BoldAttributes, BoldOclError, @@ -21,10 +25,13 @@ implementation BoldSystemRT, BoldSystem, Classes, + Variants, + Math, BoldSubscription, - BoldValueSpaceInterfaces, // besExisting is defined here... - BoldRegularExpression, - BoldCoreConsts; + BoldValueSpaceInterfaces, + System.RegularExpressions, + System.RegularExpressionsCore, + BoldIsoDateTime; var G_OCLOperations: TList = nil; @@ -42,6 +49,18 @@ procedure RegisterOCLOperation(OperationClass: TBoldOclSymbolClass); OCLOperations.Add(OperationClass); end; +function ExtractDateTimeFromMoment(moment: TBAMoment): TDateTime; +begin + if Moment is TBADateTime then + Result := (Moment as TBADateTime).asDateTime + else if Moment is TBADate then + Result := (Moment as TBADate).asDate + else if Moment is TBATime then + Result := (Moment as TBATime).asTime + else + Result := 0; +end; + type TBOS_AbstractCompare = class(TBoldOclSymbol) @@ -63,14 +82,6 @@ TBOS_NotEqual = class(TBOS_AbstractCompare) procedure Evaluate(const Params: TBoldOclSymbolParameters); override; end; - TBOS_Except = class(TBoldOclSymbol) - protected - procedure Init; override; - public - procedure Evaluate(const Params: TBoldOclSymbolParameters); override; - end; - - TBOS_Add = class(TBoldOclSymbol) protected procedure Init; override; @@ -134,6 +145,13 @@ TBOS_strToInt = class(TBoldOclSymbol) procedure Evaluate(const Params: TBoldOclSymbolParameters); override; end; + TBOS_strToFloat = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + TBOS_Min = class(TBoldOclSymbol) protected procedure Init; override; @@ -183,6 +201,13 @@ TBOS_Div = class(TBoldOclSymbol) procedure Evaluate(const Params: TBoldOclSymbolParameters); override; end; + TBOS_SafeDivZero = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + TBOS_Mod = class(TBoldOclSymbol) protected procedure Init; override; @@ -225,6 +250,13 @@ TBOS_SubString = class(TBoldOclSymbol) procedure Evaluate(const Params: TBoldOclSymbolParameters); override; end; + TBOS_Contains = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + TBOS_Pad = class(TBoldOclSymbol) protected procedure Init; override; @@ -239,7 +271,19 @@ TBOS_PostPad = class(TBoldOclSymbol) procedure Evaluate(const Params: TBoldOclSymbolParameters); override; end; - TBOS_FormatNumeric = class(TBoldOclSymbol) + TBOS_Format = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_FormatNumeric = class(TBOS_Format) + protected + procedure Init; override; + end; + + TBOS_FormatFloat = class(TBoldOclSymbol) protected procedure Init; override; public @@ -253,6 +297,20 @@ TBOS_FormatDateTime = class(TBoldOclSymbol) procedure Evaluate(const Params: TBoldOclSymbolParameters); override; end; + TBOS_AsISODateTime = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_AsISODate = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + TBOS_StrToDate = class(TBoldOclSymbol) protected procedure Init; override; @@ -274,9 +332,66 @@ TBOS_StrToDateTime = class(TBoldOclSymbol) procedure Evaluate(const Params: TBoldOclSymbolParameters); override; end; + TBOS_DayOfDate = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_MonthOfDate = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_YearOfDate = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_WeekOfDate = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_DayOfWeekOfDate = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_HoursBetween = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_MinutesBetween = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_SecondsBetween = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + TBOS_or = class(TBoldOclSymbol) protected procedure Init; override; + function GetShortCircuitType: ShortCircuitType; override; public procedure Evaluate(const Params: TBoldOclSymbolParameters); override; end; @@ -284,6 +399,7 @@ TBOS_or = class(TBoldOclSymbol) TBOS_and = class(TBoldOclSymbol) protected procedure Init; override; + function GetShortCircuitType: ShortCircuitType; override; public procedure Evaluate(const Params: TBoldOclSymbolParameters); override; end; @@ -312,6 +428,7 @@ TBOS_implies = class(TBoldOclSymbol) TBOS_if = class(TBoldOclSymbol) protected procedure Init; override; + function GetShortCircuitType: ShortCircuitType; override; public procedure Evaluate(const Params: TBoldOclSymbolParameters); override; end; @@ -372,12 +489,6 @@ TBOS_Sum = class(TBoldOclSymbol) procedure Evaluate(const Params: TBoldOclSymbolParameters); override; end; - TBOS_SumTime = class(TBoldOclSymbol) - protected - procedure Init; override; - public - procedure Evaluate(const Params: TBoldOclSymbolParameters); override; - end; TBOS_Maxvalue = class(TBoldOclSymbol) protected @@ -509,12 +620,14 @@ TBOS_Append = class(TBoldOclSymbol) public procedure Evaluate(const Params: TBoldOclSymbolParameters); override; end; + TBOS_Prepend = class(TBoldOclSymbol) protected procedure Init; override; public procedure Evaluate(const Params: TBoldOclSymbolParameters); override; end; + TBOS_SubSequence = class(TBoldOclSymbol) protected procedure Init; override; @@ -565,7 +678,28 @@ TBOS_asString = class(TBoldOclSymbol) procedure Evaluate(const Params: TBoldOclSymbolParameters); override; end; - TBOS_dateTimeAsFloat = class(TBoldOclSymbol) + TBOS_AsFloat = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_FloatAsDateTime = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_datePart = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_asDateTime = class(TBoldOclSymbol) protected procedure Init; override; public @@ -645,6 +779,14 @@ TBOS_AllInstances = class(TBoldOclSymbol) procedure Evaluate(const Params: TBoldOclSymbolParameters); override; end; + TBOS_NullValue = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_AllLoadedObjects = class(TBoldOclSymbol) protected procedure Init; override; @@ -796,431 +938,602 @@ TBOS_TimeToTimeStamp = class(TBoldOclSymbol) procedure Evaluate(const Params: TBoldOclSymbolParameters); override; end; + TBOS_IndexOf = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_ReverseCollection = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_asCommaText = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_separate = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_CommaSeparatedStringToCollection = class(TBoldOclSymbol) + protected + function GetListTypeInfo: TBoldListTypeInfo; virtual; abstract; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_CommaSeparatedStringToStringCollection = class(TBOS_CommaSeparatedStringToCollection) + protected + procedure Init; override; + function GetListTypeInfo: TBoldListTypeInfo; override; + end; + + TBOS_CommaSeparatedStringToIntegerCollection = class(TBOS_CommaSeparatedStringToCollection) + protected + procedure Init; override; + function GetListTypeInfo: TBoldListTypeInfo; override; + end; + + TBOS_Trim = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_HasDuplicates = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_BoldId = class(TBoldOclSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_Power = class(TBoldOCLSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + + TBOS_Sqrt = class(TBoldOCLSymbol) + protected + procedure Init; override; + public + procedure Evaluate(const Params: TBoldOclSymbolParameters); override; + end; + procedure TBOS_Equal.Init; begin - InternalInit('=', [nil, nil], tbodNo, HELP.BooleanType, False, 100); + InternalInit('=', [nil, nil], tbodNo, HELP.BooleanType, False, 100, true); end; procedure TBOS_NotEqual.Init; begin - InternalInit('<>', [nil, nil], tbodNo, HELP.BooleanType, False, 101); // do not localize -end; - -procedure TBOS_Except.Init; -begin - InternalInit('except', [nil, nil], tbodLCC, nil, true, 101); // do not localize + InternalInit('<>', [nil, nil], tbodNo, HELP.BooleanType, False, 101, true); end; procedure TBOS_Add.Init; begin - InternalInit('+', [nil, nil], tbodLCC, nil, False, 102); // do not localize + InternalInit('+', [nil, nil], tbodLCC, nil, False, 102); end; procedure TBOS_Subtract.Init; begin - InternalInit('-',[HELP.NumericType, HELP.NumericType], tbodLCC, nil, False, 103); // do not localize + InternalInit('-',[HELP.NumericType, HELP.NumericType], tbodLCC, nil, False, 103); end; procedure TBOS_UnaryMinus.Init; begin - InternalInit('unary-', [HELP.NumericType], tbodCopyArg1, nil, False, 104); // do not localize + InternalInit('unary-', [HELP.NumericType], tbodCopyArg1, nil, False, 104); end; procedure TBOS_Multiply.Init; begin - InternalInit('*', [HELP.NumericType, HELP.NumericType], tbodLCC, nil, False, 105); // do not localize + InternalInit('*', [HELP.NumericType, HELP.NumericType], tbodLCC, nil, False, 105); end; procedure TBOS_Divide.Init; begin - InternalInit('/', [HELP.NumericType, HELP.NumericType], tbodNo, HELP.RealType, False, 106); // do not localize + InternalInit('/', [HELP.NumericType, HELP.NumericType], tbodNo, HELP.RealType, False, 106); +end; + +procedure TBOS_SafeDivZero.Init; +begin + InternalInit('safediv', [Help.NumericType, Help.NumericType], tbodNo, Help.NumericType, True, 106); end; procedure TBOS_Abs.Init; begin - InternalInit('abs', [HELP.NumericType], tbodCopyArg1, nil, True, 107); // do not localize + InternalInit('abs', [HELP.NumericType], tbodCopyArg1, nil, True, 107); end; procedure TBOS_Floor.Init; begin - InternalInit('floor', [HELP.NumericType], tbodNo, HELP.IntegerType, True, 108); // do not localize + InternalInit('floor', [HELP.NumericType], tbodNo, HELP.IntegerType, True, 108); end; procedure TBOS_Round.Init; begin - InternalInit('round', [HELP.NumericType], tbodNo, HELP.IntegerType, True, 109); // do not localize + InternalInit('round', [HELP.NumericType], tbodNo, HELP.IntegerType, True, 109); end; procedure TBOS_strToInt.Init; begin - InternalInit('strToInt', [HELP.stringType], tbodNo, HELP.IntegerType, True, 109); // do not localize + InternalInit('strToInt', [HELP.stringType], tbodNo, HELP.IntegerType, True, 109); +end; + +procedure TBOS_strToFloat.Init; +begin + InternalInit('strToFloat', [HELP.stringType], tbodNo, HELP.RealType, True, 109); end; procedure TBOS_Max.Init; begin - InternalInit('max', [HELP.NumericType, HELP.NumericType], tbodLCC, nil, True, 110); // do not localize + InternalInit('max', [HELP.NumericType, HELP.NumericType], tbodLCC, nil, True, 110); end; + procedure TBOS_Min.Init; begin - InternalInit('min', [HELP.NumericType, HELP.NumericType], tbodLCC, nil, True, 111); // do not localize + InternalInit('min', [HELP.NumericType, HELP.NumericType], tbodLCC, nil, True, 111); end; procedure TBOS_Less.Init; begin - InternalInit('<', [nil, nil], tbodNo, HELP.BooleanType, False, 112); // do not localize + InternalInit('<', [nil, nil], tbodNo, HELP.BooleanType, False, 112); end; + procedure TBOS_Greater.Init; begin - InternalInit('>', [nil, nil], tbodNo, HELP.BooleanType, False, 113); // do not localize + InternalInit('>', [nil, nil], tbodNo, HELP.BooleanType, False, 113); end; + procedure TBOS_LessEQ.Init; begin - InternalInit('<=', [nil, nil], tbodNo, HELP.BooleanType, False, 114); // do not localize + InternalInit('<=', [nil, nil], tbodNo, HELP.BooleanType, False, 114); end; + procedure TBOS_GreaterEQ.Init; begin - InternalInit('>=', [nil, nil], tbodNo, HELP.BooleanType, False, 115); // do not localize + InternalInit('>=', [nil, nil], tbodNo, HELP.BooleanType, False, 115); end; procedure TBOS_Div.Init; begin - InternalInit('div', [HELP.IntegerType, HELP.IntegerType], tbodNo, HELP.IntegerType, False, 116); // do not localize + InternalInit('div', [HELP.IntegerType, HELP.IntegerType], tbodNo, HELP.IntegerType, False, 116); end; + procedure TBOS_Mod.Init; begin - InternalInit('mod', [HELP.IntegerType, HELP.IntegerType], tbodNo, HELP.IntegerType, False, 117); // do not localize + InternalInit('mod', [HELP.IntegerType, HELP.IntegerType], tbodNo, HELP.IntegerType, False, 117); end; procedure TBOS_Length.Init; begin - InternalInit('length', [HELP.StringType], tbodNo, HELP.IntegerType, True, 118); // do not localize + InternalInit('length', [HELP.StringType], tbodNo, HELP.IntegerType, True, 118); end; + procedure TBOS_concat.Init; begin - InternalInit('concat', [HELP.StringType, HELP.StringType], tbodNo, HELP.StringType, True, 119); // do not localize + InternalInit('concat', [HELP.StringType, HELP.StringType], tbodNo, HELP.StringType, True, 119); end; + procedure TBOS_ToUpper.Init; begin - InternalInit('toUpper', [HELP.StringType], tbodNo, HELP.StringType, True, 120); // do not localize + InternalInit('toUpper', [HELP.StringType], tbodNo, HELP.StringType, True, 120); end; + procedure TBOS_toLower.Init; begin - InternalInit('toLower', [HELP.StringType], tbodNo, HELP.StringType, True, 121); // do not localize + InternalInit('toLower', [HELP.StringType], tbodNo, HELP.StringType, True, 121); end; + procedure TBOS_SubString.Init; begin - InternalInit('subString', [HELP.StringType, HELP.IntegerType, HELP.IntegerType], tbodNo, HELP.StringType, True, 122); // do not localize + InternalInit('subString', [HELP.StringType, HELP.IntegerType, HELP.IntegerType], tbodNo, HELP.StringType, True, 122); +end; + +procedure TBOS_Contains.Init; +begin + InternalInit('contains', [HELP.StringType, HELP.StringType], tbodNo, HELP.BooleanType, True, 122); end; procedure TBOS_Pad.Init; begin - InternalInit('pad', [HELP.StringType, HELP.IntegerType, HELP.StringType], tbodNo, HELP.StringType, True, 123); // do not localize + InternalInit('pad', [HELP.StringType, HELP.IntegerType, HELP.StringType], tbodNo, HELP.StringType, True, 123); end; procedure TBOS_PostPad.Init; begin - InternalInit('postPad', [HELP.StringType, HELP.IntegerType, HELP.StringType], tbodNo, HELP.StringType, True, 124); // do not localize + InternalInit('postPad', [HELP.StringType, HELP.IntegerType, HELP.StringType], tbodNo, HELP.StringType, True, 124); +end; + +procedure TBOS_format.Init; +begin + InternalInit('format', [HELP.NumericType, HELP.StringType], tbodNo, HELP.StringType, True, 124); +end; + +procedure TBOS_FormatFloat.Init; +begin + InternalInit('formatFloat', [HELP.NumericType, HELP.StringType], tbodNo, HELP.StringType, True, 124); end; procedure TBOS_formatNumeric.Init; begin - InternalInit('formatNumeric', [HELP.NumericType, HELP.StringType], tbodNo, HELP.StringType, True, 124); // do not localize + InternalInit('formatNumeric', [HELP.NumericType, HELP.StringType], tbodNo, HELP.StringType, True, 124); end; procedure TBOS_formatDateTime.Init; begin - InternalInit('formatDateTime', [HELP.MomentType, HELP.StringType], tbodNo, HELP.StringType, True, 124); // do not localize + InternalInit('formatDateTime', [HELP.MomentType, HELP.StringType], tbodNo, HELP.StringType, True, 124); +end; + +procedure TBOS_AsISODateTime.Init; +begin + InternalInit('asISODateTime', [HELP.MomentType], tbodNo, HELP.StringType, True, 124); +end; + +procedure TBOS_AsISODate.Init; +begin + InternalInit('asISODate', [HELP.MomentType], tbodNo, HELP.StringType, True, 124); end; procedure TBOS_StrToDate.Init; begin - InternalInit('strToDate', [HELP.StringType], tbodNo, HELP.DateType, True, 124); // do not localize + InternalInit('strToDate', [HELP.StringType], tbodNo, HELP.DateType, True, 124); end; procedure TBOS_StrToTime.Init; begin - InternalInit('strToTime', [HELP.StringType], tbodNo, HELP.TimeType, True, 124); // do not localize + InternalInit('strToTime', [HELP.StringType], tbodNo, HELP.TimeType, True, 124); end; procedure TBOS_StrToDateTime.Init; begin - InternalInit('strToDateTime', [HELP.StringType], tbodNo, HELP.DateTimeType, True, 124); // do not localize + InternalInit('strToDateTime', [HELP.StringType], tbodNo, HELP.DateTimeType, True, 124); +end; + +function TBOS_or.GetShortCircuitType: ShortCircuitType; +begin + Result := csOr; end; procedure TBOS_or.Init; begin - InternalInit('or', [HELP.BooleanType, HELP.BooleanType], tbodNo, HELP.BooleanType, True, 125); // do not localize + InternalInit('or', [HELP.BooleanType, HELP.BooleanType], tbodNo, HELP.BooleanType, True, 125); +end; + +function TBOS_and.GetShortCircuitType: ShortCircuitType; +begin + Result := csAnd; end; + procedure TBOS_and.Init; begin - InternalInit('and', [HELP.BooleanType, HELP.BooleanType], tbodNo, HELP.BooleanType, True, 126); // do not localize + InternalInit('and', [HELP.BooleanType, HELP.BooleanType], tbodNo, HELP.BooleanType, True, 126); end; + procedure TBOS_xor.Init; begin - InternalInit('xor', [HELP.BooleanType, HELP.BooleanType], tbodNo, HELP.BooleanType, True, 127); // do not localize + InternalInit('xor', [HELP.BooleanType, HELP.BooleanType], tbodNo, HELP.BooleanType, True, 127); end; + procedure TBOS_implies.Init; begin - InternalInit('implies', [HELP.BooleanType, HELP.BooleanType], tbodNo, HELP.BooleanType, True, 128); // do not localize + InternalInit('implies', [HELP.BooleanType, HELP.BooleanType], tbodNo, HELP.BooleanType, True, 128); end; + procedure TBOS_not.Init; begin - InternalInit('not', [HELP.BooleanType], tbodNo, HELP.BooleanType, True, 129); // do not localize + InternalInit('not', [HELP.BooleanType], tbodNo, HELP.BooleanType, True, 129); +end; + +function TBOS_if.GetShortCircuitType: ShortCircuitType; +begin + Result := csIf; end; procedure TBOS_if.Init; begin - InternalInit('if', [HELP.BooleanType, nil, nil], tbodLCC23, nil, True, 130); // do not localize + InternalInit('if', [HELP.BooleanType, nil, nil], tbodLCC23, nil, True, 130); end; procedure TBOS_Size.Init; begin - InternalInit('size', [HELP.ListType], tbodNo, HELP.IntegerType, True, 131); // do not localize + InternalInit('size', [HELP.ListType], tbodNo, HELP.IntegerType, True, 131); end; + procedure TBOS_includes.Init; begin - InternalInit('includes', [HELP.ListType, nil], tbodNo, HELP.BooleanType, True, 132, true); // do not localize + InternalInit('includes', [HELP.ListType, nil], tbodNo, HELP.BooleanType, True, 132, true); end; + procedure TBOS_Count.Init; begin - InternalInit('count', [HELP.ListType, nil], tbodNo, HELP.IntegerType, True, 133, true); // do not localize + InternalInit('count', [HELP.ListType, nil], tbodNo, HELP.IntegerType, True, 133, true); end; + procedure TBOS_IncludesAll.Init; begin - InternalInit('includesAll', [HELP.ListType, HELP.ListType], tbodNo, HELP.BooleanType, True, 134, true); // do not localize + InternalInit('includesAll', [HELP.ListType, HELP.ListType], tbodNo, HELP.BooleanType, True, 134, true); end; + procedure TBOS_isEmpty.Init; begin - InternalInit('isEmpty', [HELP.ListType], tbodNo, HELP.BooleanType, True, 135); // do not localize + InternalInit('isEmpty', [HELP.ListType], tbodNo, HELP.BooleanType, True, 135); end; procedure TBOS_NotEmpty.Init; begin - InternalInit('notEmpty', [HELP.ListType], tbodNo, HELP.BooleanType, True, 136); // do not localize + InternalInit('notEmpty', [HELP.ListType], tbodNo, HELP.BooleanType, True, 136); end; + procedure TBOS_Sum.Init; begin - InternalInit('sum', [HELP.NumericListType], tbodCopyArg1Elem, nil, True, 137); // do not localize + InternalInit('sum', [HELP.NumericListType], tbodCopyArg1Elem, nil, True, 137); end; procedure TBOS_MinValue.Init; begin - InternalInit('minValue', [HELP.NumericListType], tbodCopyArg1Elem, nil, True, 138); // do not localize + InternalInit('minValue', [HELP.NumericListType], tbodCopyArg1Elem, nil, True, 138); end; + procedure TBOS_Maxvalue.Init; begin - InternalInit('maxValue', [HELP.NumericListType], tbodCopyArg1Elem, nil, True, 139); // do not localize + InternalInit('maxValue', [HELP.NumericListType], tbodCopyArg1Elem, nil, True, 139); end; + procedure TBOS_Average.Init; begin - InternalInit('average', [HELP.NumericListType], tbodNo, HELP.RealType, True, 140); // do not localize + InternalInit('average', [HELP.NumericListType], tbodNo, HELP.RealType, True, 140); end; + procedure TBOS_Exists.Init; begin - InternalInit('exists', [HELP.ListType, HELP.BooleanType], tbodNo, HELP.BooleanType, True, 141); // do not localize + InternalInit('exists', [HELP.ListType, HELP.BooleanType], tbodNo, HELP.BooleanType, True, 141); end; + procedure TBOS_ForAll.Init; begin - InternalInit('forAll', [HELP.ListType, HELP.BooleanType], tbodNo, HELP.BooleanType, True, 142); // do not localize + InternalInit('forAll', [HELP.ListType, HELP.BooleanType], tbodNo, HELP.BooleanType, True, 142); end; + procedure TBOS_union.Init; begin - InternalInit('union', [HELP.ListType, HELP.ListType], tbodLCC, nil, True, 143); // do not localize + InternalInit('union', [HELP.ListType, HELP.ListType], tbodLCC, nil, True, 143); end; + procedure TBOS_Intersection.Init; begin - InternalInit('intersection', [HELP.ListType, HELP.ListType], tbodLCC, nil, True, 144, true); // do not localize + InternalInit('intersection', [HELP.ListType, HELP.ListType], tbodLCC, nil, True, 144, true); end; + procedure TBOS_difference.Init; begin - InternalInit('difference', [HELP.ListType, HELP.ListType], tbodCopyArg1, nil, True, 145, true); // do not localize + InternalInit('difference', [HELP.ListType, HELP.ListType], tbodCopyArg1, nil, True, 145, true); end; + procedure TBOS_Including.Init; begin - InternalInit('including', [HELP.ListType, HELP.ObjectType], tbodLCC, nil, True, 146); // do not localize + InternalInit('including', [HELP.ListType, HELP.ObjectType], tbodLCC, nil, True, 146); end; + procedure TBOS_excluding.Init; begin - InternalInit('excluding', [HELP.ListType, HELP.ObjectType], tbodCopyArg1, nil, True, 147); // do not localize + InternalInit('excluding', [HELP.ListType, HELP.ObjectType], tbodCopyArg1, nil, True, 147); end; + procedure TBOS_SymmetricDifference.Init; begin - InternalInit('symmetricDifference', [HELP.ListType, HELP.ListType], tbodLCC, nil, True, 148); // do not localize + InternalInit('symmetricDifference', [HELP.ListType, HELP.ListType], tbodLCC, nil, True, 148); end; + procedure TBOS_Select.Init; begin - InternalInit('select', [HELP.ListType, HELP.BooleanType], tbodCopyArg1, nil, True, 149); // do not localize + InternalInit('select', [HELP.ListType, HELP.BooleanType], tbodCopyArg1, nil, True, 149); end; + procedure TBOS_reject.Init; begin - InternalInit('reject', [HELP.ListType, HELP.BooleanType], tbodCopyArg1, nil, True, 150); // do not localize + InternalInit('reject', [HELP.ListType, HELP.BooleanType], tbodCopyArg1, nil, True, 150); end; + procedure TBOS_collect.Init; begin - InternalInit('collect', [HELP.ListType, nil], tbodListofArg2, nil, True, 151); // do not localize + InternalInit('collect', [HELP.ListType, nil], tbodListofArg2, nil, True, 151); end; + procedure TBOS_AsSequence.Init; begin - InternalInit('asSequence', [HELP.ListType], tbodArg1AsList, nil, True, 152); // do not localize + InternalInit('asSequence', [HELP.ListType], tbodArg1AsList, nil, True, 152); end; + procedure TBOS_AsBag.Init; begin - InternalInit('asBag', [HELP.ListType], tbodArg1AsList, nil, True, 153); // do not localize + InternalInit('asBag', [HELP.ListType], tbodArg1AsList, nil, True, 153); end; + procedure TBOS_AsSet.Init; begin - InternalInit('asSet', [HELP.ListType], tbodArg1AsList, nil, True, 154); // do not localize + InternalInit('asSet', [HELP.ListType], tbodArg1AsList, nil, True, 154); end; + procedure TBOS_Append.Init; begin - InternalInit('append', [HELP.ListType, HELP.ObjectType], tbodLCC, nil, True, 155); // do not localize + InternalInit('append', [HELP.ListType, HELP.ObjectType], tbodLCC, nil, True, 155); end; + procedure TBOS_Prepend.Init; begin - InternalInit('prepend', [HELP.ListType, HELP.ObjectType], tbodLCC, nil, True, 156); // do not localize + InternalInit('prepend', [HELP.ListType, HELP.ObjectType], tbodLCC, nil, True, 156); end; + procedure TBOS_SubSequence.Init; begin - InternalInit('subSequence', [HELP.ListType, HELP.IntegerType, HELP.IntegerType], tbodCopyArg1, nil, True, 157); // do not localize + InternalInit('subSequence', [HELP.ListType, HELP.IntegerType, HELP.IntegerType], tbodCopyArg1, nil, True, 157); end; + procedure TBOS_at.Init; begin - InternalInit('at', [HELP.ListType, HELP.IntegerType], tbodCopyArg1Elem, nil, True, 158); // do not localize + InternalInit('at', [HELP.ListType, HELP.IntegerType], tbodCopyArg1Elem, nil, True, 158); end; + procedure TBOS_first.Init; begin - InternalInit('first', [HELP.ListType], tbodCopyArg1Elem, nil, True, 159); // do not localize + InternalInit('first', [HELP.ListType], tbodCopyArg1Elem, nil, True, 159); end; + procedure TBOS_last.Init; begin - InternalInit('last', [HELP.ListType], tbodCopyArg1Elem, nil, True, 160); // do not localize + InternalInit('last', [HELP.ListType], tbodCopyArg1Elem, nil, True, 160); end; procedure TBOS_orderby.Init; begin - InternalInit('orderby', [HELP.ListType, nil], tbodCopyArg1, nil, True, 161); // do not localize + InternalInit('orderby', [HELP.ListType, nil], tbodCopyArg1, nil, True, 161); end; + procedure TBOS_orderDescending.Init; begin - InternalInit('orderdescending', [HELP.ListType, nil], tbodCopyArg1, nil, True, 162); // do not localize + InternalInit('orderdescending', [HELP.ListType, nil], tbodCopyArg1, nil, True, 162); end; - - procedure TBOS_asString.Init; begin - InternalInit('asString', [nil], tbodNo, HELP.StringType, True, 163); // do not localize + InternalInit('asString', [nil], tbodNo, HELP.StringType, True, 163); +end; + +procedure TBOS_datePart.Init; +begin + InternalInit('datePart', [HELP.MomentType], tbodNo, HELP.DateType, True, 163); end; -procedure TBOS_dateTimeAsFloat.Init; +procedure TBOS_asDateTime.Init; begin - InternalInit('dateTimeAsFloat', [HELP.MomentType], tbodNo, HELP.RealType, True, 163); // do not localize + InternalInit('asDateTime', [HELP.MomentType], tbodNo, HELP.DateTimeType, True, 163); end; procedure TBOS_TypeName.Init; begin - InternalInit('typename', [HELP.TypeType], tbodNo, HELP.StringType, True, 164); // do not localize + InternalInit('typename', [HELP.TypeType], tbodNo, HELP.StringType, True, 164); end; procedure TBOS_Attributes.Init; begin - InternalInit('attributes', [HELP.TypeType], tbodNo, HELP.StringListType, True, 165); // do not localize + InternalInit('attributes', [HELP.TypeType], tbodNo, HELP.StringListType, True, 165); end; procedure TBOS_AssociationEnds.Init; begin - InternalInit('associationEnds', [HELP.TypeType], tbodNo, HELP.StringListType, True, 166); // do not localize + InternalInit('associationEnds', [HELP.TypeType], tbodNo, HELP.StringListType, True, 166); end; {procedure TBOS_Operations.Init; begin - InternalInit('operations', [HELP.TypeType], tbodNo, HELP.StringListType, True, 167); // do not localize + InternalInit('operations', [HELP.TypeType], tbodNo, HELP.StringListType, True, 167); end; } procedure TBOS_SuperTypes.Init; begin - InternalInit('superTypes', [HELP.TypeType], tbodNo, HELP.TypeListType, True, 168); // do not localize + InternalInit('superTypes', [HELP.TypeType], tbodNo, HELP.TypeListType, True, 168); end; procedure TBOS_AllSuperTypes.Init; begin - InternalInit('allSuperTypes', [HELP.TypeType], tbodNo, HELP.TypeListType, True, 169); // do not localize + InternalInit('allSuperTypes', [HELP.TypeType], tbodNo, HELP.TypeListType, True, 169); end; procedure TBOS_AllSubClasses.Init; begin - InternalInit('allSubClasses', [HELP.TypeType], tbodNo, HELP.TypeListType, True, 169); // do not localize + InternalInit('allSubClasses', [HELP.TypeType], tbodNo, HELP.TypeListType, True, 169); end; procedure TBOS_AllInstances.Init; begin - InternalInit('allInstances', [HELP.TypeType], tbodObjectList, nil, True, 170); // do not localize + InternalInit('allInstances', [HELP.TypeType], tbodObjectList, nil, True, 170); end; procedure TBOS_AllLoadedObjects.Init; begin - InternalInit('allLoadedObjects', [HELP.TypeType], tbodObjectList, nil, True, 170); // do not localize + InternalInit('allLoadedObjects', [HELP.TypeType], tbodObjectList, nil, True, 170); end; procedure TBOS_emptyList.Init; begin - InternalInit('emptyList', [HELP.TypeType], tbodObjectList, nil, True, 170); // do not localize + InternalInit('emptyList', [HELP.TypeType], tbodObjectList, nil, True, 170); end; procedure TBOS_oclType.Init; begin - InternalInit('oclType', [nil], tbodNo, HELP.TypeType, True, 171); // do not localize + InternalInit('oclType', [nil], tbodNo, HELP.TypeType, True, 171); end; procedure TBOS_oclIsKindOf.Init; begin - InternalInit('oclIsKindOf', [nil, Help.TypeType], tbodNo, HELP.BooleanType, True, 172); // do not localize + InternalInit('oclIsKindOf', [nil, Help.TypeType], tbodNo, HELP.BooleanType, True, 172); end; procedure TBOS_OclIsTypeOf.Init; begin - InternalInit('oclIsTypeOf', [nil, Help.TypeType], tbodNo, HELP.BooleanType, True, 173); // do not localize + InternalInit('oclIsTypeOf', [nil, Help.TypeType], tbodNo, HELP.BooleanType, True, 173); end; procedure TBOS_OclAsType.Init; begin - InternalInit('oclAsType', [nil, Help.TypeType], tbodTypeCast, nil, True, 174); // do not localize + InternalInit('oclAsType', [nil, Help.TypeType], tbodTypeCast, nil, True, 174); end; procedure TBOS_SafeCast.Init; begin - InternalInit('safeCast', [nil, Help.TypeType], tbodTypeCast, nil, True, 174); // do not localize + InternalInit('safeCast', [nil, Help.TypeType], tbodTypeCast, nil, True, 174); end; procedure TBOS_sqlLike.Init; begin - InternalInit('sqlLike', [help.StringType, help.StringType], tbodNo, Help.BooleanType, True, 175); // do not localize + InternalInit('sqlLike', [help.StringType, help.StringType], tbodNo, Help.BooleanType, True, 175); end; procedure TBOS_SqlLikeCaseInsensitive.Init; begin - InternalInit('sqlLikeCaseInsensitive', [help.StringType, help.StringType], tbodNo, Help.BooleanType, True, 176); // do not localize + InternalInit('sqlLikeCaseInsensitive', [help.StringType, help.StringType], tbodNo, Help.BooleanType, True, 176); end; procedure TBOS_RegExpMatch.Init; begin - InternalInit('regExpMatch', [help.StringType, help.StringType], tbodNo, Help.BooleanType, True, 177); // do not localize + InternalInit('regExpMatch', [help.StringType, help.StringType], tbodNo, Help.BooleanType, True, 177); end; procedure TBOS_InDateRange.Init; begin - InternalInit('inDateRange', [help.MomentType, help.NumericType, help.NumericType], tbodNo, Help.BooleanType, True, 178); // do not localize + InternalInit('inDateRange', [help.MomentType, help.NumericType, help.NumericType], tbodNo, Help.BooleanType, True, 178); end; procedure TBOS_InTimeRange.Init; begin - InternalInit('inTimeRange', [help.MomentType, help.NumericType, help.NumericType], tbodNo, Help.BooleanType, True, 179); // do not localize + InternalInit('inTimeRange', [help.MomentType, help.NumericType, help.NumericType], tbodNo, Help.BooleanType, True, 179); end; procedure TBOS_isNull.Init; begin - InternalInit('isNull', [nil], tbodNo, HELP.BooleanType, True, 180); // do not localize + InternalInit('isNull', [nil], tbodNo, HELP.BooleanType, True, 180); end; procedure TBOS_Constraints.Init; @@ -1228,63 +1541,87 @@ procedure TBOS_Constraints.Init; ConstraintListTypeInfo: TBoldListTypeInfo; begin ConstraintListTypeInfo := Help.SystemTypeInfo.ListTypeInfoByElement[Help.ConstraintType]; - InternalInit('constraints', [nil], tbodNo, ConstraintListTypeInfo, True, 181); // do not localize + InternalInit('constraints', [nil], tbodNo, ConstraintListTypeInfo, True, 181); end; procedure TBOS_AtTime.Init; begin - InternalInit('atTime', [help.ObjectType, help.IntegerType], tbodCopyArg1, nil, True, 182); // do not localize + InternalInit('atTime', [help.ObjectType, help.IntegerType], tbodCopyArg1, nil, True, 182); end; procedure TBOS_ObjectTimeStamp.Init; begin - InternalInit('objectTimeStamp', [help.ObjectType], tbodNo, Help.IntegerType, True, 182); // do not localize + InternalInit('objectTimeStamp', [help.ObjectType], tbodNo, Help.IntegerType, True, 182); end; - procedure TBOS_allInstancesAtTime.Init; begin - InternalInit('allInstancesAtTime', [help.TypeType, help.IntegerType], tbodObjectList, nil, True, 183); // do not localize + InternalInit('allInstancesAtTime', [help.TypeType, help.IntegerType], tbodObjectList, nil, True, 183); end; procedure TBOS_existing.Init; begin - InternalInit('existing', [help.ObjectType], tbodNo, HELP.BooleanType, True, 184); // do not localize + InternalInit('existing', [help.ObjectType], tbodNo, HELP.BooleanType, True, 184); end; procedure TBOS_FilterOnType.Init; begin - InternalInit('filterOnType', [help.ListType, help.TypeType], tbodListFromArg2, nil, True, 185); // do not localize + InternalInit('filterOnType', [help.ListType, help.TypeType], tbodListFromArg2, nil, True, 185); end; procedure TBOS_BoldTime.Init; begin - InternalInit('boldTime', [help.ObjectType], tbodno, help.integerType, True, 186); // do not localize + InternalInit('boldTime', [help.ObjectType], tbodno, help.integerType, True, 186); end; procedure TBOS_TimeStampToTime.Init; begin - InternalInit('timeStampToTime', [help.IntegerType], tbodno, help.DateTimeType, True, 187); // do not localize + InternalInit('timeStampToTime', [help.IntegerType], tbodno, help.DateTimeType, True, 187); end; procedure TBOS_TimeToTimeStamp.Init; begin - InternalInit('timeToTimeStamp', [help.DateTimeType], tbodno, help.IntegerType, True, 188); // do not localize + InternalInit('timeToTimeStamp', [help.DateTimeType], tbodno, help.IntegerType, True, 188); end; -procedure TBOS_SumTime.Init; +procedure TBOS_StringRepresentation.Init; begin - InternalInit('sumTime', [HELP.MomentListType], tbodNo, Help.DateTimeType, True, 189); // do not localize + InternalInit('stringRepresentation', [nil, help.integerType], tbodNo, HELP.StringType, True, 190); end; -procedure TBOS_StringRepresentation.Init; +procedure TBOS_TaggedValue.Init; begin - InternalInit('stringRepresentation', [nil, help.integerType], tbodNo, HELP.StringType, True, 190); // do not localize + InternalInit('taggedValue', [help.ObjectType, help.StringType], tbodNo, HELP.StringType, True, 190); end; -procedure TBOS_TaggedValue.Init; +procedure TBOS_IndexOf.Init; +begin + InternalInit('indexOf', [HELP.ListType, nil{HELP.ObjectType}], tbodNo, HELP.IntegerType, True, 191, true); +end; + +procedure TBOS_ReverseCollection.Init; +begin + InternalInit('reverseCollection', [HELP.ListType], tbodCopyArg1, nil, True, 192); +end; + +procedure TBOS_HasDuplicates.Init; +begin + InternalInit('hasDuplicates', [HELP.ListType], tbodNo, HELP.BooleanType, True, 193); +end; + +procedure TBOS_BoldId.Init; +begin + InternalInit('boldID', [Help.ObjectType], tbodNo, Help.IntegerType, True, 194); +end; + +procedure TBOS_Power.Init; begin - InternalInit('taggedValue', [help.ObjectType, help.StringType], tbodNo, HELP.StringType, True, 190); // do not localize + InternalInit('power', [Help.NumericType, Help.NumericType], tbodNo, Help.RealType, True, 0); +end; + +procedure TBOS_Sqrt.Init; +begin + InternalInit('sqrt', [Help.NumericType], tbodNo, Help.RealType, True, 0); end; {-- SymbolImplementations --} @@ -1306,7 +1643,7 @@ function TBOS_AbstractCompare.CompareEnumLiterals(const Params: TBoldOclSymbolPa if Str = '' then str := (Params.nodes[1] as TBoldOClEnumLiteral).Name else - raise EBoldOclRunTimeError.CreateFmt(sCannotCompareEnumLiterals, + raise EBoldOclRunTimeError.CreateFmt('%d: Enum literals can not be compared to other enum literals (%s and %s)', [0, str, (Params.nodes[1] as TBoldOClEnumLiteral).Name]); end else if Params.Values[1] is TBAValueSet then @@ -1321,6 +1658,8 @@ procedure TBOS_Equal.Evaluate(const Params: TBoldOclSymbolParameters); HELP.MakeNewBoolean(Params.Result, CompareEnumLiterals(Params)) else if not assigned(Params.values[0]) then Help.MakeNewBoolean(Params.Result, not Assigned(Params.values[1])) + else if not Assigned(Params.values[1]) then + Help.MakeNewBoolean(Params.Result, false) else HELP.MakeNewBoolean(Params.Result, Params.values[0].IsEqual(Params.values[1])); end; @@ -1331,16 +1670,12 @@ procedure TBOS_NotEqual.Evaluate(const Params: TBoldOclSymbolParameters); HELP.MakeNewBoolean(Params.Result, not CompareEnumLiterals(Params)) else if not assigned(Params.values[0]) then Help.MakeNewBoolean(Params.Result, Assigned(Params.values[1])) + else if not Assigned(Params.values[1]) then + Help.MakeNewBoolean(Params.Result, true) else HELP.MakeNewBoolean(Params.Result, not Params.values[0].IsEqual(Params.values[1])); end; -procedure TBOS_Except.Evaluate(const Params: TBoldOclSymbolParameters); -begin - // this operation does not need to do anything as it is all handled by the evaluator - // this method is never called... -end; - {-- Real operations --} @@ -1394,14 +1729,36 @@ procedure TBOS_Multiply.Evaluate(const Params: TBoldOclSymbolParameters); end; procedure TBOS_Divide.Evaluate(const Params: TBoldOclSymbolParameters); + + procedure RaiseError; + begin + raise EBoldOclRuntimeError.CreateFmt(borteDivisionByZero, [0]); + end; + begin try HELP.MakeNewNumeric(Params.Result, XNumeric(Params.values[0]) / XNumeric(Params.values[1])); except + on e: EInvalidOp do + RaiseError; on e: EDivByZero do - raise EBoldOclRuntimeError.CreateFmt(borteDivisionByZero, [0]); + RaiseError; on e: EZeroDivide do - raise EBoldOclRuntimeError.CreateFmt(borteDivisionByZero, [0]); + RaiseError; + end; +end; + +{ TBOS_SafeDivZero } + +procedure TBOS_SafeDivZero.Evaluate( + const Params: TBoldOclSymbolParameters); +begin + try + HELP.MakeNewNumeric(Params.Result, XNumeric(Params.values[0]) / XNumeric(Params.values[1])); + except + on e: EInvalidOp do; + on e: EDivByZero do; + on e: EZeroDivide do; end; end; @@ -1427,23 +1784,56 @@ procedure TBOS_Round.Evaluate(const Params: TBoldOclSymbolParameters); procedure TBOS_StrToInt.Evaluate(const Params: TBoldOclSymbolParameters); begin - HELP.MakeNewInteger(Params.Result, StrToIntDef(XString(Params.values[0]), 0)); + HELP.MakeNewInteger(Params.Result, StrToInt(XString(Params.values[0]))); +end; + +procedure TBOS_strToFloat.Evaluate(const Params: TBoldOclSymbolParameters); +begin + HELP.MakeNewNumeric(Params.Result, StrToFloat(XString(Params.values[0]))); end; procedure TBOS_Max.Evaluate(const Params: TBoldOclSymbolParameters); +var + result: TBoldElement; begin - if Params.Result.BoldType.ConformsTo(HELP.integerType) then - HELP.MakeNewInteger(Params.Result, MaxIntValue([XInteger(Params.values[0]),XInteger(Params.values[1])])) + result := Params.values[0]; + if Assigned(result) and Assigned(Params.values[1]) then + begin + if result.CompareTo(Params.Values[1]) = -1 then + result := Params.values[1]; + end + else + if not Assigned(result) then + result := Params.values[1]; + if not Assigned(result) then + HELP.MakeNewNull(Params.Result, Params.Result.BoldType) else - HELP.MakeNewNumeric(Params.Result, maxValue([XNumeric(Params.values[0]),XNumeric(Params.values[1])])); + begin + HELP.MakeNew(Params.Result, Params.Result.BoldType); + Params.Result.Value.Assign(Result); + end; end; procedure TBOS_Min.Evaluate(const Params: TBoldOclSymbolParameters); +var + result: TBoldElement; begin - if Params.Result.BoldType.ConformsTo(HELP.integerType) then - HELP.MakeNewInteger(Params.Result, MinIntValue([XInteger(Params.values[0]),XInteger(Params.values[1])])) + result := Params.values[0]; + if Assigned(result) and Assigned(Params.values[1]) then + begin + if result.CompareTo(Params.Values[1]) = 1 then + result := Params.values[1]; + end + else + if not Assigned(result) then + result := Params.values[1]; + if not Assigned(result) then + HELP.MakeNewNull(Params.Result, Params.Result.BoldType) else - HELP.MakeNewNumeric(Params.Result, MinValue([XNumeric(Params.values[0]),XNumeric(Params.values[1])])); + begin + HELP.MakeNew(Params.Result, Params.Result.BoldType); + Params.Result.Value.Assign(Result); + end; end; procedure TBOS_Less.Evaluate(const Params: TBoldOclSymbolParameters); @@ -1530,6 +1920,15 @@ procedure TBOS_SubString.Evaluate(const Params: TBoldOclSymbolParameters); HELP.MakeNewString(Params.Result, S); end; +procedure TBOS_Contains.Evaluate(const Params: TBoldOclSymbolParameters); +var + s, subs : string; +begin + S := XString(Params.values[0]); + Subs := XString(Params.values[1]); + HELP.MakeNewBoolean(Params.Result, Pos(Subs, S) > 0); +end; + procedure TBOS_Pad.Evaluate(const Params: TBoldOclSymbolParameters); var Finallength: Integer; @@ -1578,32 +1977,50 @@ procedure TBOS_PostPad.Evaluate(const Params: TBoldOclSymbolParameters); Help.MakeNewString(Params.Result, PaddedStr); end; -procedure TBOS_FormatNumeric.Evaluate(const Params: TBoldOclSymbolParameters); +procedure TBOS_Format.Evaluate(const Params: TBoldOclSymbolParameters); begin help.MakeNewString(params.result, format(XString(Params.values[1]), [XNumeric(Params.values[0])])); end; +procedure TBOS_FormatFloat.Evaluate(const Params: TBoldOclSymbolParameters); +begin + help.MakeNewString(params.result, formatFloat(XString(Params.values[1]), XNumeric(Params.values[0]))); +end; + +procedure TBOS_AsISODateTime.Evaluate(const Params: TBoldOclSymbolParameters); +var + Moment: TBAMoment; +begin + Moment := Params.values[0] as TBAMoment; + if not Assigned(moment) or moment.IsNull then + HELP.MakeNewNull(Params.Result, Params.Result.BoldType) + else + help.MakeNewString(params.result, formatDateTime(cIsoDateTimeFormat, ExtractDateTimeFromMoment(Moment))); +end; + +procedure TBOS_AsISODate.Evaluate(const Params: TBoldOclSymbolParameters); +var + Moment: TBAMoment; +begin + Moment := Params.values[0] as TBAMoment; + if not Assigned(moment) or moment.IsNull then + HELP.MakeNewNull(Params.Result, Params.Result.BoldType) + else + help.MakeNewString(params.result, formatDateTime(cIsoDateFormat, ExtractDateTimeFromMoment(Moment))); +end; + procedure TBOS_FormatDateTime.Evaluate(const Params: TBoldOclSymbolParameters); var Moment: TBAMoment; - val: TDateTime; begin Moment := Params.values[0] as TBAMoment; - if moment.IsNull then + if not Assigned(moment) or moment.IsNull then begin help.MakeNewString(params.result, ''); end else begin - if Moment is TBADateTime then - val := (Moment as TBADateTime).asDateTime - else if Moment is TBADate then - val := (Moment as TBADate).asDate - else if Moment is TBATime then - val := (Moment as TBATime).asTime - else - val := 0; - help.MakeNewString(params.result, formatDateTime(XString(Params.values[1]), val)); + help.MakeNewString(params.result, formatDateTime(XString(Params.values[1]), ExtractDateTimeFromMoment(Moment))); end; end; @@ -1682,6 +2099,7 @@ procedure TBOS_Count.Evaluate(const Params: TBoldOclSymbolParameters); else begin Elem := Params.values[1]; + List.EnsureRange(0, List.Count - 1); for i := 0 to List.Count - 1 do if List[i].IsEqual(Elem) then inc(Count); HELP.MakeNewInteger(Params.Result, Count); @@ -1706,9 +2124,9 @@ procedure TBOS_IncludesAll.Evaluate(const Params: TBoldOclSymbolParameters); begin IncludesAll := True; - while (i < list2.Count) and IncludesAll do + while (i < list1.Count) and IncludesAll do begin - IncludesAll := IncludesAll and list1.Includes(list2[i]); + IncludesAll := IncludesAll and list2.Includes(list1[i]); inc(i); end; HELP.MakeNewBoolean(Params.Result, IncludesAll); @@ -1734,7 +2152,7 @@ procedure TBOS_NotEmpty.Evaluate(const Params: TBoldOclSymbolParameters); List := XList(Params.values[0]); if not assigned(list) then - HELP.MakeNewBoolean(Params.Result, true) + HELP.MakeNewBoolean(Params.Result, false) else HELP.MakeNewBoolean(Params.Result, List.Count <> 0); end; @@ -1744,29 +2162,25 @@ procedure TBOS_IsNull.Evaluate(const Params: TBoldOclSymbolParameters); if Params.values[0] is TBoldAttribute then HELP.MakeNewBoolean(Params.Result, (Params.values[0] as TBoldAttribute).IsNull) else - HELP.MakeNewBoolean(Params.Result, false); + HELP.MakeNewBoolean(Params.Result, Params.values[0] = nil); end; procedure TBOS_Select.Evaluate(const Params: TBoldOclSymbolParameters); - // First argument is the evaluated expression, the second argument is the object begin if Assigned(XList(Params.Result.value)) and XBoolean(Params.values[0]) then XList(Params.Result.value).Add(Params.values[1]); end; procedure TBOS_reject.Evaluate(const Params: TBoldOclSymbolParameters); - // First argument is the evaluated expression, the second argument is the object begin - if Assigned(XList(Params.Result.value)) and not XBoolean(Params.values[0]) then + if not (Assigned(XList(Params.Result.value)) and XBoolean(Params.values[0])) then XList(Params.Result.value).Add(Params.values[1]); end; procedure TBOS_collect.Evaluate(const Params: TBoldOclSymbolParameters); - // First argument is the evaluated expression, the second argument is the object var ResultList: TBoldList; SourceList: TBoldList; - i: integer; begin ResultList := XList(Params.Result.value); if assigned(Resultlist) then @@ -1774,12 +2188,12 @@ procedure TBOS_collect.Evaluate(const Params: TBoldOclSymbolParameters); sourceList := XList(Params.values[0]); if assigned(SourceList) then begin - for i := 0 to SourceList.Count - 1 do - ResultList.add(SourceList[i]); + ResultList.AddList(SourceList); end else begin - resultList.Add(Params.values[0]); + if Assigned(Params.values[0]) then + resultList.Add(Params.values[0]); end; end; end; @@ -1789,7 +2203,7 @@ procedure TBOS_GenericOrder.Evaluate(const Params: TBoldOclSymbolParameters); SortList: TBoldMemberList; DummyValue: TBoldAttribute; begin - Sortlist := XList(Params.Result.value) as tBoldMemberList; + Sortlist := XList(Params.Result.value) as TBoldMemberList; if Assigned(SortList) then begin if assigned(Params.values[0]) then @@ -1828,84 +2242,77 @@ procedure TBOS_Sum.Evaluate(const Params: TBoldOclSymbolParameters); Sum := 0 else for i := 0 to List.Count - 1 do - Sum := Sum + XNumeric(List[i]); + if not TBoldAttribute(List[i]).IsNull then + Sum := Sum + XNumeric(List[i]); if ListElementType.ConformsTo(HELP.IntegerType) then HELP.MakeNewInteger(Params.Result, Round(Sum)) else if ListElementType.ConformsTo(HELP.CurrencyType) then HELP.MakeNewCurrency(Params.Result, Sum) + else if ListElementType.ConformsTo(HELP.TimeType) then + HELP.MakeNewDateTime(Params.Result, Sum) else HELP.MakeNewNumeric(Params.Result, Sum); end; - -procedure TBOS_SumTime.Evaluate(const Params: TBoldOclSymbolParameters); -var - Sum : TDateTime; - i : Integer; - List : TBoldList; -begin - Sum := 0; - List := XList(Params.values[0]); - - if assigned(list) then - for i := 0 to List.Count - 1 do - Sum := Sum + XDateTime(List[i]); - - HELP.MakeNewDateTime(Params.Result, Sum) -end; - - procedure TBOS_Maxvalue.Evaluate(const Params: TBoldOclSymbolParameters); var - MAX : Double; + Max : Variant; i : Integer; List : TBoldList; ListElementType: TBoldElementTypeInfo; begin + Max := Null; List := XList(Params.values[0]); ListElementType := Params.Result.BoldType; - if not assigned(list) or (list.Count = 0) then - Max := 0 - else + if assigned(list) then + for i := 0 to List.Count - 1 do begin - MAX := xNumeric(List[0]); - for i := 1 to List.Count - 1 do + if not TBoldAttribute(List[i]).IsNull then begin - if MAX < XNumeric(List[i]) then - MAX := XNumeric(List[i]) + if VarIsNull(Max) or (Max < XNumeric(List[i])) then + Max := XNumeric(List[i]); end; end; - if ListElementType.ConformsTo(HELP.IntegerType) then - HELP.MakeNewInteger(Params.Result, Round(MAX)) + if VarIsNull(Max) then + HELP.MakeNewNull(Params.Result, Params.Result.BoldType) + else if ListElementType.ConformsTo(HELP.IntegerType) then + HELP.MakeNewInteger(Params.Result, Round(Max)) else if ListElementType.ConformsTo(HELP.CurrencyType) then - HELP.MakeNewCurrency(Params.Result, MAX) + HELP.MakeNewCurrency(Params.Result, Max) + else if ListElementType.ConformsTo(HELP.MomentType) then + HELP.MakeNewDateTime(Params.Result, Max) else - HELP.MakeNewNumeric(Params.Result, MAX); + HELP.MakeNewNumeric(Params.Result, Max); end; procedure TBOS_MinValue.Evaluate(const Params: TBoldOclSymbolParameters); var - Min : Double; + Min : Variant; i : Integer; List : TBoldList; ListElementType: TBoldElementTypeInfo; begin + Min := Null; List := XList(Params.values[0]); - ListElementType := Params.Result.Boldtype; - if not assigned(list) or (List.Count = 0) then - min := 0 - else + ListElementType := Params.Result.BoldType; + if assigned(list) then + for i := 0 to List.Count - 1 do begin - Min := XNumeric(List[0]); - for i := 1 to List.Count - 1 do - if Min > XNumeric(List[i]) then Min := XNumeric(List[i]); + if not TBoldAttribute(List[i]).IsNull then + begin + if VarIsNull(Min) or (Min > XNumeric(List[i])) then + Min := XNumeric(List[i]); + end; end; - - if ListElementType.ConformsTo(HELP.IntegerType) then + if VarIsNull(Min) then + HELP.MakeNewNull(Params.Result, Params.Result.BoldType) + else if ListElementType.ConformsTo(HELP.IntegerType) then HELP.MakeNewInteger(Params.Result, Round(Min)) else if ListElementType.ConformsTo(HELP.CurrencyType) then HELP.MakeNewCurrency(Params.Result, Min) + else if ListElementType.ConformsTo(HELP.MomentType) then + HELP.MakeNewDateTime(Params.Result, Min) else HELP.MakeNewNumeric(Params.Result, Min); end; @@ -1923,21 +2330,18 @@ procedure TBOS_Average.Evaluate(const Params: TBoldOclSymbolParameters); else begin for i := 0 to List.Count - 1 do - begin - Sum := Sum + XNumeric(List[i]); - end; + if not TBoldAttribute(List[i]).IsNull then + Sum := Sum + XNumeric(List[i]); HELP.MakeNewNumeric(Params.Result, Sum / List.Count); end; end; procedure TBOS_ForAll.Evaluate(const Params: TBoldOclSymbolParameters); - // First argument is the evaluated expression, the second argument is the object begin (Params.Result.Value as TBABoolean).AsBoolean := XBoolean(Params.Result.value) and xBoolean(Params.values[0]); end; procedure TBOS_Exists.Evaluate(const Params: TBoldOclSymbolParameters); - // First argument is the evaluated expression, the second argument is the object begin (Params.Result.Value as TBABoolean).AsBoolean := XBoolean(Params.Result.value) or XBoolean(Params.values[0]); end; @@ -1945,14 +2349,37 @@ procedure TBOS_Exists.Evaluate(const Params: TBoldOclSymbolParameters); procedure TBOS_includes.Evaluate(const Params: TBoldOclSymbolParameters); var List: TBoldList; + Element: TBoldElement; + aObj: TBoldObject; i : Integer; temp: Boolean; begin temp := False; List := XList(Params.values[0]); - If Assigned(List) then - for i := 0 to List.Count - 1 do - temp := temp or (List[i].IsEqual(Params.values[1])); + if Assigned(List) and (List.Count > 0) then begin + Element := Params.Values[1]; + if List is TBoldObjectList then begin + // Optimization for ObjectLists: check for locator. + // No need to ensure objects for equality check + aObj := nil; + if Element is TBoldObject then begin + aObj := TBoldObject(Element); + end else if Element is TBoldObjectReference then begin + aObj := TBoldObjectReference(Element).BoldObject; + end; + if Assigned(aObj) then begin + temp := TBoldObjectList(List).LocatorInList(aObj.BoldObjectLocator); + end; + end else begin + List.EnsureRange(0, List.Count - 1); + for i := 0 to List.Count - 1 do begin + if List[i].IsEqual(Element) then begin + temp := True; + Break; + end; + end; + end; + end; HELP.MakeNewBoolean(Params.Result, temp); end; @@ -1962,7 +2389,6 @@ procedure TBOS_union.Evaluate(const Params: TBoldOclSymbolParameters); Help.TransferOrClone(Params.nodes[1], Params.Result) else begin - // if the result is a supertype of the two parameters, then we can not reuse either list. if assigned(Params.nodes[0].BoldType) and assigned(Params.nodes[1].BoldType) and not Params.nodes[1].BoldType.conformsto(Params.nodes[0].BoldType) then begin @@ -1980,6 +2406,7 @@ procedure TBOS_Intersection.Evaluate(const Params: TBoldOclSymbolParameters); var i : Integer; resList, list1, list2: TBoldList; +aResListObject, aList1Object, aList2Object: TBoldObjectList; begin list1 := XList(Params.values[0]); list2 := XList(Params.values[1]); @@ -1991,24 +2418,36 @@ procedure TBOS_Intersection.Evaluate(const Params: TBoldOclSymbolParameters); begin if list2.Count < list1.Count then begin - // Make sure we loop over the shortes list. resList := list1; list1 := list2; list2 := resList; end; resList := help.CreateNewMember(Params.Result.BoldType) as TBoldList; - for i := 0 to list1.Count - 1 do - if list2.Includes(list1[i]) then - resList.Add(list1[i]); + + // Optimization for ObjectLists + // Thus, the objects no longer need to be fechted during OCL evaluation + if resList is TBoldObjectList then begin + aList1Object := TBoldObjectList(list1); + aList2Object := TBoldObjectList(list2); + aResListObject := TBoldObjectList(resList); + for i := 0 to aList1Object.Count - 1 do + if aList2Object.LocatorInList(aList1Object.Locators[i]) then + aResListObject.AddLocator(aList1Object.Locators[i]); + end else begin + for i := 0 to list1.Count - 1 do + if list2.Includes(list1[i]) then + resList.Add(list1[i]); + end; Params.Result.SetOwnedValue(resList); end; end; procedure TBOS_difference.Evaluate(const Params: TBoldOclSymbolParameters); var - i, p : Integer; + i, p: Integer; list1, list2: TBoldList; + aList1Object, aList2Object: TBoldObjectList; begin if not assigned(XList(Params.values[0])) then Params.Result.SetReferenceValue(nil) @@ -2019,11 +2458,22 @@ procedure TBOS_difference.Evaluate(const Params: TBoldOclSymbolParameters); HELP.TransferOrClone(Params.nodes[0], Params.Result); list2 := XList(Params.values[1]); list1 := XList(Params.Result.value); - for i := 0 to list2.Count - 1 do - begin - p := list1.IndexOf(List2[i]); - if p <> -1 then - list1.RemoveByIndex(p); + if (list1 is TBoldObjectList) and (list2 is TBoldObjectList) then begin + aList1Object := TBoldObjectList(list1); + aList2Object := TBoldObjectList(list2); + for i := 0 to aList2Object.Count - 1 do + begin + p := aList1Object.IndexOfLocator(aList2Object.Locators[i]); + if p <> -1 then + aList1Object.RemoveByIndex(p); + end; + end else begin + for i := 0 to list2.Count - 1 do + begin + p := list1.IndexOf(List2[i]); + if p <> -1 then + list1.RemoveByIndex(p); + end; end; end; end; @@ -2057,6 +2507,7 @@ procedure TBOS_SymmetricDifference.Evaluate(const Params: TBoldOclSymbolParamete var i : Integer; resList, list1, list2: TBoldList; + aResListObject, aList1Object, aList2Object: TBoldObjectList; begin list1 := XList(Params.values[0]); list2 := XList(Params.values[1]); @@ -2067,18 +2518,33 @@ procedure TBOS_SymmetricDifference.Evaluate(const Params: TBoldOclSymbolParamete else begin resList := help.CreateNewMember(Params.Result.BoldType) as TBoldList; - for i := 0 to list1.Count - 1 do - if not list2.Includes(list1[i]) then resList.Add(list1[i]); - - for i := 0 to list2.Count - 1 do - if not list1.Includes(list2[i]) then resList.Add(list2[i]); + // Optimization for ObjectLists + if resList is TBoldObjectList then begin + aResListObject := TBoldObjectList(resList); + aList1Object := TBoldObjectList(list1); + aList2Object := TBoldObjectList(list2); + + for i := 0 to aList1Object.Count - 1 do + if not aList2Object.LocatorInList(aList1Object.Locators[i]) then + aResListObject.AddLocator(aList1Object.Locators[i]); + + for i := 0 to aList2Object.Count - 1 do + if not aList1Object.LocatorInList(aList2Object.Locators[i]) then + aResListObject.AddLocator(aList2Object.Locators[i]); + end else begin + for i := 0 to list1.Count - 1 do + if not list2.Includes(list1[i]) then resList.Add(list1[i]); + + for i := 0 to list2.Count - 1 do + if not list1.Includes(list2[i]) then resList.Add(list2[i]); + end; Params.Result.SetOwnedValue(ResList); end; end; procedure TBOS__ListCopier.CopyListToResult(const Params: TBoldOclSymbolParameters); var - temp: TBoldIndirectElement; + temp: TBoldIndirectElement; begin if assigned(Params.values[0]) then begin @@ -2109,10 +2575,17 @@ procedure TBOS_AsBag.Evaluate(const Params: TBoldOclSymbolParameters); procedure TBOS_AsSet.Evaluate(const Params: TBoldOclSymbolParameters); begin - CopyListToResult(params); - - if assigned(xlist(Params.Result.value)) then - XList(Params.Result.value).DuplicateMode := bldmMerge; + if not assigned(XList(Params.values[0])) then + Params.Result.SetReferenceValue(nil) + else + if xlist(params.Values[0]).DuplicateMode = bldmAllow then + begin + Params.Result.SetOwnedValue(TBoldMemberFactory.CreateMemberFromBoldType(params.Values[0].BoldType)); + xlist(Params.Result.value).DuplicateMode := bldmMerge; + xlist(Params.Result.value).AddList(XList(params.Values[0])); + end + else + CopyListToResult(params); end; procedure TBOS_Append.Evaluate(const Params: TBoldOclSymbolParameters); @@ -2134,22 +2607,31 @@ procedure TBOS_SubSequence.Evaluate(const Params: TBoldOclSymbolParameters); i : Integer; Start, Stop: Integer; resList, List: TBoldList; + aResListObject, aListObject: TBoldObjectList; begin - if not assigned(xlist(Params.values[0])) then - raise EBoldOclRunTimeError.CreateFmt(boeArgrtIsNotList, [0, '->subSequence']); // do not localize - List := XList(Params.values[0]); + resList := help.CreateNewMember(Params.Result.BoldType) as TBoldList; + Params.Result.SetOwnedValue(resList); + if not assigned(List) then + exit; + Start := XInteger(Params.values[1])- 1; Stop := XInteger(Params.values[2])- 1; - resList := help.CreateNewMember(Params.Result.BoldType) as TBoldList; - if Start < 0 then Start := 0; if Stop > List.Count - 1 then Stop := List.Count - 1; - for i := Start to Stop do - resList.Add(List[i]); - Params.Result.SetOwnedValue(resList); + // Optimization for ObjectLists + // Thus, the objects no longer need to be fechted during OCL evaluation + if resList is TBoldObjectList then begin + aListObject := TBoldObjectList(List); + aResListObject := TBoldObjectList(resList); + for i := Start to Stop do + aResListObject.AddLocator(aListObject.Locators[i]); + end else begin + for i := Start to Stop do + resList.Add(List[i]); + end; end; procedure TBOS_at.Evaluate(const Params: TBoldOclSymbolParameters); @@ -2158,6 +2640,7 @@ procedure TBOS_at.Evaluate(const Params: TBoldOclSymbolParameters); P : Integer; EL: TBoldElement; begin + EL := nil; List := XList(Params.values[0]); if not assigned(list) then Params.Result.SetReferenceValue(nil) @@ -2165,12 +2648,18 @@ procedure TBOS_at.Evaluate(const Params: TBoldOclSymbolParameters); begin P := XInteger(Params.values[1]) - 1; try - EL := List[P]; + if (P >= 0) and (P < List.Count) then begin + EL := List[P]; + end; except on e:EListError do raise EBoldOclRunTimeError.CreateFmt(borteAtIndexOutOfBounds, [0, p, list.Count]); end; - EL.GetAsValue(Params.Result); + if Assigned(EL) then begin + EL.GetAsValue(Params.Result); + end else begin + Params.Result.SetOwnedValue(nil); + end; end; end; @@ -2211,19 +2700,30 @@ procedure TBOS_last.Evaluate(const Params: TBoldOclSymbolParameters); end; procedure TBOS_asString.Evaluate(const Params: TBoldOclSymbolParameters); - // First argument is the evaluated expression, the second argument is the object ; Subscriber: TBoldSubscriber begin HELP.MakeNewString(Params.Result, XString(Params.values[0])); if assigned(Params.values[0]) then Params.values[0].SubscribeToStringRepresentation(brDefault, Params.subscriber, breReEvaluate); end; -procedure TBOS_dateTimeAsFloat.Evaluate(const Params: TBoldOclSymbolParameters); - // First argument is the evaluated expression, the second argument is the object ; Subscriber: TBoldSubscriber +procedure TBOS_datePart.Evaluate(const Params: TBoldOclSymbolParameters); +var + vMoment: TBAMoment; begin - HELP.MakeNewNumeric(Params.Result, XDateTime(Params.values[0])); + vMoment := Params.values[0] as TBAMoment; + if Assigned(vMoment) and not vMoment.IsNull then + HELP.MakeNewDateTime(Params.Result, INT(XDateTime(Params.values[0]))) + else + Params.Result.SetReferenceValue(nil); end; +procedure TBOS_asDateTime.Evaluate(const Params: TBoldOclSymbolParameters); +begin + if Assigned(Params.values[0]) then + HELP.MakeNewDateTime(Params.Result, XDateTime(Params.values[0])) + else + Params.Result.SetReferenceValue(nil); +end; procedure TBOS_StringRepresentation.Evaluate(const Params: TBoldOclSymbolParameters); var @@ -2275,11 +2775,14 @@ procedure TBOS_oclType.Evaluate(const Params: TBoldOclSymbolParameters); end; procedure TBOS_OclAsType.Evaluate(const Params: TBoldOclSymbolParameters); +var + Parm1Type: TBoldElementTypeInfo; begin - if not assigned(xtype(Params.values[1])) then - raise EBoldOclRunTimeError.CreateFmt(boeArgrtIsNottype, [0, '->oclAsType']); // do not localize + Parm1Type := xtype(Params.values[1]); + if not assigned(Parm1Type) then + raise EBoldOclRunTimeError.CreateFmt(boeArgrtIsNottype, [0, '->oclAsType']); - if not assigned(Params.values[0]) or Params.values[0].BoldType.ConformsTo(XType(Params.values[1])) then + if not assigned(Params.values[0]) or Params.values[0].BoldType.ConformsTo(Parm1Type) then Params.Result.SetReferenceValue(Params.values[0]) else raise EBoldOclRunTimeError.CreateFmt(borteInvalidCast, [0, Params.values[0].BoldType.AsString, Params.values[1].AsString]); @@ -2288,7 +2791,7 @@ procedure TBOS_OclAsType.Evaluate(const Params: TBoldOclSymbolParameters); procedure TBOS_SafeCast.Evaluate(const Params: TBoldOclSymbolParameters); begin if not assigned(xtype(Params.values[1])) then - raise EBoldOclRunTimeError.CreateFmt(boeArgrtIsNottype, [0, '.safeCast']); // do not localize + raise EBoldOclRunTimeError.CreateFmt(boeArgrtIsNottype, [0, '.safeCast']); if not assigned(Params.values[0]) or Params.values[0].BoldType.ConformsTo(XType(Params.values[1])) then Params.Result.SetReferenceValue(Params.values[0]) @@ -2298,19 +2801,25 @@ procedure TBOS_SafeCast.Evaluate(const Params: TBoldOclSymbolParameters); procedure TBOS_oclIsKindOf.Evaluate(const Params: TBoldOclSymbolParameters); +var + Parm1Type: TBoldElementTypeInfo; begin - if not assigned(xtype(Params.values[1])) then - raise EBoldOclRunTimeError.CreateFmt(boeArgrtIsNottype, [0, '->oclIsKindOf']); // do not localize + Parm1Type := xtype(Params.values[1]); + if not assigned(Parm1Type) then + raise EBoldOclRunTimeError.CreateFmt(boeArgrtIsNottype, [0, '->oclIsKindOf']); - HELP.MakeNewBoolean(Params.Result, assigned(Params.values[0]) and Params.values[0].BoldType.ConformsTo(Xtype(Params.values[1]))); + HELP.MakeNewBoolean(Params.Result, assigned(Params.values[0]) and Params.values[0].BoldType.ConformsTo(Parm1Type)); end; procedure TBOS_OclIsTypeOf.Evaluate(const Params: TBoldOclSymbolParameters); +var + Parm1Type: TBoldElementTypeInfo; begin - if not assigned(xtype(Params.values[1])) then - raise EBoldOclRunTimeError.CreateFmt(boeArgrtIsNottype, [0, '->oclIsTypeOf']); // do not localize + Parm1Type := xtype(Params.values[1]); + if not assigned(Parm1Type) then + raise EBoldOclRunTimeError.CreateFmt(boeArgrtIsNottype, [0, '->oclIsTypeOf']); - HELP.MakeNewBoolean(Params.Result, assigned(Params.values[0]) and (Params.values[0].BoldType = Xtype(Params.values[1]))); + HELP.MakeNewBoolean(Params.Result, assigned(Params.values[0]) and (Params.values[0].BoldType = Parm1Type)); end; procedure TBOS_AllInstances.Evaluate(const Params: TBoldOclSymbolParameters); @@ -2328,13 +2837,13 @@ procedure TBOS_AllInstances.Evaluate(const Params: TBoldOclSymbolParameters); if assigned(Params.System) then Params.Result.SetReferenceValue(Params.System.Classes[ClassTypeInfo.TopSortedIndex]) else - raise EBoldOclRunTimeError.Create(sUnableToGetAllInstances); + raise EBoldOclRunTimeError.Create('0: Unable to get allInstances. This evaluator has no system'); end else if Params.values[0] is TBoldAttributeTypeInfo then begin AttributeTypeInfo := Params.values[0] as TBoldAttributeTypeInfo; - if AttributeTypeInfo.ConformsTo(Params.SystemTypeInfo.AttributeTypeInfoByExpressionName['ValueSet']) then // do not localize + if AttributeTypeInfo.ConformsTo(Params.SystemTypeInfo.ValueSetTypeInfo) then begin With Params.SystemTypeInfo do begin @@ -2347,8 +2856,6 @@ procedure TBOS_AllInstances.Evaluate(const Params: TBoldOclSymbolParameters); Free; end; -// StrList.Sort; - for i := 0 to StrList.Count - 1 do ValueSetlist.AddNew.StringRepresentation[brDefault] := StrList[i]; StrList.Free; @@ -2373,26 +2880,26 @@ procedure TBOS_AllLoadedObjects.Evaluate(const Params: TBoldOclSymbolParameters) ClassList := Params.System.Classes[ClassTypeInfo.TopSortedIndex]; if assigned(Params.Subscriber) then - ClassList.AddSmallSubscription(params.subscriber, [beItemAdded, beItemDeleted, beObjectFetched], breReEvaluate); + ClassList.AddSmallSubscription(params.subscriber, [beItemAdded, beItemDeleted, beObjectFetched, beObjectUnloaded], breReEvaluate); if ClassList.BoldPersistenceState <> bvpsCurrent then begin ObjectList := help.CreateNewMember(Params.Result.BoldType) as TBoldObjectList; + ObjectList.DuplicateMode := bldmAllow; Params.Result.SetOwnedValue(ObjectList); Traverser := Params.System.Locators.CreateTraverser; - while not Traverser.EndOfList do + while Traverser.MoveNext do + with Traverser.Locator do begin - if assigned(Traverser.Locator.BoldObject) and - Traverser.Locator.Boldobject.BoldType.ConformsTo(ClassTypeInfo) then - ObjectList.Add(Traverser.Locator.Boldobject); - Traverser.Next; + if assigned(BoldObject) and Boldobject.BoldType.ConformsTo(ClassTypeInfo) then + ObjectList.AddLocator(Traverser.Locator); end; Traverser.Free; end else Params.Result.SetReferenceValue(ClassList); end else - raise EBoldOclRunTimeError.Create(sUnableToGetAllLoadedObjects); + raise EBoldOclRunTimeError.Create('0: Unable to get allLoadedObjects. This evaluator has no system'); end; procedure TBOS_EmptyList.Evaluate(const Params: TBoldOclSymbolParameters); @@ -2535,72 +3042,41 @@ procedure TBOS_AllSubClasses.Evaluate(const Params: TBoldOclSymbolParameters); end; end; -var - RegExp: TRegularExpression; - SQLRegExp: TRegularExpression; - -function FixSQLRegExp(S: String): String; -var - i: integer; -begin - Result := #11; - for i := 1 to Length(S) do - case S[i] of - '%': Result := Result + #1 + #8; - '_': Result := Result + #1; - else Result := Result + S[i]; - end; - Result := Result + #6; -end; - -Procedure InitSQLRegExp; +function EscapeRegEx(const ASource: string): string; begin - if not assigned(SQLRegExp) then - begin - SQLRegExp := TRegularExpression.Create; - with SQLRegExp.MetaCharacters do - begin - AnyChar := #1; - CharSetClose := #2; - CharSetComplement := #3; - CharSetOpen := #4; - CharSetRange := #5; - EndOfLine := #6; - QuoteChar := #7; - Repeat0OrMoreTimes := #8; - Repeat1OrMoreTimes := #9; - StartOfLine := #11; - end; - end; -end; - -procedure InitRegExp; -begin - if not assigned(RegExp) then - RegExp := TRegularExpression.Create; + result := StringReplace(ASource, '%', '', [rfReplaceAll]); + result := TPerlRegEx.EscapeRegExChars(result); end; procedure TBOS_SQLLike.Evaluate(const Params: TBoldOclSymbolParameters); +var + s: string; begin - InitSQLRegExp; - SQlRegExp.RegularExpression := FixSqlRegExp(XString(Params.values[1])); - SqlRegExp.CaseSensitive := true; - Help.MakeNewBoolean(Params.Result, SQLRegExp.SearchString(XString(Params.values[0])) <> 0); + s := XString(Params.values[1]); + s := EscapeRegEx(s); + if s = '' then + Help.MakeNewBoolean(Params.Result, false) + else + Help.MakeNewBoolean(Params.Result, TRegEx.IsMatch(XString(Params.values[0]), s)); end; procedure TBOS_SQLLikeCaseInSensitive.Evaluate(const Params: TBoldOclSymbolParameters); +var + s: string; begin - InitSQLRegExp; - SQlRegExp.RegularExpression := FixSqlRegExp(XString(Params.values[1])); - SqlRegExp.CaseSensitive := False; - Help.MakeNewBoolean(Params.Result, SQLRegExp.SearchString(XString(Params.values[0])) <> 0); + s := XString(Params.values[1]); + s := EscapeRegEx(s); + if s = '' then + Help.MakeNewBoolean(Params.Result, false) + else + Help.MakeNewBoolean(Params.Result, TRegEx.IsMatch(XString(Params.values[0]), s, [roIgnoreCase])); end; procedure TBOS_RegExpMatch.Evaluate(const Params: TBoldOclSymbolParameters); +var + RegExp: TRegEx; begin - InitRegExp; - RegExp.RegularExpression := XString(Params.values[1]); - Help.MakeNewBoolean(Params.Result, RegExp.SearchString(XString(Params.values[0])) <> 0); + Help.MakeNewBoolean(Params.Result, TRegEx.IsMatch(XString(Params.values[0]), XString(Params.values[1]), [])); end; procedure TBOS_InDateRange.Evaluate(const Params: TBoldOclSymbolParameters); @@ -2609,20 +3085,13 @@ procedure TBOS_InDateRange.Evaluate(const Params: TBoldOclSymbolParameters); Start, Stop, val: TDateTime; begin Moment := Params.values[0] as TBAMoment; - if moment.IsNull then + if not Assigned(Moment) or (Moment.IsNull or (Params.values[1] as TBoldAttribute).IsNull or (Params.values[2] as TBoldAttribute).IsNull) then begin help.MakeNewBoolean(params.result, false); end else begin - if Moment is TBADateTime then - val := (Moment as TBADateTime).asDateTime - else if Moment is TBADate then - val := (Moment as TBADate).asDate - else if Moment is TBATime then - val := (Moment as TBATime).asTime - else - val := 0; + Val := ExtractDateTimeFromMoment(Moment); val := trunc(val); @@ -2638,20 +3107,20 @@ procedure TBOS_InTimeRange.Evaluate(const Params: TBoldOclSymbolParameters); Start, Stop, val: TDateTime; begin Moment := Params.values[0] as TBAMoment; - if Moment is TBADateTime then - val :=(Moment as TBADateTime).asDateTime - else if Moment is TBADate then - val :=(Moment as TBADate).asDate - else if Moment is TBATime then - val :=(Moment as TBATime).asTime + if not Assigned(Moment) or (moment.IsNull or (Params.values[1] as TBoldAttribute).IsNull or (Params.values[2] as TBoldAttribute).IsNull) then + begin + help.MakeNewBoolean(params.result, false); + end else - val := 0; + begin + Val := ExtractDateTimeFromMoment(Moment); - Val := Frac(val); + Val := Frac(val); - Start := frac((Params.values[1] as TBANumeric).AsFloat); - Stop := frac((Params.values[2] as TBANumeric).AsFloat); - Help.MakeNewBoolean(Params.Result, (val >= start) and (val <= stop)); + Start := frac((Params.values[1] as TBANumeric).AsFloat); + Stop := frac((Params.values[2] as TBANumeric).AsFloat); + Help.MakeNewBoolean(Params.Result, (CompareTime(val,Start)>=0) and (CompareTime(val,stop)<=0)); + end; end; procedure TBOS_Constraints.Evaluate(const Params: TBoldOclSymbolParameters); @@ -2661,7 +3130,7 @@ procedure TBOS_Constraints.Evaluate(const Params: TBoldOclSymbolParameters); procedure AddConstraint(IncomingConstraint: TBoldConstraintRTInfo; element: TBoldElement); begin with ResList.AddNew as TBAConstraint do - Initialize(IncomingConstraint, element); + InitializeConstraint(IncomingConstraint, element); end; var @@ -2704,7 +3173,10 @@ procedure TBOS_AtTime.Evaluate(const Params: TBoldOclSymbolParameters); NewTime: Integer; begin OldObject := Params.values[0] as TBoldObject; - NewTime := (Params.values[1] as TBAInteger).AsInteger; + if (Params.values[1] as TBAInteger).IsNull then + NewTime := maxInt + else + NewTime := (Params.values[1] as TBAInteger).AsInteger; Params.Result.SetReferenceValue(OldObject.AtTime(NewTime)); end; @@ -2730,10 +3202,10 @@ procedure TBOS_AllInstancesAtTime.Evaluate(const Params: TBoldOclSymbolParameter if assigned(Params.System) then Params.Result.SetReferenceValue(Params.System.Classes[ClassTypeInfo.TopSortedIndex].atTime(NewTime)) else - raise EBoldOclRunTimeError.Create(sUnableToGetAllInstances); + raise EBoldOclRunTimeError.Create('0: Unable to get allInstances. This evaluator has no system'); end else - raise EBoldOclRunTimeError.Create(sAllInstancesAtTimeOnlyAllowedOnClasses); + raise EBoldOclRunTimeError.Create('0: AllInstancesAtTime only allowed on classes'); end; procedure TBOS_Existing.Evaluate(const Params: TBoldOclSymbolParameters); @@ -2746,12 +3218,52 @@ procedure TBOS_FilterOnType.Evaluate(const Params: TBoldOclSymbolParameters); IncomingList: TBoldList; i: integer; OutList: TBoldList; + aIncommingListObject, + aOutListObject: TBoldObjectList; + aClasses: TBoldClassTypeInfoList; + iTopSortedIndex: Integer; + Locator: TBoldObjectLocator; + FilterType: TBoldElementTypeInfo; begin IncomingList := XList(Params.values[0]); OutList := TBoldMemberFactory.CreateMemberFromBoldType(params.Result.BoldType) as TBoldList; - for i := 0 to IncomingList.Count - 1 do - if IncomingList[i].BoldType.ConformsTo(Params.values[1] as TBoldElementTypeInfo) then - OutList.Add(IncomingList[i]); + FilterType := Params.values[1] as TBoldElementTypeInfo; + if Assigned(IncomingList) then + begin + // Optimization for ObjectLists + if OutList is TBoldObjectList then begin + aIncommingListObject := TBoldObjectList(IncomingList); + aOutListObject := TBoldObjectList(OutList); + aClasses := Help.SystemTypeInfo.TopSortedClasses; + iTopSortedIndex := -1; + aIncommingListObject.EnsureObjects; + for i := 0 to aIncommingListObject.Count - 1 do begin + Locator := aIncommingListObject.Locators[i]; + if Locator.BoldObjectID.TopSortedIndexExact then + begin + if (iTopSortedIndex = Locator.BoldObjectID.TopSortedIndex) or (Locator.BoldClassTypeInfo.ConformsTo(FilterType)) then + begin + aOutListObject.AddLocator(Locator); + iTopSortedIndex := Locator.BoldObjectID.TopSortedIndex; // this is to skip ConformsTo with objects of repeated type + end; + end + else + if Locator.EnsuredBoldObject.BoldType.ConformsTo(FilterType) then + aOutListObject.AddLocator(Locator); + end; + end else begin + //Prefetch + if Assigned(IncomingList) then begin + IncomingList.EnsureRange(0, IncomingList.Count - 1); + for i := 0 to IncomingList.Count - 1 do begin + if IncomingList[i].BoldType.ConformsTo(FilterType) then + begin + OutList.Add(IncomingList[i]); + end; + end; + end; + end; + end; params.result.SetOwnedValue(OutList); end; @@ -2770,29 +3282,492 @@ procedure TBOS_TimeToTimeStamp.Evaluate(const Params: TBoldOclSymbolParameters); help.MakeNewInteger(Params.Result, Params.System.TimestampForTime[(Params.values[0] as TBAdateTime).AsDateTime]); end; +procedure TBOS_indexOf.Evaluate(const Params: TBoldOclSymbolParameters); +var + Index: Integer; + List: TBoldList; + aObj: TBoldObject; + i: Integer; +begin + Index := -1; + List := XList(Params.values[0]); + if List is TBoldObjectList then begin + // Optimization for ObjectLists: check for locator. + // No need to ensure objects for equality check + aObj := nil; + if Params.values[1] is TBoldObject then begin + aObj := TBoldObject(Params.values[1]); + end else if Params.values[1] is TBoldObjectReference then begin + aObj := TBoldObjectReference(Params.values[1]).BoldObject; + end; + if Assigned(aObj) then begin + Index := TBoldObjectList(List).IndexOfLocator(aObj.BoldObjectLocator); + end; + end else if Assigned(List) then begin + List.EnsureRange(0, List.Count - 1); + for i := 0 to List.Count - 1 do begin + if List[i].IsEqual(Params.values[1]) then begin + Index := i; + Break; + end; + end; + end; + HELP.MakeNewInteger(Params.Result, Index); +end; + +procedure TBOS_reverseCollection.Evaluate(const Params: TBoldOclSymbolParameters); +var + List, resList: TBoldLIst; + i: Integer; +begin + List := XList(Params.values[0]); + resList := help.CreateNewMember(Params.Result.BoldType) as TBoldList; + resList.Capacity := List.Count; + if List is TBoldObjectList then begin + // Optimization for ObjectLists: check for locator. + // No need to ensure objects for equality check + for i := List.Count - 1 downto 0 do begin + TBoldObjectList(resList).AddLocator(TBoldObjectList(List).Locators[i]); + end; + end else if Assigned(List) then begin + for i := List.Count - 1 downto 0 do begin + resList.Add(List[i]); + end; + end; + + Params.Result.SetOwnedValue(resList); +end; + procedure InitializeSymbolTable(SymTab: TBoldSymbolDictionary); var i: integer; begin + SymTab.Capacity := SymTab.Count + OCLOperations.Count; for i := 0 to OCLOperations.Count - 1 do SymTab.Add(TBoldOclSymbolClass(OCLOperations[i]).Create(SymTab.Help)); end; +{ TBOS_CommaText } + +procedure TBOS_asCommaText.Init; +begin + InternalInit('asCommaText', [HELP.{String}ListType], tbodNo, HELP.StringType, True, 193); +end; + +procedure TBOS_asCommaText.Evaluate(const Params: TBoldOclSymbolParameters); +var + List : TBoldList; + sl: TStringList; + i: Integer; +begin + sl := TStringList.Create; + try + List := XList(Params.values[0]); + for i := 0 to List.Count - 1 do + sl.Add(XString(List[i])); + HELP.MakeNewString(Params.Result, sl.CommaText); + finally + FreeAndNil(sl); + end; +end; + +procedure TBOS_separate.Init; +begin + InternalInit('separate', [HELP.StringListType, HELP.StringType], tbodNo, HELP.StringType, True, 194); +end; + +procedure TBOS_separate.Evaluate(const Params: TBoldOclSymbolParameters); +var + List : TBoldList; + ResultString: string; + Separator: string; + i: Integer; +begin + ResultString := ''; + List := XList(Params.values[0]); + Separator := XString(Params.values[1]); + for i := 0 to List.Count - 1 do + begin + if i > 0 then + ResultString := ResultString + Separator; + ResultString := ResultString + XString(List[i]); + end; + HELP.MakeNewString(Params.Result, ResultString); +end; + +{ TBOS_CommaSeparatedStringToCollection } + +procedure TBOS_CommaSeparatedStringToCollection.Evaluate( + const Params: TBoldOclSymbolParameters); +var + lStringList: TStringList; + lBoldMember: TBoldMember; + lBoldMemberList: TBoldMemberList; + lIndexStringList: integer; + lElementTypeInfo : TBoldElementTypeInfo; +begin + lStringList := TStringList.Create; + try + lStringList.CommaText := (Params.Values[0].AsString); + lBoldMemberList := Help.CreateNewMember(GetListTypeInfo) as TBoldMemberList; + lElementTypeInfo := GetListTypeInfo.ListElementTypeInfo; + for lIndexStringList := 0 to lStringList.Count - 1 do + begin + lBoldMember := Help.CreateNewMember(lElementTypeInfo) as TBoldMember; + lBoldMember.AsString := lStringList[lIndexStringList]; + lBoldMemberList.Add(lBoldMember); + lBoldMember.free; + end; + Params.Result.SetOwnedValue(lBoldMemberList); + finally + lStringList.free; + end; +end; + +{ TBOS_CommaSeparatedStringToStringCollection } + +procedure TBOS_CommaSeparatedStringToStringCollection.Init; +begin + InternalInit('toStringCollection', [Help.StringType], tbodNo, GetListTypeInfo, True, 0); +end; + +function TBOS_CommaSeparatedStringToStringCollection.GetListTypeInfo: TBoldListTypeInfo; +begin + result := Help.StringListType; +end; + +{ TBOS_CommaSeparatedStringToIntegerCollection } + +procedure TBOS_CommaSeparatedStringToIntegerCollection.Init; +begin + InternalInit('toIntegerCollection', [Help.StringType], tbodNo, GetListTypeInfo, True, 0); +end; + + +function TBOS_CommaSeparatedStringToIntegerCollection.GetListTypeInfo: TBoldListTypeInfo; +begin + result := Help.IntegerListType; +end; + +{ TBOS_intAsFloat } + +procedure TBOS_AsFloat.Evaluate(const Params: TBoldOclSymbolParameters); +begin + HELP.MakeNewNumeric(Params.Result, XNumeric(Params.values[0])); +end; + +procedure TBOS_AsFloat.Init; +begin + InternalInit('asFloat', [HELP.NumericType], tbodNo, HELP.RealType, True, 163); +end; + +{ TBOS_FloatAsDateTime } + +procedure TBOS_FloatAsDateTime.Evaluate(const Params: TBoldOclSymbolParameters); +begin + HELP.MakeNewDateTime(Params.Result, XNumeric(Params.Values[0])); +end; + +procedure TBOS_FloatAsDateTime.Init; +begin + InternalInit('floatAsDateTime', [HELP.NumericType], tbodNo, HELP.DateTimeType, True, 163); +end; + +{ TBOS_NullValue } + +procedure TBOS_NullValue.Evaluate(const Params: TBoldOclSymbolParameters); +begin + HELP.MakeNewNull(Params.Result, XType(Params.values[0])); +end; + +procedure TBOS_NullValue.Init; +begin + InternalInit('nullValue', [HELP.TypeType], tbodArg1Type, nil, True, 170); +end; + +{ TBOS_DayOfDate } + +procedure TBOS_DayOfDate.Evaluate(const Params: TBoldOclSymbolParameters); +var + Moment: TBAMoment; + LYear, LMonth, LDay: Word; +begin + Moment := Params.values[0] as TBAMoment; + if not Assigned(Moment) then + Params.Result.SetReferenceValue(nil) + else + begin + if Moment.IsNull then + LYear := 0 + else + DecodeDate(ExtractDateTimeFromMoment(Moment), LYear, LMonth, LDay); + HELP.MakeNewInteger(Params.Result, LDay); + end; +end; + +procedure TBOS_DayOfDate.Init; +begin + InternalInit('day', [HELP.MomentType], tbodNo, HELP.IntegerType, True, 124); + +end; + +procedure TBOS_MonthOfDate.Evaluate(const Params: TBoldOclSymbolParameters); +var + Moment: TBAMoment; + LYear, LMonth, LDay: Word; +begin + Moment := Params.values[0] as TBAMoment; + if not Assigned(Moment) then + Params.Result.SetReferenceValue(nil) + else + begin + if Moment.IsNull then + LMonth := 0 + else + DecodeDate(ExtractDateTimeFromMoment(Moment), LYear, LMonth, LDay); + HELP.MakeNewInteger(Params.Result, LMonth); + end; +end; + +procedure TBOS_MonthOfDate.Init; +begin + InternalInit('month', [HELP.MomentType], tbodNo, HELP.IntegerType, True, 124); +end; + +procedure TBOS_YearOfDate.Evaluate(const Params: TBoldOclSymbolParameters); +var + Moment: TBAMoment; + LYear, LMonth, LDay: Word; +begin + Moment := Params.values[0] as TBAMoment; + if not Assigned(Moment) then + Params.Result.SetReferenceValue(nil) + else + begin + if Moment.IsNull then + LYear := 0 + else + DecodeDate(ExtractDateTimeFromMoment(Moment), LYear, LMonth, LDay); + HELP.MakeNewInteger(Params.Result, LYear); + end; +end; + +procedure TBOS_YearOfDate.Init; +begin + InternalInit('year', [HELP.MomentType], tbodNo, HELP.IntegerType, True, 124); +end; + +procedure TBOS_WeekOfDate.Evaluate(const Params: TBoldOclSymbolParameters); +var + Moment: TBAMoment; + LYear, LWeek, LDOW: Word; +begin + Moment := Params.values[0] as TBAMoment; + if not Assigned(Moment) then + Params.Result.SetReferenceValue(nil) + else + begin + if Moment.IsNull then + LWeek := 0 + else + DecodeDateWeek(ExtractDateTimeFromMoment(Moment), LYear, LWeek, LDOW); + HELP.MakeNewInteger(Params.Result, LWeek); + end; +end; + +procedure TBOS_WeekOfDate.Init; +begin + InternalInit('week', [HELP.MomentType], tbodNo, HELP.IntegerType, True, 124); +end; + +procedure TBOS_DayOfWeekOfDate.Evaluate(const Params: TBoldOclSymbolParameters); +var + Moment: TBAMoment; + LYear, LWeek, LDOW: Word; +begin + Moment := Params.values[0] as TBAMoment; + if not Assigned(Moment) then + Params.Result.SetReferenceValue(nil) + else + begin + if Moment.IsNull then + LDOW := 0 + else + DecodeDateWeek(ExtractDateTimeFromMoment(Moment), LYear, LWeek, LDOW); + HELP.MakeNewInteger(Params.Result, LDOW); + end; +end; + +procedure TBOS_DayOfWeekOfDate.Init; +begin + InternalInit('dayOfWeek', [HELP.MomentType], tbodNo, HELP.IntegerType, True, 124); +end; + +{ TBOS_Trim } + +procedure TBOS_Trim.Evaluate(const Params: TBoldOclSymbolParameters); +begin + Help.MakeNewString(Params.Result, StringReplace(Trim(XString(Params.Values[0])), BOLDCRLF, ' ', [rfReplaceAll])); +end; + +procedure TBOS_Trim.Init; +begin + InternalInit('trim', [Help.StringType], tbodNo, Help.StringType, True, 124); +end; + +{ TBOS_HasDuplicates } + +procedure TBOS_HasDuplicates.Evaluate(const Params: TBoldOclSymbolParameters); +var + list: TBoldLIst; +begin + List := XList(Params.values[0]); + if not assigned(list) then + Help.MakeNewBoolean(Params.Result, false) + else + HELP.MakeNewBoolean(Params.Result, List.HasDuplicates); +end; + +{ TBOS_BoldId } + +procedure TBOS_BoldId.Evaluate(const Params: TBoldOclSymbolParameters); +var + S: String; + Locator: TBoldObjectLocator; +begin + if assigned(Params.Values[0]) then + begin + Locator := (Params.Values[0] as TBoldObject).BoldObjectLocator; + s := Locator.BoldObjectID.AsString; + if not Locator.BoldObjectID.IsStorable then + Locator.BoldObject.AddSmallSubscription(Params.subscriber, [bePostUpdateID ], breResubscribe); + Help.MakeNewInteger(Params.Result,StrToInt(s)); + end + else + HELP.MakeNewNull(Params.Result, Params.Result.BoldType) +end; + +{ TBOS_SecondsBetween } + +procedure TBOS_SecondsBetween.Evaluate( + const Params: TBoldOclSymbolParameters); +var + i:integer; +begin + if (Params.values[0] = nil) or (Params.values[0] as TBoldAttribute).IsNull + or (Params.values[1] = nil) or (Params.values[1] as TBoldAttribute).IsNull then + Params.Result.SetReferenceValue(nil) + else + begin + i := SecondsBetween(XDateTime(Params.Values[0]),XDateTime(Params.Values[1])); + Help.MakeNewInteger(Params.Result,i); + end; +end; + +procedure TBOS_SecondsBetween.Init; +begin + InternalInit('secondsBetween',[Help.MomentType,Help.MomentType],tbodNo,Help.IntegerType,True,0); +end; + +function HoursBetween(const ANow, AThen: TDateTime): Int64; +begin + Result := Round(HourSpan(ANow, AThen)); + if ANow < AThen then + Result := -Result; +end; + +function MinutesBetween(const ANow, AThen: TDateTime): Int64; +begin + Result := Round(MinuteSpan(ANow, AThen)); + if ANow < AThen then + Result := -Result; +end; + +function SecondsBetween(const ANow, AThen: TDateTime): Int64; +begin + Result := Round(SecondSpan(ANow, AThen)); + if ANow < AThen then + Result := -Result; +end; + +{ TBOS_MinutesBetween } + +procedure TBOS_MinutesBetween.Evaluate( + const Params: TBoldOclSymbolParameters); +var + i:integer; +begin + if (Params.values[0] = nil) or (Params.values[0] as TBoldAttribute).IsNull + or (Params.values[1] = nil) or (Params.values[1] as TBoldAttribute).IsNull then + Params.Result.SetReferenceValue(nil) + else + begin + i := MinutesBetween(XDateTime(Params.Values[0]),XDateTime(Params.Values[1])); + Help.MakeNewInteger(Params.Result,i); + end; +end; + +procedure TBOS_MinutesBetween.Init; +begin + InternalInit('minutesBetween',[Help.MomentType,Help.MomentType],tbodNo,Help.IntegerType,True,0); +end; + +{ TBOS_HoursBetween } + +procedure TBOS_HoursBetween.Evaluate( + const Params: TBoldOclSymbolParameters); +var + i:integer; +begin + if (Params.values[0] = nil) or (Params.values[0] as TBoldAttribute).IsNull + or (Params.values[1] = nil) or (Params.values[1] as TBoldAttribute).IsNull then + Params.Result.SetReferenceValue(nil) + else + begin + i := HoursBetween(XDateTime(Params.Values[0]),XDateTime(Params.Values[1])); + Help.MakeNewInteger(Params.Result,i); + end; +end; + +procedure TBOS_HoursBetween.Init; +begin + InternalInit('hoursBetween',[Help.MomentType, Help.MomentType],tbodNo,Help.IntegerType,True,0); +end; + +{ TBOS_Power } + +procedure TBOS_Power.Evaluate(const Params: TBoldOclSymbolParameters); +begin + if (Params.values[0] = nil) or (Params.values[1] = nil) then + Params.Result.SetReferenceValue(nil) + else + Help.MakeNewNumeric(Params.Result, Power(XNumeric(Params.values[0]), XNumeric(Params.values[1]))); +end; + +{ TBOS_Sqrt } + +procedure TBOS_Sqrt.Evaluate(const Params: TBoldOclSymbolParameters); +begin + if (Params.values[0] = nil) then + Params.Result.SetReferenceValue(nil) + else + Help.MakeNewNumeric(Params.Result, Sqrt(XNumeric(Params.values[0]))); +end; + initialization - SQLRegExp := nil; - RegExp := nil; RegisterOclOperation(TBOS_Equal); RegisterOclOperation(TBOS_NotEqual); - RegisterOclOperation(TBOS_Except); RegisterOclOperation(TBOS_Add); RegisterOclOperation(TBOS_Subtract); RegisterOclOperation(TBOS_UnaryMinus); RegisterOclOperation(TBOS_Multiply); RegisterOclOperation(TBOS_Divide); + RegisterOclOperation(TBOS_SafeDivZero); RegisterOclOperation(TBOS_Abs); RegisterOclOperation(TBOS_Floor); RegisterOclOperation(TBOS_Round); RegisterOclOperation(TBOS_strToInt); + RegisterOclOperation(TBOS_strToFloat); RegisterOclOperation(TBOS_Min); RegisterOclOperation(TBOS_Max); RegisterOclOperation(TBOS_Less); @@ -2806,6 +3781,7 @@ initialization RegisterOclOperation(TBOS_ToUpper); RegisterOclOperation(TBOS_toLower); RegisterOclOperation(TBOS_SubString); + RegisterOclOperation(TBOS_Contains); RegisterOclOperation(TBOS_Pad); RegisterOclOperation(TBOS_PostPad); RegisterOclOperation(TBOS_or); @@ -2822,7 +3798,6 @@ initialization RegisterOclOperation(TBOS_isNull); RegisterOclOperation(TBOS_NotEmpty); RegisterOclOperation(TBOS_Sum); - RegisterOclOperation(TBOS_SumTime); RegisterOclOperation(TBOS_Maxvalue); RegisterOclOperation(TBOS_MinValue); RegisterOclOperation(TBOS_Average); @@ -2849,12 +3824,16 @@ initialization RegisterOclOperation(TBOS_orderby); RegisterOclOperation(TBOS_orderDescending); RegisterOclOperation(TBOS_asString); - RegisterOclOperation(TBOS_dateTimeAsFloat); + RegisterOclOperation(TBOS_AsFloat); + RegisterOclOperation(TBOS_FloatAsDateTime); + RegisterOclOperation(TBOS_datePart); + RegisterOclOperation(TBOS_asDateTime); RegisterOclOperation(TBOS_stringRepresentation); RegisterOclOperation(TBOS_TaggedValue); RegisterOclOperation(TBOS_TypeName); RegisterOclOperation(TBOS_Attributes); RegisterOclOperation(TBOS_AssociationEnds); + RegisterOclOperation(TBOS_NullValue); { RegisterOclOperation(TBOS_Operations); } @@ -2876,8 +3855,12 @@ initialization RegisterOclOperation(TBOS_InDateRange); RegisterOclOperation(TBOS_InTimeRange); RegisterOclOperation(TBOS_Constraints); + RegisterOclOperation(TBOS_Format); RegisterOclOperation(TBOS_FormatNumeric); + RegisterOclOperation(TBOS_FormatFloat); RegisterOclOperation(TBOS_FormatDateTime); + RegisterOclOperation(TBOS_AsISODate); + RegisterOclOperation(TBOS_AsISODateTime); RegisterOclOperation(TBOS_StrToDateTime); RegisterOclOperation(TBOS_StrToDate); RegisterOclOperation(TBOS_StrToTime); @@ -2889,10 +3872,27 @@ initialization RegisterOclOperation(TBOS_BoldTime); RegisterOclOperation(TBOS_TimeStampToTime); RegisterOclOperation(TBOS_TimeToTimeStamp); + RegisterOclOperation(TBOS_IndexOf); + RegisterOclOperation(TBOS_ReverseCollection); + RegisterOclOperation(TBOS_asCommaText); + RegisterOclOperation(TBOS_separate); + RegisterOclOperation(TBOS_DayOfDate); + RegisterOclOperation(TBOS_MonthOfDate); + RegisterOclOperation(TBOS_YearOfDate); + RegisterOclOperation(TBOS_DayOfWeekOfDate); + RegisterOclOperation(TBOS_WeekOfDate); + RegisterOCLOperation(TBOS_HoursBetween); + RegisterOCLOperation(TBOS_MinutesBetween); + RegisterOCLOperation(TBOS_SecondsBetween); + RegisterOclOperation(TBOS_Trim); + RegisterOclOperation(TBOS_HasDuplicates); + RegisterOclOperation(TBOS_CommaSeparatedStringToStringCollection); + RegisterOclOperation(TBOS_CommaSeparatedStringToIntegerCollection); + RegisterOclOperation(TBOS_BoldId); + RegisterOclOperation(TBOS_Power); + RegisterOclOperation(TBOS_Sqrt); finalization - SqlRegExp.Free; - RegExp.Free; FreeAndNil(G_OCLOperations); end. diff --git a/Source/ObjectSpace/Ocl/BoldSSExcept.pas b/Source/ObjectSpace/Ocl/BoldSSExcept.pas index da8c5db7..62e0b3b6 100644 --- a/Source/ObjectSpace/Ocl/BoldSSExcept.pas +++ b/Source/ObjectSpace/Ocl/BoldSSExcept.pas @@ -1,5 +1,6 @@ -{$DEFINE SANDSTONEREDISTRIBUTABLE} +{ Global compiler directives } +{$include bold.inc} unit BoldSSExcept; interface @@ -35,17 +36,11 @@ interface SSExceptionYaccBadResource ); - type - { forward declarations } - SSException = class; - - { SSException } SSException = class(EAbort) public Position: integer; Id: SSExceptionError; - constructor Create(TheId: SSExceptionError; FmtStr: string); constructor CreateName(TheId: SSExceptionError; FmtStr: string; Name: PChar); constructor CreateLong(TheId: SSExceptionError; TheFmtStr: string; TheLong: Longint); @@ -63,26 +58,26 @@ constructor SSException.Create(TheId: SSExceptionError; FmtStr: string); constructor SSException.CreateName(TheId: SSExceptionError; FmtStr: string; Name: PChar); begin - inherited Create(Format(FmtStr, [String(Name)])); + inherited Create(Format(FmtStr, [string(Name)])); Id := TheId; Position := 0; end; -constructor SSException.CreateLong(TheId: SSExceptionError; TheFmtStr: string; TheLong: Longint); +constructor SSException.CreateLong(TheId: SSExceptionError; TheFmtStr: string; TheLong: Integer); begin - inherited Create(Format(StringReplace(TheFmtStr, '%ld', '%d', []), [TheLong])); // do not localize + inherited Create(Format(StringReplace(TheFmtStr, '%ld', '%d', [rfReplaceAll]), [TheLong])); Id := TheId; Position := 0; end; -constructor SSException.CreateLongLongNameLen(TheId: SSExceptionError; FmtStr: string; - Long0, Long1: Longint; TheName: PChar; TheLen: Word); +constructor SSException.CreateLongLongNameLen(TheId: SSExceptionError; + FmtStr: string; Long0, Long1: Integer; TheName: PChar; TheLen: Word); var Name: PChar; begin GetMem(Name, TheLen + 1); StrMove(Name, TheName, TheLen); - inherited Create(Format(StringReplace(FmtStr, '%ld', '%d', [rfReplaceAll]), [Long0, Long1, string(Name)])); // do not localize + inherited Create(Format(StringReplace(FmtStr, '%ld', '%d', [rfReplaceAll]), [Long0, Long1, string(Name)])); FreeMem(Name, TheLen + 1); Id := TheId; Position := Long1; diff --git a/Source/ObjectSpace/Ocl/BoldSSLexU.pas b/Source/ObjectSpace/Ocl/BoldSSLexU.pas index 1bc8f6e0..b8649fea 100644 --- a/Source/ObjectSpace/Ocl/BoldSSLexU.pas +++ b/Source/ObjectSpace/Ocl/BoldSSLexU.pas @@ -1,294 +1,233 @@ + +{ Global compiler directives } +{$include bold.inc} + unit BoldSSLexU; interface uses Classes, - WinTypes, - WinProcs, BoldBase; -procedure SSAux; - -function SSHugeInc(ThePointer: Pointer; TheInc: Longint): Pointer; -procedure SSHugeCopy(TheCopyTo: Pointer; TheCopyFrom: Pointer; TheLength: Longint); - -{$IFDEF SSAUX} -{$I SSAUXDEF.PAS} -{$ENDIF} - const - SSHugeIncVal = 8; - SSLexMaxRead = $7fffffff; {32767} - SSLexMaxCopy = $7fffffff; {32767} SSLexConsumerBof = -1; - SSLexMaxBlock = $7fffffff-1; {32528} SSLexStateInvalid = -1; - SSLexBufferMax = $7fffffff; {32767} - SSLexThreshold = 65536; SSLexStructMax = 65520; - SSLexPairTable = $53534C58; SSLexFinalStateFlagsContextStart = $01; - SSLexFinalStateFlagsStartOfLine = $02; - SSLexFinalStateFlagsPop = $08; - SSLexFinalStateFlagsFinal = $10; - SSLexFinalStateFlagsPush = $20; - SSLexFinalStateFlagsIgnore = $40; - SSLexFinalStateFlagsContextEnd = $80; - SSLexFinalStateFlagsReduce = $100; - - SSLexMsgFileOpen = 'SSLex0101e: Error opening file, %s'; - SSLexMsgFileRead = 'SSLex0102e: Invalid file length or read error, %s'; - SSLexMsgLexemeLength = 'SSLex0103e: Lexeme too long, %ld'; - SSLexMsgBadTable = 'SSLex0104e: Invalid table, %s'; + SSLexFinalStateFlagsStartOfLine = $02; + SSLexFinalStateFlagsPop = $08; + SSLexFinalStateFlagsFinal = $10; + SSLexFinalStateFlagsPush = $20; + SSLexFinalStateFlagsIgnore = $40; + SSLexFinalStateFlagsContextEnd = $80; + SSLexFinalStateFlagsReduce = $100; + SSLexMsgError = 'SSLex0105e: Invalid token, Line %ld, Offset %ld, %s'; SSLexMsgBadList = 'SSLex0106e: Invalid expression list index, %ld'; SSLexMsgMissingPart = 'SSLex0107e: Table or consumer missing, required'; - SSLexMsgFindResource = 'SSLex0108e: Unable to locate resource, %s'; - SSLexMsgBadResource = 'SSLex0109e: Bad resource format, %s'; - SSLifoMsgStackTop = 'SSLifo0002e: No top, stack empty'; SSLifoMsgStackPop = 'SSLifo0004e: Cannot pop empty stack'; - SSLexMsgOutOfMemory = 'SSLex1000e: Out of memory'; - -type - SSArrayOfPointer = array[ 0..(SSLexStructMax div sizeof(Pointer))] of Pointer; - PSSArrayOfPointer = ^SSArrayOfPointer; - - type - SSStack = class(TBoldMemoryManagedObject) - public - Incr : Integer; - Size : Integer; - TopOfStack : Integer; - PArray : PSSArrayOfPointer; - - constructor Create; - procedure Pop; -{ procedure PopAll;} - function Top: Pointer; - procedure Push(ThePointer: Pointer); - destructor Destroy; override; -end; - + SSLexLexeme = class; + SSYaccStackElement = class; + SSLexRoot = class; + SSArrayOfSSYaccStackElement = array[0..(SSLexStructMax div SizeOf(Pointer))] of SSYaccStackElement; + PSSArrayOfSSYaccStackElement = ^SSArrayOfSSYaccStackElement; -type - SSLexTableBase = record - Size : Longint; - TableType : Longint; - Reserved : array[ 0..6] of Longint; -end; - -type - SSLexTableHeader = record - TableType : Longint; - Size : Longint; - Reserved0 : array[ 0..7] of Longint; - Rows : Longint; - Push : Longint; - Index : Longint; - Final : Longint; - Reserved1 : array[ 0..7] of Longint; -end; + SSLexRoot = class(TBoldMemoryManagedObject) + end; -type - SSLexTableRow = record - Size : Longint; -end; + SSYaccStackElement = class(SSLexRoot) + public + Lexeme: SSLexLexeme; + State: Longint; + Use: Longint; + constructor Create; + procedure RefInc; + function RefDec: Boolean; + procedure SetLexeme(TheLexeme: SSLexLexeme); + destructor Destroy; override; + end; -type - SSLexTableRowEntry = record - StartPoint: Longint; - EndPoint : Longint; - State : Longint; -end; + SSStack = class(SSLexRoot) + public + Incr: Integer; + Size: Integer; + TopOfStack: Integer; + PArray: PSSArrayOfSSYaccStackElement; + constructor Create; + procedure Pop; + function Top: SSLexRoot; + procedure Push(TheSSYaccStackElement: SSLexRoot); + destructor Destroy; override; + end; -type - SSLexTableIndex = record - Row : Longint; -end; + TEntry = record + StartPoint: Longint; + EndPoint: Longint; + State: Longint; + end; -type - SSLexFinalState = record - Token : Longint; - Push : Longint; - Flags : Longint; - Reserved: array[ 0..3] of Longint; -end; + TRow = record + Token: ShortInt; + Push: ShortInt; + Flags: ShortInt; + Entries: array of TEntry; + end; -type - PSSLexTableBase = ^SSLexTableBase; - PSSLexTableHeader = ^SSLexTableHeader; - PSSLexTableRow = ^SSLexTableRow; - PSSLexTableRowEntry = ^SSLexTableRowEntry; - PSSLexTableIndex = ^SSLexTableIndex; - PSSLexFinalState = ^SSLexFinalState; - SSLexRowArray = array[ 0..(SSLexStructMax div sizeof(PSSLexTableRow))] of PSSLexTableRow; - SSLexFinalArray = array[ 0..((SSLexStructMax div sizeof(SSLexFinalState))-1)] of SSLexFinalState; - SSLexRowOffsetArray = array[ 0..(SSLexStructMax div sizeof(Longint))] of Longint; - SSLexRowEntryArray = array[ 0..((SSLexStructMax div sizeof(SSLexTableRowEntry))-1)] of SSLexTableRowEntry; - PSSLexRowArray = ^SSLexRowArray; - PSSLexFinalArray = ^SSLexFinalArray; - PSSLexRowOffsetArray = ^SSLexRowOffsetArray; - PSSLexRowEntryArray = ^SSLexRowEntryArray; + TRows = array of TRow; -type - SSLexExpressionList = class(TBoldMemoryManagedObject) + SSLexExpressionList = class(SSYaccStackElement) public - Buffer : Pointer; - Size : Longint; - Index : Longint; - Final : Longint; - Rows : Longint; - PPRows : PSSLexRowArray; - PFinalStates: PSSLexFinalArray; - - constructor Create; - constructor CreateBuffer(TheHeader: PSSLexTableHeader; TheFile: PChar); - procedure Open; - destructor Destroy; override; - + ARows: TRows; function LookupState(TheToken, TheState: Longint): Longint; - function LookupFinal(TheState: Longint): PSSLexFinalState; -end; + end; -type SSLexExpressionListStack = class(SSStack) - public - function Top: SSLexExpressionList; - procedure Push(TheList: SSLexExpressionList); -end; + function Top: SSLexExpressionList; + procedure Push(TheList: SSLexExpressionList); + end; -type - SSLexTable = class(TBoldMemoryManagedObject) + SSLexTable = class(SSLexRoot) public ExpressionLists: TList; - NumLists : Integer; - - constructor Create(FileName: String); - constructor CreateResource(TheInstance: THandle; TheName, TheType: PChar); - function GetExpressionList(TheList: Longint): SSLexExpressionList; - destructor Destroy; override; -end; + LexTab: array[0..1] of TRows; + constructor Create; + destructor Destroy; override; + function GetExpressionList(TheList: Longint): SSLexExpressionList; + procedure FullTab; + end; -type - SSLexLexeme = class(TBoldMemoryManagedObject) + SSLexLexeme = class(SSLexRoot) public - Buffer: PChar; - Use : Integer; - Line : Longint; + Buffer: PAnsiChar; + Use: Integer; + Line: Longint; Offset: Longint; Length: Longint; - Token : Cardinal; // was LongInt, changed to foor Delphi-hints - - constructor Create(TheData: PChar; TheLength, TheLine, TheOffset: Longint); - procedure RefInc; - function RefDec: Boolean; - destructor Destroy; override; -end; + Token: Cardinal; + constructor Create(TheData: PAnsiChar; TheLength, TheLine, TheOffset: Longint); + procedure RefInc; + function RefDec: Boolean; + destructor Destroy; override; + end; -type SSLexConsumerMode = (SSLexBinaryMode, SSLexTextMode); - SSLexConsumer = class(TBoldMemoryManagedObject) + + SSLexConsumer = class(SSLexRoot) public - Buffer : PChar; - Bof : Longint; - Line : Longint; - Offset : Longint; - BuffLen : Longint; - BuffInc : Longint; - Current : Longint; - MarkLine : Longint; - MarkOffset : Longint; - ScanLine : Longint; - ScanOffset : Longint; - EndOfData : Boolean; - Start : Longint; - Index : Integer; - DataLen : Longint; - Mark : Longint; - MarkContext : Longint; - MarkContextLine : Longint; + Buffer: PAnsiChar; + Bof: Longint; + Line: Longint; + Offset: Longint; + BuffLen: Longint; + BuffInc: Longint; + Current: Longint; + MarkLine: Longint; + MarkOffset: Longint; + ScanLine: Longint; + ScanOffset: Longint; + EndOfData: Boolean; + Start: Longint; + Index: Integer; + DataLen: Longint; + Mark: Longint; + MarkContext: Longint; + MarkContextLine: Longint; MarkContextOffset: Longint; - Mode : SSLexConsumerMode; - - constructor Create(TheIncrement: Longint; - TheMode: SSLexConsumerMode); - destructor Destroy; override; - - function Next: Boolean; virtual; - function NextBuffer: Longint; virtual; - - procedure MarkFinal; - procedure FlushLexeme; - procedure FlushLexemeAll; - procedure SetContextFinal; - procedure MarkContextFinal; - procedure FlushStartOfLine; - function Lexeme: SSLexLexeme; - function LexemeAll: SSLexLexeme; -{ function ShiftBuffer(var TheOffset, TheFill: Longint): Boolean; - function ExpandBuffer(var TheOffset, TheFill: Longint): Boolean; - } -end; + Mode: SSLexConsumerMode; + + constructor Create(TheIncrement: Longint; TheMode: SSLexConsumerMode); + destructor Destroy; override; + function Next: Boolean; virtual; + function NextBuffer: Longint; virtual; + procedure MarkFinal; + procedure FlushLexeme; + procedure FlushLexemeAll; + procedure SetContextFinal; + procedure MarkContextFinal; + procedure FlushStartOfLine; + function Lexeme: SSLexLexeme; + function LexemeAll: SSLexLexeme; + end; -type SSLexStringConsumer = class(SSLexConsumer) public - constructor Create(TheString: PChar); -end; + constructor Create(TheString: PAnsiChar); + end; -type SSLexFileConsumer = class(SSLexConsumer) public Handle: Integer; + end; -{ constructor Create(TheFileName: PChar; TheLength, TheIncrement: Longint; - TheMode: SSLexConsumerMode); - function NextBuffer: Longint; override; - function ReadData(TheBuffer: PChar; TheLength: Longint): Longint; - procedure Close; - destructor Destroy; override; - } -end; - -type - SSLex = class(TBoldMemoryManagedObject) + SSLex = class(SSLexRoot) public - State : Longint; - Table : SSLexTable; - Consumer: SSLexConsumer; - List : SSLexExpressionList; - Stack : SSLexExpressionListStack; - - constructor Create(TheConsumer: SSLexConsumer; TheTable: SSLexTable); -{ procedure Reset;} - procedure PopExpressionList; - function Next: SSLexLexeme; - procedure PushExpressionList(TheList: Longint); - procedure GotoExpressionList(TheList: Longint); - procedure ProcessExpressionList(ThePFinal: PSSLexFinalState); -{ function IsCurrentExpressionList(TheList: Longint): Boolean;} - - function Error: SSLexLexeme; virtual; - function Complete(TheToken: Longint): SSLexLexeme; virtual; - function TokenToString(TheToken: Longint): string; virtual; - destructor Destroy; override; + State: Longint; + Table: SSLexTable; + Consumer: SSLexConsumer; + List: SSLexExpressionList; + Stack: SSLexExpressionListStack; + + constructor Create(TheConsumer: SSLexConsumer; TheTable: SSLexTable); + + procedure PopExpressionList; + function Next: SSLexLexeme; + procedure PushExpressionList(TheList: Longint); + procedure GotoExpressionList(TheList: Longint); + procedure ProcessExpressionList(ThePFinal: TRow); + function Error: SSLexLexeme; virtual; + function Complete(TheToken: Longint): SSLexLexeme; virtual; + function TokenToString(TheToken: Longint): string; virtual; + destructor Destroy; override; + end; + -end; implementation uses - BoldSSExcept, - BoldCoreConsts, - SysUtils; + BoldSSExcept, SysUtils; + +constructor SSYaccStackElement.Create; +begin + inherited Create; + Lexeme := nil; + State := 0; + Use := 0; +end; + +procedure SSYaccStackElement.SetLexeme(TheLexeme: SSLexLexeme); +begin + if TheLexeme <> nil then + TheLexeme.RefInc; + if (Lexeme <> nil) and Lexeme.RefDec then + Lexeme.Free; + Lexeme := TheLexeme; +end; + +procedure SSYaccStackElement.RefInc; +begin + Inc(Use); +end; + +function SSYaccStackElement.RefDec: Boolean; +begin + Dec(Use); + Result := Use = 0; +end; -constructor SSLexConsumer.Create(TheIncrement: Longint; - TheMode: SSLexConsumerMode); +destructor SSYaccStackElement.Destroy; +begin + if (Lexeme <> nil) and Lexeme.RefDec then + Lexeme.Free; + inherited; +end; + +constructor SSLexConsumer.Create(TheIncrement: Integer; TheMode: SSLexConsumerMode); begin inherited Create; BuffInc := TheIncrement; @@ -305,7 +244,7 @@ destructor SSLexConsumer.Destroy; begin if Buffer <> nil then FreeMem(Buffer, BuffLen); - inherited Destroy; + inherited; end; procedure SSLexConsumer.MarkFinal; @@ -342,7 +281,7 @@ procedure SSLexConsumer.FlushLexeme; begin Start := Mark; Index := Mark; - Line := Line + MarkLine; + Inc(Line, MarkLine); Offset := MarkOffset; ScanLine := 0; ScanOffset := MarkOffset; @@ -351,129 +290,62 @@ procedure SSLexConsumer.FlushLexeme; procedure SSLexConsumer.FlushLexemeAll; begin Start := Index; - Line := Line + ScanLine; + Inc(Line, ScanLine); Offset := ScanOffset; ScanLine := 0; end; - function SSLexConsumer.Next: Boolean; var NewLen: Integer; - begin - if EndOfData = True then - Result := False + if EndOfData = True then + Result := False + else + begin + if Bof <> 0 then + begin + Current := Bof; + Bof := 0; + Result := True; + end else + begin + if Index >= DataLen then begin - if Bof <> 0 then + NewLen := NextBuffer; + if NewLen = 0 then begin - Current := Bof; - Bof := 0; - Result := True; + EndOfData := True; + Result := False; end - else - begin - if Index >= DataLen then - begin - NewLen := NextBuffer; - if NewLen = 0 then - begin - EndOfData := True; - Result := False; - end - else - begin - DataLen := DataLen + NewLen; - Result := True; - end - end else + begin + Inc(DataLen, NewLen); Result := True; - - - if Result = True then - begin - Current := Longint(Buffer[ Index]); - Inc(Index); - if Current = Ord($0A) then - begin - Inc(ScanLine); - ScanOffset := 1; - end - else - Inc(ScanOffset); - end end; - end; - -end; - -{function SSLexConsumer.ShiftBuffer(var TheOffset, TheFill: Longint): Boolean; -var - StartOfData: PChar; - -begin - if ((Start = 0) and (DataLen = 0)) then - begin - TheOffset := 0; - TheFill := BuffLen; - Result := False; - end - else if Start = 0 then - Result := True - else - begin - TheOffset := DataLen - Start; - if Offset <> 0 then - begin - StartOfData := Buffer + Start; - StrMove(Buffer, StartOfData, TheOffset); - TheFill := BuffLen - TheOffset; - Index := Index - Start; - Mark := Mark - Start; - MarkContext := MarkContext - Start; - DataLen := DataLen - Start; - Start := 0; - Result := False; end - else - begin - TheOffset := 0; - DataLen := 0; - Index := 0; - Start := 0; - TheFill := BuffLen; - Result := False; - end - end -end; + else + Result := True; -function SSLexConsumer.ExpandBuffer(var TheOffset, TheFill: Longint): Boolean; -var - NewBuff: PChar; - NewLen : Longint; + if Result = True then + begin + Current := Longint(Buffer[Index]); + Inc(Index); + if Current = Ord($0A) then + begin + Inc(ScanLine); + ScanOffset := 1; + end + else + Inc(ScanOffset); + end; + end; + end; -begin - if (BuffInc = 0) or (BuffLen >= SSLexBufferMax) then - Result := True - else - begin - NewLen := BuffLen + BuffInc; - if NewLen > SSLexBufferMax then - NewLen := SSLexBufferMax; - GetMem(NewBuff, NewLen); - StrMove(NewBuff, Buffer, BuffLen); - TheOffset := DataLen; - FreeMem(Buffer, BuffLen); - Buffer := NewBuff; - TheFill := NewLen - DataLen; - BuffLen := NewLen; - Result := False; - end end; - } -constructor SSLexStringConsumer.Create(TheString: PChar); + +constructor SSLexStringConsumer.Create(TheString: PAnsiChar); begin inherited Create(0, SSLexBinaryMode); DataLen := StrLen(TheString); @@ -481,144 +353,28 @@ constructor SSLexStringConsumer.Create(TheString: PChar); GetMem(Buffer, BuffLen); StrMove(Buffer, TheString, BuffLen); end; -(* -constructor SSLexFileConsumer.Create(TheFileName: PChar; - TheLength, TheIncrement: Longint; TheMode: SSLexConsumerMode); -var - Size : Longint; - NewException : SSException; - -begin - inherited Create(TheIncrement, TheMode); - DataLen := 0; - Mode := TheMode; - BuffLen := TheLength; - BuffInc := TheIncrement; - Handle := _lopen(TheFileName, OF_READ); - if Handle = -1 { HFILE_ERROR } then - begin - NewException := SSException.CreateName(SSExceptionLexFileOpen, SSLexMsgFileOpen, TheFileName); - raise NewException; - end - else - begin - Size := _llseek(Handle, 0, 2); - if Size < BuffLen then - BuffLen := Size; - if BuffLen > SSLexBufferMax then - BuffLen := SSLexBufferMax; - GetMem(Buffer, BuffLen); - _llseek(Handle, 0, 0); - DataLen := ReadData(Buffer, BuffLen); - if (DataLen = 0) then - Close; - end -end; - -function SSLexFileConsumer.ReadData(TheBuffer: PChar; TheLength: Longint): Longint; -var - TestChar : Byte; - IntBuff : PChar; - i : Integer; - SaveLength: Integer; - -begin - Result := 0; - if Mode = SSLexTextMode then - begin - GetMem(IntBuff, TheLength); - SaveLength := TheLength; - TheLength := _lread(Handle, IntBuff, TheLength); - for i := 0 to TheLength - 1 do - begin - TestChar := PByteArray(IntBuff)^[ i]; - if (TestChar <> $0D) and (TestChar <> $1A) then - begin - PByteArray(TheBuffer)^[ 0] := PByteArray(IntBuff)^[ i]; - Inc(Result); - TheBuffer := TheBuffer + 1; - end; - end; - FreeMem(IntBuff, SaveLength); - end - else - Result := _lread(Handle, TheBuffer, TheLength); -end; - -procedure SSLexFileConsumer.Close; -begin - if Handle <> 0 then - begin - _lclose(Handle); - Handle := 0; - end -end; - -function SSLexFileConsumer.NextBuffer: Longint; -var - TestChar: Char; - TestLen: Longint; - Offset, Fill: Longint; - NewException: SSException; - -begin - if Handle <> 0 then - begin - if (ShiftBuffer(Offset, Fill) and ExpandBuffer(Offset, Fill)) then - begin - TestLen := _lread(Handle, PChar(@TestChar), 1); - if TestLen <> 0 then - begin - NewException := SSException.CreateLong(SSExceptionLexLexemeLength, SSLexMsgLexemeLength, BuffLen); - raise NewException; - end - else - begin - Close; - Result := 0; - end - end - else - begin - Result := ReadData(Buffer + Offset, Fill); - if (Result = 0) then - Close; - end - end - else - Result := 0; - -end; - -destructor SSLexFileConsumer.Destroy; -begin - Close; - inherited Destroy; -end; -*) function SSLexConsumer.Lexeme: SSLexLexeme; var - Length : Longint; + Length: Longint; begin - Length := Mark - Start; - Result := SSLexLexeme.Create(Buffer + Start, Length, Line, Offset); - FlushLexeme; + Length := Mark - Start; + Result := SSLexLexeme.Create(PAnsiChar(Buffer) + Start, Length, Line, Offset); + FlushLexeme; end; function SSLexConsumer.LexemeAll: SSLexLexeme; begin - Result := SSLexLexeme.Create(Buffer + Start, Index - Start, Line, Offset); + Result := SSLexLexeme.Create(PAnsiChar(Buffer) + Start, Index - Start, Line, Offset); FlushLexemeAll; end; - -constructor SSLexLexeme.Create(TheData: PChar; TheLength, TheLine, TheOffset: Longint); +constructor SSLexLexeme.Create(TheData: PAnsiChar; TheLength, TheLine, TheOffset: Integer); begin inherited Create; GetMem(Buffer, TheLength + 1); StrMove(Buffer, TheData, TheLength); - PByteArray(Buffer)^[ TheLength] := $0; + PByteArray(Buffer)[TheLength] := 0; Length := TheLength; Line := TheLine; Offset := TheOffset; @@ -627,23 +383,26 @@ constructor SSLexLexeme.Create(TheData: PChar; TheLength, TheLine, TheOffset: Lo procedure SSLexLexeme.RefInc; begin - Assert(Use>=0); + if Use < 0 then + Assert(False, 'Assertion failure'); Inc(Use); end; function SSLexLexeme.RefDec: Boolean; begin Dec(Use); - Result := (Use = 0); - Assert(Use >= 0); + Result := Use = 0; + if Use < 0 then + Assert(False, 'Assertion failure'); end; destructor SSLexLexeme.Destroy; begin - Assert(Use=0); + if Use <> 0 then + Assert(False, 'Assertion failure'); if Buffer <> nil then - FreeMem(Buffer, Length); - inherited Destroy; + FreeMem(Buffer, Length + 1); + inherited; end; function SSLexConsumer.NextBuffer: Longint; @@ -651,231 +410,85 @@ function SSLexConsumer.NextBuffer: Longint; Result := 0; end; -function SSHugeInc(ThePointer: Pointer; TheInc: Longint): Pointer; -begin - Result := PChar(ThePointer) + TheInc; -end; - -constructor SSLexTable.Create(FileName: String); +constructor SSLexTable.Create; var - i : Integer; - Current : Longint; - FileHandle : TFileStream; - Base : SSLexTableBase; - Header : SSLexTableHeader; - ExprList : SSLexExpressionList; - + i: Integer; + ExprList: SSLexExpressionList; begin inherited Create; - SSAux; - ExpressionLists := nil; - if not FileExists(FileName) then - raise Exception.CreateFmt(sFileDoesNotExist, [FileName]); - - FileHandle := TFileStream.Create(FileName, fmOpenRead); - FileHandle.Read(Base, sizeOf(Base)); - if Base.TableType <> SSLexPairTable then - raise SSException.CreateName(SSExceptionLexBadTable, SSLexMsgBadTable, PChar(FileName)); + FullTab; - NumLists := Base.Size; ExpressionLists := TList.Create; - for i := 0 to NumLists - 1 do + for i := 0 to Length(LexTab) - 1 do begin - Current := FileHandle.Position; - FileHandle.Read(Header, SizeOf(Header)); ExprList := SSLexExpressionList.Create; - GetMem(ExprList.Buffer, Header.Size); - ExprList.Size := Header.Size; - ExprList.Final := Header.Final; - ExprList.Index := Header.Index; - ExprList.Rows := Header.Rows; - FileHandle.Position := Current; - FileHandle.Read(ExprList.Buffer^, ExprList.Size); - ExprList.Open; + ExprList.ARows := LexTab[i]; ExpressionLists.Insert(i, ExprList); end; - FreeAndNil(FileHandle); -end; - -constructor SSLexTable.CreateResource(TheInstance: THandle; TheName, TheType: PChar); -var - LoadHandle : THandle; - FindHandle : THandle; - Resource : Pointer; - i : Integer; - NewException: SSException; - Base : SSLexTableBase; - Header : SSLexTableHeader; - ExprList : SSLexExpressionList; - -begin - inherited Create; - LoadHandle := 0; // to prevent compiler warning - SSAux; - Resource := nil; - ExpressionLists := nil; - FindHandle := FindResource(TheInstance, TheName, TheType); - if (FindHandle <> 0) then - begin - LoadHandle := LoadResource(TheInstance, FindHandle); - if (LoadHandle <> 0) then - Resource := LockResource(LoadHandle); - end; - if (Resource = nil) then - begin - NewException := SSException.CreateName(SSExceptionLexFindResource, SSLexMsgFindResource, TheType); - raise NewException; - end - else - begin - SSHugeCopy(@Base, Resource, sizeof(Base)); - if Base.TableType <> SSLexPairTable then - begin - NewException := SSException.CreateName(SSExceptionLexBadResource, SSLexMsgBadResource, TheType); - raise NewException; - end; - NumLists := Base.Size; - ExpressionLists := TList.Create; - Resource := SSHugeInc(Resource, sizeof(Base)); - for i := 0 to NumLists - 1 do - begin - SSHugeCopy(@Header, Resource, sizeof(Header)); - ExprList := SSLexExpressionList.Create; - Getmem(ExprList.Buffer, Header.Size); - ExprList.Size := Header.Size; - ExprList.Final := Header.Final; - ExprList.Index := Header.Index; - ExprList.Rows := Header.Rows; - SSHugeCopy(ExprList.Buffer, Resource, ExprList.Size); - ExprList.Open; - ExpressionLists.Insert(i, ExprList); - Resource := SSHugeInc(Resource, ExprList.Size); - end; - FreeResource(LoadHandle); - end end; -constructor SSLexExpressionList.CreateBuffer(TheHeader: PSSLexTableHeader; TheFile: PChar); -var -// i : Integer; - NewException: SSException; - Header : SSLexTableHeader; -begin - inherited Create; - SSHugeCopy(@Header, TheHeader, sizeof(SSLexTableHeader)); - if Header.TableType <> SSLexPairTable then - begin - NewException := SSException.CreateName(SSExceptionLexBadTable, SSLexMsgBadTable, TheFile); - raise NewException; - end; - GetMem(Buffer, Header.Size); //Buffer := SSHugeAlloc(Header.Size, Handle); - Size := Header.Size; - Final := Header.Final; - Index := Header.Index; - Rows := Header.Rows; - SSHugeCopy(Buffer, TheHeader, Size); - Open; -end; - -function SSLexTable.GetExpressionList(TheList: Longint): SSLexExpressionList; +function SSLexTable.GetExpressionList(TheList: Integer): SSLexExpressionList; var AnException: SSException; begin - if (TheList < 0) or (TheList >= ExpressionLists.Count) then - begin + if (TheList < 0) or (ExpressionLists.Count <= TheList) then + begin AnException := SSException.CreateLong(SSExceptionBadList, SSLexMsgBadList, TheList); raise AnException; - end; - Result := ExpressionLists.Items[ TheList]; -end; - -procedure SSLexExpressionList.Open; -var - i : Integer; - PRowOffsets: PSSLexRowOffsetArray; -begin - PPRows := SSHugeInc(Buffer, Index); - PRowOffsets := Pointer(PPRows); - PFinalStates := SSHugeInc(Buffer, Final); - for i := 0 to Rows - 1 do - PPRows^[ i] := SSHugeInc(Buffer, PRowOffsets^[ i]); -end; - -procedure SSHugeCopy(TheCopyTo: Pointer; TheCopyFrom: Pointer; TheLength: Longint); -begin - Move(TheCopyFrom^, TheCopyTo^, TheLength); + end; + Result := ExpressionLists[TheList]; end; - -function SSLexExpressionList.LookupState(TheToken, TheState: Longint): Longint; +function SSLexExpressionList.LookupState(TheToken, TheState: Integer): Longint; var - i : Integer; - PRow : PSSLexTableRow; - PEntry : PSSLexTableRowEntry; - PEntries: PSSLexRowEntryArray; - + i: Integer; + Row: TRow; + Entry: TEntry; begin Result := SSLexStateInvalid; - PRow := PPRows^[ TheState]; - PEntries := PSSLexRowEntryArray(PChar(PRow) + sizeof(SSLexTableRow)); - for i := 0 to PRow^.Size - 1 do - begin - PEntry := @PEntries^[ i]; + Row := ARows[TheState]; + for i := 0 to Length(Row.Entries) - 1 do + begin + Entry := Row.Entries[i]; if TheToken = SSLexConsumerBof then + begin + if Entry.StartPoint = SSLexConsumerBof then begin - if PEntry^.StartPoint = SSLexConsumerBof then - begin - Result := PEntry^.State; - Break; - end - end - else if TheToken < PEntry^.StartPoint then - Break - else - begin - if TheToken <= PEntry^.EndPoint then - begin - Result := PEntry^.State; + Result := Entry.State; Break; - end end; + end + else if TheToken < Entry.StartPoint then + begin + Break; + end + else if TheToken <= Entry.EndPoint then + begin + Result := Entry.State; + Break; end; -end; - -function SSLexExpressionList.LookupFinal(TheState: Longint): PSSLexFinalState; -begin - Result := @PFinalStates^[ TheState]; + end; end; destructor SSLexTable.Destroy; var - i : Integer; + i: Integer; List: SSLexExpressionList; begin if ExpressionLists <> nil then - begin + begin for i := 0 to ExpressionLists.Count - 1 do - begin - List := ExpressionLists.Items[ i]; + begin + List := ExpressionLists[i]; List.Free; - end; + + LexTab[i] := nil; end; + end; ExpressionLists.Free; - inherited Destroy; -end; - -constructor SSLexExpressionList.Create; -begin - inherited Create; - Buffer := nil; -end; -destructor SSLexExpressionList.Destroy; -begin - if Buffer <> nil then - FreeMem(Buffer, Size); - inherited Destroy; + inherited; end; constructor SSLex.Create(TheConsumer: SSLexConsumer; TheTable: SSLexTable); @@ -885,22 +498,16 @@ constructor SSLex.Create(TheConsumer: SSLexConsumer; TheTable: SSLexTable); inherited Create; Stack := nil; if (TheTable = nil) or (TheConsumer = nil) then - begin + begin AnException := SSException.Create(SSExceptionMissingPart, SSLexMsgMissingPart); raise AnException; - end; + end; Table := TheTable; Consumer := TheConsumer; Stack := SSLexExpressionListStack.Create; PushExpressionList(0); end; -{procedure SSLex.Reset; -begin - Stack.PopAll; - Stack.Push(Table.GetExpressionList(0)); -end; - } procedure SSLex.PopExpressionList; begin Stack.Pop; @@ -909,82 +516,77 @@ procedure SSLex.PopExpressionList; function SSLex.Next: SSLexLexeme; var - Consumed : Boolean; - PFinal : PSSLexFinalState; - PTempFinal : PSSLexFinalState; + Consumed: Boolean; + RFinal, RTempFinal: TRow; begin - result := nil; + Result := nil; while True do - begin + begin State := 0; Result := nil; Consumed := False; - PFinal := List.LookupFinal(State); + RFinal := List.ARows[State]; while Consumer.Next do - begin + begin Consumed := True; State := List.LookupState(Consumer.Current, State); if State = SSLexStateInvalid then - Break - else - begin - PTempFinal := List.LookupFinal(State); - if (PTempFinal^.Flags and SSLexFinalStateFlagsFinal) <> 0 then - begin - Consumer.MarkFinal; - PFinal := PTempFinal; - end; - if (PTempFinal^.Flags and SSLexFinalStateFlagsContextStart) <> 0 then - Consumer.MarkContextFinal; - end; + begin + Break; end; + RTempFinal := List.ARows[State]; + if RTempFinal.Flags and SSLexFinalStateFlagsFinal <> 0 then + begin + Consumer.MarkFinal; + RFinal := RTempFinal; + end; + if RTempFinal.Flags and SSLexFinalStateFlagsContextStart <> 0 then + Consumer.MarkContextFinal; + end; - if Consumed = False then + if not Consumed then Break; - if (PFinal^.Flags and SSLexFinalStateFlagsContextEnd) <> 0 then + if RFinal.Flags and SSLexFinalStateFlagsContextEnd <> 0 then Consumer.SetContextFinal; - if (PFinal^.Flags and SSLexFinalStateFlagsIgnore) <> 0 then - begin + if RFinal.Flags and SSLexFinalStateFlagsIgnore <> 0 then + begin Consumer.FlushLexeme; - ProcessExpressionList(PFinal); + ProcessExpressionList(RFinal); Continue; - end; + end; - if (PFinal^.Flags and SSLexFinalStateFlagsFinal) = 0 then - begin + if RFinal.Flags and SSLexFinalStateFlagsFinal = 0 then + begin Result := Error; if Result <> nil then - Break - else - begin - Consumer.FlushLexemeAll; - Continue; - end; - end; + Break; + + Consumer.FlushLexemeAll; + Continue; + end; - ProcessExpressionList(PFinal); - if (PFinal^.Flags and SSLexFinalStateFlagsStartOfLine) <> 0 then + ProcessExpressionList(RFinal); + if RFinal.Flags and SSLexFinalStateFlagsStartOfLine <> 0 then if (Consumer.Line <> 1) and (Consumer.Offset <> 1) then Consumer.FlushStartOfLine; - Result := Complete(PFinal^.Token); + Result := Complete(RFinal.Token); if Result <> nil then - Break - end; - + Break; + end; end; -procedure SSLex.ProcessExpressionList(ThePFinal: PSSLexFinalState); +procedure SSLex.ProcessExpressionList(ThePFinal: TRow); begin - if ((ThePFinal^.Flags and SSLexFinalStateFlagsPop) <> 0) and - ((ThePFinal^.Flags and SSLexFinalStateFlagsPush) <> 0) then - GotoExpressionList(ThePFinal^.Push) - else if (ThePFinal^.Flags and SSLexFinalStateFlagsPop) <> 0 then + if (ThePFinal.Flags and SSLexFinalStateFlagsPop <> 0) + and (ThePFinal.Flags and SSLexFinalStateFlagsPush <> 0) then + GotoExpressionList(ThePFinal.Push) + else if (ThePFinal.Flags and SSLexFinalStateFlagsPop <> 0) then PopExpressionList - else if (ThePFinal^.Flags and SSLexFinalStateFlagsPush) <> 0 then - PushExpressionList(ThePFinal^.Push); + else if (ThePFinal.Flags and SSLexFinalStateFlagsPush <> 0) then + PushExpressionList(ThePFinal.Push); end; procedure SSLex.PushExpressionList(TheList: Longint); @@ -999,29 +601,20 @@ procedure SSLex.GotoExpressionList(TheList: Longint); PushExpressionList(TheList); end; -{function SSLex.IsCurrentExpressionList(TheList: Longint): Boolean; -begin - if Table.GetExpressionList(TheList) = Stack.Top then - Result := True - else - Result := False; -end; -} - function SSLex.Error: SSLexLexeme; var - Lexeme : SSLexLexeme; + Lexeme: SSLexLexeme; AnException: SSException; begin Lexeme := Consumer.LexemeAll; - AnException := SSException.CreateLongLongNameLen(SSExceptionLexError, - SSLexMsgError, Lexeme.Line, Lexeme.Offset, Lexeme.Buffer, Lexeme.Length); + AnException := SSException.CreateLongLongNameLen(SSExceptionLexError, SSLexMsgError, + Lexeme.Line, Lexeme.Offset, PChar(string(Lexeme.Buffer)), Lexeme.Length); raise AnException; end; -function SSLex.TokenToString(TheToken: Longint): String; +function SSLex.TokenToString(TheToken: Longint): string; begin - result := ''; + Result := ''; end; function SSLex.Complete(TheToken: Longint): SSLexLexeme; @@ -1033,12 +626,12 @@ function SSLex.Complete(TheToken: Longint): SSLexLexeme; destructor SSLex.Destroy; begin Stack.Free; - inherited Destroy; + inherited; end; function SSLexExpressionListStack.Top: SSLexExpressionList; begin - Result := inherited Top; + Result := inherited Top as SSLexExpressionList; end; procedure SSLexExpressionListStack.Push(TheList: SSLexExpressionList); @@ -1051,7 +644,7 @@ constructor SSStack.Create; inherited Create; Size := 32; Incr := 32; - GetMem(PArray, Size * sizeof(Pointer)); + GetMem(PArray, Size * SizeOf(Pointer)); TopOfStack := 0; end; @@ -1060,66 +653,886 @@ procedure SSStack.Pop; AnException: SSException; begin if TopOfStack = 0 then - begin + begin AnException := SSException.Create(SSExceptionStackPop, SSLifoMsgStackPop); raise AnException; - end; + end; Dec(TopOfStack); end; -{procedure SSStack.PopAll; -begin - TopOfStack := 0; -end; - } -function SSStack.Top: Pointer; +function SSStack.Top: SSLexRoot; var AnException: SSException; begin if TopOfStack = 0 then - begin + begin AnException := SSException.Create(SSExceptionStackTop, SSLifoMsgStackTop); raise AnException; - end; - Result := PArray^[ TopOfStack - 1]; + end; + Result := PArray[TopOfStack - 1]; end; -procedure SSStack.Push(ThePointer: Pointer); +procedure SSStack.Push(TheSSYaccStackElement: SSLexRoot); var - i : Integer; - NewSize : Integer; - PNewArray: PSSArrayOfPointer; + i: Integer; + NewSize: Integer; + PNewArray: PSSArrayOfSSYaccStackElement; begin if TopOfStack >= Size then - begin + begin NewSize := Size + Incr; - GetMem(PNewArray, NewSize * sizeof(Pointer)); + GetMem(PNewArray, NewSize * SizeOf(Pointer)); for i := 0 to TopOfStack - 1 do - PNewArray^[ i] := PArray^[ i]; - FreeMem(PArray, Size * sizeof(Pointer)); + PNewArray[i] := PArray[i]; + FreeMem(PArray, Size * SizeOf(Pointer)); PArray := PNewArray; Size := NewSize; - end; + end; - PArray^[ TopOfStack] := ThePointer; + PArray[TopOfStack] := TheSSYaccStackElement as SSYaccStackElement; Inc(TopOfStack); end; destructor SSStack.Destroy; begin - FreeMem(PArray, Size * sizeof(Pointer)); + FreeMem(PArray, Size * SizeOf(Pointer)); inherited; end; -{$IFDEF SSAUX} -{$I SSAUXFUN.PAS} -{$ELSE} -procedure SSAux; +procedure SSLexTable.FullTab; +var + Row: TRow; + N: Integer; + + procedure R(T, P, F, C: ShortInt); + begin + with Row do + begin + Token := T; + Push := P; + Flags := F; + SetLength(Entries, C); + N := 0; + end; + end; + + procedure RE(B, E, S: Longint); + begin + with Row.Entries[N] do + begin + StartPoint := B; + EndPoint := E; + State := S; + end; + Inc(N); + end; + begin + {$REGION 'Full LexTab'} + + // === LexTab[0] === + + SetLength(LexTab[0], 111); + // [0, 0] + R(0, 0, 0, 45); + RE(9, 10, 1); + RE(32, 32, 1); + RE(35, 35, 12); + RE(39, 39, 14); + RE(40, 40, 16); + RE(41, 41, 18); + RE(42, 42, 20); + RE(43, 43, 22); + RE(44, 44, 24); + RE(45, 45, 26); + RE(46, 46, 28); + RE(47, 47, 30); + RE(48, 57, 32); + RE(58, 58, 34); + RE(60, 60, 36); + RE(61, 61, 38); + RE(62, 62, 40); + RE(64, 64, 42); + RE(65, 65, 44); + RE(66, 66, 46); + RE(67, 67, 48); + RE(68, 82, 44); + RE(83, 83, 50); + RE(84, 90, 44); + RE(91, 91, 52); + RE(93, 93, 54); + RE(97, 97, 56); + RE(98, 99, 60); + RE(100, 100, 58); + RE(101, 101, 62); + RE(102, 104, 60); + RE(105, 105, 64); + RE(106, 108, 60); + RE(109, 109, 66); + RE(110, 110, 102); + RE(111, 111, 68); + RE(112, 115, 60); + RE(116, 116, 70); + RE(117, 119, 60); + RE(120, 120, 101); + RE(121, 122, 60); + RE(123, 123, 72); + RE(124, 124, 74); + RE(125, 125, 76); + RE(-1, -1, 78); + LexTab[0][0] := Row; + // [0, 1] + R(1, 0, 80, 0); + LexTab[0][1] := Row; + // [0, 2] + R(0, 0, 0, 1); + RE(48, 57, 11); + LexTab[0][2] := Row; + // [0, 3] + R(0, 0, 0, 1); + RE(48, 57, 5); + LexTab[0][3] := Row; + // [0, 4] + R(0, 0, 0, 1); + RE(48, 57, 2); + LexTab[0][4] := Row; + // [0, 5] + R(0, 0, 0, 2); + RE(48, 57, 7); + RE(58, 58, 109); + LexTab[0][5] := Row; + // [0, 6] + R(0, 0, 0, 1); + RE(45, 45, 4); + LexTab[0][6] := Row; + // [0, 7] + R(0, 0, 0, 1); + RE(48, 57, 9); + LexTab[0][7] := Row; + // [0, 8] + R(0, 0, 0, 1); + RE(48, 57, 6); + LexTab[0][8] := Row; + // [0, 9] + R(0, 0, 0, 1); + RE(45, 45, 10); + LexTab[0][9] := Row; + // [0, 10] + R(0, 0, 0, 1); + RE(48, 57, 8); + LexTab[0][10] := Row; + // [0, 11] + R(6, 0, 16, 0); + LexTab[0][11] := Row; + // [0, 12] + R(34, 0, 16, 1); + RE(48, 57, 3); + LexTab[0][12] := Row; + // [0, 13] + R(7, 0, 16, 0); + LexTab[0][13] := Row; + // [0, 14] + R(8, 1, 48, 0); + LexTab[0][14] := Row; + // [0, 15] + R(7, 0, 16, 1); + RE(58, 58, 110); + LexTab[0][15] := Row; + // [0, 16] + R(11, 0, 16, 0); + LexTab[0][16] := Row; + // [0, 17] + R(26, 0, 16, 0); + LexTab[0][17] := Row; + // [0, 18] + R(12, 0, 16, 0); + LexTab[0][18] := Row; + // [0, 19] + R(37, 0, 16, 0); + LexTab[0][19] := Row; + // [0, 20] + R(23, 0, 16, 0); + LexTab[0][20] := Row; + // [0, 21] + R(3, 0, 16, 1); + RE(48, 57, 21); + LexTab[0][21] := Row; + // [0, 22] + R(21, 0, 16, 0); + LexTab[0][22] := Row; + // [0, 23] + R(36, 0, 16, 0); + LexTab[0][23] := Row; + // [0, 24] + R(27, 0, 16, 0); + LexTab[0][24] := Row; + // [0, 25] + R(20, 0, 16, 0); + LexTab[0][25] := Row; + // [0, 26] + R(22, 0, 16, 1); + RE(62, 62, 17); + LexTab[0][26] := Row; + // [0, 27] + R(19, 0, 16, 0); + LexTab[0][27] := Row; + // [0, 28] + R(25, 0, 16, 1); + RE(46, 46, 19); + LexTab[0][28] := Row; + // [0, 29] + R(18, 0, 16, 0); + LexTab[0][29] := Row; + // [0, 30] + R(24, 0, 16, 0); + LexTab[0][30] := Row; + // [0, 31] + R(39, 0, 16, 4); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 122, 44); + LexTab[0][31] := Row; + // [0, 32] + R(2, 0, 16, 2); + RE(46, 46, 106); + RE(48, 57, 32); + LexTab[0][32] := Row; + // [0, 33] + R(5, 0, 16, 6); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 102, 44); + RE(103, 103, 31); + RE(104, 122, 44); + LexTab[0][33] := Row; + // [0, 34] + R(38, 0, 16, 1); + RE(58, 58, 23); + LexTab[0][34] := Row; + // [0, 35] + R(42, 0, 16, 4); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 122, 44); + LexTab[0][35] := Row; + // [0, 36] + R(16, 0, 16, 2); + RE(61, 61, 27); + RE(62, 62, 25); + LexTab[0][36] := Row; + // [0, 37] + R(5, 0, 16, 6); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 109, 44); + RE(110, 110, 35); + RE(111, 122, 44); + LexTab[0][37] := Row; + // [0, 38] + R(17, 0, 16, 0); + LexTab[0][38] := Row; + // [0, 39] + R(5, 0, 16, 6); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 110, 44); + RE(111, 111, 37); + RE(112, 122, 44); + LexTab[0][39] := Row; + // [0, 40] + R(15, 0, 16, 1); + RE(61, 61, 29); + LexTab[0][40] := Row; + // [0, 41] + R(5, 0, 16, 6); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 104, 44); + RE(105, 105, 39); + RE(106, 122, 44); + LexTab[0][41] := Row; + // [0, 42] + R(28, 0, 16, 0); + LexTab[0][42] := Row; + // [0, 43] + R(5, 0, 16, 6); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 115, 44); + RE(116, 116, 41); + RE(117, 122, 44); + LexTab[0][43] := Row; + // [0, 44] + R(5, 0, 16, 4); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 122, 44); + LexTab[0][44] := Row; + // [0, 45] + R(5, 0, 16, 6); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 98, 44); + RE(99, 99, 43); + RE(100, 122, 44); + LexTab[0][45] := Row; + // [0, 46] + R(5, 0, 16, 5); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 97, 33); + RE(98, 122, 44); + LexTab[0][46] := Row; + // [0, 47] + R(5, 0, 16, 6); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 100, 44); + RE(101, 101, 45); + RE(102, 122, 44); + LexTab[0][47] := Row; + // [0, 48] + R(5, 0, 16, 6); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 110, 44); + RE(111, 111, 51); + RE(112, 122, 44); + LexTab[0][48] := Row; + // [0, 49] + R(5, 0, 16, 6); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 107, 44); + RE(108, 108, 47); + RE(109, 122, 44); + LexTab[0][49] := Row; + // [0, 50] + R(5, 0, 16, 6); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 100, 44); + RE(101, 101, 67); + RE(102, 122, 44); + LexTab[0][50] := Row; + // [0, 51] + R(5, 0, 16, 6); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 107, 44); + RE(108, 108, 49); + RE(109, 122, 44); + LexTab[0][51] := Row; + // [0, 52] + R(9, 0, 16, 0); + LexTab[0][52] := Row; + // [0, 53] + R(41, 0, 16, 4); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 122, 44); + LexTab[0][53] := Row; + // [0, 54] + R(10, 0, 16, 0); + LexTab[0][54] := Row; + // [0, 55] + R(5, 0, 16, 6); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 100, 44); + RE(101, 101, 53); + RE(102, 122, 44); + LexTab[0][55] := Row; + // [0, 56] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 109, 60); + RE(110, 110, 71); + RE(111, 122, 60); + LexTab[0][56] := Row; + // [0, 57] + R(5, 0, 16, 6); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 98, 44); + RE(99, 99, 55); + RE(100, 122, 44); + LexTab[0][57] := Row; + // [0, 58] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 104, 60); + RE(105, 105, 75); + RE(106, 122, 60); + LexTab[0][58] := Row; + // [0, 59] + R(5, 0, 16, 6); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 109, 44); + RE(110, 110, 57); + RE(111, 122, 44); + LexTab[0][59] := Row; + // [0, 60] + R(4, 0, 16, 4); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 122, 60); + LexTab[0][60] := Row; + // [0, 61] + R(5, 0, 16, 6); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 100, 44); + RE(101, 101, 59); + RE(102, 122, 44); + LexTab[0][61] := Row; + // [0, 62] + R(4, 0, 16, 8); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 107, 60); + RE(108, 108, 91); + RE(109, 109, 60); + RE(110, 110, 89); + RE(111, 122, 60); + LexTab[0][62] := Row; + // [0, 63] + R(40, 0, 16, 4); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 122, 44); + LexTab[0][63] := Row; + // [0, 64] + R(4, 0, 16, 8); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 101, 60); + RE(102, 102, 96); + RE(103, 108, 60); + RE(109, 109, 98); + RE(110, 122, 60); + LexTab[0][64] := Row; + // [0, 65] + R(5, 0, 16, 6); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 116, 44); + RE(117, 117, 61); + RE(118, 122, 44); + LexTab[0][65] := Row; + // [0, 66] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 110, 60); + RE(111, 111, 92); + RE(112, 122, 60); + LexTab[0][66] := Row; + // [0, 67] + R(5, 0, 16, 8); + RE(48, 57, 44); + RE(65, 90, 44); + RE(95, 95, 44); + RE(97, 112, 44); + RE(113, 113, 65); + RE(114, 115, 44); + RE(116, 116, 63); + RE(117, 122, 44); + LexTab[0][67] := Row; + // [0, 68] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 113, 60); + RE(114, 114, 86); + RE(115, 122, 60); + LexTab[0][68] := Row; + // [0, 69] + R(45, 0, 16, 4); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 122, 60); + LexTab[0][69] := Row; + // [0, 70] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 103, 60); + RE(104, 104, 82); + RE(105, 122, 60); + LexTab[0][70] := Row; + // [0, 71] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 99, 60); + RE(100, 100, 69); + RE(101, 122, 60); + LexTab[0][71] := Row; + // [0, 72] + R(13, 0, 16, 0); + LexTab[0][72] := Row; + // [0, 73] + R(43, 0, 16, 4); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 122, 60); + LexTab[0][73] := Row; + // [0, 74] + R(35, 0, 16, 0); + LexTab[0][74] := Row; + // [0, 75] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 117, 60); + RE(118, 118, 73); + RE(119, 122, 60); + LexTab[0][75] := Row; + // [0, 76] + R(14, 0, 16, 0); + LexTab[0][76] := Row; + // [0, 77] + R(31, 0, 16, 4); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 122, 60); + LexTab[0][77] := Row; + // [0, 78] + R(-1, 0, 80, 0); + LexTab[0][78] := Row; + // [0, 79] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 100, 60); + RE(101, 101, 77); + RE(102, 122, 60); + LexTab[0][79] := Row; + // [0, 80] + R(48, 0, 16, 4); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 122, 60); + LexTab[0][80] := Row; + // [0, 81] + R(32, 0, 16, 4); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 122, 60); + LexTab[0][81] := Row; + // [0, 82] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 100, 60); + RE(101, 101, 105); + RE(102, 122, 60); + LexTab[0][82] := Row; + // [0, 83] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 101, 60); + RE(102, 102, 81); + RE(103, 122, 60); + LexTab[0][83] := Row; + // [0, 84] + R(30, 0, 16, 4); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 122, 60); + LexTab[0][84] := Row; + // [0, 85] + R(33, 0, 16, 4); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 122, 60); + LexTab[0][85] := Row; + // [0, 86] + R(46, 0, 16, 4); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 122, 60); + LexTab[0][86] := Row; + // [0, 87] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 108, 60); + RE(109, 109, 85); + RE(110, 122, 60); + LexTab[0][87] := Row; + // [0, 88] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 115, 60); + RE(116, 116, 90); + RE(117, 122, 60); + LexTab[0][88] := Row; + // [0, 89] + R(4, 0, 16, 8); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 99, 60); + RE(100, 100, 103); + RE(101, 116, 60); + RE(117, 117, 87); + RE(118, 122, 60); + LexTab[0][89] := Row; + // [0, 90] + R(47, 0, 16, 4); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 122, 60); + LexTab[0][90] := Row; + // [0, 91] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 114, 60); + RE(115, 115, 79); + RE(116, 122, 60); + LexTab[0][91] := Row; + // [0, 92] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 99, 60); + RE(100, 100, 94); + RE(101, 122, 60); + LexTab[0][92] := Row; + // [0, 93] + R(49, 0, 16, 4); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 122, 60); + LexTab[0][93] := Row; + // [0, 94] + R(44, 0, 16, 4); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 122, 60); + LexTab[0][94] := Row; + // [0, 95] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 114, 60); + RE(115, 115, 93); + RE(116, 122, 60); + LexTab[0][95] := Row; + // [0, 96] + R(29, 0, 16, 4); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 122, 60); + LexTab[0][96] := Row; + // [0, 97] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 100, 60); + RE(101, 101, 95); + RE(102, 122, 60); + LexTab[0][97] := Row; + // [0, 98] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 111, 60); + RE(112, 112, 99); + RE(113, 122, 60); + LexTab[0][98] := Row; + // [0, 99] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 107, 60); + RE(108, 108, 104); + RE(109, 122, 60); + LexTab[0][99] := Row; + // [0, 100] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 113, 60); + RE(114, 114, 80); + RE(115, 122, 60); + LexTab[0][100] := Row; + // [0, 101] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 110, 60); + RE(111, 111, 100); + RE(112, 122, 60); + LexTab[0][101] := Row; + // [0, 102] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 110, 60); + RE(111, 111, 88); + RE(112, 122, 60); + LexTab[0][102] := Row; + // [0, 103] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 104, 60); + RE(105, 105, 83); + RE(106, 122, 60); + LexTab[0][103] := Row; + // [0, 104] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 104, 60); + RE(105, 105, 97); + RE(106, 122, 60); + LexTab[0][104] := Row; + // [0, 105] + R(4, 0, 16, 6); + RE(48, 57, 60); + RE(65, 90, 60); + RE(95, 95, 60); + RE(97, 109, 60); + RE(110, 110, 84); + RE(111, 122, 60); + LexTab[0][105] := Row; + // [0, 106] + R(0, 0, 0, 1); + RE(48, 57, 21); + LexTab[0][106] := Row; + // [0, 107] + R(0, 0, 0, 1); + RE(48, 57, 13); + LexTab[0][107] := Row; + // [0, 108] + R(0, 0, 0, 1); + RE(48, 57, 15); + LexTab[0][108] := Row; + // [0, 109] + R(0, 0, 0, 1); + RE(48, 57, 108); + LexTab[0][109] := Row; + // [0, 110] + R(0, 0, 0, 1); + RE(48, 57, 107); + LexTab[0][110] := Row; + + // === LexTab[1] === + + SetLength(LexTab[1], 6); + // [1, 0] + R(50, 0, 16, 7); + RE(0, 9, 2); + RE(11, 38, 2); + RE(39, 39, 4); + RE(40, 91, 2); + RE(92, 92, 1); + RE(93, 65535, 2); + RE(-1, -1, 5); + LexTab[1][0] := Row; + // [1, 1] + R(50, 0, 16, 4); + RE(0, 9, 2); + RE(11, 91, 2); + RE(92, 92, 3); + RE(93, 65535, 2); + LexTab[1][1] := Row; + // [1, 2] + R(50, 0, 16, 5); + RE(0, 9, 2); + RE(11, 38, 2); + RE(40, 91, 2); + RE(92, 92, 1); + RE(93, 65535, 2); + LexTab[1][2] := Row; + // [1, 3] + R(50, 0, 16, 4); + RE(0, 9, 2); + RE(11, 91, 2); + RE(92, 92, 3); + RE(93, 65535, 2); + LexTab[1][3] := Row; + // [1, 4] + R(51, 0, 24, 0); + LexTab[1][4] := Row; + // [1, 5] + R(-1, 0, 80, 0); + LexTab[1][5] := Row; + + {$ENDREGION} end; -{$ENDIF} -end. +end. diff --git a/Source/ObjectSpace/Ocl/BoldSSYaccU.pas b/Source/ObjectSpace/Ocl/BoldSSYaccU.pas index 48b99815..ff75f103 100644 --- a/Source/ObjectSpace/Ocl/BoldSSYaccU.pas +++ b/Source/ObjectSpace/Ocl/BoldSSYaccU.pas @@ -1,3 +1,4 @@ + unit BoldSSYaccU; {$RANGECHECKS OFF} @@ -5,420 +6,166 @@ interface uses - Classes, - WinTypes, - WinProcs, - BoldSSLexU, - BoldBase; + Classes, BoldSSLexU, BoldBase; const - SSYaccPairTableMaxSize = 65528; - SSYaccPairTableId = $53535943; - SSYaccPairTableRowFlagsSync = $0001; SSYaccPairTableRowFlagsError = $0002; SSYaccPairTableRowFlagsSyncAll = $0004; - SSYaccPairTableRowFlagsDuplicate = $0008; SSYaccPairTableRowFlagsSyncPossible = $0005; - SSYaccPairTableEntryMask = $f8000000; SSYaccPairTableEntrySync = $80000000; SSYaccPairTableEntryShift = $40000000; SSYaccPairTableEntryReduce = $20000000; SSYaccPairTableEntryAccept = $10000000; SSYaccPairTableEntryConflict = $08000000; - SSYaccPairTableEntryMax = $07ffffff; + SSYaccPairTableEntryMax = $07FFFFFF; SSYaccEofString = 'eof'; SSYaccErrorString = 'error'; - SSYaccEofToken = $ffffffff; - SSYaccErrorToken = $fffffffe; - SSYaccMsgFileOpen = 'SSYacc0101e: Open file failed, %s'; + SSYaccEofToken = $FFFFFFFF; + SSYaccErrorToken = $FFFFFFFE; + SSYaccMsgParse = 'SSYacc0102e: Parse failed, invalid table'; SSYaccMsgEof = 'SSYacc0103e: Attempted read past eof'; SSYaccMsgMissingTable = 'SSYacc0109e: Table missing, required'; SSYaccMsgMissingLexer = 'SSYacc0110e: Lexer missing, required'; - SSYaccMsgRead = 'SSYacc0111e: Error reading table, %s'; - SSYaccMsgTableSize = 'SSYacc0112e: Table too big'; SSYaccMsgElement = 'SSYacc0108e: Invalid index on ElementFromxxx'; SSYaccMsgSyncErrToken = 'SSYacc0105e: SyncErr failed, no valid token'; SSYaccMsgSyncErrEof = 'SSYacc0106e: SyncErr failed, eof'; - SSYaccMsgFindResource = 'SSYacc0107e: Unable to locate resource, %s'; - SSYaccMsgBadResource = 'SSYacc0108e: Invalid resource, %s'; type - SSArrayOfLongint = array[ 0..(SSLexStructMax div sizeof(Longint))] of Longint; + SSArrayOfLongint = array[0..(SSLexStructMax div SizeOf(Longint))] of Longint; PSSArrayOfLongint = ^SSArrayOfLongint; -type SSSetOfLongint = class(TBoldMemoryManagedObject) public - Incr : Longint; - Size : Longint; - Count : Longint; - PArray : PSSArrayOfLongint; - - constructor Create(TheSize, TheInc: Longint); - function Insert(TheItem: Longint): Boolean; - function Contains(TheItem: Longint): Boolean; - destructor Destroy; override; -end; + Incr: Longint; + Size: Longint; + Count: Longint; + PArray: PSSArrayOfLongint; + + constructor Create(TheSize, TheInc: Longint); + function Insert(TheItem: Longint): Boolean; + function Contains(TheItem: Longint): Boolean; + destructor Destroy; override; + end; -type - SSYaccPairTable = record - TableType : Longint; - Prods : Longint; - States : Longint; - RowOffset : Longint; - ProdOffset: Longint; -end; + TYProd = record + Size: Byte; + Leftside: Word; + end; -type - SSYaccPairTableRow = record - Flags : Longint; - Gotos : Longint; - Actions : Longint; -end; + TYEntry = record + Entry: Longint; + Token: Longint; + end; -type - SSYaccPairTableEntry = record - Entry : Longint; - Token : Longint; -end; + TYRow = record + Flags: Byte; + Gotos: Byte; + Actions: Byte; + Entries: array of TYEntry; + end; -type - SSYaccPairTableProd = record - Size : Longint; - Leftside : Longint; -end; + TYRows = array of TYRow; + TYProds = array of TYProd; -type SSYaccAction = (ShiftAction, ErrorAction, ReduceAction, AcceptAction, ConflictAction); - PSSYaccPairTable = ^SSYaccPairTable; - PSSYaccPairTableRow = ^SSYaccPairTableRow; - PSSYaccPairTableProd = ^SSYaccPairTableProd; - PSSYaccPairTableEntry = ^SSYaccPairTableEntry; - SSYaccEntryArray = array[ 0..(SSLexStructMax div sizeof(SSYaccPairTableEntry))] of SSYaccPairTableEntry; - PSSYaccEntryArray = ^SSYaccEntryArray; - SSYaccProdArray = array[ 0..(SSLexStructMax div sizeof(SSYaccPairTableProd))] of SSYaccPairTableProd; - PSSYaccProdArray = ^SSYaccProdArray; - SSYaccRowArray = array[ 0..(SSLexStructMax div sizeof(PSSYaccPairTableRow))] of PSSYaccPairTableRow; - SSYaccRowOffsetArray = array[ 0..(SSLexStructMax div sizeof(Longint))] of Longint; - PSSYaccRowArray = ^SSYaccRowArray; - PSSYaccRowOffsetArray = ^SSYaccRowOffsetArray; - -type - SSYaccStackElement = class(TBoldMemoryManagedObject) - public - Lexeme: SSLexLexeme; - State : Longint; - Use : Longint; - - constructor Create; - procedure RefInc; - function RefDec: Boolean; - procedure SetLexeme(TheLexeme: SSLexLexeme); - destructor Destroy; override; -end; -type SSYaccStack = class(SSStack) public - function Top: SSYaccStackElement; - procedure Push(TheElement: SSYaccStackElement); - destructor Destroy; override; -end; + function Top: SSYaccStackElement; + procedure Push(TheElement: SSYaccStackElement); + destructor Destroy; override; + end; -type SSYaccTable = class(TBoldMemoryManagedObject) public - LarTableList: TList; - Size : Longint; - PPRowArray : PSSYaccRowArray; - PTable : PSSYaccPairTable; - PProdArray : PSSYaccProdArray; - - constructor Create(FileName: String); - constructor CreateResource(TheInstance: THandle; TheName, TheType: PChar); - function LarTables: Longint; - function Productions: Longint; - function RowSize(TheRow: PSSYaccPairTableRow): Longint; - procedure GetLarTables(TheBuffer: Pointer; TheNumber: Word; TheFile: PChar); - destructor Destroy; override; -end; + RowArray: TYRows; + ProdArray: TYProds; + constructor Create; + destructor Destroy; override; + procedure FullTab; + end; -type SSYaccLexemeCache = class(TList) public + constructor Create; + function Dequeue: SSLexLexeme; + procedure Enqueue(TheLexeme: SSLexLexeme); + function Get(TheIndex: Longint): SSLexLexeme; + destructor Destroy; override; + end; - constructor Create; - function Dequeue: SSLexLexeme; - procedure Enqueue(TheLexeme: SSLexLexeme); - function Get(TheIndex: Longint): SSLexLexeme; - destructor Destroy; override; -end; - -type SSYacc = class(TBoldMemoryManagedObject) public - Lex : SSLex; - ErrorInd : Boolean; - AbortInd : Boolean; - EndOfInput : Boolean; - Cache : Longint; - State : Longint; - ShiftedSinceError: Longint; - Leftside : Longint; - Production : Longint; - ProductionSize : Longint; - Table : SSYaccTable; - Lookahead : SSLexLexeme; - LarLookahead : SSLexLexeme; - Stack : SSYaccStack; - EndLexeme : SSLexLexeme; - Action : SSYaccAction; - LexemeCache : SSYaccLexemeCache; - Element : SSYaccStackElement; - ExprList : SSLexExpressionList; - -{ constructor Create(TheTable: SSTable);} - constructor CreateLex(TheLexer: SSLex; TheTable: SSYaccTable); -{ procedure Reset;} - procedure SetEof; - procedure SyncErr; - function Parse: Boolean; - function DoShift: Boolean; - function DoReduce: Boolean; - function DoConflict: Boolean; - function DoLarError: Boolean; -{ procedure SetLex(TheLex: SSLex);} - procedure Pop(TheNumber: Longint); - procedure DoGoto(TheGoto: Longint); - function GetLexemeCache: SSLexLexeme; - procedure LookupGoto(TheGoto: Longint); - procedure LookupAction(TheToken: Longint); - function GetLexeme(Look: Boolean): Boolean; - function DoGetLexeme(Look: Boolean): Boolean; - procedure SetLookahead(TheLexeme: SSLexLexeme); - procedure SetLarLookahead(TheLexeme: SSLexLexeme); - procedure SetElement(TheElement: SSYaccStackElement); - function GetAction(PEntry: PSSYaccPairTableEntry): SSYaccAction; -{ function ElementFromStack(TheDepth: Longint): SSYaccStackElement;} - function ElementFromProduction(TheIndex: Longint): SSYaccStackElement; -{ function ValidLookaheads(TheState: Longint; var TheCount: Longint): PSSArrayOfLongint;} - - function NextLexeme: SSLexLexeme; virtual; - function Shift: SSYaccStackElement; virtual; - function StackElement: SSYaccStackElement; virtual; - function LarLook(TheLexeme: SSLexLexeme): Boolean; virtual; - function Error(TheState: Longint; TheLookahead: SSLexLexeme): Boolean; virtual; - function LarError(TheState: Longint; TheLookahead, TheLarLookahead: SSLexLexeme): Boolean; virtual; - function Reduce(TheProduction, TheProductionSize: Longint): SSYaccStackElement; virtual; - - destructor Destroy; override; -end; + Lex: SSLex; + ErrorInd: Boolean; + AbortInd: Boolean; + EndOfInput: Boolean; + Cache: Longint; + State: Longint; + ShiftedSinceError: Longint; + Leftside: Longint; + Production: Longint; + ProductionSize: Longint; + Table: SSYaccTable; + Lookahead: SSLexLexeme; + LarLookahead: SSLexLexeme; + Stack: SSYaccStack; + EndLexeme: SSLexLexeme; + Action: SSYaccAction; + LexemeCache: SSYaccLexemeCache; + Element: SSYaccStackElement; + ExprList: SSLexExpressionList; + constructor CreateLex(TheLexer: SSLex; TheTable: SSYaccTable); + procedure SetEof; + procedure SyncErr; + function Parse: Boolean; + function DoShift: Boolean; + function DoReduce: Boolean; + function DoConflict: Boolean; + function DoLarError: Boolean; + procedure Pop(TheNumber: Longint); + procedure DoGoto(TheGoto: Longint); + function GetLexemeCache: SSLexLexeme; + procedure LookupGoto(TheGoto: Longint); + procedure LookupAction(TheToken: Longint); + function GetLexeme(Look: Boolean): Boolean; + function DoGetLexeme(Look: Boolean): Boolean; + procedure SetLookahead(TheLexeme: SSLexLexeme); + procedure SetLarLookahead(TheLexeme: SSLexLexeme); + procedure SetElement(TheElement: SSYaccStackElement); + function GetAction(YEntry: TYEntry): SSYaccAction; + function ElementFromProduction(TheIndex: Longint): SSYaccStackElement; + function NextLexeme: SSLexLexeme; virtual; + function Shift: SSYaccStackElement; virtual; + function StackElement: SSYaccStackElement; virtual; + function LarLook(TheLexeme: SSLexLexeme): Boolean; virtual; + function Error(TheState: Longint; TheLookahead: SSLexLexeme): Boolean; virtual; + function LarError(TheState: Longint; TheLookahead, TheLarLookahead: SSLexLexeme): Boolean; virtual; + function Reduce(TheProduction, TheProductionSize: Longint): SSYaccStackElement; virtual; + destructor Destroy; override; + end; implementation uses - BoldSSExcept, - SysUtils, - BoldCoreConsts, - BoldUtils; + BoldSSExcept, SysUtils, AnsiStrings; -constructor SSYaccTable.Create(FileName: String); -var - i : Word; - FileStream: TFileStream; - BaseSize : Longint; - PLarTables : Pointer; - PRowOffsetArray: PSSYaccRowOffsetArray; +constructor SSYaccTable.Create; begin - SSAux; - - if not FileExists(FileName) then - raise Exception.CreateFmt(sFileDoesNotExist, [FileName]); - - FileStream := TFileStream.Create(FileName, fmOpenRead); - - Size := FileStream.Size; - - Getmem(PTable, FileStream.Size); - FileStream.Read(PTable^, Size); - FileStream.Free; - - if PTable^.TableType <> SSYaccPairTableId then - begin - FreeMem(Ptable, Size); - PTable := nil; - raise SSException.CreateName(SSExceptionYaccRead, SSYaccMsgRead, PChar(FileName)); - end; - - BaseSize := sizeof(SSYaccPairTable) + sizeof(SSYaccPairTableProd) * - Productions + sizeof(PSSYaccPairTableRow) * PTable^.States; - if BaseSize > SSYaccPairTableMaxSize then - begin - FreeMem(PTable, Size); - PTable := nil; - raise SSException.Create(SSExceptionYaccTableSize, SSYaccMsgTableSize); - end; - - PProdArray := PSSYaccProdArray(SSHugeInc(PTable, PTable^.ProdOffset)); - PPRowArray := PSSYaccRowArray(SSHugeInc(PTable, sizeof(SSYaccPairTable))); - PRowOffsetArray := PSSYaccRowOffsetArray(PPRowArray); - PLarTables := SSHugeInc(PTable, PTable^.RowOffset); - for i := 0 to PTable^.States - 1 do - begin - PPRowArray^[ i] := PSSYaccPairTableRow(SSHugeInc(PTable, PRowOffsetArray^[ i])); - PLarTables := SSHugeInc(PPRowArray^[ i], RowSize(PPRowArray^[ i])); - end; - - if (LarTables > 0) then - GetLarTables(PLarTables, LarTables, PChar(Filename)); -end; - -constructor SSYaccTable.CreateResource(TheInstance: THandle; TheName, TheType: PChar); -var - i : Word; - FindHandle : THandle; - LoadHandle : THandle; - Resource : Pointer; - BaseSize : Longint; - PLarTables : Pointer; - NewException : SSException; - PRowOffsetArray: PSSYaccRowOffsetArray; -begin - SSAux; - LoadHandle := 0; // to prevent compiler warning - Resource := nil; - FindHandle := FindResource(TheInstance, TheName, TheType); - if (FindHandle <> 0) then - begin - LoadHandle := LoadResource(TheInstance, FindHandle); - if (LoadHandle <> 0) then - Resource := LockResource(LoadHandle); - end; - if (Resource = nil) then - begin - NewException := SSException.CreateName(SSExceptionYaccFindResource, SSYaccMsgFindResource, TheType); - raise NewException; - end; - - Size := SizeOfResource(TheInstance, FindHandle); - GetMem(PTable, Size); - SSHugeCopy(PTable, Resource, Size); - FreeResource(LoadHandle); - - if PTable^.TableType <> SSYaccPairTableId then - begin - FreeMem(PTable, Size); - PTable := nil; - NewException := SSException.CreateName(SSExceptionYaccBadResource, SSYaccMsgBadResource, TheType); - raise NewException; - end; - - BaseSize := sizeof(SSYaccPairTable) + sizeof(SSYaccPairTableProd) * - Productions + sizeof(PSSYaccPairTableRow) * PTable^.States; - if BaseSize > SSYaccPairTableMaxSize then - begin - FreeMem(PTable, Size); - PTable := nil; - NewException := SSException.Create(SSExceptionYaccTableSize, SSYaccMsgTableSize); - raise NewException; - end; - - PProdArray := PSSYaccProdArray(SSHugeInc(PTable, PTable^.ProdOffset)); - PPRowArray := PSSYaccRowArray(SSHugeInc(PTable, sizeof(SSYaccPairTable))); - PRowOffsetArray := PSSYaccRowOffsetArray(PPRowArray); - PLarTables := SSHugeInc(PTable, PTable^.RowOffset); - for i := 0 to PTable^.States - 1 do - begin - PPRowArray^[ i] := PSSYaccPairTableRow(SSHugeInc(PTable, PRowOffsetArray^[ i])); - PLarTables := SSHugeInc(PPRowArray^[ i], RowSize(PPRowArray^[ i])); - end; - - if (LarTables > 0) then - GetLarTables(PLarTables, LarTables, TheType); -end; - -function SSYaccTable.RowSize(TheRow: PSSYaccPairTableRow): Longint; -var - Entries: Longint; -begin - Entries := TheRow^.Gotos + TheRow^.Actions; - if (TheRow^.Flags and SSYaccPairTableRowFlagsError) <> 0 then - Inc(Entries); - Result := SizeOf(SSYaccPairTableEntry) * Entries + SizeOf(SSYaccPairTableRow); -end; - -procedure SSYaccTable.GetLarTables(TheBuffer: Pointer; TheNumber: Word; TheFile: PChar); -var - i : Word; - Header : SSLexTableHeader; - ExprList: SSLexExpressionList; -begin - LarTableList := TList.Create; - for i := 0 to TheNumber - 1 do - begin - SSHugeCopy(@Header, TheBuffer, sizeof(Header)); - ExprList := SSLexExpressionList.CreateBuffer(TheBuffer, TheFile); - LarTableList.Insert(i, ExprList); - TheBuffer := SSHugeInc(TheBuffer, Header.Size); - end -end; - -function SSYaccTable.Productions: Longint; -begin - Result := PTable^.Prods and $0000ffff; -end; - -function SSYaccTable.LarTables: Longint; -begin - Result := PTable^.Prods shr 16; + FullTab; end; destructor SSYaccTable.Destroy; begin - if PTable <> nil then - FreeMem(Ptable, Size); - inherited; -end; - -constructor SSYaccStackElement.Create; -begin - inherited Create; - Lexeme := nil; - State := 0; - Use := 0; -end; - -procedure SSYaccStackElement.SetLexeme(TheLexeme: SSLexLexeme); -begin - if TheLexeme <> nil then - TheLexeme.RefInc; - if (Lexeme <> nil) and (Lexeme.RefDec) then - Lexeme.Free; - Lexeme := TheLexeme; -end; - -procedure SSYaccStackElement.RefInc; -begin - Inc(Use); -end; - -function SSYaccStackElement.RefDec: Boolean; -begin - Dec(Use); - Result := (Use = 0); -end; - -destructor SSYaccStackElement.Destroy; -begin - if (Lexeme <> nil) and (Lexeme.RefDec) then - Lexeme.Free; + RowArray := nil; + ProdArray := nil; inherited; end; function SSYaccStack.Top: SSYaccStackElement; begin - Result := inherited Top; + Result := inherited Top as SSYaccStackElement; end; procedure SSYaccStack.Push(TheElement: SSYaccStackElement); @@ -429,43 +176,20 @@ procedure SSYaccStack.Push(TheElement: SSYaccStackElement); destructor SSYaccStack.Destroy; var - i : Integer; + i: Integer; Element: SSYaccStackElement; begin for i := 0 to TopOfStack - 1 do - begin - Element := PArray^[ i]; + begin +{$WARN UNSAFE_CODE OFF} + Element := PArray^[i]; +{$WARN UNSAFE_CODE ON} if Element.RefDec then Element.Free; - end; - inherited Destroy; + end; + inherited; end; -{constructor SSYacc.Create(TheTable: SSYaccTable); -var - AnException: SSException; -begin - inherited Create; - EndLexeme := nil; - Stack := nil; - Lex := nil; - EndOfInput := False; - ErrorInd := False; - ShiftedSinceError := 0; - AbortInd := False; - if TheTable = nil then - begin - AnException := SSException.Create(SSExceptionYaccMissingTable, SSYaccMsgMissingTable); - raise AnException; - end; - Table := TheTable; - Stack := SSYaccStack.Create; - Element := StackElement; - Element.RefInc; - Stack.Push(Element); - LexemeCache := SSYaccLexemeCache.Create; -end; -} constructor SSYacc.CreateLex(TheLexer: SSLex; TheTable: SSYaccTable); var AnException: SSException; @@ -479,10 +203,10 @@ constructor SSYacc.CreateLex(TheLexer: SSLex; TheTable: SSYaccTable); ShiftedSinceError := 0; AbortInd := False; if TheTable = nil then - begin + begin AnException := SSException.Create(SSExceptionYaccMissingTable, SSYaccMsgMissingTable); raise AnException; - end; + end; Lex := TheLexer; Table := TheTable; Stack := SSYaccStack.Create; @@ -494,88 +218,81 @@ constructor SSYacc.CreateLex(TheLexer: SSLex; TheTable: SSYaccTable); procedure SSYacc.SetEof; var - EofString: PChar; + EofString: PAnsiChar; begin EndOfInput := True; - EofString := StrNew(SSYaccEofString); - EndLexeme := SSLexLexeme.Create(EofString, StrLen(EofString), 0, 0); + EofString := AnsiStrings.StrNew(PAnsiChar(SSYaccEofString)); + EndLexeme := SSLexLexeme.Create(EofString, AnsiStrings.StrLen(EofString), 0, 0); EndLexeme.Token := SSYaccEofToken; EndLexeme.RefInc; - StrDispose(EofString); + AnsiStrings.StrDispose(EofString); end; -{procedure SSYacc.SetLex(TheLex: SSLex); -begin - Lex := TheLex; -end; - } -procedure SSYacc.LookupAction(TheToken: Longint); +procedure SSYacc.LookupAction(TheToken: Integer); var - i : Integer; - PEntryArray: PSSYaccEntryArray; - PCurrentRow: PSSYaccPairTableRow; - PProd : PSSYaccPairTableProd; - PEntry : PSSYaccPairTableEntry; + i: Integer; + CurrentRow: TYRow; + YEntry: TYEntry; + Prod: TYProd; + EntryIndex: Integer; begin - PEntry := nil; - PCurrentRow := Table.PPRowArray^[ State]; - PEntryArray := PSSYaccEntryArray(PChar(PCurrentRow) + sizeof(SSYaccPairTableRow)); - for i := 0 to PCurrentRow^.Actions - 1 do - if PEntryArray^[ i].Token = TheToken then - begin - PEntry := @PEntryArray^[ i]; + EntryIndex := -1; + CurrentRow := Table.RowArray[State]; + for i := 0 to CurrentRow.Actions - 1 do + if CurrentRow.Entries[i].Token = TheToken then + begin + EntryIndex := i; + YEntry := CurrentRow.Entries[i]; Break; - end; + end; - if PEntry = nil then + if EntryIndex = -1 then Action := ErrorAction else - begin - Action := GetAction(PEntry); + begin + Action := GetAction(YEntry); case Action of ShiftAction: - State := PEntry^.Entry and SSYaccPairTableEntryMax; + State := YEntry.Entry and SSYaccPairTableEntryMax; ReduceAction: begin - Production := PEntry^.Entry and SSYaccPairTableEntryMax; - PProd := @Table.PProdArray^[ Production]; - Leftside := PProd^.Leftside; - ProductionSize := PProd^.Size; + Production := YEntry.Entry and SSYaccPairTableEntryMax; + Prod := Table.ProdArray[Production]; + Leftside := Prod.Leftside; + ProductionSize := Prod.Size; end; ConflictAction: begin - ExprList := Table.LarTableList.Items[ PEntry^.Entry and SSYaccPairTableEntryMax]; - end; + end; end; - end; + end; end; -function SSYacc.GetAction(PEntry: PSSYaccPairTableEntry): SSYaccAction; +function SSYacc.GetAction(YEntry: TYEntry): SSYaccAction; begin - if (PEntry^.Entry and SSYaccPairTableEntryShift) <> 0 then + if YEntry.Entry and SSYaccPairTableEntryShift <> 0 then Result := ShiftAction - else if (PEntry^.Entry and SSYaccPairTableEntryReduce) <> 0 then + else if YEntry.Entry and SSYaccPairTableEntryReduce <> 0 then Result := ReduceAction - else if (PEntry^.Entry and SSYaccPairTableEntryAccept) <> 0 then + else if YEntry.Entry and SSYaccPairTableEntryAccept <> 0 then Result := AcceptAction - else if (PEntry^.Entry and SSYaccPairTableEntryConflict) <> 0 then + else if YEntry.Entry and SSYaccPairTableEntryConflict <> 0 then Result := ConflictAction else Result := ErrorAction; end; -function SSYacc.LarError(TheState: Longint; TheLookahead, TheLarLookahead: SSLexLexeme): Boolean; +function SSYacc.LarError(TheState: Integer; TheLookahead, TheLarLookahead: SSLexLexeme): Boolean; begin Result := Error(TheState, TheLookahead); end; -function SSYacc.Reduce(TheProduction, TheProductionSize: Longint): SSYaccStackElement; +function SSYacc.Reduce(TheProduction, TheProductionSize: Integer): SSYaccStackElement; begin - result := nil; + Result := nil; end; - function SSYacc.LarLook(TheLexeme: SSLexLexeme): Boolean; begin Result := False; @@ -585,40 +302,39 @@ function SSYacc.DoLarError: Boolean; begin ErrorInd := True; Result := LarError(State, Lookahead, LarLookahead); - if (Result = False) then + if not Result then ShiftedSinceError := 0; end; -procedure SSYacc.LookupGoto(TheGoto: Longint); +procedure SSYacc.LookupGoto(TheGoto: Integer); var - i : Integer; - EndIndex : Longint; + i, EndIndex: Integer; AnException: SSException; - PEntryArray: PSSYaccEntryArray; - PCurrentRow: PSSYaccPairTableRow; - PEntry : PSSYaccPairTableEntry; + CurrentRow: TYRow; + YEntry: TYEntry; + EntryIndex: Integer; begin - PEntry := nil; - PCurrentRow := Table.PPRowArray^[ State]; - EndIndex := PCurrentRow^.Actions + PCurrentRow^.Gotos - 1; - PEntryArray := PSSYaccEntryArray(PChar(PCurrentRow) + sizeof(SSYaccPairTableRow)); - for i := PCurrentRow^.Actions to EndIndex do - if PEntryArray^[ i].Token = TheGoto then - begin - PEntry := @PEntryArray^[ i]; + EntryIndex := -1; + CurrentRow := Table.RowArray[State]; + EndIndex := CurrentRow.Actions + CurrentRow.Gotos - 1; + for i := CurrentRow.Actions to EndIndex do + if CurrentRow.Entries[i].Token = TheGoto then + begin + EntryIndex := i; + YEntry := CurrentRow.Entries[i]; Break; - end; + end; - if PEntry = nil then - begin + if EntryIndex = -1 then + begin AnException := SSException.Create(SSExceptionYaccParse, SSYaccMsgParse); raise AnException; - end; + end; - State := PEntry^.Entry and SSYaccPairTableEntryMax; + State := YEntry.Entry and SSYaccPairTableEntryMax; end; -procedure SSYacc.DoGoto(TheGoto: Longint); +procedure SSYacc.DoGoto(TheGoto: Integer); begin LookupGoto(Leftside); Element.State := State; @@ -631,10 +347,10 @@ function SSYacc.NextLexeme: SSLexLexeme; AnException: SSException; begin if Lex = nil then - begin + begin AnException := SSException.Create(SSExceptionYaccMissingLexer, SSYaccMsgMissingLexer); raise AnException; - end; + end; Result := Lex.Next; end; @@ -646,58 +362,61 @@ function SSYacc.StackElement: SSYaccStackElement; function SSYacc.Parse: Boolean; var AnException: SSException; -// AnElement : SSYaccStackElement; begin Result := DoGetLexeme(True); - if Result = True then Exit; + if Result = True then + Exit; while True do - begin + begin if AbortInd = True then Break; case Action of ShiftAction: begin - Result := DoShift; - if (Result = True) then Break; + Result := DoShift; + if Result = True then + Break; end; ReduceAction: begin - Result := DoReduce; - if (Result = True) then Break; + Result := DoReduce; + if Result = True then + Break; end; ErrorAction: begin - ErrorInd := True; - if Error(State, Lookahead) then + ErrorInd := True; + if Error(State, Lookahead) then begin - Result := True; - Break; + Result := True; + Break; end; - ShiftedSinceError := 0; + ShiftedSinceError := 0; end; ConflictAction: begin - Result := DoConflict; - if (Result = True) then Break; + Result := DoConflict; + if Result = True then + Break; end; AcceptAction: begin - Result := ErrorInd; - Break; + Result := ErrorInd; + Break; end; - else - begin + else + begin AnException := SSException.Create(SSExceptionYaccParse, SSYaccMsgParse); raise AnException; - end; end; end; + end; end; function SSYacc.DoShift: Boolean; @@ -706,14 +425,14 @@ function SSYacc.DoShift: Boolean; if Element = nil then Result := True else - begin + begin Element.SetLexeme(Lookahead); Element.State := State; Stack.Push(Element); Result := DoGetLexeme(True); - if Result = False then + if not Result then Inc(ShiftedSinceError); - end; + end; end; function SSYacc.DoReduce: Boolean; @@ -726,79 +445,80 @@ function SSYacc.DoReduce: Boolean; if Element = nil then Result := True else - begin + begin Pop(ProductionSize); DoGoto(Leftside); - end; + end; end; function SSYacc.GetLexemeCache: SSLexLexeme; begin Result := nil; - if (Cache <> MaxLongInt) then - begin + if Cache <> MaxLongint then + begin Result := LexemeCache.Get(Cache); Inc(Cache); - end; - if (Result = nil) then - begin - Cache := MaxLongInt; + end; + if Result = nil then + begin + Cache := MaxLongint; Result := NextLexeme; - if (Result = nil) then - begin + if Result = nil then + begin SetEof; Result := EndLexeme; - end; end; + end; LexemeCache.Enqueue(Result); end; function SSYacc.DoConflict: Boolean; var - LarState : Longint; - PFinal : PSSLexFinalState; - PProd : PSSYaccPairTableProd; + LarState: Longint; + PFinal: TRow; + Prod: TYProd; begin Cache := 0; LarState := ExprList.LookupState(Lookahead.Token, 0); SetLarLookahead(GetLexemeCache); - while (LarLookahead <> nil) do - begin + while LarLookahead <> nil do + begin LarState := ExprList.LookupState(LarLookahead.Token, LarState); - if (State = SSLexStateInvalid) then Break; - PFinal := ExprList.LookupFinal(LarState); - if (PFinal^.Flags and SSLexFinalStateFlagsFinal) <> 0 then + if State = SSLexStateInvalid then + Break; + PFinal := ExprList.ARows[LarState]; + if PFinal.Flags and SSLexFinalStateFlagsFinal <> 0 then + begin + if PFinal.Flags and SSLexFinalStateFlagsReduce <> 0 then begin - if (PFinal^.Flags and SSLexFinalStateFlagsReduce) <> 0 then - begin - Production := PFinal^.Token; - PProd := @Table.PProdArray^[ Production]; - Leftside := PProd^.Leftside; - ProductionSize := PProd^.Size; + Production := PFinal.Token; + Prod := Table.ProdArray[Production]; + Leftside := Prod.Leftside; + ProductionSize := Prod.Size; Result := DoReduce; Exit; - end + end else - begin - State := PFinal^.Token; + begin + State := PFinal.Token; Result := DoShift; Exit; - end; end; - SetLarLookahead(GetLexemeCache); end; + SetLarLookahead(GetLexemeCache); + end; Result := DoLarError; end; function SSYacc.DoGetLexeme(Look: Boolean): Boolean; begin SetLookahead(LexemeCache.Dequeue); - if (Lookahead <> nil) then - begin + if Lookahead <> nil then + begin Result := LarLook(Lookahead); - if ((Result = False) and (Look = True)) then + if (Result = False) and (Look = True) then LookupAction(Lookahead.Token); - end + end else Result := GetLexeme(Look); end; @@ -808,19 +528,19 @@ function SSYacc.GetLexeme(Look: Boolean): Boolean; AnException: SSException; begin if EndOfInput = True then - begin + begin AnException := SSException.Create(SSExceptionYaccEof, SSYaccMsgEof); raise AnException; - end; + end; SetLookahead(NextLexeme); if Lookahead = nil then - begin + begin SetEof; SetLookahead(EndLexeme); - end; + end; - if (Look) then + if Look then LookupAction(Lookahead.Token); Result := False; end; @@ -857,23 +577,23 @@ function SSYacc.Shift: SSYaccStackElement; Result := StackElement; end; -procedure SSYacc.Pop(TheNumber: Longint); +procedure SSYacc.Pop(TheNumber: Integer); var - i : Integer; + i: Integer; TopElement: SSYaccStackElement; begin for i := 0 to TheNumber - 1 do - begin + begin TopElement := Stack.Top; Stack.Pop; if (TopElement <> nil) and TopElement.RefDec then TopElement.Free; - end; + end; TopElement := Stack.Top; State := TopElement.State; end; -function SSYacc.Error(TheState: Longint; TheLookahead: SSLexLexeme): Boolean; +function SSYacc.Error(TheState: Integer; TheLookahead: SSLexLexeme): Boolean; begin SyncErr; Result := False; @@ -881,236 +601,191 @@ function SSYacc.Error(TheState: Longint; TheLookahead: SSLexLexeme): Boolean; procedure SSYacc.SyncErr; var - ErrorString: PChar; - i, j : Integer; + ErrorString: PAnsiChar; + i, j: Integer; AnException: SSException; ErrorLexeme: SSLexLexeme; - SetOfToken : SSSetOfLongint; - PEntryArray: PSSYaccEntryArray; - AnElement : SSYaccStackElement; - PRow : PSSYaccPairTableRow; - PErrorRow : PSSYaccPairTableRow; - PEntry : PSSYaccPairTableEntry; - TempCardinal1, TempCardinal2, TempCardinal3, TempCardinal4: Cardinal; // used to avoid warning from DelphiParser + SetOfToken: SSSetOfLongint; + AnElement: SSYaccStackElement; + Row, ErrorRow: TYRow; + YEntry: TYEntry; + TempCardinal1, TempCardinal2, TempCardinal3, TempCardinal4: Cardinal; begin SetOfToken := SSSetOfLongint.Create(16, 16); for i := 0 to Stack.TopOfStack - 1 do - begin - AnElement := Stack.PArray^[ i]; - PRow := Table.PPRowArray^[ AnElement.State]; - PEntryArray := PSSYaccEntryArray(PChar(PRow) + sizeof(SSYaccPairTableRow)); - if (PRow^.Flags and SSYaccPairTableRowFlagsSyncPossible) <> 0 then - for j := 0 to PRow^.Actions - 1 do - begin - PEntry := @PEntryArray^[ j]; - TempCardinal1 := PRow^.Flags; + begin + AnElement := Stack.PArray[i]; + Row := Table.RowArray[AnElement.State]; + if Row.Flags and SSYaccPairTableRowFlagsSyncPossible <> 0 then + for j := 0 to Row.Actions - 1 do + begin + YEntry := Row.Entries[j]; + TempCardinal1 := Row.Flags; TempCardinal2 := SSYaccPairTableRowFlagsSyncAll; - tempCardinal3 := PEntry^.Entry; - tempCardinal4 := SSYaccPairTableEntrySync; + TempCardinal3 := YEntry.Entry; + TempCardinal4 := SSYaccPairTableEntrySync; - if ((TempCardinal1 and TempCardinal2) or - (TempCardinal3 and TempCardinal4)) <> 0 then - SetOfToken.Insert(PEntry^.Token); - end; - if (PRow^.Flags and SSYaccPairTableRowFlagsError) <> 0 then - begin - PEntry := @PEntryArray^[ PRow^.Actions + PRow^.Gotos]; - PErrorRow := Table.PPRowArray^[ PEntry^.Entry and SSYaccPairTableEntryMax]; - PEntryArray := PSSYaccEntryArray(PChar(PErrorRow) + sizeof(SSYaccPairTableRow)); - for j := 0 to PRow^.Actions - 1 do - SetOfToken.Insert(PEntryArray^[ j].Token); - end + if (TempCardinal1 and TempCardinal2) or (TempCardinal3 and TempCardinal4) <> 0 then + SetOfToken.Insert(YEntry.Token); + end; + if Row.Flags and SSYaccPairTableRowFlagsError <> 0 then + begin + YEntry := Row.Entries[Row.Actions + Row.Gotos]; + ErrorRow := Table.RowArray[YEntry.Entry and SSYaccPairTableEntryMax]; + for j := 0 to Row.Actions - 1 do + SetOfToken.Insert(ErrorRow.Entries[j].Token); end; + end; if SetOfToken.Count = 0 then - begin + begin SetOfToken.Free; AnException := SSException.Create(SSExceptionYaccSyncErrToken, SSYaccMsgSyncErrToken); raise AnException; - end; + end; while True do - begin + begin if SetOfToken.Contains(Lookahead.Token) then Break; -// SetLookahead(NextLexeme); -// if Lookahead = nil then - if (DoGetLexeme(False)) then - begin + + if DoGetLexeme(False) then + begin SetOfToken.Free; AnException := SSException.Create(SSExceptionYaccSyncErrEof, SSYaccMsgSyncErrEof); raise AnException; - end; end; + end; SetOfToken.Free; while True do + begin + Row := Table.RowArray[State]; + if Row.Flags and SSYaccPairTableRowFlagsError <> 0 then begin - PRow := Table.PPRowArray^[ State]; - if (PRow^.Flags and SSYaccPairTableRowFlagsError) <> 0 then - begin - PEntryArray := PSSYaccEntryArray(PChar(PRow) + sizeof(SSYaccPairTableRow)); - PEntry := @PEntryArray^[ PRow^.Actions + PRow^.Gotos]; - State := PEntry^.Entry and SSYaccPairTableEntryMax; + YEntry := Row.Entries[Row.Actions + Row.Gotos]; + State := YEntry.Entry and SSYaccPairTableEntryMax; LookupAction(Lookahead.Token); if Action <> ErrorAction then - begin - ErrorString := StrNew(SSYaccErrorString); - ErrorLexeme := SSLexLexeme.Create(ErrorString, StrLen(ErrorString), 0, 0); + begin + ErrorString := AnsiStrings.StrNew(PAnsiChar(SSYaccErrorString)); + ErrorLexeme := SSLexLexeme.Create(ErrorString, AnsiStrings.StrLen(ErrorString), 0, 0); ErrorLexeme.Token := SSYaccErrorToken; - StrDispose(ErrorString); + AnsiStrings.StrDispose(ErrorString); SetElement(StackElement); Element.Lexeme := ErrorLexeme; Element.State := State; Stack.Push(Element); Break; - end end; - if (PRow^.Flags and SSYaccPairTableRowFlagsSyncPossible) <> 0 then - begin + end; + if Row.Flags and SSYaccPairTableRowFlagsSyncPossible <> 0 then + begin LookupAction(Lookahead.Token); if Action <> ErrorAction then Break; - end; + end; Pop(1); - end + end; end; -{function SSYacc.ElementFromStack(TheDepth: Longint): SSYaccStackElement; -var - AnException: SSException; -begin - if TheDepth > Stack.TopOfStack then - begin - AnException := SSException.Create(SSExceptionYaccElement, SSYaccMsgElement); - raise AnException; - end; - - Result := Stack.PArray^[ TheDepth]; -end; -} function SSYacc.ElementFromProduction(TheIndex: Longint): SSYaccStackElement; var AnException: SSException; begin TheIndex := Stack.TopOfStack - ProductionSize + TheIndex; if (TheIndex < 0) or (TheIndex >= Stack.TopOfStack) then - begin + begin AnException := SSException.Create(SSExceptionYaccElement, SSYaccMsgElement); raise AnException; - end; + end; - Result := Stack.PArray^[ TheIndex]; + Result := Stack.PArray[TheIndex]; end; -{procedure SSYacc.Reset; -begin - State := 0; - ShiftedSinceError := 0; - if (EndLexeme <> nil) and EndLexeme.RefDec then - EndLexeme.Free; - ErrorInd := False; - AbortInd := False; - EndOfInput := False; - Stack.Free; - Stack := SSYaccStack.Create; - SetElement(StackElement); - Stack.Push(Element); -end; - } destructor SSYacc.Destroy; begin - if (LarLookahead <> nil) and (LarLookahead.RefDec) then + if (LarLookahead <> nil) and LarLookahead.RefDec then LarLookahead.Free; - if (EndLexeme <> nil) and (EndLexeme.RefDec) then + if (EndLexeme <> nil) and EndLexeme.RefDec then EndLexeme.Free; Stack.Free; - if (Lookahead <> nil) and (Lookahead.RefDec) then - Lookahead.Free; - if (Element <> nil) and (Element.RefDec) then - Element.Free; + if (Lookahead <> nil) and Lookahead.RefDec then + Lookahead.Free; + if (Element <> nil) and Element.RefDec then + Element.Free; LexemeCache.Free; inherited; end; -constructor SSSetOfLongint.Create(TheSize, TheInc: Longint); +constructor SSSetOfLongint.Create(TheSize, TheInc: Integer); begin inherited Create; Size := TheSize; Incr := TheInc; Count := 0; - GetMem(PArray, Size * sizeof(Longint)); +{$WARN UNSAFE_CODE OFF} + GetMem(PArray, Size * SizeOf(Longint)); +{$WARN UNSAFE_CODE ON} end; -function SSSetOfLongint.Insert(TheItem: Longint): Boolean; +function SSSetOfLongint.Insert(TheItem: Integer): Boolean; var - i : Integer; - NewSize : Longint; + i: Integer; + NewSize: Longint; PNewArray: PSSArrayOfLongint; begin Result := True; for i := 0 to Count - 1 do - if PArray^[ i] = TheItem then - begin + if PArray[i] = TheItem then + begin Result := False; Break; - end; + end; if Result = True then - begin + begin if Count >= Size then - begin + begin NewSize := Size + Incr; - GetMem(PNewArray, NewSize * sizeof(Longint)); +{$WARN UNSAFE_CODE OFF} + GetMem(PNewArray, NewSize * SizeOf(Longint)); +{$WARN UNSAFE_CODE ON} for i := 0 to Count - 1 do - PNewArray^[ i] := PArray^[ i]; - FreeMem(PArray, Size * sizeof(Longint)); + PNewArray[i] := PArray[i]; +{$WARN UNSAFE_CODE OFF} + FreeMem(PArray, Size * SizeOf(Longint)); +{$WARN UNSAFE_CODE ON} Size := NewSize; PArray := PNewArray; - end; - PArray^[ Count] := TheItem; + end; + PArray[Count] := TheItem; Inc(Count); - end + end; end; -function SSSetOfLongint.Contains(TheItem: Longint): Boolean; +function SSSetOfLongint.Contains(TheItem: Integer): Boolean; var - i : Integer; + i: Integer; begin Result := False; for i := 0 to Count - 1 do - if PArray^[ i] = TheItem then - begin + if PArray[i] = TheItem then + begin Result := True; Break; - end; + end; end; destructor SSSetOfLongint.Destroy; begin - FreeMem(PArray, Size * sizeof(Longint)); +{$WARN UNSAFE_CODE OFF} + FreeMem(PArray, Size * SizeOf(Longint)); +{$WARN UNSAFE_CODE ON} inherited Destroy; end; -{function SSYacc.ValidLookaheads(TheState: Longint; var TheCount: Longint): PSSArrayOfLongint; -var - i : Integer; - PEntryArray: PSSYaccEntryArray; - PRow : PSSYaccPairTableRow; - PEntry : PSSYaccPairTableEntry; -begin - PRow := Table.PPRowArray^[ TheState]; - GetMem(Result, PRow^.Actions * sizeof(Longint)); - PEntryArray := PSSYaccEntryArray(PChar(PRow) + sizeof(SSYaccPairTableRow)); - TheCount := PRow^.Actions; - for i := 0 to TheCount - 1 do - begin - PEntry := @PEntryArray^[ i]; - Result^[ i] := PEntry^.Token; - end; -end; - } constructor SSYaccLexemeCache.Create; begin inherited Create; @@ -1118,34 +793,3086 @@ constructor SSYaccLexemeCache.Create; function SSYaccLexemeCache.Dequeue: SSLexLexeme; begin - if (Count = 0) then + if Count = 0 then Result := nil else - begin - // Result := List^[ 0]; // marco + begin +{$WARN UNSAFE_CAST OFF} + Result := SSLexLexeme(List[0]); +{$WARN UNSAFE_CAST ON} Result.RefDec; Delete(0); Pack; - end; + end; end; procedure SSYaccLexemeCache.Enqueue(TheLexeme: SSLexLexeme); begin - Add(TheLexeme); +{$WARN UNSAFE_CAST OFF} + Add(Pointer(TheLexeme)); +{$WARN UNSAFE_CAST ON} TheLexeme.RefInc; end; -function SSYaccLexemeCache.Get(TheIndex: Longint): SSLexLexeme; +function SSYaccLexemeCache.Get(TheIndex: Integer): SSLexLexeme; begin - if ((Count = 0) or (TheIndex = MaxLongInt)) then + if (Count = 0) or (TheIndex = MaxLongint) then Result := nil else - Result := Items[ TheIndex]; +{$WARN UNSAFE_CAST OFF} + Result := SSLexLexeme(Items[TheIndex]); +{$WARN UNSAFE_CAST ON} end; -destructor SSYaccLexemeCache.Destroy; +destructor SSYaccLexemeCache.Destroy; begin inherited Destroy; end; + +procedure SSYaccTable.FullTab; +var + YaccProds: TYProds; + YaccRows: TYRows; + Row: TYRow; + N: Integer; + + procedure YP(S, L: Word); + begin + with YaccProds[N] do + begin + Size := S; + Leftside := L; + end; + Inc(N); + end; + + procedure R(F, G, A: Byte); + begin + with Row do + begin + Flags := F; + Gotos := G; + Actions := A; + SetLength(Entries, G + A); + N := 0; + end; + end; + + procedure RE(E, T: Longint); + begin + with Row.Entries[N] do + begin + Entry := E; + Token := T; + end; + Inc(N); + end; + +begin + + {$REGION 'Full YaccTable'} + + // === YaccProds === + + SetLength(YaccProds, 73); + N := 0; + YP(2, 0); + YP(1, 16386); + YP(1, 16385); + YP(3, 16385); + YP(3, 16385); + YP(3, 16385); + YP(3, 16385); + YP(3, 16385); + YP(3, 16385); + YP(3, 16385); + YP(3, 16385); + YP(3, 16385); + YP(3, 16385); + YP(3, 16385); + YP(3, 16385); + YP(3, 16385); + YP(3, 16385); + YP(3, 16385); + YP(3, 16385); + YP(2, 16385); + YP(2, 16385); + YP(7, 16388); + YP(1, 16387); + YP(5, 16387); + YP(6, 16387); + YP(5, 16387); + YP(6, 16387); + YP(1, 16389); + YP(1, 16389); + YP(3, 16389); + YP(1, 16389); + YP(3, 16389); + YP(4, 16389); + YP(3, 16393); + YP(5, 16393); + YP(7, 16393); + YP(3, 16395); + YP(2, 16395); + YP(1, 16395); + YP(1, 16395); + YP(1, 16395); + YP(1, 16395); + YP(2, 16395); + YP(0, 16397); + YP(1, 16397); + YP(1, 16397); + YP(4, 16394); + YP(1, 16402); + YP(1, 16403); + YP(3, 16403); + YP(3, 16402); + YP(4, 16400); + YP(2, 16404); + YP(4, 16404); + YP(0, 16392); + YP(3, 16392); + YP(1, 16399); + YP(1, 16405); + YP(3, 16405); + YP(1, 16390); + YP(3, 16390); + YP(1, 16398); + YP(1, 16398); + YP(2, 16391); + YP(0, 16391); + YP(0, 16396); + YP(1, 16396); + YP(1, 16406); + YP(3, 16406); + YP(1, 16401); + YP(1, 16401); + YP(1, 16401); + YP(1, 16401); + + // === YaccRows === + + SetLength(YaccRows, 134); + // [0] + R(0, 10, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(25, 16385); + RE(26, 16386); + YaccRows[0] := Row; + // [1] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(133, 16385); + YaccRows[1] := Row; + // [2] + R(0, 0, 1); + RE(536870984, 13); + YaccRows[2] := Row; + // [3] + R(0, 0, 1); + RE(536870983, 13); + YaccRows[3] := Row; + // [4] + R(0, 0, 1); + RE(536870981, 13); + YaccRows[4] := Row; + // [5] + R(0, 0, 1); + RE(536870982, 13); + YaccRows[5] := Row; + // [6] + R(0, 1, 2); + RE(1073741837, 5); + RE(1073741838, 4); + RE(132, 16398); + YaccRows[6] := Row; + // [7] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(126, 16385); + YaccRows[7] := Row; + // [8] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(125, 16385); + YaccRows[8] := Row; + // [9] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(123, 16385); + YaccRows[9] := Row; + // [10] + R(0, 0, 2); + RE(1073741944, 51); + RE(1073741945, 50); + YaccRows[10] := Row; + // [11] + R(0, 0, 27); + RE(536870953, 10); + RE(536870953, 12); + RE(536870953, 14); + RE(536870953, 15); + RE(536870953, 16); + RE(536870953, 17); + RE(536870953, 18); + RE(536870953, 19); + RE(536870953, 20); + RE(536870953, 21); + RE(536870953, 22); + RE(536870953, 23); + RE(536870953, 24); + RE(536870953, 25); + RE(536870953, 26); + RE(536870953, 27); + RE(536870953, 30); + RE(536870953, 31); + RE(536870953, 32); + RE(536870953, 37); + RE(536870953, 43); + RE(536870953, 44); + RE(536870953, 45); + RE(536870953, 46); + RE(536870953, 48); + RE(536870953, 49); + RE(536870953, -1); + YaccRows[11] := Row; + // [12] + R(0, 0, 27); + RE(536870952, 10); + RE(536870952, 12); + RE(536870952, 14); + RE(536870952, 15); + RE(536870952, 16); + RE(536870952, 17); + RE(536870952, 18); + RE(536870952, 19); + RE(536870952, 20); + RE(536870952, 21); + RE(536870952, 22); + RE(536870952, 23); + RE(536870952, 24); + RE(536870952, 25); + RE(536870952, 26); + RE(536870952, 27); + RE(536870952, 30); + RE(536870952, 31); + RE(536870952, 32); + RE(536870952, 37); + RE(536870952, 43); + RE(536870952, 44); + RE(536870952, 45); + RE(536870952, 46); + RE(536870952, 48); + RE(536870952, 49); + RE(536870952, -1); + YaccRows[12] := Row; + // [13] + R(0, 0, 31); + RE(536870973, 9); + RE(536870973, 10); + RE(536870973, 11); + RE(536870973, 12); + RE(536870973, 14); + RE(536870973, 15); + RE(536870973, 16); + RE(536870973, 17); + RE(536870973, 18); + RE(536870973, 19); + RE(536870973, 20); + RE(536870973, 21); + RE(536870973, 22); + RE(536870973, 23); + RE(536870973, 24); + RE(536870973, 25); + RE(536870973, 26); + RE(536870973, 27); + RE(536870973, 28); + RE(536870973, 30); + RE(536870973, 31); + RE(536870973, 32); + RE(536870973, 36); + RE(536870973, 37); + RE(536870973, 43); + RE(536870973, 44); + RE(536870973, 45); + RE(536870973, 46); + RE(536870973, 48); + RE(536870973, 49); + RE(536870973, -1); + YaccRows[13] := Row; + // [14] + R(0, 0, 31); + RE(536870974, 9); + RE(536870974, 10); + RE(536870974, 11); + RE(536870974, 12); + RE(536870974, 14); + RE(536870974, 15); + RE(536870974, 16); + RE(536870974, 17); + RE(536870974, 18); + RE(536870974, 19); + RE(536870974, 20); + RE(536870974, 21); + RE(536870974, 22); + RE(536870974, 23); + RE(536870974, 24); + RE(536870974, 25); + RE(536870974, 26); + RE(536870974, 27); + RE(536870974, 28); + RE(536870974, 30); + RE(536870974, 31); + RE(536870974, 32); + RE(536870974, 36); + RE(536870974, 37); + RE(536870974, 43); + RE(536870974, 44); + RE(536870974, 45); + RE(536870974, 46); + RE(536870974, 48); + RE(536870974, 49); + RE(536870974, -1); + YaccRows[14] := Row; + // [15] + R(0, 0, 27); + RE(536870951, 10); + RE(536870951, 12); + RE(536870951, 14); + RE(536870951, 15); + RE(536870951, 16); + RE(536870951, 17); + RE(536870951, 18); + RE(536870951, 19); + RE(536870951, 20); + RE(536870951, 21); + RE(536870951, 22); + RE(536870951, 23); + RE(536870951, 24); + RE(536870951, 25); + RE(536870951, 26); + RE(536870951, 27); + RE(536870951, 30); + RE(536870951, 31); + RE(536870951, 32); + RE(536870951, 37); + RE(536870951, 43); + RE(536870951, 44); + RE(536870951, 45); + RE(536870951, 46); + RE(536870951, 48); + RE(536870951, 49); + RE(536870951, -1); + YaccRows[15] := Row; + // [16] + R(0, 0, 27); + RE(536870950, 10); + RE(536870950, 12); + RE(536870950, 14); + RE(536870950, 15); + RE(536870950, 16); + RE(536870950, 17); + RE(536870950, 18); + RE(536870950, 19); + RE(536870950, 20); + RE(536870950, 21); + RE(536870950, 22); + RE(536870950, 23); + RE(536870950, 24); + RE(536870950, 25); + RE(536870950, 26); + RE(536870950, 27); + RE(536870950, 30); + RE(536870950, 31); + RE(536870950, 32); + RE(536870950, 37); + RE(536870950, 43); + RE(536870950, 44); + RE(536870950, 45); + RE(536870950, 46); + RE(536870950, 48); + RE(536870950, 49); + RE(536870950, -1); + YaccRows[16] := Row; + // [17] + R(0, 0, 1); + RE(1073741934, 13); + YaccRows[17] := Row; + // [18] + R(0, 0, 31); + RE(536870971, 9); + RE(536870971, 10); + RE(536870971, 11); + RE(536870971, 12); + RE(536870971, 14); + RE(536870971, 15); + RE(536870971, 16); + RE(536870971, 17); + RE(536870971, 18); + RE(536870971, 19); + RE(536870971, 20); + RE(536870971, 21); + RE(536870971, 22); + RE(536870971, 23); + RE(536870971, 24); + RE(536870971, 25); + RE(536870971, 26); + RE(536870971, 27); + RE(536870971, 28); + RE(536870971, 30); + RE(536870971, 31); + RE(536870971, 32); + RE(536870971, 37); + RE(536870971, 43); + RE(536870971, 44); + RE(536870971, 45); + RE(536870971, 46); + RE(536870971, 48); + RE(536870971, 49); + RE(536870971, -1); + RE(1073741932, 36); + YaccRows[18] := Row; + // [19] + R(0, 0, 27); + RE(536870940, 10); + RE(536870940, 12); + RE(536870940, 14); + RE(536870940, 15); + RE(536870940, 16); + RE(536870940, 17); + RE(536870940, 18); + RE(536870940, 19); + RE(536870940, 20); + RE(536870940, 21); + RE(536870940, 22); + RE(536870940, 23); + RE(536870940, 24); + RE(536870940, 25); + RE(536870940, 26); + RE(536870940, 27); + RE(536870940, 30); + RE(536870940, 31); + RE(536870940, 32); + RE(536870940, 37); + RE(536870940, 43); + RE(536870940, 44); + RE(536870940, 45); + RE(536870940, 46); + RE(536870940, 48); + RE(536870940, 49); + RE(536870940, -1); + YaccRows[19] := Row; + // [20] + R(0, 0, 27); + RE(536870939, 10); + RE(536870939, 12); + RE(536870939, 14); + RE(536870939, 15); + RE(536870939, 16); + RE(536870939, 17); + RE(536870939, 18); + RE(536870939, 19); + RE(536870939, 20); + RE(536870939, 21); + RE(536870939, 22); + RE(536870939, 23); + RE(536870939, 24); + RE(536870939, 25); + RE(536870939, 26); + RE(536870939, 27); + RE(536870939, 30); + RE(536870939, 31); + RE(536870939, 32); + RE(536870939, 37); + RE(536870939, 43); + RE(536870939, 44); + RE(536870939, 45); + RE(536870939, 46); + RE(536870939, 48); + RE(536870939, 49); + RE(536870939, -1); + YaccRows[20] := Row; + // [21] + R(0, 1, 30); + RE(536870976, 9); + RE(536870976, 10); + RE(536870976, 11); + RE(536870976, 12); + RE(536870976, 14); + RE(536870976, 15); + RE(536870976, 16); + RE(536870976, 17); + RE(536870976, 18); + RE(536870976, 19); + RE(536870976, 20); + RE(536870976, 21); + RE(536870976, 22); + RE(536870976, 23); + RE(536870976, 24); + RE(536870976, 25); + RE(536870976, 26); + RE(536870976, 27); + RE(536870976, 30); + RE(536870976, 31); + RE(536870976, 32); + RE(536870976, 37); + RE(536870976, 43); + RE(536870976, 44); + RE(536870976, 45); + RE(536870976, 46); + RE(536870976, 48); + RE(536870976, 49); + RE(536870976, -1); + RE(1073741887, 28); + RE(105, 16391); + YaccRows[21] := Row; + // [22] + R(0, 0, 27); + RE(536870934, 10); + RE(536870934, 12); + RE(536870934, 14); + RE(536870934, 15); + RE(536870934, 16); + RE(536870934, 17); + RE(536870934, 18); + RE(536870934, 19); + RE(536870934, 20); + RE(536870934, 21); + RE(536870934, 22); + RE(536870934, 23); + RE(536870934, 24); + RE(536870934, 25); + RE(536870934, 26); + RE(536870934, 27); + RE(536870934, 30); + RE(536870934, 31); + RE(536870934, 32); + RE(536870934, 37); + RE(536870934, 43); + RE(536870934, 44); + RE(536870934, 45); + RE(536870934, 46); + RE(536870934, 48); + RE(536870934, 49); + RE(536870934, -1); + YaccRows[22] := Row; + // [23] + R(0, 0, 27); + RE(536870942, 10); + RE(536870942, 12); + RE(536870942, 14); + RE(536870942, 15); + RE(536870942, 16); + RE(536870942, 17); + RE(536870942, 18); + RE(536870942, 19); + RE(536870942, 20); + RE(536870942, 21); + RE(536870942, 22); + RE(536870942, 23); + RE(536870942, 24); + RE(536870942, 25); + RE(536870942, 26); + RE(536870942, 27); + RE(536870942, 30); + RE(536870942, 31); + RE(536870942, 32); + RE(536870942, 37); + RE(536870942, 43); + RE(536870942, 44); + RE(536870942, 45); + RE(536870942, 46); + RE(536870942, 48); + RE(536870942, 49); + RE(536870942, -1); + YaccRows[23] := Row; + // [24] + R(0, 0, 27); + RE(536870914, 10); + RE(536870914, 12); + RE(536870914, 14); + RE(536870914, 15); + RE(536870914, 16); + RE(536870914, 17); + RE(536870914, 18); + RE(536870914, 19); + RE(536870914, 20); + RE(536870914, 21); + RE(536870914, 22); + RE(536870914, 23); + RE(536870914, 24); + RE(536870914, 27); + RE(536870914, 30); + RE(536870914, 31); + RE(536870914, 32); + RE(536870914, 37); + RE(536870914, 43); + RE(536870914, 44); + RE(536870914, 45); + RE(536870914, 46); + RE(536870914, 48); + RE(536870914, 49); + RE(536870914, -1); + RE(1073741884, 26); + RE(1073741885, 25); + YaccRows[24] := Row; + // [25] + R(0, 0, 17); + RE(536870913, -1); + RE(1073741852, 49); + RE(1073741853, 48); + RE(1073741854, 46); + RE(1073741855, 45); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741858, 24); + RE(1073741859, 23); + RE(1073741860, 22); + RE(1073741861, 21); + RE(1073741862, 20); + RE(1073741863, 19); + RE(1073741864, 18); + RE(1073741865, 17); + RE(1073741866, 16); + RE(1073741867, 15); + YaccRows[25] := Row; + // [26] + R(0, 0, 1); + RE(268435456, -1); + YaccRows[26] := Row; + // [27] + R(0, 0, 0); + YaccRows[27] := Row; + // [28] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(59, 16385); + YaccRows[28] := Row; + // [29] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(58, 16385); + YaccRows[29] := Row; + // [30] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(57, 16385); + YaccRows[30] := Row; + // [31] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(56, 16385); + YaccRows[31] := Row; + // [32] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(55, 16385); + YaccRows[32] := Row; + // [33] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(54, 16385); + YaccRows[33] := Row; + // [34] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(53, 16385); + YaccRows[34] := Row; + // [35] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(52, 16385); + YaccRows[35] := Row; + // [36] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(51, 16385); + YaccRows[36] := Row; + // [37] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(50, 16385); + YaccRows[37] := Row; + // [38] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(49, 16385); + YaccRows[38] := Row; + // [39] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(48, 16385); + YaccRows[39] := Row; + // [40] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(47, 16385); + YaccRows[40] := Row; + // [41] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(46, 16385); + YaccRows[41] := Row; + // [42] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(45, 16385); + YaccRows[42] := Row; + // [43] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(44, 16385); + YaccRows[43] := Row; + // [44] + R(0, 0, 25); + RE(536870921, 10); + RE(536870921, 12); + RE(536870921, 14); + RE(536870921, 15); + RE(536870921, 16); + RE(536870921, 17); + RE(536870921, 18); + RE(536870921, 19); + RE(536870921, 20); + RE(536870921, 27); + RE(536870921, 30); + RE(536870921, 31); + RE(536870921, 32); + RE(536870921, 37); + RE(536870921, -1); + RE(1073741852, 49); + RE(1073741853, 48); + RE(1073741854, 46); + RE(1073741855, 45); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741858, 24); + RE(1073741859, 23); + RE(1073741860, 22); + RE(1073741861, 21); + YaccRows[44] := Row; + // [45] + R(0, 0, 25); + RE(536870920, 10); + RE(536870920, 12); + RE(536870920, 14); + RE(536870920, 15); + RE(536870920, 16); + RE(536870920, 17); + RE(536870920, 18); + RE(536870920, 19); + RE(536870920, 20); + RE(536870920, 27); + RE(536870920, 30); + RE(536870920, 31); + RE(536870920, 32); + RE(536870920, 37); + RE(536870920, -1); + RE(1073741852, 49); + RE(1073741853, 48); + RE(1073741854, 46); + RE(1073741855, 45); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741858, 24); + RE(1073741859, 23); + RE(1073741860, 22); + RE(1073741861, 21); + YaccRows[45] := Row; + // [46] + R(0, 0, 25); + RE(536870919, 10); + RE(536870919, 12); + RE(536870919, 14); + RE(536870919, 15); + RE(536870919, 16); + RE(536870919, 17); + RE(536870919, 18); + RE(536870919, 19); + RE(536870919, 20); + RE(536870919, 27); + RE(536870919, 30); + RE(536870919, 31); + RE(536870919, 32); + RE(536870919, 37); + RE(536870919, -1); + RE(1073741852, 49); + RE(1073741853, 48); + RE(1073741854, 46); + RE(1073741855, 45); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741858, 24); + RE(1073741859, 23); + RE(1073741860, 22); + RE(1073741861, 21); + YaccRows[46] := Row; + // [47] + R(0, 0, 25); + RE(536870923, 10); + RE(536870923, 12); + RE(536870923, 14); + RE(536870923, 15); + RE(536870923, 16); + RE(536870923, 17); + RE(536870923, 18); + RE(536870923, 19); + RE(536870923, 20); + RE(536870923, 27); + RE(536870923, 30); + RE(536870923, 31); + RE(536870923, 32); + RE(536870923, 37); + RE(536870923, -1); + RE(1073741852, 49); + RE(1073741853, 48); + RE(1073741854, 46); + RE(1073741855, 45); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741858, 24); + RE(1073741859, 23); + RE(1073741860, 22); + RE(1073741861, 21); + YaccRows[47] := Row; + // [48] + R(0, 0, 25); + RE(536870922, 10); + RE(536870922, 12); + RE(536870922, 14); + RE(536870922, 15); + RE(536870922, 16); + RE(536870922, 17); + RE(536870922, 18); + RE(536870922, 19); + RE(536870922, 20); + RE(536870922, 27); + RE(536870922, 30); + RE(536870922, 31); + RE(536870922, 32); + RE(536870922, 37); + RE(536870922, -1); + RE(1073741852, 49); + RE(1073741853, 48); + RE(1073741854, 46); + RE(1073741855, 45); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741858, 24); + RE(1073741859, 23); + RE(1073741860, 22); + RE(1073741861, 21); + YaccRows[48] := Row; + // [49] + R(0, 0, 25); + RE(536870924, 10); + RE(536870924, 12); + RE(536870924, 14); + RE(536870924, 15); + RE(536870924, 16); + RE(536870924, 17); + RE(536870924, 18); + RE(536870924, 19); + RE(536870924, 20); + RE(536870924, 27); + RE(536870924, 30); + RE(536870924, 31); + RE(536870924, 32); + RE(536870924, 37); + RE(536870924, -1); + RE(1073741852, 49); + RE(1073741853, 48); + RE(1073741854, 46); + RE(1073741855, 45); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741858, 24); + RE(1073741859, 23); + RE(1073741860, 22); + RE(1073741861, 21); + YaccRows[49] := Row; + // [50] + R(0, 0, 25); + RE(536870925, 10); + RE(536870925, 12); + RE(536870925, 14); + RE(536870925, 15); + RE(536870925, 16); + RE(536870925, 17); + RE(536870925, 18); + RE(536870925, 19); + RE(536870925, 20); + RE(536870925, 21); + RE(536870925, 22); + RE(536870925, 27); + RE(536870925, 30); + RE(536870925, 31); + RE(536870925, 32); + RE(536870925, 37); + RE(536870925, 45); + RE(536870925, 46); + RE(536870925, 48); + RE(536870925, 49); + RE(536870925, -1); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741858, 24); + RE(1073741859, 23); + YaccRows[50] := Row; + // [51] + R(0, 0, 25); + RE(536870926, 10); + RE(536870926, 12); + RE(536870926, 14); + RE(536870926, 15); + RE(536870926, 16); + RE(536870926, 17); + RE(536870926, 18); + RE(536870926, 19); + RE(536870926, 20); + RE(536870926, 21); + RE(536870926, 22); + RE(536870926, 27); + RE(536870926, 30); + RE(536870926, 31); + RE(536870926, 32); + RE(536870926, 37); + RE(536870926, 45); + RE(536870926, 46); + RE(536870926, 48); + RE(536870926, 49); + RE(536870926, -1); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741858, 24); + RE(1073741859, 23); + YaccRows[51] := Row; + // [52] + R(0, 0, 25); + RE(536870928, 10); + RE(536870928, 12); + RE(536870928, 14); + RE(536870928, 15); + RE(536870928, 16); + RE(536870928, 17); + RE(536870928, 18); + RE(536870928, 19); + RE(536870928, 20); + RE(536870928, 21); + RE(536870928, 22); + RE(536870928, 23); + RE(536870928, 24); + RE(536870928, 27); + RE(536870928, 30); + RE(536870928, 31); + RE(536870928, 32); + RE(536870928, 37); + RE(536870928, 43); + RE(536870928, 44); + RE(536870928, 45); + RE(536870928, 46); + RE(536870928, 48); + RE(536870928, 49); + RE(536870928, -1); + YaccRows[52] := Row; + // [53] + R(0, 0, 25); + RE(536870927, 10); + RE(536870927, 12); + RE(536870927, 14); + RE(536870927, 15); + RE(536870927, 16); + RE(536870927, 17); + RE(536870927, 18); + RE(536870927, 19); + RE(536870927, 20); + RE(536870927, 21); + RE(536870927, 22); + RE(536870927, 23); + RE(536870927, 24); + RE(536870927, 27); + RE(536870927, 30); + RE(536870927, 31); + RE(536870927, 32); + RE(536870927, 37); + RE(536870927, 43); + RE(536870927, 44); + RE(536870927, 45); + RE(536870927, 46); + RE(536870927, 48); + RE(536870927, 49); + RE(536870927, -1); + YaccRows[53] := Row; + // [54] + R(0, 0, 25); + RE(536870929, 10); + RE(536870929, 12); + RE(536870929, 14); + RE(536870929, 15); + RE(536870929, 16); + RE(536870929, 17); + RE(536870929, 18); + RE(536870929, 19); + RE(536870929, 20); + RE(536870929, 21); + RE(536870929, 22); + RE(536870929, 23); + RE(536870929, 24); + RE(536870929, 27); + RE(536870929, 30); + RE(536870929, 31); + RE(536870929, 32); + RE(536870929, 37); + RE(536870929, 43); + RE(536870929, 44); + RE(536870929, 45); + RE(536870929, 46); + RE(536870929, 48); + RE(536870929, 49); + RE(536870929, -1); + YaccRows[54] := Row; + // [55] + R(0, 0, 25); + RE(536870930, 10); + RE(536870930, 12); + RE(536870930, 14); + RE(536870930, 15); + RE(536870930, 16); + RE(536870930, 17); + RE(536870930, 18); + RE(536870930, 19); + RE(536870930, 20); + RE(536870930, 21); + RE(536870930, 22); + RE(536870930, 23); + RE(536870930, 24); + RE(536870930, 27); + RE(536870930, 30); + RE(536870930, 31); + RE(536870930, 32); + RE(536870930, 37); + RE(536870930, 43); + RE(536870930, 44); + RE(536870930, 45); + RE(536870930, 46); + RE(536870930, 48); + RE(536870930, 49); + RE(536870930, -1); + YaccRows[55] := Row; + // [56] + R(0, 0, 25); + RE(536870915, 10); + RE(536870915, 12); + RE(536870915, 14); + RE(536870915, 15); + RE(536870915, 16); + RE(536870915, 17); + RE(536870915, 18); + RE(536870915, 19); + RE(536870915, 20); + RE(536870915, 27); + RE(536870915, 30); + RE(536870915, 31); + RE(536870915, 32); + RE(536870915, 37); + RE(536870915, 45); + RE(536870915, 46); + RE(536870915, 48); + RE(536870915, 49); + RE(536870915, -1); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741858, 24); + RE(1073741859, 23); + RE(1073741860, 22); + RE(1073741861, 21); + YaccRows[56] := Row; + // [57] + R(0, 0, 25); + RE(536870916, 10); + RE(536870916, 12); + RE(536870916, 14); + RE(536870916, 15); + RE(536870916, 16); + RE(536870916, 17); + RE(536870916, 18); + RE(536870916, 19); + RE(536870916, 20); + RE(536870916, 27); + RE(536870916, 30); + RE(536870916, 31); + RE(536870916, 32); + RE(536870916, 37); + RE(536870916, 45); + RE(536870916, 46); + RE(536870916, 48); + RE(536870916, 49); + RE(536870916, -1); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741858, 24); + RE(1073741859, 23); + RE(1073741860, 22); + RE(1073741861, 21); + YaccRows[57] := Row; + // [58] + R(0, 0, 25); + RE(536870917, 10); + RE(536870917, 12); + RE(536870917, 14); + RE(536870917, 15); + RE(536870917, 16); + RE(536870917, 17); + RE(536870917, 18); + RE(536870917, 19); + RE(536870917, 20); + RE(536870917, 27); + RE(536870917, 30); + RE(536870917, 31); + RE(536870917, 32); + RE(536870917, 37); + RE(536870917, 45); + RE(536870917, 46); + RE(536870917, 48); + RE(536870917, 49); + RE(536870917, -1); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741858, 24); + RE(1073741859, 23); + RE(1073741860, 22); + RE(1073741861, 21); + YaccRows[58] := Row; + // [59] + R(0, 0, 25); + RE(536870918, 10); + RE(536870918, 12); + RE(536870918, 14); + RE(536870918, 15); + RE(536870918, 16); + RE(536870918, 17); + RE(536870918, 18); + RE(536870918, 19); + RE(536870918, 20); + RE(536870918, 27); + RE(536870918, 30); + RE(536870918, 31); + RE(536870918, 32); + RE(536870918, 37); + RE(536870918, 49); + RE(536870918, -1); + RE(1073741853, 48); + RE(1073741854, 46); + RE(1073741855, 45); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741858, 24); + RE(1073741859, 23); + RE(1073741860, 22); + RE(1073741861, 21); + YaccRows[59] := Row; + // [60] + R(0, 2, 2); + RE(1073741837, 5); + RE(1073741838, 4); + RE(18, 16398); + RE(101, 16390); + YaccRows[60] := Row; + // [61] + R(0, 2, 2); + RE(1073741837, 5); + RE(1073741838, 4); + RE(18, 16398); + RE(62, 16390); + YaccRows[61] := Row; + // [62] + R(0, 1, 30); + RE(536870976, 9); + RE(536870976, 10); + RE(536870976, 11); + RE(536870976, 12); + RE(536870976, 14); + RE(536870976, 15); + RE(536870976, 16); + RE(536870976, 17); + RE(536870976, 18); + RE(536870976, 19); + RE(536870976, 20); + RE(536870976, 21); + RE(536870976, 22); + RE(536870976, 23); + RE(536870976, 24); + RE(536870976, 25); + RE(536870976, 26); + RE(536870976, 27); + RE(536870976, 30); + RE(536870976, 31); + RE(536870976, 32); + RE(536870976, 37); + RE(536870976, 43); + RE(536870976, 44); + RE(536870976, 45); + RE(536870976, 46); + RE(536870976, 48); + RE(536870976, 49); + RE(536870976, -1); + RE(1073741887, 28); + RE(64, 16391); + YaccRows[62] := Row; + // [63] + R(0, 1, 2); + RE(1073741837, 5); + RE(1073741838, 4); + RE(100, 16398); + YaccRows[63] := Row; + // [64] + R(0, 1, 29); + RE(536870966, 10); + RE(536870966, 11); + RE(536870966, 12); + RE(536870966, 14); + RE(536870966, 15); + RE(536870966, 16); + RE(536870966, 17); + RE(536870966, 18); + RE(536870966, 19); + RE(536870966, 20); + RE(536870966, 21); + RE(536870966, 22); + RE(536870966, 23); + RE(536870966, 24); + RE(536870966, 25); + RE(536870966, 26); + RE(536870966, 27); + RE(536870966, 30); + RE(536870966, 31); + RE(536870966, 32); + RE(536870966, 37); + RE(536870966, 43); + RE(536870966, 44); + RE(536870966, 45); + RE(536870966, 46); + RE(536870966, 48); + RE(536870966, 49); + RE(536870966, -1); + RE(1073741889, 9); + RE(66, 16392); + YaccRows[64] := Row; + // [65] + R(0, 11, 17); + RE(536870977, 10); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(70, 16406); + RE(17, 16401); + RE(18, 16398); + RE(98, 16396); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(72, 16385); + YaccRows[65] := Row; + // [66] + R(0, 1, 28); + RE(536870935, 10); + RE(536870935, 12); + RE(536870935, 14); + RE(536870935, 15); + RE(536870935, 16); + RE(536870935, 17); + RE(536870935, 18); + RE(536870935, 19); + RE(536870935, 20); + RE(536870935, 21); + RE(536870935, 22); + RE(536870935, 23); + RE(536870935, 24); + RE(536870935, 25); + RE(536870935, 26); + RE(536870935, 27); + RE(536870935, 30); + RE(536870935, 31); + RE(536870935, 32); + RE(536870935, 37); + RE(536870935, 43); + RE(536870935, 44); + RE(536870935, 45); + RE(536870935, 46); + RE(536870935, 48); + RE(536870935, 49); + RE(536870935, -1); + RE(1073741891, 11); + RE(68, 16393); + YaccRows[66] := Row; + // [67] + R(0, 11, 17); + RE(536870977, 12); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741893, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(70, 16406); + RE(17, 16401); + RE(18, 16398); + RE(71, 16396); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(72, 16385); + YaccRows[67] := Row; + // [68] + R(0, 0, 27); + RE(536870936, 10); + RE(536870936, 12); + RE(536870936, 14); + RE(536870936, 15); + RE(536870936, 16); + RE(536870936, 17); + RE(536870936, 18); + RE(536870936, 19); + RE(536870936, 20); + RE(536870936, 21); + RE(536870936, 22); + RE(536870936, 23); + RE(536870936, 24); + RE(536870936, 25); + RE(536870936, 26); + RE(536870936, 27); + RE(536870936, 30); + RE(536870936, 31); + RE(536870936, 32); + RE(536870936, 37); + RE(536870936, 43); + RE(536870936, 44); + RE(536870936, 45); + RE(536870936, 46); + RE(536870936, 48); + RE(536870936, 49); + RE(536870936, -1); + YaccRows[68] := Row; + // [69] + R(0, 0, 26); + RE(536870974, 9); + RE(536870974, 11); + RE(536870974, 12); + RE(536870974, 15); + RE(536870974, 16); + RE(536870974, 17); + RE(536870974, 18); + RE(536870974, 19); + RE(536870974, 20); + RE(536870974, 21); + RE(536870974, 22); + RE(536870974, 23); + RE(536870974, 24); + RE(536870974, 25); + RE(536870974, 26); + RE(536870974, 27); + RE(536870974, 28); + RE(536870974, 36); + RE(536870974, 43); + RE(536870974, 44); + RE(536870974, 45); + RE(536870974, 46); + RE(536870974, 48); + RE(536870974, 49); + RE(1073741900, 38); + RE(1073741901, 35); + YaccRows[69] := Row; + // [70] + R(0, 0, 2); + RE(536870978, 10); + RE(536870978, 12); + YaccRows[70] := Row; + // [71] + R(0, 0, 1); + RE(1073741899, 12); + YaccRows[71] := Row; + // [72] + R(0, 0, 19); + RE(536870979, 10); + RE(536870979, 12); + RE(1073741852, 49); + RE(1073741853, 48); + RE(1073741854, 46); + RE(1073741855, 45); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741897, 27); + RE(1073741858, 24); + RE(1073741859, 23); + RE(1073741860, 22); + RE(1073741861, 21); + RE(1073741862, 20); + RE(1073741863, 19); + RE(1073741864, 18); + RE(1073741865, 17); + RE(1073741866, 16); + RE(1073741867, 15); + YaccRows[72] := Row; + // [73] + R(0, 10, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(74, 16406); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(72, 16385); + YaccRows[73] := Row; + // [74] + R(0, 0, 2); + RE(536870980, 10); + RE(536870980, 12); + YaccRows[74] := Row; + // [75] + R(0, 0, 27); + RE(536870945, 10); + RE(536870945, 12); + RE(536870945, 14); + RE(536870945, 15); + RE(536870945, 16); + RE(536870945, 17); + RE(536870945, 18); + RE(536870945, 19); + RE(536870945, 20); + RE(536870945, 21); + RE(536870945, 22); + RE(536870945, 23); + RE(536870945, 24); + RE(536870945, 25); + RE(536870945, 26); + RE(536870945, 27); + RE(536870945, 30); + RE(536870945, 31); + RE(536870945, 32); + RE(536870945, 37); + RE(536870945, 43); + RE(536870945, 44); + RE(536870945, 45); + RE(536870945, 46); + RE(536870945, 48); + RE(536870945, 49); + RE(536870945, -1); + YaccRows[75] := Row; + // [76] + R(0, 4, 3); + RE(536870955, 35); + RE(1073741904, 33); + RE(1073741905, 5); + RE(82, 16405); + RE(83, 16400); + RE(84, 16399); + RE(85, 16397); + YaccRows[76] := Row; + // [77] + R(0, 11, 17); + RE(536870977, 12); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(70, 16406); + RE(17, 16401); + RE(18, 16398); + RE(78, 16396); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(72, 16385); + YaccRows[77] := Row; + // [78] + R(0, 0, 1); + RE(1073741903, 12); + YaccRows[78] := Row; + // [79] + R(0, 0, 27); + RE(536870946, 10); + RE(536870946, 12); + RE(536870946, 14); + RE(536870946, 15); + RE(536870946, 16); + RE(536870946, 17); + RE(536870946, 18); + RE(536870946, 19); + RE(536870946, 20); + RE(536870946, 21); + RE(536870946, 22); + RE(536870946, 23); + RE(536870946, 24); + RE(536870946, 25); + RE(536870946, 26); + RE(536870946, 27); + RE(536870946, 30); + RE(536870946, 31); + RE(536870946, 32); + RE(536870946, 37); + RE(536870946, 43); + RE(536870946, 44); + RE(536870946, 45); + RE(536870946, 46); + RE(536870946, 48); + RE(536870946, 49); + RE(536870946, -1); + YaccRows[79] := Row; + // [80] + R(0, 0, 1); + RE(1073741915, 13); + YaccRows[80] := Row; + // [81] + R(0, 0, 2); + RE(536870969, 35); + RE(1073741913, 36); + YaccRows[81] := Row; + // [82] + R(0, 0, 1); + RE(536870968, 35); + YaccRows[82] := Row; + // [83] + R(0, 0, 1); + RE(536870957, 35); + YaccRows[83] := Row; + // [84] + R(0, 0, 1); + RE(536870956, 35); + YaccRows[84] := Row; + // [85] + R(0, 0, 1); + RE(1073741910, 35); + YaccRows[85] := Row; + // [86] + R(0, 11, 17); + RE(536870977, 12); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(70, 16406); + RE(17, 16401); + RE(18, 16398); + RE(87, 16396); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(72, 16385); + YaccRows[86] := Row; + // [87] + R(0, 0, 1); + RE(1073741912, 12); + YaccRows[87] := Row; + // [88] + R(0, 0, 27); + RE(536870947, 10); + RE(536870947, 12); + RE(536870947, 14); + RE(536870947, 15); + RE(536870947, 16); + RE(536870947, 17); + RE(536870947, 18); + RE(536870947, 19); + RE(536870947, 20); + RE(536870947, 21); + RE(536870947, 22); + RE(536870947, 23); + RE(536870947, 24); + RE(536870947, 25); + RE(536870947, 26); + RE(536870947, 27); + RE(536870947, 30); + RE(536870947, 31); + RE(536870947, 32); + RE(536870947, 37); + RE(536870947, 43); + RE(536870947, 44); + RE(536870947, 45); + RE(536870947, 46); + RE(536870947, 48); + RE(536870947, 49); + RE(536870947, -1); + YaccRows[88] := Row; + // [89] + R(0, 1, 1); + RE(1073741905, 5); + RE(90, 16405); + YaccRows[89] := Row; + // [90] + R(0, 0, 1); + RE(536870970, 35); + YaccRows[90] := Row; + // [91] + R(0, 1, 1); + RE(1073741916, 34); + RE(93, 16404); + YaccRows[91] := Row; + // [92] + R(0, 1, 2); + RE(1073741837, 5); + RE(1073741838, 4); + RE(95, 16398); + YaccRows[92] := Row; + // [93] + R(0, 0, 1); + RE(1073741918, 14); + YaccRows[93] := Row; + // [94] + R(0, 0, 1); + RE(536870963, 35); + YaccRows[94] := Row; + // [95] + R(0, 0, 2); + RE(536870964, 14); + RE(1073741920, 27); + YaccRows[95] := Row; + // [96] + R(0, 1, 1); + RE(1073741916, 34); + RE(97, 16404); + YaccRows[96] := Row; + // [97] + R(0, 0, 1); + RE(536870965, 14); + YaccRows[97] := Row; + // [98] + R(0, 0, 1); + RE(1073741923, 10); + YaccRows[98] := Row; + // [99] + R(0, 0, 28); + RE(536870967, 10); + RE(536870967, 11); + RE(536870967, 12); + RE(536870967, 14); + RE(536870967, 15); + RE(536870967, 16); + RE(536870967, 17); + RE(536870967, 18); + RE(536870967, 19); + RE(536870967, 20); + RE(536870967, 21); + RE(536870967, 22); + RE(536870967, 23); + RE(536870967, 24); + RE(536870967, 25); + RE(536870967, 26); + RE(536870967, 27); + RE(536870967, 30); + RE(536870967, 31); + RE(536870967, 32); + RE(536870967, 37); + RE(536870967, 43); + RE(536870967, 44); + RE(536870967, 45); + RE(536870967, 46); + RE(536870967, 48); + RE(536870967, 49); + RE(536870967, -1); + YaccRows[99] := Row; + // [100] + R(0, 0, 29); + RE(536870975, 9); + RE(536870975, 10); + RE(536870975, 11); + RE(536870975, 12); + RE(536870975, 14); + RE(536870975, 15); + RE(536870975, 16); + RE(536870975, 17); + RE(536870975, 18); + RE(536870975, 19); + RE(536870975, 20); + RE(536870975, 21); + RE(536870975, 22); + RE(536870975, 23); + RE(536870975, 24); + RE(536870975, 25); + RE(536870975, 26); + RE(536870975, 27); + RE(536870975, 30); + RE(536870975, 31); + RE(536870975, 32); + RE(536870975, 37); + RE(536870975, 43); + RE(536870975, 44); + RE(536870975, 45); + RE(536870975, 46); + RE(536870975, 48); + RE(536870975, 49); + RE(536870975, -1); + YaccRows[100] := Row; + // [101] + R(0, 1, 30); + RE(536870976, 9); + RE(536870976, 10); + RE(536870976, 11); + RE(536870976, 12); + RE(536870976, 14); + RE(536870976, 15); + RE(536870976, 16); + RE(536870976, 17); + RE(536870976, 18); + RE(536870976, 19); + RE(536870976, 20); + RE(536870976, 21); + RE(536870976, 22); + RE(536870976, 23); + RE(536870976, 24); + RE(536870976, 25); + RE(536870976, 26); + RE(536870976, 27); + RE(536870976, 30); + RE(536870976, 31); + RE(536870976, 32); + RE(536870976, 37); + RE(536870976, 43); + RE(536870976, 44); + RE(536870976, 45); + RE(536870976, 46); + RE(536870976, 48); + RE(536870976, 49); + RE(536870976, -1); + RE(1073741887, 28); + RE(102, 16391); + YaccRows[101] := Row; + // [102] + R(0, 1, 29); + RE(536870966, 10); + RE(536870966, 11); + RE(536870966, 12); + RE(536870966, 14); + RE(536870966, 15); + RE(536870966, 16); + RE(536870966, 17); + RE(536870966, 18); + RE(536870966, 19); + RE(536870966, 20); + RE(536870966, 21); + RE(536870966, 22); + RE(536870966, 23); + RE(536870966, 24); + RE(536870966, 25); + RE(536870966, 26); + RE(536870966, 27); + RE(536870966, 30); + RE(536870966, 31); + RE(536870966, 32); + RE(536870966, 37); + RE(536870966, 43); + RE(536870966, 44); + RE(536870966, 45); + RE(536870966, 46); + RE(536870966, 48); + RE(536870966, 49); + RE(536870966, -1); + RE(1073741889, 9); + RE(103, 16392); + YaccRows[102] := Row; + // [103] + R(0, 1, 28); + RE(536870937, 10); + RE(536870937, 12); + RE(536870937, 14); + RE(536870937, 15); + RE(536870937, 16); + RE(536870937, 17); + RE(536870937, 18); + RE(536870937, 19); + RE(536870937, 20); + RE(536870937, 21); + RE(536870937, 22); + RE(536870937, 23); + RE(536870937, 24); + RE(536870937, 25); + RE(536870937, 26); + RE(536870937, 27); + RE(536870937, 30); + RE(536870937, 31); + RE(536870937, 32); + RE(536870937, 37); + RE(536870937, 43); + RE(536870937, 44); + RE(536870937, 45); + RE(536870937, 46); + RE(536870937, 48); + RE(536870937, 49); + RE(536870937, -1); + RE(1073741891, 11); + RE(104, 16393); + YaccRows[103] := Row; + // [104] + R(0, 0, 27); + RE(536870938, 10); + RE(536870938, 12); + RE(536870938, 14); + RE(536870938, 15); + RE(536870938, 16); + RE(536870938, 17); + RE(536870938, 18); + RE(536870938, 19); + RE(536870938, 20); + RE(536870938, 21); + RE(536870938, 22); + RE(536870938, 23); + RE(536870938, 24); + RE(536870938, 25); + RE(536870938, 26); + RE(536870938, 27); + RE(536870938, 30); + RE(536870938, 31); + RE(536870938, 32); + RE(536870938, 37); + RE(536870938, 43); + RE(536870938, 44); + RE(536870938, 45); + RE(536870938, 46); + RE(536870938, 48); + RE(536870938, 49); + RE(536870938, -1); + YaccRows[104] := Row; + // [105] + R(0, 1, 29); + RE(536870966, 10); + RE(536870966, 11); + RE(536870966, 12); + RE(536870966, 14); + RE(536870966, 15); + RE(536870966, 16); + RE(536870966, 17); + RE(536870966, 18); + RE(536870966, 19); + RE(536870966, 20); + RE(536870966, 21); + RE(536870966, 22); + RE(536870966, 23); + RE(536870966, 24); + RE(536870966, 25); + RE(536870966, 26); + RE(536870966, 27); + RE(536870966, 30); + RE(536870966, 31); + RE(536870966, 32); + RE(536870966, 37); + RE(536870966, 43); + RE(536870966, 44); + RE(536870966, 45); + RE(536870966, 46); + RE(536870966, 48); + RE(536870966, 49); + RE(536870966, -1); + RE(1073741889, 9); + RE(106, 16392); + YaccRows[105] := Row; + // [106] + R(0, 1, 28); + RE(536870943, 10); + RE(536870943, 12); + RE(536870943, 14); + RE(536870943, 15); + RE(536870943, 16); + RE(536870943, 17); + RE(536870943, 18); + RE(536870943, 19); + RE(536870943, 20); + RE(536870943, 21); + RE(536870943, 22); + RE(536870943, 23); + RE(536870943, 24); + RE(536870943, 25); + RE(536870943, 26); + RE(536870943, 27); + RE(536870943, 30); + RE(536870943, 31); + RE(536870943, 32); + RE(536870943, 37); + RE(536870943, 43); + RE(536870943, 44); + RE(536870943, 45); + RE(536870943, 46); + RE(536870943, 48); + RE(536870943, 49); + RE(536870943, -1); + RE(1073741891, 11); + RE(107, 16393); + YaccRows[106] := Row; + // [107] + R(0, 0, 27); + RE(536870944, 10); + RE(536870944, 12); + RE(536870944, 14); + RE(536870944, 15); + RE(536870944, 16); + RE(536870944, 17); + RE(536870944, 18); + RE(536870944, 19); + RE(536870944, 20); + RE(536870944, 21); + RE(536870944, 22); + RE(536870944, 23); + RE(536870944, 24); + RE(536870944, 25); + RE(536870944, 26); + RE(536870944, 27); + RE(536870944, 30); + RE(536870944, 31); + RE(536870944, 32); + RE(536870944, 37); + RE(536870944, 43); + RE(536870944, 44); + RE(536870944, 45); + RE(536870944, 46); + RE(536870944, 48); + RE(536870944, 49); + RE(536870944, -1); + YaccRows[107] := Row; + // [108] + R(0, 2, 2); + RE(1073741837, 5); + RE(1073741838, 4); + RE(18, 16398); + RE(109, 16390); + YaccRows[108] := Row; + // [109] + R(0, 0, 30); + RE(536870972, 9); + RE(536870972, 10); + RE(536870972, 11); + RE(536870972, 12); + RE(536870972, 14); + RE(536870972, 15); + RE(536870972, 16); + RE(536870972, 17); + RE(536870972, 18); + RE(536870972, 19); + RE(536870972, 20); + RE(536870972, 21); + RE(536870972, 22); + RE(536870972, 23); + RE(536870972, 24); + RE(536870972, 25); + RE(536870972, 26); + RE(536870972, 27); + RE(536870972, 28); + RE(536870972, 30); + RE(536870972, 31); + RE(536870972, 32); + RE(536870972, 37); + RE(536870972, 43); + RE(536870972, 44); + RE(536870972, 45); + RE(536870972, 46); + RE(536870972, 48); + RE(536870972, 49); + RE(536870972, -1); + YaccRows[109] := Row; + // [110] + R(0, 11, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(111, 16403); + RE(112, 16402); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(113, 16385); + YaccRows[110] := Row; + // [111] + R(0, 0, 1); + RE(536870959, 14); + YaccRows[111] := Row; + // [112] + R(0, 0, 1); + RE(1073741943, 14); + YaccRows[112] := Row; + // [113] + R(0, 0, 19); + RE(536870960, 14); + RE(1073741852, 49); + RE(1073741853, 48); + RE(1073741854, 46); + RE(1073741855, 45); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741938, 37); + RE(1073741939, 27); + RE(1073741858, 24); + RE(1073741859, 23); + RE(1073741860, 22); + RE(1073741861, 21); + RE(1073741862, 20); + RE(1073741863, 19); + RE(1073741864, 18); + RE(1073741865, 17); + RE(1073741866, 16); + RE(1073741867, 15); + YaccRows[113] := Row; + // [114] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(118, 16385); + YaccRows[114] := Row; + // [115] + R(0, 10, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(116, 16403); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(117, 16385); + YaccRows[115] := Row; + // [116] + R(0, 0, 1); + RE(536870961, 14); + YaccRows[116] := Row; + // [117] + R(0, 0, 18); + RE(536870960, 14); + RE(1073741852, 49); + RE(1073741853, 48); + RE(1073741854, 46); + RE(1073741855, 45); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741939, 27); + RE(1073741858, 24); + RE(1073741859, 23); + RE(1073741860, 22); + RE(1073741861, 21); + RE(1073741862, 20); + RE(1073741863, 19); + RE(1073741864, 18); + RE(1073741865, 17); + RE(1073741866, 16); + RE(1073741867, 15); + YaccRows[117] := Row; + // [118] + R(0, 0, 17); + RE(536870962, 14); + RE(1073741852, 49); + RE(1073741853, 48); + RE(1073741854, 46); + RE(1073741855, 45); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741858, 24); + RE(1073741859, 23); + RE(1073741860, 22); + RE(1073741861, 21); + RE(1073741862, 20); + RE(1073741863, 19); + RE(1073741864, 18); + RE(1073741865, 17); + RE(1073741866, 16); + RE(1073741867, 15); + YaccRows[118] := Row; + // [119] + R(0, 0, 27); + RE(536870958, 10); + RE(536870958, 12); + RE(536870958, 14); + RE(536870958, 15); + RE(536870958, 16); + RE(536870958, 17); + RE(536870958, 18); + RE(536870958, 19); + RE(536870958, 20); + RE(536870958, 21); + RE(536870958, 22); + RE(536870958, 23); + RE(536870958, 24); + RE(536870958, 25); + RE(536870958, 26); + RE(536870958, 27); + RE(536870958, 30); + RE(536870958, 31); + RE(536870958, 32); + RE(536870958, 37); + RE(536870958, 43); + RE(536870958, 44); + RE(536870958, 45); + RE(536870958, 46); + RE(536870958, 48); + RE(536870958, 49); + RE(536870958, -1); + YaccRows[119] := Row; + // [120] + R(0, 0, 27); + RE(536870949, 10); + RE(536870949, 12); + RE(536870949, 14); + RE(536870949, 15); + RE(536870949, 16); + RE(536870949, 17); + RE(536870949, 18); + RE(536870949, 19); + RE(536870949, 20); + RE(536870949, 21); + RE(536870949, 22); + RE(536870949, 23); + RE(536870949, 24); + RE(536870949, 25); + RE(536870949, 26); + RE(536870949, 27); + RE(536870949, 30); + RE(536870949, 31); + RE(536870949, 32); + RE(536870949, 37); + RE(536870949, 43); + RE(536870949, 44); + RE(536870949, 45); + RE(536870949, 46); + RE(536870949, 48); + RE(536870949, 49); + RE(536870949, -1); + YaccRows[120] := Row; + // [121] + R(0, 0, 1); + RE(1073741946, 51); + YaccRows[121] := Row; + // [122] + R(0, 0, 27); + RE(536870948, 10); + RE(536870948, 12); + RE(536870948, 14); + RE(536870948, 15); + RE(536870948, 16); + RE(536870948, 17); + RE(536870948, 18); + RE(536870948, 19); + RE(536870948, 20); + RE(536870948, 21); + RE(536870948, 22); + RE(536870948, 23); + RE(536870948, 24); + RE(536870948, 25); + RE(536870948, 26); + RE(536870948, 27); + RE(536870948, 30); + RE(536870948, 31); + RE(536870948, 32); + RE(536870948, 37); + RE(536870948, 43); + RE(536870948, 44); + RE(536870948, 45); + RE(536870948, 46); + RE(536870948, 48); + RE(536870948, 49); + RE(536870948, -1); + YaccRows[122] := Row; + // [123] + R(0, 0, 17); + RE(1073741852, 49); + RE(1073741853, 48); + RE(1073741854, 46); + RE(1073741855, 45); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741858, 24); + RE(1073741859, 23); + RE(1073741860, 22); + RE(1073741861, 21); + RE(1073741862, 20); + RE(1073741863, 19); + RE(1073741864, 18); + RE(1073741865, 17); + RE(1073741866, 16); + RE(1073741867, 15); + RE(1073741948, 12); + YaccRows[123] := Row; + // [124] + R(0, 0, 27); + RE(536870941, 10); + RE(536870941, 12); + RE(536870941, 14); + RE(536870941, 15); + RE(536870941, 16); + RE(536870941, 17); + RE(536870941, 18); + RE(536870941, 19); + RE(536870941, 20); + RE(536870941, 21); + RE(536870941, 22); + RE(536870941, 23); + RE(536870941, 24); + RE(536870941, 25); + RE(536870941, 26); + RE(536870941, 27); + RE(536870941, 30); + RE(536870941, 31); + RE(536870941, 32); + RE(536870941, 37); + RE(536870941, 43); + RE(536870941, 44); + RE(536870941, 45); + RE(536870941, 46); + RE(536870941, 48); + RE(536870941, 49); + RE(536870941, -1); + YaccRows[124] := Row; + // [125] + R(0, 0, 25); + RE(536870931, 10); + RE(536870931, 12); + RE(536870931, 14); + RE(536870931, 15); + RE(536870931, 16); + RE(536870931, 17); + RE(536870931, 18); + RE(536870931, 19); + RE(536870931, 20); + RE(536870931, 21); + RE(536870931, 22); + RE(536870931, 27); + RE(536870931, 30); + RE(536870931, 31); + RE(536870931, 32); + RE(536870931, 37); + RE(536870931, 45); + RE(536870931, 46); + RE(536870931, 48); + RE(536870931, 49); + RE(536870931, -1); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741858, 24); + RE(1073741859, 23); + YaccRows[125] := Row; + // [126] + R(0, 0, 17); + RE(1073741852, 49); + RE(1073741853, 48); + RE(1073741854, 46); + RE(1073741855, 45); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741951, 30); + RE(1073741858, 24); + RE(1073741859, 23); + RE(1073741860, 22); + RE(1073741861, 21); + RE(1073741862, 20); + RE(1073741863, 19); + RE(1073741864, 18); + RE(1073741865, 17); + RE(1073741866, 16); + RE(1073741867, 15); + YaccRows[126] := Row; + // [127] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(128, 16385); + YaccRows[127] := Row; + // [128] + R(0, 0, 17); + RE(1073741852, 49); + RE(1073741853, 48); + RE(1073741854, 46); + RE(1073741855, 45); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741953, 31); + RE(1073741858, 24); + RE(1073741859, 23); + RE(1073741860, 22); + RE(1073741861, 21); + RE(1073741862, 20); + RE(1073741863, 19); + RE(1073741864, 18); + RE(1073741865, 17); + RE(1073741866, 16); + RE(1073741867, 15); + YaccRows[128] := Row; + // [129] + R(0, 9, 16); + RE(1073741825, 47); + RE(1073741826, 42); + RE(1073741827, 41); + RE(1073741828, 40); + RE(1073741829, 39); + RE(1073741830, 34); + RE(1073741831, 29); + RE(1073741832, 22); + RE(1073741833, 11); + RE(1073741834, 8); + RE(1073741835, 7); + RE(1073741836, 6); + RE(1073741837, 5); + RE(1073741838, 4); + RE(1073741839, 3); + RE(1073741840, 2); + RE(17, 16401); + RE(18, 16398); + RE(19, 16395); + RE(20, 16394); + RE(21, 16390); + RE(22, 16389); + RE(23, 16388); + RE(24, 16387); + RE(130, 16385); + YaccRows[129] := Row; + // [130] + R(0, 0, 17); + RE(1073741852, 49); + RE(1073741853, 48); + RE(1073741854, 46); + RE(1073741855, 45); + RE(1073741856, 44); + RE(1073741857, 43); + RE(1073741955, 32); + RE(1073741858, 24); + RE(1073741859, 23); + RE(1073741860, 22); + RE(1073741861, 21); + RE(1073741862, 20); + RE(1073741863, 19); + RE(1073741864, 18); + RE(1073741865, 17); + RE(1073741866, 16); + RE(1073741867, 15); + YaccRows[130] := Row; + // [131] + R(0, 0, 27); + RE(536870933, 10); + RE(536870933, 12); + RE(536870933, 14); + RE(536870933, 15); + RE(536870933, 16); + RE(536870933, 17); + RE(536870933, 18); + RE(536870933, 19); + RE(536870933, 20); + RE(536870933, 21); + RE(536870933, 22); + RE(536870933, 23); + RE(536870933, 24); + RE(536870933, 25); + RE(536870933, 26); + RE(536870933, 27); + RE(536870933, 30); + RE(536870933, 31); + RE(536870933, 32); + RE(536870933, 37); + RE(536870933, 43); + RE(536870933, 44); + RE(536870933, 45); + RE(536870933, 46); + RE(536870933, 48); + RE(536870933, 49); + RE(536870933, -1); + YaccRows[131] := Row; + // [132] + R(0, 0, 27); + RE(536870954, 10); + RE(536870954, 12); + RE(536870954, 14); + RE(536870954, 15); + RE(536870954, 16); + RE(536870954, 17); + RE(536870954, 18); + RE(536870954, 19); + RE(536870954, 20); + RE(536870954, 21); + RE(536870954, 22); + RE(536870954, 23); + RE(536870954, 24); + RE(536870954, 25); + RE(536870954, 26); + RE(536870954, 27); + RE(536870954, 30); + RE(536870954, 31); + RE(536870954, 32); + RE(536870954, 37); + RE(536870954, 43); + RE(536870954, 44); + RE(536870954, 45); + RE(536870954, 46); + RE(536870954, 48); + RE(536870954, 49); + RE(536870954, -1); + YaccRows[132] := Row; + // [133] + R(0, 0, 25); + RE(536870932, 10); + RE(536870932, 12); + RE(536870932, 14); + RE(536870932, 15); + RE(536870932, 16); + RE(536870932, 17); + RE(536870932, 18); + RE(536870932, 19); + RE(536870932, 20); + RE(536870932, 21); + RE(536870932, 22); + RE(536870932, 23); + RE(536870932, 24); + RE(536870932, 27); + RE(536870932, 30); + RE(536870932, 31); + RE(536870932, 32); + RE(536870932, 37); + RE(536870932, 43); + RE(536870932, 44); + RE(536870932, 45); + RE(536870932, 46); + RE(536870932, 48); + RE(536870932, 49); + RE(536870932, -1); + YaccRows[133] := Row; + + {$ENDREGION} + + RowArray := YaccRows; + ProdArray := YaccProds; +end; + + end. + diff --git a/Source/ObjectSpace/PessimisticLocking/BoldLockHandler.pas b/Source/ObjectSpace/PessimisticLocking/BoldLockHandler.pas index 923c2d32..486a2a58 100644 --- a/Source/ObjectSpace/PessimisticLocking/BoldLockHandler.pas +++ b/Source/ObjectSpace/PessimisticLocking/BoldLockHandler.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLockHandler; interface @@ -14,8 +17,8 @@ interface BoldLockHolder; resourcestring - BOLD_GET_LOCKS_FAILED_ERROR = 'Failed to get locks'; - + BOLD_GET_LOCKS_FAILED_ERROR = '%s locked by %s'; + type TBoldFailureGetLocksFailed = class; @@ -59,7 +62,7 @@ TBoldEmptyLockHolder = class(TBoldAbstractLockHolder) function EnsureLocks: Boolean; override; procedure GetPropagationEvents(EventList: TStringList); override; end; - + {$IFNDEF BOLD_NO_QUERIES} TBoldPessimisticLockHandler = class(TBoldAbstractPessimisticLockHandler) private fRequiredShared: TBoldRegionList; @@ -70,7 +73,7 @@ TBoldPessimisticLockHandler = class(TBoldAbstractPessimisticLockHandler) fParentsChangedRegions: TBoldRegionList; fSubregionsChangedRegions: TBoldRegionList; fLockHolder: TBoldAbstractLockHolder; - fSubscriber: TBoldPassthroughSubscriber; + fSubscriber: TBoldExtendedPassthroughSubscriber; fOnActivityPropgress: TBoldLockManagerProgressEvent; fOnActivityStart: TNotifyEvent; fOnActivityEnd: TNotifyEvent; @@ -102,7 +105,7 @@ TBoldPessimisticLockHandler = class(TBoldAbstractPessimisticLockHandler) destructor Destroy; override; function LockElement(Element: TBoldDomainElement): Boolean; override; function EnsureLocks: Boolean; override; - procedure ReleaseUnneededRegions; override; + procedure ReleaseUnNeededRegions; override; property RequiredShared: TBoldRegionList read GetRequiredShared; property RequiredExclusive: TBoldRegionList read GetRequiredExclusive; property OnActivityStart: TNotifyEvent read fOnActivityStart write fOnActivityStart; @@ -110,6 +113,7 @@ TBoldPessimisticLockHandler = class(TBoldAbstractPessimisticLockHandler) property OnProgress: TBoldLockManagerProgressEvent read fOnActivityPropgress write fOnActivityPropgress; end; + {$ENDIF} implementation uses @@ -119,7 +123,6 @@ implementation BoldObjectSpaceExternalEvents, BoldDefaultID, BoldIndex, - HandlesConst, BoldElements; function NewRegionListFromStrings(Locks: TStrings; Factory: TBoldRegionFactory): TBoldRegionList; @@ -142,6 +145,7 @@ procedure RegionListToLockList(RegionList: TBoldRegionList; LockList: TBoldLockL { TBoldPessimisticLockHandler } +{$IFNDEF BOLD_NO_QUERIES} constructor TBoldPessimisticLockHandler.CreateWithLockHolder(System: TBoldSystem; LockHolder: TBoldAbstractLockHolder); begin inherited Create(System); @@ -154,13 +158,12 @@ constructor TBoldPessimisticLockHandler.CreateWithLockHolder(System: TBoldSystem fParentsChangedRegions := TBoldRegionList.Create; fSubregionsChangedRegions := TBoldRegionList.Create; - fSubscriber := TBoldPassthroughSubscriber.CreateWithReceiveAndAnswer(_ReceiveRolledBack, _AnswerMayCommit); + fSubscriber := TBoldExtendedPassthroughSubscriber.CreateWithReceiveAndAnswer(_ReceiveRolledBack, _AnswerMayCommit); System.AddSubscription(fSubscriber, bqMayCommit, bqMayCommit); System.AddSubscription(fSubscriber, beRolledBack, beRolledBack); System.PessimisticLockHandler := self; fLockHolder := LockHolder; - // this should be replaced with a subscription-mechanism Factory.OnRegionChanged := _RegionChanged; end; @@ -209,11 +212,9 @@ procedure TBoldPessimisticLockHandler.EnsureAllRequiredRegions; KnownRequiredOrHeldParentRegions.AddRegionLookup(fKnownRequiredParents); - // we know that the Explicit regions are ParentRegions... AddHeldLocksToRegionLookup(KnownRequiredOrHeldParentRegions, false); KnownRequiredOrHeldSubregions.AddRegionLookup(fKnownRequiredSubregions); - // we know that all held regions are atleast subregions... AddHeldLocksToRegionLookup(KnownRequiredOrHeldSubregions, true); Expander.ExpandParentRegions(RegionsToExpand, KnownRequiredOrHeldParentRegions, KnownRequiredOrHeldSubregions); @@ -252,12 +253,14 @@ function TBoldPessimisticLockHandler.GetRequiredLocks: Boolean; SharedLocks, ExclusiveLocks: TBoldLockList; HeldLocks, ClientsHoldingRequestedLocks: TStringList; ConflictingRegions: TBoldRegionList; + Clients: string; + Guard: IBoldGuard; begin + Guard := TBoldGuard.Create(SharedLocks, ExclusiveLocks, HeldLocks, ClientsHoldingRequestedLocks, ConflictingRegions); SharedLocks := TBoldLockList.Create; ExclusiveLocks := TBoldLockList.Create; HeldLocks := TStringList.Create; ClientsHoldingRequestedLocks := TStringList.Create; - try EnsureAllRequiredRegions; RegionListToLockList(fRequiredShared, SharedLocks); RegionListToLockList(fRequiredExclusive, ExclusiveLocks); @@ -279,14 +282,12 @@ function TBoldPessimisticLockHandler.GetRequiredLocks: Boolean; if not result then begin ConflictingRegions := NewRegionListFromStrings(HeldLocks, Factory); - SetBoldLastFailureReason(TBoldFailureGetLocksFailed.Create(BOLD_GET_LOCKS_FAILED_ERROR, nil, ConflictingRegions, ClientsHoldingRequestedLocks)); - ConflictingRegions.Free; - end; - finally - SharedLocks.Free; - ExclusiveLocks.Free; - FreeAndNil(HeldLocks); - FreeAndNil(ClientsHoldingRequestedLocks); + clients := ''; + if ClientsHoldingRequestedLocks.Count > 0 then + Clients := ClientsHoldingRequestedLocks.ValueFromIndex[0]; + SetBoldLastFailureReason(TBoldFailureGetLocksFailed.Create( + Format(BOLD_GET_LOCKS_FAILED_ERROR, [ConflictingRegions.AsString, clients]) + , nil, ConflictingRegions, ClientsHoldingRequestedLocks)); end; end; @@ -309,6 +310,7 @@ function TBoldPessimisticLockHandler.LockElement(Element: TBoldDomainElement): B for i := 0 to Regions.Count - 1 do RequireRegionExplicit(Regions[i]); +// REMOVED FOR TESTING if System.InTransaction then result := true else @@ -360,26 +362,28 @@ function TBoldPessimisticLockHandler.ArePropagationEventsInConflictWithRequiredR EventList: TStringList; i, j: integer; ClassName, MemberName, LockName: string; - ObjectID: TBoldDefaultID; + ObjectID, ExactId: TBoldDefaultID; EventType: TBoldObjectSpaceSubscriptionType; CurrObj: TBoldObject; CurrMember: TBoldMember; RegionList: TBoldRegionList; + Guard: IBoldGuard; begin + Guard := TBoldGuard.Create(EventList,ObjectId,ExactId,RegionList); Result := false; EventList := TStringList.Create; ObjectID:= TBoldDefaultID.CreateWithClassID(0, False); RegionList := TBoldRegionList.Create; - try fLockHolder.GetPropagationEvents(EventList); for i:= 0 to EventList.Count - 1 do begin EventType := TBoldObjectSpaceExternalEvent.DecodeExternalEvent(EventList[i], ClassName, MemberName, LockName, ObjectID); + ExactId := ObjectID.CloneWithClassId(System.BoldSystemTypeInfo.ClassTypeInfoByExpressionName[ClassName].TopSortedIndex, true) as TBoldDefaultID; case EventType of bsClassChanged:; bsEmbeddedStateOfObjectChanged: begin - CurrObj := System.EnsuredLocatorByID[ObjectID].EnsuredBoldObject; + CurrObj := System.EnsuredLocatorByID[ExactId].EnsuredBoldObject; for j:= 0 to CurrObj.BoldMemberCount - 1 do begin CurrMember := CurrObj.BoldMembers[j]; @@ -390,18 +394,13 @@ function TBoldPessimisticLockHandler.ArePropagationEventsInConflictWithRequiredR end; bsNonEmbeddedStateOfObjectChanged: begin - CurrObj := System.EnsuredLocatorByID[ObjectID].EnsuredBoldObject; + CurrObj := System.EnsuredLocatorByID[ExactId].EnsuredBoldObject; CurrMember := CurrObj.BoldMemberByExpressionName[MemberName]; result := IsElementInAnyRequiredRegion(CurrMember); end; end; if result then Break; end; - finally - FreeAndNil(EventList); - FreeAndNil(ObjectID); - FreeAndNil(RegionList); - end; end; function TBoldPessimisticLockHandler.IsElementInAnyRequiredRegion( @@ -432,16 +431,19 @@ procedure TBoldPessimisticLockHandler.ReleaseUnNeededRegions; UnRequiredLocks, RequiredExclusiveLocks, RequiredSharedLocks: TBoldLockList; LockName: string; TrueLockHolder: TBoldAbstractLockHolder; + Guard: IBoldGuard; begin - Elements := TList.Create; + Guard := TBoldGuard.Create(Elements, UnRequiredLocks, RequiredExclusiveLocks, RequiredSharedLocks, aTraverser); UnRequiredLocks := TBoldLockList.Create; RequiredSharedLocks := TBoldLockList.Create; RequiredExclusiveLocks := TBoldLockList.Create; TrueLockHolder := fLockHolder; try - aTraverser := fLockHolder.HeldExclusive.CreateTraverser; - try - while not aTraverser.EndOfList do + if fLockHolder.HeldExclusive.Count > 0 then + begin + Elements := TList.Create; + aTraverser := fLockHolder.HeldExclusive.CreateTraverser; + while aTraverser.MoveNext do begin LockName := (aTraverser.Item as TBoldLock).Name; if LockName <> BOLD_DBLOCK_NAME then @@ -452,16 +454,11 @@ procedure TBoldPessimisticLockHandler.ReleaseUnNeededRegions; if ElementListContainsDirtyElements(Elements) then RequireRegionExplicit(CurrentRegion); end; - aTraverser.Next; end; - finally - aTraverser.Free; end; - // since the regionExpander will cut the expansion tree with the held locks, we need to fake - // an empty lockholder for this excersise. The expansion will occur in the getmethod of RequiredExclusive and RequiredShared... fLockHolder := TBoldEmptyLockHolder.Create; - + RegionListToLockList(RequiredExclusive, RequiredExclusiveLocks); RegionListToLockList(RequiredShared, RequiredSharedLocks); @@ -475,11 +472,7 @@ procedure TBoldPessimisticLockHandler.ReleaseUnNeededRegions; fLockHolder.Release(UnRequiredLocks); finally - FreeAndNil(Elements); - FreeAndNil(UnRequiredLocks); - FreeAndNil(RequiredSharedLocks); - FreeAndNil(RequiredExclusiveLocks); - fLockHolder := TrueLockHolder; // Just in case + fLockHolder := TrueLockHolder; end; end; @@ -590,14 +583,12 @@ procedure TBoldPessimisticLockHandler.AddHeldLocksToRegionLookup(RegionLookup: T begin Guard := TBoldGuard.CReate(Traverser); Traverser := List.CreateTraverser; - while not Traverser.EndOfList do + while Traverser.MoveNext do begin RegionId := (Traverser.Item as TBoldLock).Name; - // Only check locks that are region-locks if (pos('.', RegionId) <> 0) then if not assigned(RegionLookup.FindByID(RegionId)) then RegionLookup.Add(Factory.GetRegionByName(RegionId)); - Traverser.Next; end; end; @@ -606,7 +597,7 @@ procedure TBoldPessimisticLockHandler.AddHeldLocksToRegionLookup(RegionLookup: T if AddSharedRegions then Add(fLockHolder.HeldShared); end; - + {$ENDIF} { TBoldFailureGetLocksFailed } @@ -656,7 +647,7 @@ destructor EBoldGetLocksFailed.Destroy; end; -{ TBoldEmptyLockHolder } + { BoldEmptyLockHolder } constructor TBoldEmptyLockHolder.Create; begin diff --git a/Source/ObjectSpace/PessimisticLocking/BoldLockHolder.pas b/Source/ObjectSpace/PessimisticLocking/BoldLockHolder.pas index 467edfb0..fe589f42 100644 --- a/Source/ObjectSpace/PessimisticLocking/BoldLockHolder.pas +++ b/Source/ObjectSpace/PessimisticLocking/BoldLockHolder.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLockHolder; interface @@ -17,13 +20,12 @@ interface TBoldLock = class; TBoldLockList = class; TBoldLockHolder = class; -// TBoldDatabaseLock = class; TBoldLock = class(TBoldMemoryManagedObject) private fName: string; public - constructor Create(Name: string); + constructor Create(const Name: string); property Name: string read fName; end; @@ -36,16 +38,16 @@ { TBoldDatabaseLock = class(TBoldLock) } TBoldLockList = class(TBoldStringHashIndex) protected - function ItemAsKeyString(Item: TObject): string; override; + function ItemASKeyString(Item: TObject): string; override; public destructor Destroy; override; procedure Add(Item: TObject); override; procedure AddList(List: TBoldLockList); - procedure AddLock(Name: string); + procedure AddLock(const Name: string); function AsOLEVariant: OleVariant; - function Includes(Name: string): Boolean; + function Includes(const Name: string): Boolean; procedure RemoveList(List: TBoldLockList); - procedure RemoveLock(Name: string); + procedure RemoveLock(const Name: string); end; TBoldAbstractLockHolder = class(TBoldMemoryManagedObject) @@ -72,7 +74,7 @@ TBoldLockHolder = class(TBoldAbstractLockHolder) fDequeuer: TBoldAbstractDequeuer; procedure WaitForWakeup; procedure WakeUp; - function _ListenerMessage(Msg: string): Boolean; + function _ListenerMessage(const Msg: string): Boolean; protected function GetHeldExclusive: TBoldLockList; override; function GetHeldShared: TBoldLockList; override; @@ -82,12 +84,13 @@ TBoldLockHolder = class(TBoldAbstractLockHolder) function Lock(Shared: TBoldLockList; Exclusive: TBoldLockList; HeldLocks, ClientsHoldingRequestedLocks: TStringList): Boolean; override; procedure Release(Locks: TBoldLockList); override; function EnsureLocks: Boolean; override; - function LockDatabase: Boolean; + function LockDatabase: Boolean; procedure GetPropagationEvents(EventList: TStringList); override; property TimeOut: Integer read fTimeOut write fTimeOut; property LockManager: IBoldLockManager read fLockManager write fLockManager; end; + implementation uses @@ -97,8 +100,8 @@ implementation BoldIndex, BoldLockingDefs, BoldObjectSpaceExternalEvents, - BoldDefaultID, - BoldCoreConsts; + BoldDefaultID + ; { TBoldLockHolder } @@ -144,7 +147,7 @@ function TBoldLockHolder.GetHeldShared: TBoldLockList; procedure TBoldLockHolder.GetPropagationEvents(EventList: TStringList); begin - fListener.Queue.AppendToStringList(EventList); + fListener.InQueue.AppendToStringList(EventList); end; function TBoldLockHolder.Lock(Shared: TBoldLockList; Exclusive: TBoldLockList; HeldLocks, ClientsHoldingRequestedLocks: TStringList): Boolean; @@ -166,7 +169,6 @@ function TBoldLockHolder.Lock(Shared: TBoldLockList; Exclusive: TBoldLockList; H WaitForWakeup; fHeldShared.AddList(Shared); fHeldExclusive.AddList(Exclusive); - // upgrade shared locks that we now aquired as exclusive fHeldShared.RemoveList(Exclusive); end else @@ -185,7 +187,7 @@ function TBoldLockHolder.LockDatabase: Boolean; ConflictingUsers: TStringList; begin if not assigned(fDequeuer) then - raise EBold.CreateFmt(sNoDequeuerAvailable, [classname]); + raise EBold.CreateFmt('%s.LockDatabase: there is no dequeuer available', [classname]); SharedLocks := TBoldLockList.Create; ExclusiveLocks := TBoldLockList.Create; Conflicts := TStringList.Create; @@ -217,7 +219,7 @@ procedure TBoldLockHolder.Release(Locks: TBoldLockList); procedure TBoldLockHolder.WaitForWakeup; begin if fWakeUpEvent.WaitFor(Timeout) <> wrSignaled then - raise EBold.CreateFmt(sOperationTimedOut, [ClassName]); + raise EBold.CreateFmt('%s.WaitForWakeUp: Operation timed out', [ClassName]); fWakeUpEvent.ResetEvent; end; @@ -226,7 +228,7 @@ procedure TBoldLockHolder.WakeUp; fWakeUpEvent.SetEvent; end; -function TBoldLockHolder._ListenerMessage(Msg: string): Boolean; +function TBoldLockHolder._ListenerMessage(const Msg: string): Boolean; var ClassName, MemberName, LockName: string; begin @@ -240,7 +242,7 @@ function TBoldLockHolder._ListenerMessage(Msg: string): Boolean; { TBoldLock } -constructor TBoldLock.Create(Name: string); +constructor TBoldLock.Create(const Name: string); begin fName := Name; end; @@ -250,7 +252,7 @@ constructor TBoldLock.Create(Name: string); procedure TBoldLockList.Add(Item: TObject); begin if not (Item is TBoldLock) then - raise EBold.CreateFmt(sWrongItemType, [classname, Item.classname]); + raise EBold.CreateFmt('%s.Add: Item should be TBoldLock, but is %s', [classname, Item.classname]); inherited; end; @@ -258,19 +260,18 @@ procedure TBoldLockList.AddList(List: TBoldLockList); var aTraverser: TBoldIndexTraverser; begin + if List.Count = 0 then + exit; aTraverser := List.CreateTraverser; try - while not aTraverser.EndOfList do - begin + while aTraverser.MoveNext do AddLock(TBoldLock(aTraverser.Item).Name); - aTraverser.Next; - end; finally aTraverser.Free; end; end; -procedure TBoldLockList.AddLock(Name: string); +procedure TBoldLockList.AddLock(const Name: string); begin if not Includes(Name) then Add(TBoldLock.Create(Name)); @@ -285,24 +286,23 @@ function TBoldLockList.AsOLEVariant: OleVariant; aTraverser := CreateTraverser; try i := 0; - while not aTraverser.EndOfList do + while aTraverser.MoveNext do begin result[i] := (aTraverser.Item as TBoldLock).Name; inc(i); - aTraverser.Next; end; finally aTraverser.Free; end; end; -destructor TBoldLockList.Destroy; +destructor TBoldLockList.destroy; begin Clear(True); inherited; end; -function TBoldLockList.Includes(Name: string): Boolean; +function TBoldLockList.Includes(const Name: string): Boolean; begin result := assigned(FindByString(Name)); end; @@ -317,30 +317,27 @@ procedure TBoldLockList.RemoveList(List: TBoldLockList); aTraverser: TBoldIndexTraverser; aLock: TBoldLock; begin + if (count = 0) or (List.Count = 0) then + exit; if List.Count > Count then begin aTraverser := CreateTraverser; - while not aTraverser.EndOfList do - begin - aLock := aTraverser.Item as TBoldLock; - aTraverser.Next; - if List.Includes(aLock.Name) then - RemoveLock(aLock.Name); - end; + while aTraverser.MoveNext do // double while loop is needed as removing from traversing list moves to next item automatically on remove + while Assigned(aTraverser.Item) and List.Includes((aTraverser.Item as TBoldLock).Name) do + RemoveLock((aTraverser.Item as TBoldLock).Name); aTraverser.Free; end else begin aTraverser := List.CreateTraverser; - while not aTraverser.EndOfList do + while aTraverser.MoveNext do begin RemoveLock((aTraverser.Item as TBoldLock).Name); - aTraverser.Next; end; aTraverser.Free; end; end; -procedure TBoldLockList.RemoveLock(Name: string); +procedure TBoldLockList.RemoveLock(const Name: string); var Item: TObject; begin @@ -365,4 +362,6 @@ constructor TBoldDatabaseLock.Create; inherited Create(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsDBLock, '', '', '', nil)); end; } +initialization + end. diff --git a/Source/ObjectSpace/PessimisticLocking/BoldLockRegions.pas b/Source/ObjectSpace/PessimisticLocking/BoldLockRegions.pas index 16f0dd1a..8ca8ca0e 100644 --- a/Source/ObjectSpace/PessimisticLocking/BoldLockRegions.pas +++ b/Source/ObjectSpace/PessimisticLocking/BoldLockRegions.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLockRegions; interface @@ -9,14 +12,11 @@ interface BoldSystemRT, BoldDefs, BoldBase, - BoldElements, - BoldGuard, BoldDomainElement, BoldRegionDefinitions, BoldLogHandler, BoldIndexableList; - const breNone = 0; breParentsChanged = 1; @@ -72,13 +72,26 @@ TBoldRegionFactory = class(TBoldAbstractRegionFactory) property OnRegionChanged: TBoldRegionEvent read fOnRegionChanged write fOnRegionChanged; end; + TBoldRegionLookupTraverser = class(TBoldIndexableListTraverser) + private + function GetRegion: TBoldRegion; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + public + property Region: TBoldRegion read GetRegion; + property Current: TBoldRegion read GetRegion; + end; + TBoldRegionLookup = class(TBoldUnOrderedIndexableList) private + class var IX_RegionId: integer; procedure ExpandOneLevelRegionsForNavigation(Regions: TBoldRegionLookup; Navigation: TBoldRoleRTInfo; CoreDef: TBoldRegionCoreDefinition; AlreadyExpandedRegions, AlreadyKnownRegions: TBoldregionLookup); procedure AddIfNotInLookup(Region: TBoldRegion); + protected + function TraverserClass: TBoldIndexableListTraverserClass; override; public constructor Create; - function FindByID(RegionId: string): TBoldRegion; + function CreateTraverser: TBoldRegionLookupTraverser; + function GetEnumerator: TBoldRegionLookupTraverser; + function FindByID(RegionId: string): TBoldRegion; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure AddRegionLookup(Regions: TBoldRegionLookup); procedure AddRegionLookupWithFilter(Regions: TBoldRegionLookup; Filter: TBoldRegionLookup); procedure AddRegionList(Regions: TBoldRegionList); @@ -89,7 +102,8 @@ TBoldRegionLookup = class(TBoldUnOrderedIndexableList) TBoldOrderedRegionLookup = class(TBoldRegionLookup) private - function GetFirstRegion: TBoldRegion; + class var IX_RegionOrder: integer; + function GetFirstRegion: TBoldRegion; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public constructor Create; property FirstRegion: TBoldRegion read GetFirstRegion; @@ -99,12 +113,13 @@ TBoldOrderedRegionLookup = class(TBoldRegionLookup) TBoldRegionList = class(TList) private function GetItems(i: Integer): TBoldRegion; + function GetAsString: string; public procedure AddList(List: TBoldRegionList); procedure AddRegionLookup(Regions: TBoldRegionLookup); procedure Assign(List: TBoldRegionList); -// procedure EnsureSubRegionObjects; property Items[i: Integer]: TBoldRegion read GetItems; default; + property AsString: string read GetAsString; end; { TBoldRegionState = @@ -128,10 +143,13 @@ TBoldRegionExpander = class(TBoldMemoryManagedObject) destructor Destroy; override; procedure ExpandParentRegions(RegionsToExpand: TBoldRegionLookup; KnownParentRegions, KnownSubregions: TBoldRegionLookup); procedure ExpandSubregions(RegionsToExpand: TBoldRegionLookup; KnownSubregions: TBoldregionLookup); + procedure ExpandRegionEnclosure(Regions: TBoldRegionLookup); + property NewParentRegions: TBoldRegionLookup read fNewParentRegions; property NewSubRegions: TBoldRegionLookup read fNewSubRegions; property OnProgress: TBoldLockManagerProgressEvent read fOnActivityProgress write fOnActivityProgress; + end; var @@ -141,24 +159,21 @@ implementation uses SysUtils, - BoldUtils, - BoldIndex, - BoldId, BoldDefaultId, + BoldElements, + BoldGuard, BoldHashIndexes, - BoldCoreConsts; - -var - IX_RegionId: integer = -1; - IX_RegionOrder: integer = -1; - + BoldId, + BoldIndex, + BoldRev; type TBoldRegionIndex = class(TBoldStringHashIndex) protected - function ItemAsKeyString(Item: TObject): string; override; + function ItemASKeyString(Item: TObject): string; override; end; + procedure NavigateAndSubscribe(Obj: TBoldObject; RoleRT: TBoldRoleRtInfo; ResultElement: TBoldIndirectElement; Subscriber: TBoldSubscriber; RequestedEvent: Integer); var aMember: TBoldMember; @@ -170,7 +185,7 @@ procedure NavigateAndSubscribe(Obj: TBoldObject; RoleRT: TBoldRoleRtInfo; Result if (aMember is TBoldObjectList) or (aMember is TBoldObjectReference) then AMember.GetAsList(ResultElement) else - raise EBoldInternal.CreateFmt(sTriedToNavigateNonAssociation, [Obj.BoldClassTypeInfo.ExpressionName, aMember.BoldMemberRTInfo.ExpressionName]); + raise EBoldInternal.CreateFmt('Tried to navigate %s.%s that is not an association', [Obj.BoldClassTypeInfo.ExpressionName, aMember.BoldMemberRTInfo.ExpressionName]); if assigned(Subscriber) then aMember.DefaultSubscribe(Subscriber, RequestedEvent); end @@ -192,6 +207,19 @@ procedure DoNavigationAndSubscribe(Obj: TBoldObject; Navigation: TBoldRoleRTInfo NavigateAndSubscribe(Obj, Navigation, ResultElement, Subscriber, RequestedEvent); end; +{ TBoldOrderedRegionLookup } + +constructor TBoldOrderedRegionLookup.Create; +begin + inherited; + SetIndexVariable(IX_RegionOrder, AddIndex(TBoldIntegerIndex.Create)); +end; + +function TBoldOrderedRegionLookup.GetFirstRegion: TBoldRegion; +begin + Result := (Indexes[IX_RegionOrder] as TBoldIntegerIndex).items[0] as TBoldRegion; +end; + { TBoldRegion } constructor TBoldRegion.Create(Definition: TBoldConcreteRegionDefinition; @@ -202,12 +230,10 @@ constructor TBoldRegion.Create(Definition: TBoldConcreteRegionDefinition; fFactory := Factory; fDefinition := Definition; PlaceRootSubscriptions; -// BoldLog.Log('RegConstr: '+AsString + ':' + RootLocator.BoldObject.ClassName + ':'+IntTOStr(Integer(Self))); end; destructor TBoldRegion.Destroy; begin -// BoldLog.Log('RegDestr: '+AsString + ':' + RootLocator.BoldObject.ClassName + ':'+IntTOStr(Integer(Self))); fRootLocator := nil; inherited; end; @@ -265,7 +291,7 @@ function TBoldRegion.GetAsString: string; if assigned(RootLocator) and assigned(RootLocator.BoldObjectID) then result := fFactory.RegionId(Definition.CoreDefinition, RootLocator) else - raise EBoldInternal.CreateFmt(sRegionMissingIDOrLocator, [ClassName]); + raise EBoldInternal.Create('TBoldRegion.GetAsString: Region is missing either a locator or an ID'); end; procedure TBoldRegion.GetElements(ResultList: TList); @@ -292,15 +318,13 @@ procedure TBoldRegion.Receive(Originator: TObject; OriginalEvent: TBoldEvent; Re if (Originator is TBoldObject) and not assigned(TBoldObject(Originator).BoldObjectLocator) and not assigned(RootLocator.BoldObject) then begin - // The object has been destroyed without getting a proper locator. - // We must be very careful. + fFactory.fLookup.ItemChanged(self); fFactory.fLookup.Remove(self); end else if (Originator = Root) then begin case OriginalEvent of - // removing the region form the factory lookup will destroy it automatically beDestroying: fFactory.fLookup.Remove(self); @@ -319,6 +343,21 @@ procedure TBoldRegion.Receive(Originator: TObject; OriginalEvent: TBoldEvent; Re end; end; +function TBoldRegionLookup.FindByID(RegionId: string): TBoldRegion; +begin + result := (Indexes[IX_RegionId] as TBoldStringHashIndex).FindByString(RegionId) as TBoldRegion; +end; + +function TBoldRegionLookup.GetEnumerator: TBoldRegionLookupTraverser; +begin + result := CreateTraverser as TBoldRegionLookupTraverser; +end; + +function TBoldRegionLookup.TraverserClass: TBoldIndexableListTraverserClass; +begin + result := TBoldRegionLookupTraverser; +end; + { TBoldRegionFactory } function TBoldRegionFactory.CoreDefintionFromRegionId( @@ -326,7 +365,7 @@ function TBoldRegionFactory.CoreDefintionFromRegionId( begin result := fDefinitions.CoreDefinition[Copy(RegionId, Pos('.', RegionId)+1, MaxInt)]; if not assigned(Result) then - raise EBoldInternal.CreateFmt(sBadRegionID, [classname, 'CoreDefintionFromRegionId', RegionId]); // do not localize + raise EBoldInternal.CreateFmt('%s.CoreDefinitionFromRegionId: Erroneous RegionId %s', [classname, RegionId]); end; constructor TBoldRegionFactory.Create(Definitions: TBoldRegionDefinitions); @@ -343,6 +382,7 @@ destructor TBoldRegionFactory.Destroy; inherited; end; + function TBoldRegionFactory.GetRegion( Definition: TBoldRegionCoreDefinition; RootLocator: TBoldObjectLocator): TBoldRegion; var @@ -353,7 +393,7 @@ function TBoldRegionFactory.GetRegion( begin ConcreteDef := Definition.ConcreteDefinitions.FindByRootClass(RootLocator.EnsuredBoldObject.BoldClassTypeInfo); if not assigned(ConcreteDef) then - raise EBold.CreateFmt(sBadRegionDefinition, [classname, Definition.Name, RootLocator.EnsuredBoldObject.BoldClassTypeInfo.ExpressionName]); + raise EBold.CreateFmt('%s.GetRegion: Erroneous region definitions. The region %s does not have %s as root class.', [classname, Definition.Name, RootLocator.EnsuredBoldObject.BoldClassTypeInfo.ExpressionName]); result := TBoldRegion.Create(ConcreteDef, RootLocator, Self); fLookup.Add(result); end; @@ -403,7 +443,7 @@ function TBoldRegionFactory.RegionId(Definition: TBoldRegionCoreDefinition; begin result := RootLocator.BoldObjectID.AsString + '.' + Definition.Name; if RootLocator.BoldObjectID is TBoldInternalObjectId then - result := 'i' + Result; + result := 'i' + Result; end; function TBoldRegionFactory.RootObjectLocatorFromRegionId(RegionId: string): TBoldObjectLocator; @@ -418,13 +458,13 @@ function TBoldRegionFactory.RootObjectLocatorFromRegionId(RegionId: string): TBo begin AsInt := StrToIntDef(Copy(RegionId, 2, Pos('.', RegionId)-1), -1); if AsInt = -1 then - raise EBoldInternal.CreateFmt(sBadRegionID, [classname, 'RootObjectFromRegionId', RegionId]); // do not localize + raise EBoldInternal.CreateFmt('%s.RootObjectFromRegionId: Erroneous RegionId %s', [classname, RegionId]); ObjId := TBoldInternalObjectId.CreateWithClassIDandInternalId(AsInt, 0, false); end else begin AsInt := StrToIntDef(Copy(RegionId, 1, Pos('.', RegionId)-1), -1); if AsInt = -1 then - raise EBoldInternal.CreateFmt(sBadRegionID, [classname, 'RootObjectFromRegionId', RegionId]); // do not localize + raise EBoldInternal.CreateFmt('%s.RootObjectFromRegionId: Erroneous RegionId %s', [classname, RegionId]); ObjId := TBoldDefaultID.CreateWithClassID(0, false); (ObjId as TBoldDefaultId).AsInteger := AsInt; end; @@ -443,20 +483,12 @@ function TBoldRegionIndex.ItemASKeyString(Item: TObject): string; { TBoldRegionLookup } -procedure TBoldRegionLookup.AddRegionLookup(Regions: TBoldregionLookup); +procedure TBoldRegionLookup.AddRegionLookup(Regions: TBoldRegionLookup); var - Traverser: TBoldIndexableListTraverser; + Region: TBoldRegion; begin - Traverser := Regions.CreateTraverser; - try - while not Traverser.EndOfList do - begin - AddIfNotInLookup(Traverser.Item as TBoldRegion); - Traverser.Next; - end; - finally - Traverser.Free; - end; + for Region in Regions do + AddIfNotInLookup(Region); end; constructor TBoldRegionLookup.Create; @@ -464,20 +496,18 @@ constructor TBoldRegionLookup.Create; SetIndexVariable(IX_RegionId, AddIndex(TBoldRegionIndex.Create)); end; +function TBoldRegionLookup.CreateTraverser: TBoldRegionLookupTraverser; +begin + result := TBoldRegionLookupTraverser(inherited CreateTraverser); + Assert(Result is TBoldRegionLookupTraverser); +end; + procedure TBoldRegionLookup.FillObjectList(ObjectList: TBoldObjectList); var - Traverser: TBoldIndexableListTraverser; + Region: TBoldRegion; begin - Traverser := CreateTraverser; - try - while not Traverser.EndOfList do - begin - ObjectList.AddLocator((Traverser.Item as TBoldRegion).RootLocator); - Traverser.Next; - end; - finally - Traverser.Free; - end; + for Region in self do + ObjectList.AddLocator(Region.RootLocator); end; procedure TBoldRegionLookup.FetchAndExpandOneLevelParentRegions(ParentRegions: TBoldRegionLookup; AlreadyExpandedRegions, AlreadyKnownRegions: TBoldRegionLookup); @@ -518,10 +548,11 @@ procedure TBoldRegionLookup.FetchAndExpandOneLevelParentRegions(ParentRegions: T assert(ReverseRole.RoleType = rtLinkRole); end; else - raise EBoldInternal.CreateFmt(sUnknownRoleType, [ClassName, Navigation.AsString]); + raise EBoldInternal.CreateFmt('%s.FetchAndExpandOneLevelParentRegions: unknown roletype of role %s', [ + ClassName, Navigation.AsString]); end; assert(ConcreteDef.RootClass.Conformsto(ReverseRole.ClassTypeInfo)); - assert(ObjectList[0].BOldClassTypeInfo.Conformsto(ReverseRole.ClassTypeInfo)); + assert(ObjectList[0].BoldClassTypeInfo.ConformsTo(ReverseRole.ClassTypeInfo)); ObjectList[0].BoldSystem.FetchLinksWithObjects(ObjectList, ReverseRole.ExpressionName); ExpandOneLevelRegionsForNavigation(ParentRegions, ReverseRole, SubRegionRef.ParentRegion.CoreDefinition, AlreadyExpandedRegions, AlreadyKnownRegions); @@ -529,6 +560,7 @@ procedure TBoldRegionLookup.FetchAndExpandOneLevelParentRegions(ParentRegions: T end; end; + procedure TBoldRegionLookup.FetchAndExpandOneLevelSubRegions(SubRegions: TBoldRegionLookup; AdditionalRegions: TBoldRegionLookup; AlreadyExpandedRegions, AlreadyKnownRegions: TBoldregionLookup); procedure MassiveFetch(System: TBoldSystem; ObjectList: TBoldObjectList; RoleRTInfo: TBoldRoleRTInfo ); var @@ -539,7 +571,6 @@ procedure TBoldRegionLookup.FetchAndExpandOneLevelSubRegions(SubRegions: TBoldRe FetchNeeded: Boolean; i: integer; begin - // first, check if we actually need to fetch anything right now TempObjectLIst := ObjectLIst.Clone as TBoldObjectList; try FetchNeeded := false; @@ -551,26 +582,23 @@ procedure TBoldRegionLookup.FetchAndExpandOneLevelSubRegions(SubRegions: TBoldRe if FetchNeeded then begin - // If we need to fetch any relations in the original set, then add all the unprocessed objects - // that have the same link. + DefiningClass := RoleRTINfo.ClassTypeInfo; while DefiningClass.FirstOwnMemberIndex > RoleRTInfo.index do DefiningClass := DefiningClass.SuperClassTypeInfo; Traverser := AdditionalRegions.CreateTraverser; try - while not Traverser.EndOfList do + while Traverser.MoveNext do begin aRegion := Traverser.Item as TBoldRegion; if aRegion.fDefinition.RootClass.ConformsTo(DefiningClass) then TempObjectList.AddLocator(aRegion.RootLocator); - Traverser.Next; end; finally Traverser.Free; end; end; - // even if the links are fetched, the objects might not be, so we better call FetchLinksWithObjects anyway. System.FetchLinksWithObjects(TempObjectList, RoleRTInfo.ExpressionName); finally TempObjectList.Free; @@ -601,11 +629,6 @@ procedure TBoldRegionLookup.FetchAndExpandOneLevelSubRegions(SubRegions: TBoldRe end; end; -function TBoldRegionLookup.FindByID(RegionId: string): TBoldRegion; -begin - result := (Indexes[IX_RegionId] as TBoldRegionIndex).FindByString(RegionId) as TBoldRegion; -end; - procedure TBoldRegionLookup.ExpandOneLevelRegionsForNavigation(Regions: TBoldRegionLookup; Navigation: TBoldRoleRTInfo; CoreDef: TBoldRegionCoreDefinition; AlreadyExpandedRegions, AlreadyKnownRegions: TBoldRegionLookup); procedure ExpandRegion(Region: TBoldRegion); @@ -630,7 +653,7 @@ procedure TBoldRegionLookup.ExpandOneLevelRegionsForNavigation(Regions: TBoldReg Regions.AddIfNotInLookup(NewRegion); end; if (Regions.Count > OldRegionsCount) and assigned(BoldRegionExpansionDebugLogHandler) then - BoldRegionExpansionDebugLogHandler.LogFmt(sLogAddedRegions, [ + BoldRegionExpansionDebugLogHandler.LogFmt('%s.%s Added Regions: %d', [ Region.Root.BoldClassTypeInfo.ExpressionName, Navigation.ExpressionName, Regions.Count - OldRegionsCount]); @@ -641,18 +664,10 @@ procedure TBoldRegionLookup.ExpandOneLevelRegionsForNavigation(Regions: TBoldReg end; var - Traverser: TBoldIndexableListTraverser; + Region: TBoldRegion; begin - Traverser := CreateTraverser; - try - while not Traverser.EndOfList do - begin - ExpandRegion(Traverser.Item as TBoldRegion); - Traverser.Next; - end; - finally - Traverser.Free; - end; + for Region in self do + ExpandRegion(Region); end; procedure TBoldRegionLookup.AddRegionList(Regions: TBoldRegionList); @@ -672,19 +687,11 @@ procedure TBoldRegionLookup.AddIfNotInLookup(Region: TBoldRegion); procedure TBoldRegionLookup.AddRegionLookupWithFilter(Regions, Filter: TBoldRegionLookup); var - Traverser: TBoldIndexableListTraverser; - Guard: IBoldGuard; Region: TBoldRegion; begin - Guard := TBoldGuard.Create(Traverser); - Traverser := Regions.CreateTraverser; - while not Traverser.EndOfList do - begin - Region := Traverser.Item as TBoldRegion; + for Region in Regions do if not assigned(Filter.FindById(Region.AsString)) then AddIfNotInLookup(Region); - Traverser.Next; - end; end; { TBoldRegionList } @@ -700,18 +707,10 @@ procedure TBoldRegionList.AddList(List: TBoldRegionList); procedure TBoldRegionList.AddRegionLookup(Regions: TBoldRegionLookup); var - Traverser: TBoldIndexableListTraverser; + Region: TBoldRegion; begin - Traverser := Regions.CreateTraverser; - try - while not Traverser.EndOfList do - begin - Add(Traverser.Item as TBoldRegion); - Traverser.Next; - end; - finally - Traverser.Free; - end; + for Region in Regions do + Add(Region); end; procedure TBoldRegionList.Assign(List: TBoldRegionList); @@ -762,6 +761,22 @@ procedure TBoldRegionList.Assign(List: TBoldRegionList); end; } +function TBoldRegionList.GetAsString: string; +var + sl: TStringList; + i: integer; +begin + result := ''; + sl := TStringList.Create; + try + for I := 0 to Count - 1 do + sl.Add(self[i].Root.DebugInfo); + finally + result := sl.CommaText; + sl.free; + end; +end; + function TBoldRegionList.GetItems(i: Integer): TBoldRegion; begin result := TObject(inherited Items[i]) as TBoldRegion; @@ -777,7 +792,7 @@ procedure TBoldRegionExpander.Clear; fToBeParentExpanded.Clear; end; -constructor TBoldRegionExpander.create; +constructor TBoldRegionExpander.Create; begin inherited; fNewParentRegions := TBoldRegionLookup.Create; @@ -787,7 +802,7 @@ constructor TBoldRegionExpander.create; fToBeParentExpanded := TBoldOrderedRegionLookup.Create; end; -destructor TBoldRegionExpander.destroy; +destructor TBoldRegionExpander.Destroy; begin FreeAndNil(fNewParentRegions); FreeAndNil(fNewSubregions); @@ -796,8 +811,6 @@ destructor TBoldRegionExpander.destroy; inherited; end; - - { procedure TBoldRegionExpander.ExpandSubAndParentRegions(ExplicitRegions: TBoldRegionList); begin @@ -813,21 +826,18 @@ procedure TBoldRegionExpander.ExpandSubAndParentRegions(ExplicitRegions: TBoldRe procedure TBoldRegionExpander.ExtractSimilarRegions(Regions: TBoldRegionLookup; Region: TBoldRegion; Result: TBoldRegionLookup); var - aRegion: TBoldRegion; - Traverser: TBoldIndexableListTraverser; + Traverser: TBoldRegionLookupTraverser; begin Result.Clear; Traverser := Regions.CreateTraverser; try - while not Traverser.EndOfList do + while Traverser.MoveNext do begin - aRegion := Traverser.Item as TBoldRegion; - if (aRegion.Definition = Region.Definition) and (aRegion.Root.BoldClassTypeINfo = Region.Root.BoldClassTypeInfo) then + while Assigned(Traverser.Region) and (Traverser.Region.Definition = Region.Definition) and (Traverser.Region.Root.BoldClassTypeINfo = Region.Root.BoldClassTypeInfo) do begin - Result.Add(aRegion); - Regions.Remove(aRegion); + Result.Add(Traverser.Region); + Regions.Remove(Traverser.Region); end; - Traverser.Next; end; finally Traverser.Free; @@ -844,7 +854,7 @@ procedure TBoldRegionExpander.ExpandParentRegions( if assigned(BoldRegionExpansionDebugLogHandler) then begin BoldRegionExpansionDebugLogHandler.Separator; - BoldRegionExpansionDebugLogHandler.Log(sLogExpandingParentRegions); + BoldRegionExpansionDebugLogHandler.Log('Expanding Parent regions'); end; Guard := TBoldGuard.Create(SimilarRegions, LocalNewParentRegions); fToBeParentExpanded.AddRegionLookup(RegionsToExpand); @@ -872,7 +882,7 @@ procedure TBoldRegionExpander.ExpandSubregions( if assigned(BoldRegionExpansionDebugLogHandler) then begin BoldRegionExpansionDebugLogHandler.Separator; - BoldRegionExpansionDebugLogHandler.Log(sLogExpandingSubRegions); + BoldRegionExpansionDebugLogHandler.Log('Expanding Subregions'); end; Guard := TBoldGuard.Create(SimilarRegions, LocalNewSubregions); fToBeSubExpanded.AddRegionLookup(RegionsToExpand); @@ -910,17 +920,15 @@ procedure TBoldRegionExpander.ExpandRegionEnclosure(Regions: TBoldRegionLookup); Regions.AddRegionLookup(NewSubRegions); end; -{ TBoldOrderedRegionLookup } - -constructor TBoldOrderedRegionLookup.Create; -begin - inherited; - SetIndexVariable(IX_RegionOrder, AddIndex(TBoldIntegerIndex.Create)); -end; +{ TBoldRegionLookupTraverser } -function TBoldOrderedRegionLookup.GetFirstRegion: TBoldRegion; +function TBoldRegionLookupTraverser.GetRegion: TBoldRegion; begin - Result := (Indexes[IX_RegionOrder] as TBoldIntegerIndex).items[0] as TBoldRegion; + result := inherited Item as TBoldRegion; end; +initialization + TBoldOrderedRegionLookup.IX_RegionOrder := -1; + TBoldRegionLookup.IX_RegionId := -1; end. + diff --git a/Source/ObjectSpace/PessimisticLocking/BoldRegionDefinitionParser.pas b/Source/ObjectSpace/PessimisticLocking/BoldRegionDefinitionParser.pas index 0d6b8606..c5b5bd2e 100644 --- a/Source/ObjectSpace/PessimisticLocking/BoldRegionDefinitionParser.pas +++ b/Source/ObjectSpace/PessimisticLocking/BoldRegionDefinitionParser.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldRegionDefinitionParser; interface @@ -46,26 +49,25 @@ TBoldRegionParser = class (TBoldMemoryManagedObject) procedure GenerateDefaultRegions; public constructor Create(RegionDefinitions: TBoldRegionDefinitions; SystemTypeInfo: TBoldSystemTypeInfo); - destructor Destroy; override; + destructor destroy; override; function Parse(RegionDefinitionList: TStrings): Boolean; property RegionDefinitions: TBoldRegionDefinitions read fRegionDefinitions; property SystemTypeInfo: TBoldSystemTypeInfo read fSystemTypeInfo; property Errors: TStringList read fErrors; end; - // Format - // RegionName\[ClassName\] : memberName (, memberName)* (| RegionName\[memberName\] (, RegionName\[memberName\]*)) - // examples: - // Region1[Person]: firstName, lastName | Region2[home] - // Region1[Building]: zipCode - // Region1[Residential_Building]: totalRent + + + + implementation uses - BoldCoreConsts, - BoldTaggedValueSupport; + BoldTaggedValueSupport, + BOldUtils, + BoldRev; const SPACE = #32; @@ -95,7 +97,7 @@ procedure TBoldRegionParser.Eat(s: string); OrgPosition := fPosition; for i := 1 to length(s) do if EOS or (NextToken <> s[i]) then - AddError(OrgPosition, sExpectedToken, [s], petSyntax) + AddError(OrgPosition, 'Expected ''%s''', [s], petSyntax) else inc(fPosition); Skip; @@ -122,7 +124,6 @@ procedure TBoldRegionParser.GenerateDefaultRegions; for ClassIx := 0 to SystemTypeInfo.TopSortedClasses.Count-1 do begin ClassTypeInfo := SystemTypeInfo.TopSortedClasses[ClassIx]; - // create the defaultEmptyRegion, it might be referenced by someone DefaultEmptyCore.EnsuredConcreteDefinition(ClassTypeInfo, existed); if ClassTypeInfo.GenerateDefaultRegion then @@ -178,17 +179,17 @@ function TBoldRegionParser.GetEOS: Boolean; function TBoldRegionParser.GetSymbol(Symboltype: TBoldRegionDefinitionSymbolType): String; begin fLastSymbolPosition := fPosition; - if EOS or not (NextToken in ['a'..'z','A'..'Z','_']) then + if EOS or not CharInSet(NextToken, ['a'..'z','A'..'Z','_']) then begin case SymbolType of - stClassName: AddError(fPosition, sClassNameExpected, [], petSyntax); - stMemberName: AddError(fPosition, sMemberNameExpected, [], petSyntax); - stRegionName: AddError(fPosition, sRegionNameExpected, [], petSyntax); + stClassName: AddError(fPosition, 'Class name expected', [], petSyntax); + stMemberName: AddError(fPosition, 'Member name expected', [], petSyntax); + stRegionName: AddError(fPosition, 'Region name expected', [], petSyntax); end; end; Result := NextToken; inc(fPosition); - while (not EOS) and (NextToken in ['a'..'z','A'..'Z','_', '0'..'9']) do + while (not EOS) and CharInSet(NextToken, ['a'..'z','A'..'Z','_', '0'..'9']) do begin Result := result + NextToken; inc(fPosition); @@ -210,7 +211,6 @@ function TBoldRegionParser.Parse(RegionDefinitionList: TStrings): Boolean; ParseCurrentExpression; except on e: EBoldLockExpressionSyntaxError do - // Eat SyntaxErrors; end; end; RegionDefinitions.ExpandDefinitions; @@ -231,7 +231,7 @@ procedure TBoldRegionParser.ParseMembers(ConcreteRegionDefinition: TBoldConcrete if assigned(MemberRTInfo) then TBoldRegionElementInclusion.Create(ConcreteRegionDefinition, MemberRTInfo) else - AddError(fLastSymbolPosition, sXIsNotAMember, [MemberName, ConcreteRegionDefinition.RootClass.ExpressionName], petSemantics); + AddError(fLastSymbolPosition, '%s is not a member of %s', [MemberName, ConcreteRegionDefinition.RootClass.ExpressionName], petSemantics); tryToEat(','); end; end; @@ -253,9 +253,9 @@ procedure TBoldRegionParser.ParseSubregions(ConcreteRegionDefinition: TBoldConcr IsDependent := not tryToEat('-'); MemberRTInfo := ConcreteRegionDefinition.RootClass.MemberRTInfoByExpressionName[MemberName]; if not assigned(MemberRTInfo) then - AddError(fLastSymbolPosition, sXIsNotAMember, [MemberName, ConcreteRegionDefinition.RootClass.ExPressionName], petSemantics) + AddError(fLastSymbolPosition, '%s is not a member of %s', [MemberName, ConcreteRegionDefinition.RootClass.ExPressionName], petSemantics) else if not (MemberRTInfo is TBoldRoleRTInfo) then - AddError(fLastSymbolPosition, sMemberIsNotARole, [ConcreteRegionDefinition.RootClass.ExPressionName, MemberName], petSemantics) + AddError(fLastSymbolPosition, 'Member %s.%s is not a role, unable to navigate', [ConcreteRegionDefinition.RootClass.ExPressionName, MemberName], petSemantics) else begin SubRegion := RegionDefinitions.EnsuredCoreDefinition(RegionName); @@ -273,7 +273,7 @@ procedure TBoldRegionParser.ParseMembersAndSubregions(CoreDefinition: TBoldRegio begin ConcreteRegionDefinition := CoreDefinition.EnsuredConcreteDefinition(ClassTypeInfo, AlreadyDefined); if AlreadyDefined then - AddError(1, sMultipleDefinitions, [CoreDefinition.Name ,classTypeInfo.ExpressionName], petSemantics) + AddError(1, 'Multiple definitions of %s[%s]', [CoreDefinition.Name ,classTypeInfo.ExpressionName], petSemantics) else begin ParseMembers(ConcreteRegionDefinition); @@ -284,7 +284,7 @@ procedure TBoldRegionParser.ParseMembersAndSubregions(CoreDefinition: TBoldRegio procedure TBoldRegionParser.Skip; begin - while not EOS and (NextToken in [SPACE, TAB]) do + while not EOS and CharInSet(NextToken, [SPACE, TAB]) do inc(fPosition); end; @@ -329,13 +329,13 @@ procedure TBoldRegionParser.ParseCurrentExpression; if Assigned(ClassTypeInfo) then ParseMembersAndSubregions(CoreDefinition, ClassTypeInfo) else - AddError(fLastSymbolPosition, sUnknownClassName, [ClassName], petSemantics); + AddError(fLastSymbolPosition, 'Unknown class name: ''%s''', [ClassName], petSemantics); end; -destructor TBoldRegionParser.Destroy; +destructor TBoldRegionParser.destroy; begin FreeAndNil(fErrors); - inherited; + inherited; end; procedure TBoldRegionParser.AddError(pos: integer; msg: String; args: array of const; ErrorType: TBoldRegionParserErrorType); @@ -344,7 +344,7 @@ procedure TBoldRegionParser.AddError(pos: integer; msg: String; args: array of c begin ErrorMsg := ''; if Pos <> -1 then - ErrorMsg := format('"%s" (%d): ', [fExpression, pos]); // do not localize + ErrorMsg := format('"%s" (%d): ', [fExpression, pos]); ErrorMsg := ErrorMsg + format(Msg, args); fErrors.Add(ErrorMsg); if ErrorType = petSyntax then @@ -361,12 +361,15 @@ procedure TBoldRegionParser.CheckRegionReferences; CoreDef := TBoldRegionCoreDefinition(fRegionDefinitions.CoreDefinitions[i]); if CoreDef.ConcreteDefinitions.Count = 0 then for j := 0 to CoreDef.UsedBy.Count-1 do - AddError(-1, sReferencedRegionNotDefined, [ + AddError(-1, 'Referenced region (%s) not defined. Used by %s[%s], role %s', [ CoreDef.Name, CoreDef.UsedBy[j].ParentRegion.CoreDefinition.Name, CoreDef.UsedBy[j].ParentRegion.RootClass.ExpressionName, CoreDef.UsedBy[j].SubregionRootNavigation.ExpressionName], petSemantics); end; + end; +initialization + end. diff --git a/Source/ObjectSpace/PessimisticLocking/BoldRegionDefinitions.pas b/Source/ObjectSpace/PessimisticLocking/BoldRegionDefinitions.pas index b2d634dd..9ff41440 100644 --- a/Source/ObjectSpace/PessimisticLocking/BoldRegionDefinitions.pas +++ b/Source/ObjectSpace/PessimisticLocking/BoldRegionDefinitions.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldRegionDefinitions; interface @@ -112,23 +115,30 @@ TBoldRegionElementInclusion = class(TBoldMemoryManagedObject) TBoldConcreteRegionDefinitionList = class(TList) private function GetItem(i: Integer): TBoldConcreteRegionDefinition; + function GetAsCommaText: string; public function FindByRootClass(RootClass: TBoldClassTypeInfo): TBoldConcreteRegionDefinition; property Items[i: Integer]: TBoldConcreteRegionDefinition read GetItem; default; + public + property AsCommaText: string read GetAsCommaText; end; TBoldSubregionReferenceList = class(TList) private function GetItem(i: Integer): TBoldSubregionReference; + function GetAsCommaText: string; public property Items[i: Integer]: TBoldSubregionReference read GetItem; default; + property AsCommaText: string read GetAsCommaText; end; TBoldRegionElementInclusionList = class(TList) private function GetItem(i: Integer): TBoldRegionElementInclusion; + function GetAsCommaText: string; public property Items[i: Integer]: TBoldRegionElementInclusion read GetItem; default; + property AsCommaText: string read GetAsCommaText; end; const @@ -137,7 +147,8 @@ TBoldRegionElementInclusionList = class(TList) implementation uses - SysUtils; + SysUtils, + BoldRev; function GetEnsuredItem(List: TList; index: integer; theClass: TClass): TObject; var @@ -170,6 +181,21 @@ function TBoldConcreteRegionDefinitionList.FindByRootClass( end; end; +function TBoldConcreteRegionDefinitionList.GetAsCommaText: string; +var + sl: TStringList; + i: integer; +begin + sl := TStringList.Create; + try + for I := 0 to Count - 1 do + sl.Add(self[i].AsString); + finally + result := sl.CommaText; + sl.free; + end; +end; + function TBoldConcreteRegionDefinitionList.GetItem(i: Integer): TBoldConcreteRegionDefinition; begin result := TObject(inherited Items[i]) as TBoldConcreteRegionDefinition; @@ -292,6 +318,21 @@ function TBoldRegionDefinitions.GetRegionInclusionsByMember( { TBoldRegionElementInclusionList } +function TBoldRegionElementInclusionList.GetAsCommaText: string; +var + sl: TStringList; + i: integer; +begin + sl := TStringList.Create; + try + for I := 0 to Count - 1 do + sl.Add(self[i].Member.DisplayName); + finally + result := sl.CommaText; + sl.free; + end; +end; + function TBoldRegionElementInclusionList.GetItem( i: Integer): TBoldRegionElementInclusion; begin @@ -300,6 +341,21 @@ function TBoldRegionElementInclusionList.GetItem( { TBoldSubregionReferenceList } +function TBoldSubregionReferenceList.GetAsCommaText: string; +var + sl: TStringList; + i: integer; +begin + sl := TStringList.Create; + try + for I := 0 to Count - 1 do + sl.Add(self[i].ParentRegion.RootClass.DisplayName); + finally + result := sl.CommaText; + sl.free; + end; +end; + function TBoldSubregionReferenceList.GetItem( i: Integer): TBoldSubregionReference; begin @@ -382,7 +438,7 @@ procedure TBoldConcreteRegionDefinition.Clear; fElements.Clear; for i := 0 to fSubregions.Count-1 do fSubregions[i].Free; - fSubregions.Clear; + fSubregions.Clear; end; constructor TBoldConcreteRegionDefinition.Create(CoreDefinition: TBoldRegionCoreDefinition; Root: TBoldClassTypeInfo); @@ -463,4 +519,5 @@ constructor TBoldRegionElementInclusion.Create(Region: TBoldConcreteRegionDefini (Member as TBoldRoleRTInfo).RoleRTInfoOfOtherEnd.SetForceOtherEnd; end; + end. diff --git a/Source/ObjectSpace/RTModel/BoldGeneratedCodeDictionary.pas b/Source/ObjectSpace/RTModel/BoldGeneratedCodeDictionary.pas index 509e527f..1c3c535f 100644 --- a/Source/ObjectSpace/RTModel/BoldGeneratedCodeDictionary.pas +++ b/Source/ObjectSpace/RTModel/BoldGeneratedCodeDictionary.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldGeneratedCodeDictionary; interface @@ -18,12 +21,12 @@ TBoldGeneratedClassDescriptor = class; { TBoldGeneratedCodeList } TBoldGeneratedCodeList = class(TBoldIndexableList) private - function GetDescriptorByExpressionName(ExpressionName: string): TBoldGeneratedCodeDescriptor; + function GetDescriptorByExpressionName(const ExpressionName: string): TBoldGeneratedCodeDescriptor; function GetModelDescriptors(index: Integer): TBoldGeneratedCodeDescriptor; public constructor Create; - function AddGeneratedCodeDescriptorWithFunc(ExpressionName: string; InstBusiClasses: TInstallBusinessClasses; InstObjListClasses: TInstallObjectListClasses; CRC: string = ''):TBoldGeneratedCodeDescriptor; - property DescriptorByExpressionName[ExpressionName: string]: TBoldGeneratedCodeDescriptor read GetDescriptorByExpressionName; + function AddGeneratedCodeDescriptorWithFunc(const ExpressionName: string; InstBusiClasses: TInstallBusinessClasses; InstObjListClasses: TInstallObjectListClasses; CRC: string = ''):TBoldGeneratedCodeDescriptor; + property DescriptorByExpressionName[const ExpressionName: string]: TBoldGeneratedCodeDescriptor read GetDescriptorByExpressionName; property ModelEntries[index: Integer]: TBoldGeneratedCodeDescriptor read GetModelDescriptors; end; @@ -35,7 +38,7 @@ TBoldGeneratedCodeDescriptor = class fInstallBusinessClasses: TInstallBusinessClasses; fInstallObjectListClasses: TInstallObjectListClasses; public - constructor Create(ExpressionName: string; InstallBusinessClasses: TInstallBusinessClasses; InstallObjectListClasses: TInstallObjectListClasses; CRC: string); + constructor Create(const ExpressionName: string; InstallBusinessClasses: TInstallBusinessClasses; InstallObjectListClasses: TInstallObjectListClasses; CRC: string); property InstallBusinessClasses: TInstallBusinessClasses read fInstallBusinessClasses; property InstallObjectListClasses: TInstallObjectListClasses read fInstallObjectListClasses; property ExpressionName: string read fExpressionName; @@ -45,12 +48,12 @@ TBoldGeneratedCodeDescriptor = class { TBoldGeneratedClassList } TBoldGeneratedClassList = class(TBoldIndexableList) private - function GetDescriptorByExpressionName(ExpressionName: string): TBoldGeneratedClassDescriptor; + function GetDescriptorByExpressionName(const ExpressionName: string): TBoldGeneratedClassDescriptor; public constructor Create; procedure AddEntry(BoldObjectClassEntry: TBoldGeneratedClassDescriptor); - procedure AddObjectEntry(ExpressionName: string; AClass: TClass); - property EntryByExpressionName[ExpressionName: string]: TBoldGeneratedClassDescriptor read GetDescriptorByExpressionName; + procedure AddObjectEntry(const ExpressionName: string; AClass: TClass); + property EntryByExpressionName[const ExpressionName: string]: TBoldGeneratedClassDescriptor read GetDescriptorByExpressionName; end; { TBoldGeneratedClassDescriptor } @@ -64,7 +67,7 @@ TBoldGeneratedClassDescriptor = class property TheClass: TClass read fClass; end; -function GeneratedCodes: TBoldGeneratedCodeList; //Name space shortage!! +function GeneratedCodes: TBoldGeneratedCodeList; function BoldGeneratedCodesAssigned: Boolean; implementation @@ -78,14 +81,14 @@ implementation G_BoldGeneratedCodes: TBoldGeneratedCodeList = nil; IX_GeneratedClassExpressionName: integer = -1; IX_GeneratedCodeExpressionName: integer = -1; - + type { TGeneratedCodeExpressionNameIndex } TGeneratedCodeExpressionNameIndex = class(TBoldStringHashIndex) protected function ItemAsKeyString(Item: TObject): string; override; end; - + function TGeneratedCodeExpressionNameIndex.ItemAsKeyString(Item: TObject): string; begin Result := TBoldGeneratedCodeDescriptor(Item).ExpressionName; @@ -112,7 +115,7 @@ constructor TBoldGeneratedCodeList.Create; SetIndexVariable(IX_GeneratedCodeExpressionName, AddIndex(TGeneratedCodeExpressionNameIndex.Create)); end; -function TBoldGeneratedCodeList.GetDescriptorByExpressionName(ExpressionName: string): TBoldGeneratedCodeDescriptor; +function TBoldGeneratedCodeList.GetDescriptorByExpressionName(const ExpressionName: string): TBoldGeneratedCodeDescriptor; begin Result := TBoldGeneratedCodeDescriptor(TGeneratedCodeExpressionNameIndex(Indexes[IX_GeneratedCodeExpressionName]).FindByString(ExpressionName)) end; @@ -122,14 +125,14 @@ function TBoldGeneratedCodeList.GetModelDescriptors(index: Integer): TBoldGenera Result := TBoldGeneratedCodeDescriptor(Items[index]); end; -function TBoldGeneratedCodeList.AddGeneratedCodeDescriptorWithFunc(ExpressionName: string; InstBusiClasses: TInstallBusinessClasses; InstObjListClasses: TInstallObjectListClasses; CRC: string = ''): TBoldGeneratedCodeDescriptor; +function TBoldGeneratedCodeList.AddGeneratedCodeDescriptorWithFunc(const ExpressionName: string; InstBusiClasses: TInstallBusinessClasses; InstObjListClasses: TInstallObjectListClasses; CRC: string = ''): TBoldGeneratedCodeDescriptor; begin result := TBoldGeneratedCodeDescriptor.Create(ExpressionName, InstBusiClasses, InstObjListClasses, CRC); Add(result); end; { TBoldGeneratedCodeDescriptor } -constructor TBoldGeneratedCodeDescriptor.Create(ExpressionName: string; InstallBusinessClasses: TInstallBusinessClasses; InstallObjectListClasses: TInstallObjectListClasses; CRC: String); +constructor TBoldGeneratedCodeDescriptor.Create(const ExpressionName: string; InstallBusinessClasses: TInstallBusinessClasses; InstallObjectListClasses: TInstallObjectListClasses; CRC: String); begin fExpressionName := ExpressionName; fInstallBusinessClasses := InstallBusinessClasses; @@ -157,7 +160,8 @@ constructor TBoldGeneratedClassList.Create; SetIndexCapacity(1); SetIndexVariable(IX_GeneratedClassExpressionName, AddIndex(TGeneratedClassExpressionNameIndex.Create)); end; -function TBoldGeneratedClassList.GetDescriptorByExpressionName(ExpressionName: string): TBoldGeneratedClassDescriptor; + +function TBoldGeneratedClassList.GetDescriptorByExpressionName(const ExpressionName: string): TBoldGeneratedClassDescriptor; begin Result := TBoldGeneratedClassDescriptor(TGeneratedClassExpressionNameIndex(Indexes[IX_GeneratedClassExpressionName]).FindByString(ExpressionName)); end; @@ -167,7 +171,7 @@ procedure TBoldGeneratedClassList.AddEntry(BoldObjectClassEntry: TBoldGeneratedC Add(BoldObjectClassEntry); end; -procedure TBoldGeneratedClassList.AddObjectEntry(ExpressionName: string; AClass: TClass); +procedure TBoldGeneratedClassList.AddObjectEntry(const ExpressionName: string; AClass: TClass); begin AddEntry(TBoldGeneratedClassDescriptor.Create(ExpressionName, AClass)); end; diff --git a/Source/ObjectSpace/RTModel/BoldMemberTypeDictionary.pas b/Source/ObjectSpace/RTModel/BoldMemberTypeDictionary.pas index fa0d2db2..5fdf224f 100644 --- a/Source/ObjectSpace/RTModel/BoldMemberTypeDictionary.pas +++ b/Source/ObjectSpace/RTModel/BoldMemberTypeDictionary.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldMemberTypeDictionary; interface @@ -13,15 +16,17 @@ TBoldMemberTypeDescriptor = class; {---TBoldMemberTypeList---} TBoldMemberTypeList = class(TBoldIndexableList) private - function GetDescriptorByClass(BoldMemberClass: TClass): TBoldMemberTypeDescriptor; - function GetMemberTypeDescriptors(index: integer): TBoldMemberTypeDescriptor; - function GetDescriptorByDelphiName(DelphiName: string): TBoldMemberTypeDescriptor; + class var IX_MemberName: integer; + class var IX_MemberClass: integer; + function GetDescriptorByClass(BoldMemberClass: TClass): TBoldMemberTypeDescriptor; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetMemberTypeDescriptors(index: integer): TBoldMemberTypeDescriptor; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetDescriptorByDelphiName(const DelphiName: string): TBoldMemberTypeDescriptor; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public constructor Create; procedure AddMemberTypeDescriptor(MemberClass: TClass; const AbstractionLevel: TBoldAbstractionLevel); procedure RemoveDescriptorByClass(BoldMemberClass: TClass); - property DescriptorByDelphiName[DelphiName: string]: TBoldMemberTypeDescriptor read GetDescriptorByDelphiName; + property DescriptorByDelphiName[const DelphiName: string]: TBoldMemberTypeDescriptor read GetDescriptorByDelphiName; property DescriptorByClass[BoldMemberClass: TClass]: TBoldMemberTypeDescriptor read GetDescriptorByClass; property Descriptors[Index: integer]: TBoldMemberTypeDescriptor read GetMemberTypeDescriptors; end; @@ -52,10 +57,6 @@ implementation var G_BoldMemberTypes: TBoldMemberTypeList; -var - IX_MemberName: integer = -1; - IX_MemberClass: integer = -1; - type {---TMemberNameIndex---} TMemberNameIndex = class(TBoldStringHashIndex) @@ -104,14 +105,14 @@ constructor TBoldMemberTypeList.Create; SetIndexVariable(IX_MemberClass, AddIndex(TMemberClassIndex.Create)); end; -function TBoldMemberTypeList.GetDescriptorByDelphiName(DelphiName: string): TBoldMemberTypeDescriptor; +function TBoldMemberTypeList.GetDescriptorByDelphiName(const DelphiName: string): TBoldMemberTypeDescriptor; begin - Result := TBoldMemberTypeDescriptor(TMemberNameIndex(Indexes[IX_MemberName]).FindByString(DelphiName)) + Result := TBoldMemberTypeDescriptor(TBoldStringHashIndex(Indexes[IX_MemberName]).FindByString(DelphiName)) end; function TBoldMemberTypeList.GetDescriptorByClass(BoldMemberClass: TClass): TBoldMemberTypeDescriptor; begin - Result := TBoldMemberTypeDescriptor(TMemberClassIndex(Indexes[IX_MemberClass]).FindByClass(BoldMemberClass)) + Result := TBoldMemberTypeDescriptor(TBoldClassHashIndex(Indexes[IX_MemberClass]).FindByClass(BoldMemberClass)) end; procedure TBoldMemberTypeList.AddMemberTypeDescriptor(MemberClass: TClass; @@ -139,6 +140,8 @@ constructor TBoldMemberTypeDescriptor.Create(MemberClass: TClass; end; initialization + TBoldMemberTypeList.IX_MemberName := -1; + TBoldMemberTypeList.IX_MemberClass := -1; finalization FreeAndNil(G_BoldMemberTypes); diff --git a/Source/ObjectSpace/RTModel/BoldSystemRT.pas b/Source/ObjectSpace/RTModel/BoldSystemRT.pas index 9b33c141..d2163b25 100644 --- a/Source/ObjectSpace/RTModel/BoldSystemRT.pas +++ b/Source/ObjectSpace/RTModel/BoldSystemRT.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSystemRT; interface @@ -5,6 +8,7 @@ interface uses BoldDefs, BoldElements, + BoldIndexableList, BoldMetaElementList, BoldGeneratedCodeDictionary, BoldMeta, @@ -17,10 +21,22 @@ interface LITE_VERSION_CLASS_LIMIT = 15; CLASS_TYPE_INFO_MEM_SIZE = 24; +type + TBoldTypeInfoSearchOption = (soPartialMatch); + TBoldTypeInfoSearchOptions = set of TBoldTypeInfoSearchOption; + + TBoldSearchType = (stClass, stAttribute, stRole, stMethod, stType); + TBoldSearchTypes = set of TBoldSearchType; + +const cDefaultSearchTypes = [stClass, stAttribute, stRole, stMethod, stType]; +const cDefaultSearchTypeOptions = [soPartialMatch]; + type {forward declarations, classes in actual model} TBoldClassTypeInfoList = class; + TBoldAttributeTypeInfoList = class; TBoldMemberRTInfoList = class; + TBoldRoleRTInfoList = class; TBoldMethodRTInfoList = class; TBoldListTypeInfoList = class; @@ -34,7 +50,7 @@ TBoldNilTypeInfo = class; TBoldMemberRTInfo = class; TBoldRoleRTInfo = class; - TBoldListTypeInfo = class; +// TBoldListTypeInfo = class; // moved to BoldElements TBoldAttributeRTInfo = class; TBoldAttributeTypeInfo = class; TBoldMethodRTInfo = class; @@ -44,53 +60,130 @@ TBoldConstraintRTInfo = class; { TBoldRTEvaluator } TBoldRTEvaluator = class(TBoldEvaluator) public - function RTInfo(const Ocl: string; Context: TBoldElementTypeInfo; ReRaise: Boolean): TBoldMemberRTInfo; virtual; abstract; + function RTInfo(const Ocl: string; Context: TBoldElementTypeInfo; ReRaise: Boolean; const VariableList: TBoldExternalVariableList = nil): TBoldMemberRTInfo; virtual; abstract; + end; + + TBoldClassTypeInfoListTraverser = class(TBoldIndexableListTraverser) + public + function GetCurrent: TBoldClassTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + property Current: TBoldClassTypeInfo read GetCurrent; end; {---TBoldClassRTInfoList---} TBoldClassTypeInfoList = class(TBoldElementTypeInfoList) private - function GetItem(index: Integer): TBoldClassTypeInfo; - function GetItemByExpressionName(const ExpressionName: string): TBoldClassTypeInfo; - function GetItemByModelName(const ModelName: string): TBoldClassTypeInfo; - function GetItemByObjectClass(ObjectClass: TClass): TBoldClassTypeInfo; + class var IX_ObjectClass: integer; + function GetItem(index: Integer): TBoldClassTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByExpressionName(const ExpressionName: string): TBoldClassTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByModelName(const ModelName: string): TBoldClassTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByObjectClass(ObjectClass: TClass): TBoldClassTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + protected + function TraverserClass: TBoldIndexableListTraverserClass; override; public constructor Create; + function GetEnumerator: TBoldClassTypeInfoListTraverser; property Items[index: Integer]: TBoldClassTypeInfo read GetItem; default; property ItemsByExpressionName[const ExpressionName: string]: TBoldClassTypeInfo read GetItemByExpressionName; property ItemsByModelName[const ModelName: string]: TBoldClassTypeInfo read GetItemByModelName; property ItemsByObjectClass[ObjectClass: TClass]: TBoldClassTypeInfo read GetItemByObjectClass; end; + TBoldMemberRTInfoListTraverser = class(TBoldIndexableListTraverser) + public + function GetCurrent: TBoldMemberRTInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + property Current: TBoldMemberRTInfo read GetCurrent; + end; + {---TBoldMemberRTInfoList---} TBoldMemberRTInfoList = class(TBoldMetaElementList) private - function GetItem(index: Integer): TBoldMemberRTInfo; - function GetItemByExpressionName(const ExpressionName: string): TBoldMemberRTInfo; + function GetItem(index: Integer): TBoldMemberRTInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByExpressionName(const ExpressionName: string): TBoldMemberRTInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetItemByModelName(const ModelName: string): TBoldMemberRTInfo; + protected + function TraverserClass: TBoldIndexableListTraverserClass; override; public + function GetEnumerator: TBoldMemberRTInfoListTraverser; property Items[index: Integer]: TBoldMemberRTInfo read GetItem; default; property ItemsByExpressionName[const ExpressionName: string]: TBoldMemberRTInfo read GetItemByExpressionName; property ItemsByModelName[const ModelName: string]: TBoldMemberRTInfo read GetItemByModelName; end; + TBoldAttributeTypeInfoListTraverser = class(TBoldIndexableListTraverser) + public + function GetCurrent: TBoldAttributeTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + property Current: TBoldAttributeTypeInfo read GetCurrent; + end; + + TBoldAttributeTypeInfoList = class(TBoldMetaElementList) + private + function GetItem(index: Integer): TBoldAttributeTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByExpressionName(const ExpressionName: string): TBoldAttributeTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByModelName(const ModelName: string): TBoldAttributeTypeInfo; + protected + function TraverserClass: TBoldIndexableListTraverserClass; override; + public + function GetEnumerator: TBoldAttributeTypeInfoListTraverser; + property Items[index: Integer]: TBoldAttributeTypeInfo read GetItem; default; + property ItemsByExpressionName[const ExpressionName: string]: TBoldAttributeTypeInfo read GetItemByExpressionName; + property ItemsByModelName[const ModelName: string]: TBoldAttributeTypeInfo read GetItemByModelName; + end; + + TBoldRoleRTInfoListTraverser = class(TBoldIndexableListTraverser) + public + function GetCurrent: TBoldRoleRTInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + property Current: TBoldRoleRTInfo read GetCurrent; + end; + + {---TBoldRoleRTInfoList---} + TBoldRoleRTInfoList = class(TBoldMetaElementList) + private + function GetItem(index: Integer): TBoldRoleRTInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByExpressionName(const ExpressionName: string): TBoldRoleRTInfo; + function GetItemByModelName(const ModelName: string): TBoldRoleRTInfo; + protected + function TraverserClass: TBoldIndexableListTraverserClass; override; + public + function GetEnumerator: TBoldRoleRTInfoListTraverser; + property Items[index: Integer]: TBoldRoleRTInfo read GetItem; default; + property ItemsByExpressionName[const ExpressionName: string]: TBoldRoleRTInfo read GetItemByExpressionName; + property ItemsByModelName[const ModelName: string]: TBoldRoleRTInfo read GetItemByModelName; + end; + + TBoldConstraintRTInfoListTraverser = class(TBoldIndexableListTraverser) + public + function GetCurrent: TBoldConstraintRTInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + property Current: TBoldConstraintRTInfo read GetCurrent; + end; + TBoldConstraintRTInfoList = class(TBoldMetaElementList) private - function GetItem(index: Integer): TBoldConstraintRTInfo; - function GetItemByModelName(const ModelName: string): TBoldConstraintRTInfo; + function GetItem(index: Integer): TBoldConstraintRTInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByModelName(const ModelName: string): TBoldConstraintRTInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + protected + function TraverserClass: TBoldIndexableListTraverserClass; override; public + function GetEnumerator: TBoldConstraintRTInfoListTraverser; property Items[index: Integer]: TBoldConstraintRTInfo read GetItem; default; property ItemsByModelName[const ModelName: string]: TBoldConstraintRTInfo read GetItemByModelName; end; + TBoldMethodRTInfoListTraverser = class(TBoldIndexableListTraverser) + public + function GetCurrent: TBoldMethodRTInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + property Current: TBoldMethodRTInfo read GetCurrent; + end; {---TBoldMethodRTInfoList---} TBoldMethodRTInfoList = class(TBoldMetaElementList) private - function GetItem(index: Integer): TBoldMethodRTInfo; - function GetItemByModelName(const ModelName: string): TBoldMethodRTInfo; - function GetItemByExpressionName(const ExpressionName: string): TBoldMethodRTInfo; + function GetItem(index: Integer): TBoldMethodRTInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByModelName(const ModelName: string): TBoldMethodRTInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByExpressionName(const ExpressionName: string): TBoldMethodRTInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + protected + function TraverserClass: TBoldIndexableListTraverserClass; override; public + function GetEnumerator: TBoldMethodRTInfoListTraverser; property Items[index: Integer]: TBoldMethodRTInfo read GetItem; default; property ItemsByModelName[const ModelName: string]: TBoldMethodRTInfo read GetItemByModelName; property ItemsByExpressionName[const ExpressionName: string]: TBoldMethodRTInfo read GetItemByExpressionName; @@ -99,10 +192,14 @@ TBoldMethodRTInfoList = class(TBoldMetaElementList) {---TBoldListTypeInfoList---} TBoldListTypeInfoList = class(TBoldElementTypeInfoList) private - function GetItemByElement(Element: TBoldElementTypeInfo): TBoldListTypeInfo; + class var IX_Element: integer; + class var IX_ListClass: integer; + function GetItemByElement(Element: TBoldElementTypeInfo): TBoldListTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByListClass(ListClass: TClass): TBoldListTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public constructor Create; property ItemByElement[Element: TBoldElementTypeInfo]: TBoldListTypeInfo read GetItemByElement; + property ItemByListClass[ObjectClass: TClass]: TBoldListTypeInfo read GetItemByListClass; end; {---TBoldTypeTypeInfo---} @@ -110,6 +207,7 @@ TBoldTypeTypeInfo = class(TBoldElementTypeInfo) protected constructor Create(const ModelName: string; const ExpressionName: string; const Delphiname: string; ModelTypeInfo: TBoldElementTypeInfo); function GetBoldType: TBoldElementTypeInfo; override; + function GetListTypeInfo: TBoldListTypeInfo; override; public function ConformsTo(CompareElement: TBoldElementTypeInfo): Boolean; override; end; @@ -118,12 +216,13 @@ TBoldElementTypeInfoWithConstraint = class(TBoldElementTypeInfo) private fConstraints: TBoldConstraintRTInfoList; fTaggedValues: TStrings; - function GetTaggedValues(const Tag: string): string; - function GetConstraints(const Name: String): TBoldConstraintRTInfo; - function GetConstraintCount: integer; - function GetTaggedvalueCount: integer; - function GetConstraintByIndex(Index: integer): TBoldConstraintRTInfo; - function GetTaggedValueByIndex(Index: integer): string; + function GetTaggedValues(const Tag: string): string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetConstraints(const Name: String): TBoldConstraintRTInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetConstraintCount: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetTaggedvalueCount: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetConstraintByIndex(Index: integer): TBoldConstraintRTInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetTaggedValueByIndex(Index: integer): string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetListTypeInfo: TBoldListTypeInfo; override; public constructor Create(MoldElement: TMoldElement; SystemTypeInfo: TBoldSystemTypeInfo); destructor Destroy; override; @@ -141,16 +240,16 @@ TBoldMetaElementWithConstraint = class(TBoldMetaElement) private fConstraints: TBoldConstraintRTInfoList; fTaggedValues: TStrings; - function GetTaggedValues(const Tag: string): string; - function GetConstraints(const Name: String): TBoldConstraintRTInfo; - function GetConstraintByIndex(Index: integer): TBoldConstraintRTInfo; - function GetConstraintCount: integer; - function GetTaggedValueByIndex(Index: integer): string; - function GetTaggedvalueCount: integer; + function GetTaggedValues(const Tag: string): string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetConstraints(const Name: String): TBoldConstraintRTInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetConstraintByIndex(Index: integer): TBoldConstraintRTInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetConstraintCount: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetTaggedValueByIndex(Index: integer): string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetTaggedvalueCount: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public constructor Create(MoldElement: TMoldElement; const ModelName, ExpressionName, DelphiName: String; SystemTypeInfo: TBoldSystemTypeInfo); destructor Destroy; override; - procedure AddConstraint(Constraint: TBoldConstraintRTinfo); + procedure AddConstraint(Constraint: TBoldConstraintRTinfo); {$IFDEF BOLD_INLINE} inline; {$ENDIF} property Constraint[const Name: String]: TBoldConstraintRTInfo read GetConstraints; property ConstraintCount: integer read GetConstraintCount; property ConstraintByIndex[Index: integer]: TBoldConstraintRTInfo read GetConstraintByIndex; @@ -159,36 +258,44 @@ TBoldMetaElementWithConstraint = class(TBoldMetaElement) property TaggedValueByIndex[Index: integer]: string read GetTaggedValueByIndex; end; - {---TBoldSystemTypeInfo---} TBoldSystemTypeInfo = class(TBoldElementTypeInfoWithConstraint) private +{$IFDEF BOLD_LITE} + fClassTypeInfoMem: array[0..LITE_VERSION_CLASS_LIMIT*CLASS_TYPE_INFO_MEM_SIZE] of Integer; +{$ENDIF} fInitializationLog: TStringList; fOptimisticLocking: TBoldOptimisticLockingMode; - fAttributeTypes: TBoldElementTypeInfoList; + fAttributeTypes: TBoldAttributeTypeInfoList; fEvaluator: TBoldEvaluator; fListTypes: TBoldListTypeInfoList; fMethodsInstalled: Boolean; fNilTypeInfo: TBoldNilTypeInfo; - fTopSortedClasses: TBoldClassTypeInfoList; // Classes in topologically sorted order + fValueSetTypeInfo: TBoldElementTypeInfo; + fTopSortedClasses: TBoldClassTypeInfoList; + fValueSetTypeInfoList: TBoldElementTypeInfoList; fTypeTypeInfo: TBoldTypeTypeInfo; + fUntypedListTypeInfo: TBoldListTypeInfo; fUseGeneratedCode: Boolean; fGenerateMultiplicityConstraints: Boolean; fValueTypeNameList: TBoldElementTypeInfoList; fStereotype: string; - fUseClockLog: Boolean; + fUseClockLog: Boolean; function GetInitializationLog: TStringList; - function GetAttributeTypeInfoByDelphiName(const name: string): TBoldAttributeTypeInfo; - function GetAttributeTypeInfoByExpressionName(const name: string): TBoldAttributeTypeInfo; - function GetClassTypeInfoByExpressionName(const name: string): TBoldClassTypeInfo; - function GetClassTypeInfoByModelName(const name: string): TBoldClassTypeInfo; - function GetElementTypeInfoByDelphiName(const name: string): TBoldElementTypeInfo; - function GetElementTypeInfoByExpressionName(const name: string): TBoldElementTypeInfo; - function GetListTypeInfoByElement(Element: TBoldElementTypeInfo): TBoldListTypeInfo; - function GetRootClassTypeInfo: TBoldClassTypeInfo; + function GetAttributeTypeInfoByDelphiName(const name: string): TBoldAttributeTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetAttributeTypeInfoByExpressionName(const name: string): TBoldAttributeTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetClassTypeInfoByExpressionName(const name: string): TBoldClassTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetClassTypeInfoByModelName(const name: string): TBoldClassTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetElementTypeInfoByDelphiName(const name: string): TBoldElementTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetElementTypeInfoByExpressionName(const name: string): TBoldElementTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetListTypeInfoByElement(Element: TBoldElementTypeInfo): TBoldListTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetMemberTypeInfoByQualifiedName(const AClassName, AMemberName: string): TBoldMemberRtInfo; + function GetRootClassTypeInfo: TBoldClassTypeInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetValueTypeNameList: TBoldElementTypeInfoList; + function GetValueSetTypeInfoList: TBoldElementTypeInfoList; procedure InitializationError(const Message: String; args: array of const); procedure InstallAttributeType(TypeNameDictionary: TBoldTypeNameDictionary; pos: integer); + function GetClassTypeInfoByClass(ObjectClass: TClass): TBoldClassTypeInfo; protected function GetEvaluator: TBoldEvaluator; override; function GetBoldType: TBoldElementTypeInfo; override; @@ -198,18 +305,26 @@ TBoldSystemTypeInfo = class(TBoldElementTypeInfoWithConstraint) function ConformsTo(CompareElement: TBoldElementTypeInfo): Boolean; override; procedure GetValueTypeNames(S: TStrings; Classes, Types, System, metatype, lists: Boolean); procedure ReleaseEvaluator; + function FindElement(const AText: string; ASearchOptions: TBoldTypeInfoSearchOptions = cDefaultSearchTypeOptions; ASearchTypes: TBoldSearchTypes = cDefaultSearchTypes): TBoldMetaElement; + function FindValueSetAndTypeByName(const AName: string; out AElement: TBoldElement; out ATypeInfo: TBoldElementTypeInfo): boolean; + function FindValueSetByName(const AName: string): TBoldElement; property AttributeTypeInfoByDelphiName[const name: string]: TBoldAttributeTypeInfo read GetAttributeTypeInfoByDelphiName; property AttributeTypeInfoByExpressionName[const name: string]: TBoldAttributeTypeInfo read GetAttributeTypeInfoByExpressionName; - property AttributeTypes: TBoldElementTypeInfoList read fAttributeTypes; + property AttributeTypes: TBoldAttributeTypeInfoList read fAttributeTypes; property ClassTypeInfoByExpressionName[const name: string]: TBoldClassTypeInfo read GetClassTypeInfoByExpressionName; property ClassTypeInfoByModelName[const name: string]: TBoldClassTypeInfo read GetClassTypeInfoByModelName; + property ClassTypeInfoByClass[ObjectClass: TClass]: TBoldClassTypeInfo read GetClassTypeInfoByClass; + property MemberTypeInfoByQualifiedName[const AClassName, AMemberName: string]: TBoldMemberRtInfo read GetMemberTypeInfoByQualifiedName; property ListTypeInfoByElement[Element: TBoldElementTypeInfo]: TBoldListTypeInfo read GetListTypeInfoByElement; property ListTypes: TBoldListTypeInfoList read fListTypes; property NilTypeInfo: TBoldNilTypeInfo read fNilTypeInfo; + property ValueSetTypeInfo: TBoldElementTypeInfo read fValueSetTypeInfo; + property ValueSetTypeInfoList: TBoldElementTypeInfoList read GetValueSetTypeInfoList; property ElementTypeInfoByDelphiName[const name: string]: TBoldElementTypeInfo read GetElementTypeInfoByDelphiName; property ElementTypeInfoByExpressionName[const name: string]: TBoldElementTypeInfo read GetElementTypeInfoByExpressionName; property ValueTypeNameList: TBoldElementTypeInfoList read GetValueTypeNameList; property RootClassTypeInfo: TBoldClassTypeInfo read GetRootClassTypeInfo; + property UntypedListTypeInfo: TBoldListTypeInfo read fUntypedListTypeInfo; property TypeTypeInfo: TBoldTypeTypeInfo read fTypeTypeInfo; property MethodsInstalled: Boolean read fMethodsInstalled; property TopSortedClasses: TBoldClassTypeInfoList read FTopSortedClasses; @@ -230,21 +345,25 @@ TBoldClassTypeInfo = class(TBoldElementTypeInfoWithConstraint) private fOptimisticLocking: TBoldOptimisticLockingMode; FAllMembers: TBoldMemberRTInfoList; + fAllRoles: TBoldRoleRTInfoList; FFirstOwnMemberIndex: Integer; FMethods: TBoldMethodRTInfoList; - FObjectClass: TClass; // Really TBoldObjectClass The class with which it should be instansiated. + FObjectClass: TClass; fSuperClassTypeInfo: TBoldClassTypeInfo; fSystemTypeInfo: TBoldSystemTypeInfo; fTopSortedIndex: Integer; FStereotype: string; fDefaultStringRepresentation: string; fEmbeddedSingleLinkCount: integer; + fDerivedMemberCount: integer; fAllMembersCount: integer; + fAllRolesCount: Integer; fPackagename: string; - function GetListTypeInfo: TBoldListTypeInfo; - function GetMemberIndexByExpressionName(const name: string): Integer; - function GetMemberRTInfoByExpressionName(const Name: string): TBoldMemberRTInfo; - function GetMemberRTInfoByModelName(const Name: string): TBoldMemberRTInfo; + fSubClasssesBoldClassTypeInfoList: TBoldClassTypeInfoList; + fListTypeInfo: TBoldListTypeInfo; + function GetMemberIndexByExpressionName(const name: string): Integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetMemberRTInfoByExpressionName(const Name: string): TBoldMemberRTInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetMemberRTInfoByModelName(const Name: string): TBoldMemberRTInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure InitializeMultiplicityConstraints; procedure Initialize(MoldClass: TMoldClass; TypeNameDictionary: TBoldTypeNameDictionary; BoldObjectClasses: TBoldGeneratedClassList; BoldObjectListClasses: TBoldGeneratedClassList; SkipMembers: Boolean); virtual; procedure SetObjectClass(BoldObjectClasses: TBoldGeneratedClassList); @@ -252,19 +371,29 @@ TBoldClassTypeInfo = class(TBoldElementTypeInfoWithConstraint) protected constructor Create(SystemTypeInfo: TBoldSystemTypeInfo; moldClass: TMoldClass; TypeNameDictionary: TBoldTypeNameDictionary; BoldObjectClasses: TBoldGeneratedClassList; BoldObjectListClasses: TBoldGeneratedClassList; SkipMembers: Boolean = false); function GetBoldType: TBoldElementTypeInfo; override; + function GetDisplayName: String; override; + function GetListTypeInfo: TBoldListTypeInfo; override; public +{$IFDEF BOLD_LITE} + class function NewInstance: TObject; override; + procedure FreeInstance; override; +{$ENDIF} destructor Destroy; override; function BoldIsA(C2: TBoldElementTypeInfo): Boolean; virtual; function ConformsTo(CompareElement: TBoldElementTypeInfo): Boolean; override; function LeastCommonSuperClass(OtherClassTypeInfo: TBoldClassTypeInfo): TBoldClassTypeInfo; + function ElementClass: TBoldElementClass; override; + function CreateElement: TBoldElement; override; property AllMembers: TBoldMemberRTInfoList read fAllMembers; + property AllRoles: TBoldRoleRTInfoList read fAllRoles; + property AllRolesCount: Integer read fAllRolesCount; + property DerivedMemberCount: integer read fDerivedMemberCount; property AllMembersCount: integer read fAllMembersCount; property FirstOwnMemberIndex: Integer read FFirstOwnMemberIndex; property HasSubclasses: Boolean index befHasSubclasses read GetElementFlag; property IsAbstract: Boolean index befIsAbstract read GetElementFlag; property IsImported: Boolean index befIsImported read GetElementFlag; property IsLinkClass: Boolean index befIsLinkClass read GetElementFlag; - property ListTypeInfo: TBoldListTypeInfo read GetListTypeInfo; property MemberIndexByExpressionName[const name: string]: Integer read GetMemberIndexByExpressionName; property MemberRTInfoByExpressionName[const Name: string]: TBoldMemberRTInfo read GetMemberRTInfoByExpressionName; property MemberRTInfoByModelName[const Name: string]: TBoldMemberRTInfo read GetMemberRTInfoByModelName; @@ -282,6 +411,7 @@ TBoldClassTypeInfo = class(TBoldElementTypeInfoWithConstraint) property GenerateDefaultRegion: Boolean index befGenerateDefaultRegion read GetElementFlag; property EmbeddedSingleLinkCount: integer read fEmbeddedSingleLinkCount; property QualifiedName: string read GetQualifiedName; + property SubClasssesBoldClassTypeInfoList: TBoldClassTypeInfoList read fSubClasssesBoldClassTypeInfoList; end; {---TBoldNilTypeInfo---} @@ -298,32 +428,37 @@ TBoldNilTypeInfo = class(TBoldClassTypeInfo) TBoldMemberRTInfo = class(TBoldMetaElementWithConstraint) private fDeriveExpression: string; + fDeriveMethod: Pointer; + fReverseDeriveMethod: Pointer; fStereotype: string; fDispId: integer; fBoldType: TBoldElementTypeInfo; fClassTypeInfo: TBoldClassTypeInfo; fIndex: Integer; - fEmbeddedLinkIndex: integer; // -1 if not an embedded link + fDeriverIndex: Integer; + fEmbeddedLinkIndex: integer; fVisibility: TVisibilityKind; fStreamName: string; protected constructor Create(ClassTypeInfo: TBoldClassTypeInfo; moldMember: TMoldMember; TypeNameDictionary: TBoldTypeNameDictionary); constructor CreateWithoutMoldMember(ClassTypeInfo: TBoldClassTypeInfo; const ModelName: string; const ExpressionName: string; const DelphiName: string; Persistent: Boolean ; TypeNameDictionary: TBoldTypeNameDictionary); + function GetDisplayName: String; override; function GetBoldType: TBoldElementTypeInfo; override; - function GetIsAttribute: Boolean; - function GetIsRole: Boolean; + function GetIsRole: Boolean; virtual; procedure SetBoldType(BoldType: TBoldElementTypeInfo); function GetMemberClass: TClass; virtual; abstract; function GetEncouragesOptimisticLockingOnDeletedOnly: Boolean; virtual; function GetCanHaveOldValue: Boolean; virtual; + function GetStoreInUndo: boolean; virtual; abstract; public destructor Destroy; override; - property IsDerived: Boolean index befIsDerived read GetElementFlag; // Always false for roles. + property IsDerived: Boolean index befIsDerived read GetElementFlag; property ClassTypeInfo: TBoldClassTypeInfo read fClassTypeInfo; property DelayedFetch: Boolean index befDelayedFetch read GetElementFlag; property index: Integer read FIndex; property EmbeddedLinkIndex: integer read fEmbeddedLinkIndex; - property IsAttribute: Boolean read GetIsAttribute; + property DeriverIndex: Integer read fDeriverIndex; + property IsAttribute: Boolean index befIsAttribute read GetElementFlag; property IsMultiRole: Boolean index befIsMultiRole read GetElementFlag; property IsRole: Boolean read GetIsRole; property IsSingleRole: Boolean index befIsSingleRole read GetElementFlag; @@ -340,18 +475,21 @@ TBoldMemberRTInfo = class(TBoldMetaElementWithConstraint) property CanHaveOldValue: Boolean read GetCanHaveOldValue; property ToBeRemoved: Boolean index befMemberToBeRemoved read GetElementFlag; property DispId: integer read fDispId; + property DeriveMethod: Pointer read fDeriveMethod write fDeriveMethod; // this is a bit unsafe since anyone can change it. + property ReverseDeriveMethod: Pointer read fReverseDeriveMethod write fReverseDeriveMethod; // this is a bit unsafe since anyone can change it. + property StoreInUndo: boolean read GetStoreInUndo; end; {---TBoldRoleRTInfo---} TBoldRoleRTInfo = class(TBoldMemberRTInfo) private fClassTypeInfoOfOtherEnd: TBoldClassTypeInfo; - fIndexOfOtherEnd: Integer; // Note, -1 if other end not maintained + fIndexOfOtherEnd: Integer; fLinkClassTypeInfo: TBoldClassTypeInfo; fOtherIndexInLinkClass: Integer; fOwnIndexInLinkClass: Integer; fQualifiers: TBoldMemberRTInfoList; - fRoleRTInfoOfOtherEnd: TBoldRoleRTInfo; // note, for an indirect this is the role in the link class + fRoleRTInfoOfOtherEnd: TBoldRoleRTInfo; fRoleType: TBoldRoleType; fMultiplicity: string; fChangeability: TChangeableKind; @@ -359,8 +497,8 @@ TBoldRoleRTInfo = class(TBoldMemberRTInfo) fDeleteAction: TDeleteAction; fAssociationStereotype: string; class procedure SetPass2InfoForAssociation(SystemTypeInfo: TBoldSystemTypeInfo; moldASsociation: TMoldAssociation); - function GetIndexOfLinkObjectRole: Integer; - function GetIndexOfMainRole: Integer; + function GetIndexOfLinkObjectRole: Integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetIndexOfMainRole: Integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure InitQualifiers(Qualifiers: TMoldQualifierList); function GetDefaultRegionMode: TBoldAssociationEndDefaultRegionMode; protected @@ -373,14 +511,16 @@ TBoldRoleRTInfo = class(TBoldMemberRTInfo) function GetStringRepresentation(Representation: TBoldRepresentation): string; override; function GetEncouragesOptimisticLockingOnDeletedOnly: Boolean; override; function GetCanHaveOldValue: Boolean; override; + function GetIsRole: Boolean; override; + function GetStoreInUndo: boolean; override; public - destructor Destroy; override; + destructor destroy; override; procedure SetForceOtherEnd; property ClassTypeInfoOfOtherEnd: TBoldClassTypeInfo read FClassTypeInfoOfOtherEnd; property ForceOtherEnd: Boolean index befForceOtherEnd read GetElementFlag; property IndexOfLinkObjectRole: Integer read GetIndexOfLinkObjectRole; property IndexOfMainRole: Integer read GetIndexOfMainRole; - property IndexOfOtherEnd: Integer read FIndexOfOtherEnd; // index of the main role + property IndexOfOtherEnd: Integer read FIndexOfOtherEnd; property IsIndirect: Boolean index befIsIndirect read GetElementFlag; property IsNavigable: Boolean index befIsNavigable read GetElementFlag; property IsOrdered: Boolean index befIsOrdered read GetElementFlag; @@ -402,21 +542,6 @@ TBoldRoleRTInfo = class(TBoldMemberRTInfo) property AssociationStereotype: string read fAssociationStereotype; end; - {---TBoldListTypeInfo---} - TBoldListTypeInfo = class(TBoldElementTypeInfo) - private - fListClass: TClass; - fListElementTypeInfo: TBoldElementTypeInfo; - protected - constructor Create(ListElementTypeInfo: TBoldElementTypeInfo; SystemTypeInfo: TBoldSystemTypeInfo; ListClass: TClass); - function GetBoldType: TBoldElementTypeInfo; override; - function GetStringRepresentation(Representation: TBoldRepresentation): string; override; - public - function ConformsTo(CompareElement: TBoldElementTypeInfo): Boolean; override; - property ListClass: TClass read fListClass; - property ListElementTypeInfo: TBoldElementTypeInfo read fListElementTypeInfo; - end; - {---TBoldAttributeRTInfo---} TBoldAttributeRTInfo = class(TBoldMemberRTInfo) private @@ -426,6 +551,8 @@ TBoldAttributeRTInfo = class(TBoldMemberRTInfo) constructor Create(ClassTypeInfo: TBoldClassTypeInfo; MoldAttribute: TMoldAttribute; TypeNameDictionary: TBoldTypeNameDictionary); function GetMemberClass: TClass; override; function GetStringRepresentation(Representation: TBoldRepresentation): string; override; + function GetIsRole: Boolean; override; + function GetStoreInUndo: boolean; override; public property AllowNull: Boolean index befAllowNull read GetElementFlag; property Length: Integer read FLength; @@ -439,15 +566,20 @@ TBoldAttributeTypeInfo = class(TBoldElementTypeInfo) fAttributeClass: TClass; fIsAbstract: Boolean; fSuperAttributeTypeInfo: TBoldAttributeTypeInfo; + fListTypeInfo: TBoldListTypeInfo; protected constructor Create(const ModelName, ExpressionName: string; AttributeClass: TClass; SuperType: TBoldAttributeTypeInfo;const FallBackDelphiName: String; SystemTypeInfo: TBoldSystemTypeInfo; IsAbstract: Boolean); function GetBoldType: TBoldElementTypeInfo; override; + function GetListTypeInfo: TBoldListTypeInfo; override; public function BoldIsA(aType: TBoldElementTypeInfo): Boolean; function ConformsTo(CompareElement: TBoldElementTypeInfo): Boolean; override; + function ElementClass: TBoldElementClass; override; + function CreateElement: TBoldElement; override; property AttributeClass: TClass read fAttributeClass; property IsAbstract: Boolean read fIsAbstract; property SuperAttributeTypeInfo: TBoldAttributeTypeInfo read fSuperAttributeTypeInfo; + property ListTypeInfo: TBoldListTypeInfo read GetListTypeInfo; end; {---TBoldMethodRTInfo---} @@ -508,19 +640,21 @@ implementation SysUtils, BoldUtils, BoldGuard, - BoldIndexableList, BoldNameExpander, BoldHashIndexes, BoldMemberTypeDictionary, BoldOcl, BoldTypeList, BoldDefaultTaggedValues, - BoldCoreConsts, - BoldSystem; // FIXME move out last links here to dictionaries + BoldSystem, + BoldAttributes, + BoldDefaultStreamNames, + Windows; +{$IFDEF BOLD_LITE} var - IX_Element: integer = -1; - IX_ObjectClass: integer = -1; + G_TheSystemType: TBoldSystemTypeInfo; +{$ENDIF} type {---TObjectClassIndex---} @@ -535,6 +669,12 @@ TElementIndex = class(TBoldObjectHashIndex) function ItemAsKeyObject(Item: TObject): TObject; override; end; + {---TObjectClassIndex---} + TListClassIndex = class(TBoldClassHashIndex) + protected + function ItemAsKeyClass(Item: TObject): TClass; override; + end; + { TElementIndex } function TElementIndex.ItemASKeyObject(Item: TObject): TObject; begin @@ -548,7 +688,6 @@ function TObjectClassIndex.ItemAsKeyClass(Item: TObject): TClass; Result := TBoldClassTypeInfo(Item).ObjectClass; end; - {---TBoldClassTypeInfoList---} constructor TBoldClassTypeInfoList.Create; begin @@ -557,6 +696,11 @@ constructor TBoldClassTypeInfoList.Create; SetIndexvariable(IX_ObjectClass, AddIndex(TObjectClassIndex.Create)); end; +function TBoldClassTypeInfoList.GetEnumerator: TBoldClassTypeInfoListTraverser; +begin + result := CreateTraverser as TBoldClassTypeInfoListTraverser; +end; + function TBoldClassTypeInfoList.GetItem(index: Integer): TBoldClassTypeInfo; begin Result := TBoldClassTypeInfo(inherited Items[index]); @@ -574,10 +718,20 @@ function TBoldClassTypeInfoList.GetItemByExpressionName(const ExpressionName: st function TBoldClassTypeInfoList.GetItemByObjectClass(ObjectClass: TClass): TBoldClassTypeInfo; begin - Result := TBoldClassTypeInfo(TObjectClassIndex(Indexes[IX_ObjectClass]).FindByClass(ObjectClass)); + Result := TBoldClassTypeInfo(TBoldClassHashIndex(Indexes[IX_ObjectClass]).FindByClass(ObjectClass)); +end; + +function TBoldClassTypeInfoList.TraverserClass: TBoldIndexableListTraverserClass; +begin + result := TBoldClassTypeInfoListTraverser; end; {---TBoldMemberRTInfoList---} +function TBoldMemberRTInfoList.GetEnumerator: TBoldMemberRTInfoListTraverser; +begin + result := CreateTraverser as TBoldMemberRTInfoListTraverser; +end; + function TBoldMemberRTInfoList.GetItem(index: Integer): TBoldMemberRTInfo; begin Result := TBoldMemberRTInfo(inherited Items[index]); @@ -588,12 +742,22 @@ function TBoldMemberRTInfoList.GetItemByModelName(const ModelName: string): TBol Result := TBoldMemberRTInfo(inherited ItemsByModelName[ModelName]); end; +function TBoldMemberRTInfoList.TraverserClass: TBoldIndexableListTraverserClass; +begin + result := TBoldMemberRTInfoListTraverser; +end; + function TBoldMemberRTInfoList.GetItemByExpressionName(const ExpressionName: string): TBoldMemberRTInfo; begin Result := TBoldMemberRTInfo(inherited ItemsByExpressionName[ExpressionName]); end; {---TBoldMethodRTInfoList---} +function TBoldMethodRTInfoList.GetEnumerator: TBoldMethodRTInfoListTraverser; +begin + result := CreateTraverser as TBoldMethodRTInfoListTraverser; +end; + function TBoldMethodRTInfoList.GetItem(index: Integer): TBoldMethodRTInfo; begin Result := TBoldMethodRTInfo(inherited Items[index]); @@ -604,6 +768,11 @@ function TBoldMethodRTInfoList.GetItemByModelName(const ModelName: string): TBol Result := TBoldMethodRTInfo(inherited ItemsByModelName[ModelName]); end; +function TBoldMethodRTInfoList.TraverserClass: TBoldIndexableListTraverserClass; +begin + result := TBoldMethodRTInfoListTraverser; +end; + function TBoldMethodRTInfoList.GetItemByExpressionName(const ExpressionName: string): TBoldMethodRTInfo; begin Result := TBoldMethodRTInfo(inherited ItemsByExpressionName[ExpressionName]); @@ -612,14 +781,21 @@ function TBoldMethodRTInfoList.GetItemByExpressionName(const ExpressionName: str {---TBoldListTypeInfoList---} function TBoldListTypeInfoList.GetItemByElement(Element: TBoldElementTypeInfo): TBoldListTypeInfo; begin - Result := TBoldListTypeInfo(TElementIndex(Indexes[IX_Element]).FindByObject(Element)) + Result := TBoldListTypeInfo(TBoldObjectHashIndex(Indexes[IX_Element]).FindByObject(Element)) +end; + +function TBoldListTypeInfoList.GetItemByListClass( + ListClass: TClass): TBoldListTypeInfo; +begin + Result := TBoldListTypeInfo(TBoldClassHashIndex(Indexes[IX_ListClass]).FindByClass(ListClass)); end; constructor TBoldListTypeInfoList.Create; begin inherited; SetIndexCapacity(4); - SetIndexVariable(IX_Element, self.AddIndex(TElementIndex.Create)); + SetIndexVariable(IX_Element, AddIndex(TElementIndex.Create)); + SetIndexVariable(IX_ListClass, AddIndex(TListClassIndex.Create)); end; {---TBoldTypeTypeInfo---} @@ -639,11 +815,65 @@ function TBoldTypeTypeInfo.GetBoldType: TBoldElementTypeInfo; result := self; end; +function TBoldTypeTypeInfo.GetListTypeInfo: TBoldListTypeInfo; +begin + Result := TBoldSystemTypeInfo(SystemTypeInfo).ListTypes.ItemByElement[self]; +end; + +{ TBoldAttributeTypeInfoList } + +function TBoldAttributeTypeInfoList.GetEnumerator: TBoldAttributeTypeInfoListTraverser; +begin + result := CreateTraverser as TBoldAttributeTypeInfoListTraverser; +end; + +function TBoldAttributeTypeInfoList.GetItem( + index: Integer): TBoldAttributeTypeInfo; +begin + Result := TBoldAttributeTypeInfo(inherited Items[index]); +end; + +function TBoldAttributeTypeInfoList.GetItemByExpressionName( + const ExpressionName: string): TBoldAttributeTypeInfo; +begin + Result := TBoldAttributeTypeInfo(inherited ItemsByExpressionName[ExpressionName]); +end; + +function TBoldAttributeTypeInfoList.GetItemByModelName( + const ModelName: string): TBoldAttributeTypeInfo; +begin + Result := TBoldAttributeTypeInfo(inherited ItemsByModelName[ModelName]); +end; + +function TBoldAttributeTypeInfoList.TraverserClass: TBoldIndexableListTraverserClass; +begin + result := TBoldAttributeTypeInfoListTraverser; +end; + {---TBoldSystemTypeInfo---} function TBoldSystemTypeInfo.GetListTypeInfoByElement(Element: TBoldElementTypeInfo): TBoldListTypeInfo; begin - Result := fListTypes.ItemByElement[Element]; + if not Assigned(Element) then + Result := UntypedListTypeInfo + else + result := Element.ListTypeInfo; +end; + +function TBoldSystemTypeInfo.GetMemberTypeInfoByQualifiedName(const AClassName, AMemberName: string): TBoldMemberRtInfo; +var + vClassTypeInfo: TBoldClassTypeInfo; +begin + result := nil; + vClassTypeInfo := ClassTypeInfoByExpressionName[AClassName]; + if Assigned(vClassTypeInfo) then + result := vClassTypeInfo.MemberRTInfoByExpressionName[AMemberName]; +end; + +function TBoldSystemTypeInfo.GetClassTypeInfoByClass( + ObjectClass: TClass): TBoldClassTypeInfo; +begin + result := TopSortedClasses.ItemsByObjectClass[ObjectClass]; end; function TBoldSystemTypeInfo.GetClassTypeInfoByExpressionName(const name: string): TBoldClassTypeInfo; @@ -663,6 +893,7 @@ function TBoldSystemTypeInfo.GetAttributeTypeInfoByDelphiName(const name: string Assert(not Assigned(result) or (Result is TBoldAttributeTypeInfo)); end; + constructor TBoldSystemTypeInfo.Create(moldModel: TMoldModel; UseGeneratedCode, CheckCodeCheckSum: Boolean; TypeNameDictionary: TBoldTypeNameDictionary); var i: integer; @@ -670,6 +901,7 @@ constructor TBoldSystemTypeInfo.Create(moldModel: TMoldModel; UseGeneratedCode, BoldObjectListClasses: TBoldGeneratedClassList; Errors: TStringList; Guard: IBoldGuard; + BoldGeneratedCodeDescriptor: TBoldGeneratedCodeDescriptor; begin inherited Create(MoldModel, self); Guard := TBoldGuard.Create(BoldObjectListClasses, BoldObjectClasses, Errors); @@ -679,11 +911,16 @@ constructor TBoldSystemTypeInfo.Create(moldModel: TMoldModel; UseGeneratedCode, SetElementFlag(befSystemIsRunnable, true); fOptimisticLocking := MoldModel.OptimisticLocking; +{$IFDEF BOLD_LITE} + G_TheSystemType := self; +{$ENDIF} SetValueType(bvtSystem); - fTypeTypeInfo := TBoldTypeTypeInfo.Create('MetaType', 'MetaType', 'MetaType', self); // do not localize + fTypeTypeInfo := TBoldTypeTypeInfo.Create('MetaType', 'MetaType', 'MetaType', self); - fAttributeTypes := TBoldElementTypeInfoList.Create; + fAttributeTypes := TBoldAttributeTypeInfoList.Create; + AttributeTypes.Capacity := TypeNameDictionary.count; fListTypes := TBoldListTypeInfoList.Create; + ListTypes.Capacity := TypeNameDictionary.count + moldModel.Classes.Count + 1; ListTypes.Add(TBoldListTypeInfo.Create(fTypeTypeinfo, self, TBoldTypeList)); SetElementFlag(befSystemPersistent, true); SetElementFlag(befGenerateDefaultRegions, MoldModel.GenerateDefaultRegions); @@ -696,17 +933,29 @@ constructor TBoldSystemTypeInfo.Create(moldModel: TMoldModel; UseGeneratedCode, fUseGeneratedCode := UseGeneratedCode; if UseGeneratedCode then begin + BoldGeneratedCodeDescriptor := nil; for i := 0 to GeneratedCodes.Count - 1 do - if GeneratedCodes.ModelEntries[i].ExpressionName = MoldModel.ExpandedExpressionName then + if (GeneratedCodes.ModelEntries[i].ExpressionName = MoldModel.ExpandedExpressionName) then begin - if assigned(GeneratedCodes.ModelEntries[i].InstallBusinessClasses) then - GeneratedCodes.ModelEntries[i].InstallBusinessClasses(BoldObjectClasses); - if assigned(GeneratedCodes.ModelEntries[i].InstallObjectListClasses) then - GeneratedCodes.ModelEntries[i].InstallObjectListClasses(BoldObjectListClasses); - if CheckCodeCheckSum and (GeneratedCodes.ModelEntries[i].CRC <> '') and - (GeneratedCodes.ModelEntries[i].CRC <> MoldModel.CRC) then - InitializationError(sCRCDiffers, [MoldModel.CRC, GeneratedCodes.ModelEntries[i].CRC]); + BoldGeneratedCodeDescriptor := GeneratedCodes.ModelEntries[i]; + if (not CheckCodeCheckSum or (BoldGeneratedCodeDescriptor.CRC = '') or (BoldGeneratedCodeDescriptor.CRC = MoldModel.CRC)) then + begin + if assigned(BoldGeneratedCodeDescriptor.InstallBusinessClasses) then + begin + BoldObjectClasses.Capacity := moldModel.Classes.Count; + BoldGeneratedCodeDescriptor.InstallBusinessClasses(BoldObjectClasses); + end; + if assigned(BoldGeneratedCodeDescriptor.InstallObjectListClasses) then + begin + BoldObjectListClasses.Capacity := moldModel.Classes.Count; + BoldGeneratedCodeDescriptor.InstallObjectListClasses(BoldObjectListClasses); + end; + break; + end; end; + if CheckCodeCheckSum and (Assigned(BoldGeneratedCodeDescriptor) and (BoldGeneratedCodeDescriptor.CRC <> '') and (BoldGeneratedCodeDescriptor.CRC <> MoldModel.CRC) ) then + InitializationError('Generated CRC differs from Model CRC (expected %s, found %s). Please regenerate code.', + [MoldModel.CRC, BoldGeneratedCodeDescriptor.CRC]); end; for I := 0 to TypeNameDictionary.count - 1 do @@ -714,12 +963,8 @@ constructor TBoldSystemTypeInfo.Create(moldModel: TMoldModel; UseGeneratedCode, InstallAttributeType(TypeNameDictionary, i); end; - // The super-element-list that all other lists conform to (Used for OCL) - // Note: The elements does not need to (and should not) conform! - ListTypes.Add(TBoldListTypeInfo.Create(nil, self, TBoldObjectList)); - - // Superclasses must be constructed first. - // This also assures that FClasses will be topologicaly sorted + fUntypedListTypeInfo := TBoldListTypeInfo.Create(nil, self, TBoldObjectList); + ListTypes.Add(fUntypedListTypeInfo); moldModel.EnsureTopSorted; @@ -729,16 +974,15 @@ constructor TBoldSystemTypeInfo.Create(moldModel: TMoldModel; UseGeneratedCode, begin for i := 0 to Errors.Count - 1 do InitializationError(Errors[i], []); - // hopefully the root-class can be installed, it is required to get OCL running... TBoldClassTypeInfo.Create(self, moldModel.Classes[0], TypeNameDictionary, BoldObjectClasses, BoldObjectListClasses, true); exit; end; - + TopSortedClasses.Capacity := moldModel.Classes.Count; for I := 0 to moldModel.Classes.Count - 1 do TBoldClassTypeInfo.Create(self, moldModel.Classes[I], TypeNameDictionary, BoldObjectClasses, BoldObjectListClasses); - for I := 0 to moldModel.Associations.Count - 1 do // FIXME iterate on Classes instead + for I := 0 to moldModel.Associations.Count - 1 do TBoldRoleRTInfo.SetPass2InfoForAssociation(self, moldModel.Associations[I]); if GenerateMultiplicityConstraints then @@ -750,7 +994,7 @@ constructor TBoldSystemTypeInfo.Create(moldModel: TMoldModel; UseGeneratedCode, for i := 0 to TopSortedClasses.Count - 1 do if CompareText(TopSortedClasses[i].ObjectClass.ClassName, TopSortedClasses[i].DelphiName) <> 0 then begin - InitializationError(sGeneratedCodeNotRegistered, + InitializationError('Generated code for %s not registered with framework, ensure that it is included in project', [TopSortedClasses[i].ExpressionName]); end; end; @@ -758,6 +1002,7 @@ constructor TBoldSystemTypeInfo.Create(moldModel: TMoldModel; UseGeneratedCode, fMethodsInstalled := False; fNilTypeInfo := TBoldNilTypeInfo.Create(self, nil, nil, nil, nil); + fValueSetTypeInfo := AttributeTypeInfoByExpressionName['ValueSet']; end; function TBoldSystemTypeInfo.GetEvaluator: TBoldEvaluator; @@ -770,6 +1015,7 @@ function TBoldSystemTypeInfo.GetEvaluator: TBoldEvaluator; destructor TBoldSystemTypeInfo.Destroy; begin FreeAndNil(fListTypes); + FreeAndNil(fValueSetTypeInfoList); FreeAndNil(fAttributeTypes); FreeAndNil(fEvaluator); FreeAndNil(fTypeTypeInfo); @@ -780,6 +1026,97 @@ destructor TBoldSystemTypeInfo.Destroy; inherited; end; +function TBoldSystemTypeInfo.FindElement(const AText: string; + ASearchOptions: TBoldTypeInfoSearchOptions; + ASearchTypes: TBoldSearchTypes): TBoldMetaElement; + +var + s: string; + + function StringMatch(AElement: TBoldMetaElement): boolean; + begin + result :=((soPartialMatch in ASearchOptions) and (Pos(s, UpperCase(AElement.ExpressionName)) > 0)) + or SameText(UpperCase(AElement.ExpressionName), s); + end; + +var + ClassTypeInfo: TBoldClassTypeInfo; + MemberRTInfo: TBoldMemberRTInfo; + MethodRTInfo: TBoldMethodRTInfo; + AttributeTypeInfo: TBoldAttributeTypeInfo; +begin + result := nil; + s := UpperCase(AText); +// TBoldSearchType = stClass, stAttribute, stRole, stMethod, stType + for ClassTypeInfo in TopSortedClasses do + begin + if (stClass in ASearchTypes) and StringMatch(ClassTypeInfo) then + begin + result := ClassTypeInfo; + exit; + end; + if (stAttribute in ASearchTypes) or (stRole in ASearchTypes) then + for MemberRTInfo in ClassTypeInfo.AllMembers do + begin + if (((stRole in ASearchTypes) and MemberRTInfo.IsRole) + or ((stAttribute in ASearchTypes) and MemberRTInfo.IsAttribute) + and StringMatch(MemberRTInfo)) then + begin + result := MemberRTInfo; + exit; + end + end; + if (stMethod in ASearchTypes) then + for MethodRTInfo in ClassTypeInfo.Methods do + if StringMatch(MethodRTInfo) then + begin + result := MethodRTInfo; + exit; + end + end; + if (stType in ASearchTypes) then + for AttributeTypeInfo in AttributeTypes do + if StringMatch(AttributeTypeInfo) then + begin + result := AttributeTypeInfo; + exit; + end +end; + +function TBoldSystemTypeInfo.FindValueSetAndTypeByName( + const AName: string; out AElement: TBoldElement; out ATypeInfo: TBoldElementTypeInfo): boolean; +var + i: integer; + vValueSetClass: TBAValueSetClass; +begin + result := false; + if AName = '' then + exit; + for I := 0 to ValueSetTypeInfoList.Count - 1 do + begin + vValueSetClass := TBAValueSetClass(ValueSetTypeInfoList[i].ElementClass); + // TBABoolean descendants like TBAConstraint do not define new values, so they contain duplicated T/F therefore we skip them + if {(vValueSetClass = TBABoolean) or} {(not vValueSetClass.InheritsFrom(TBABoolean) and} (vValueSetClass.GetValues <> nil) then + begin + AElement := vValueSetClass.GetValues.FindByString(brDefault, AName); + if Assigned(AElement) then + begin + result := true; + ATypeInfo := ValueSetTypeInfoList[i]; + exit; + end; + end; + end; +end; + +function TBoldSystemTypeInfo.FindValueSetByName( + const AName: string): TBoldElement; +var + vTypeInfo: TBoldElementTypeInfo; +begin + FindValueSetAndTypeByName(AName, result, vTypeInfo); +end; + function TBoldSystemTypeInfo.ConformsTo(CompareElement: TBoldElementTypeInfo): Boolean; begin Result := CompareElement = self; @@ -793,37 +1130,55 @@ function TBoldSystemTypeInfo.GetValueTypeNameList: TBoldElementTypeInfoList; begin fValueTypeNameList := TBoldElementTypeInfoList.Create; fValueTypeNameList.OwnsEntries := false; - // System + fValueTypeNameList.Capacity := TopSortedClasses.Count + AttributeTypes.Count + ListTypes.Count + 2; fValueTypeNameList.Add(self); - // Classes for I := 0 to TopSortedClasses.Count - 1 do fValueTypeNameList.Add(TopSortedClasses[I]); - // Attributes for I := 0 to AttributeTypes.Count - 1 do fValueTypeNameList.Add(AttributeTypes[I]); - // MetaType fValueTypeNameList.Add(BoldType); - // ListTypes for I := 0 to ListTypes.Count - 1 do fValueTypeNameList.Add(ListTypes[I]); end; Result := fValueTypeNameList; end; +function TBoldSystemTypeInfo.GetValueSetTypeInfoList: TBoldElementTypeInfoList; +var + I: Integer; +begin + if not assigned(fValueSetTypeInfoList) then + begin + fValueSetTypeInfoList := TBoldElementTypeInfoList.Create; + fValueSetTypeInfoList.OwnsEntries := false; + fValueSetTypeInfoList.Capacity := AttributeTypes.Count; + for I := 0 to AttributeTypes.Count - 1 do + if AttributeTypes[I].ConformsTo(fValueSetTypeInfo) and not TBoldAttributeTypeInfo(AttributeTypes[I]).IsAbstract then + fValueSetTypeInfoList.Add(AttributeTypes[I]); + end; + result := fValueSetTypeInfoList; +end; + procedure TBoldSystemTypeInfo.GetValueTypeNames(S: TStrings; Classes, Types, System, metatype, lists: Boolean); var I: Integer; begin S.Clear; - for I := 0 to ValueTypeNameList.Count - 1 do - begin - case ValueTypeNameList[I].BoldValueType of - bvtList: if lists then S.Add(ValueTypeNameList[I].ExpressionName); - bvtClass: if Classes then S.Add(ValueTypeNameList[I].ExpressionName); - bvtAttr: if Types then S.Add(ValueTypeNameList[I].ExpressionName); - bvtSystem: if System then S.Add(ValueTypeNameList[I].ExpressionName); - bvtType: if metatype then S.Add(ValueTypeNameList[I].ExpressionName); + s.Capacity := ValueTypeNameList.Count; + s.BeginUpdate; + try + for I := 0 to ValueTypeNameList.Count - 1 do + begin + case ValueTypeNameList[I].BoldValueType of + bvtList: if lists then S.Add(ValueTypeNameList[I].ExpressionName); + bvtClass: if Classes then S.Add(ValueTypeNameList[I].ExpressionName); + bvtAttr: if Types then S.Add(ValueTypeNameList[I].ExpressionName); + bvtSystem: if System then S.Add(ValueTypeNameList[I].ExpressionName); + bvtType: if metatype then S.Add(ValueTypeNameList[I].ExpressionName); + end; end; + finally + s.EndUpdate; end; end; @@ -882,26 +1237,64 @@ constructor TBoldClassTypeInfo.Create(SystemTypeInfo: TBoldSystemTypeInfo; moldC fStereotype := MoldClass.Stereotype; end else - inherited Create(nil, SystemTypeInfo); // NilTypeInfo... + inherited Create(nil, SystemTypeInfo); SetValueType(bvtClass); fSystemTypeInfo := SystemTypeInfo; fAllMembers := TBoldMemberRTInfoList.Create; + FAllRoles := TBoldRoleRTInfoList.Create; + FAllRoles.OwnsEntries := false; fMethods := TBoldMethodRTInfoList.Create; - + fSubClasssesBoldClassTypeInfoList := TBoldClassTypeInfoList.Create; + fSubClasssesBoldClassTypeInfoList.OwnsEntries := false; Initialize(MoldClass, TypeNameDictionary, BoldObjectClasses, BoldObjectListClasses, SkipMembers); end; +function TBoldClassTypeInfo.ElementClass: TBoldElementClass; +begin + result := TBoldObjectReference +end; + +function TBoldClassTypeInfo.CreateElement: TBoldElement; +begin + result := TBoldObjectReference.CreateWithTypeInfo(self); +end; + function TBoldClassTypeInfo.BoldIsA(C2: TBoldElementTypeInfo): Boolean; +var + lBoldClassTypeInfo: TBoldClassTypeInfo; begin - result := false; - if (C2.ClassType = TBoldClassTypeInfo) or (C2 is TBoldClassTypeInfo) then // TBoldClassTypeInfo may have subclasses in future + if (c2.ClassType = TBoldClassTypeInfo) then begin - if c2 = self then - Result := True - else if Assigned(SuperClassTypeInfo) then - Result := SuperClassTypeInfo.BoldIsA(C2); - end; + if C2 = Self then + begin + Result := True; + end + else + begin + lBoldClassTypeInfo := TBoldClassTypeInfo(C2); + // if TopSortedIndex of this class is smaller than of the other class then it can't possibly descend from it + if TopSortedIndex < lBoldClassTypeInfo.TopSortedIndex then + Result := false + else + begin + if SystemTypeInfo.UseGeneratedCode then + Result := ObjectClass.InheritsFrom(lBoldClassTypeInfo.ObjectClass) + else + begin + Result := false; + lBoldClassTypeInfo := self; + while not result and Assigned(lBoldClassTypeInfo.SuperClassTypeInfo) do + begin + lBoldClassTypeInfo := lBoldClassTypeInfo.SuperClassTypeInfo; + Result := lBoldClassTypeInfo = C2; + end; + end; + end; + end; + end + else + Result := false; end; function TBoldClassTypeInfo.ConformsTo(CompareElement: TBoldElementTypeInfo): Boolean; @@ -926,7 +1319,7 @@ function TBoldNilTypeInfo.BoldIsA(C2: TBoldElementTypeInfo): Boolean; function TBoldNilTypeInfo.GetStringRepresentation(Representation: TBoldRepresentation): string; begin - result := 'nil'; // do not localize + result := 'nil'; end; {---TBoldMemberRTInfo---} @@ -948,13 +1341,16 @@ constructor TBoldMemberRTInfo.Create(ClassTypeInfo: TBoldClassTypeInfo; moldMemb SetElementFlag(befDelayedFetch, moldMember.EffectiveDelayedFetch); fIndex := ClassTypeInfo.AllMembers.Count; fEmbeddedLinkIndex := -1; + fDeriverIndex := -1; ClassTypeInfo.AllMembers.Add(self); + if IsRole then + ClassTypeInfo.AllRoles.Add(Self); if isDerived then begin + fDeriverIndex := ClassTypeInfo.fDerivedMemberCount; + inc(ClassTypeInfo.fDerivedMemberCount); fDeriveExpression := MoldMember.DerivationOCL; - // Check if we find an override expression in a subclass somewhere, - // start from superclass and move up in inheritance chain if DeriveExpression <> '' then begin MoldClass := MoldMember.Model.Classes[ClassTypeInfo.topSortedIndex]; @@ -962,7 +1358,6 @@ constructor TBoldMemberRTInfo.Create(ClassTypeInfo: TBoldClassTypeInfo; moldMemb while assigned(MoldClass) and (MoldClass <> MoldMember.MoldClass) do begin Expressions.Text := MoldClass.BoldTVByName[TAG_DERIVATIONEXPRESSIONS]; - // the following fixes a problem with the models in 2.0.20 that added extra spaces sometimes. for i := 0 to Expressions.Count - 1 do Expressions[i] := trim(Expressions[i]); @@ -982,7 +1377,6 @@ constructor TBoldMemberRTInfo.Create(ClassTypeInfo: TBoldClassTypeInfo; moldMemb constructor TBoldMemberRTInfo.CreateWithoutMoldMember(ClassTypeInfo: TBoldClassTypeInfo; const ModelName, ExpressionName, DelphiName: string; Persistent: Boolean; TypeNameDictionary: TBoldTypeNameDictionary); function EnsureLowerCaseLeadingCharacter(const ExpressionName: String): String; begin - // this is needed for the linkObject-roles since their name is made from the expressionname of the class... result := ExpressionName; if length(result) > 0 then result[1] := LowerCase(result[1])[1]; @@ -993,7 +1387,10 @@ constructor TBoldMemberRTInfo.CreateWithoutMoldMember(ClassTypeInfo: TBoldClassT fClassTypeInfo := ClassTypeInfo; FIndex := ClassTypeInfo.AllMembers.Count; fEmbeddedLinkIndex := -1; + fDeriverIndex := -1; ClassTypeInfo.AllMembers.Add(self); + if IsRole then + ClassTypeInfo.AllRoles.Add(Self); end; destructor TBoldMemberRTInfo.Destroy; @@ -1041,7 +1438,7 @@ function TBoldMethodRTInfo.GetSignature; destructor TBoldMethodRTInfo.Destroy; begin freeAndNil(fParameterList); - inherited; + inherited; end; function TBoldMethodRTInfo.GetStringRepresentation(Representation: TBoldRepresentation): string; @@ -1094,7 +1491,6 @@ procedure TBoldMethodRTInfo.EnsureParameterLIst(const Signature: string); pClass := ClassTypeInfo.SystemTypeInfo.ClassTypeInfoByModelName[pType]; if assigned(pClass) then pType := pClass.Delphiname; - // take care of commaseparated parameterlists while Pos(',', Parameter) <> 0 do begin pname := trim(copy(Parameter, 0, Pos(',', Parameter) - 1)); @@ -1116,8 +1512,7 @@ class procedure TBoldRoleRTInfo.SetPass2InfoForAssociation(SystemTypeInfo: TBold begin if assigned(aRole) then begin - // if the role of the other end is not navigable, it might not be there, - // but there is still a class on the other end... + aRole.fClassTypeInfoOfOtherEnd := ClassOfOtherEnd; aRole.fRoleRTInfoOfOtherEnd := RoleofOtherEnd; if assigned(RoleOfOtherEnd) then @@ -1201,16 +1596,15 @@ class procedure TBoldRoleRTInfo.SetPass2InfoForAssociation(SystemTypeInfo: TBold LinkObjectRole2 := nil; if not assigned(moldAssociation.Roles[0].moldClass) then begin - SystemTypeInfo.InitializationError(sInvalidAssociation, [MoldAssociation.Name , MoldAssociation.Roles[0].Name]); + SystemTypeInfo.InitializationError('Invalid association: %s.%s does not point to a class', [MoldAssociation.Name , MoldAssociation.Roles[0].Name]); exit; end; if not assigned(moldAssociation.Roles[1].moldClass) then begin - SystemTypeInfo.InitializationError(sInvalidAssociation, [MoldAssociation.Name , MoldAssociation.Roles[1].Name]); + SystemTypeInfo.InitializationError('Invalid association: %s.%s does not point to a class', [MoldAssociation.Name , MoldAssociation.Roles[1].Name]); exit; end; - // note, non-navigable association ends of derived associations will not exist in Mold. - + Class1 := SystemTypeInfo.ClassTypeInfoByModelName[moldAssociation.Roles[0].moldClass.name]; TempMember := Class1.MemberRTInfoByModelName[moldAssociation.Roles[0].name]; Assert(not assigned(TempMember) or (TempMember is TBoldRoleRTInfo)); @@ -1259,12 +1653,11 @@ class procedure TBoldRoleRTInfo.SetPass2InfoForAssociation(SystemTypeInfo: TBold PropagateOtherEnd(LinkObjectRole2, LinkClass, LinkClassRole1); end; end; - // derived associations can have qualifiers, but might only exist in one direction if assigned(Role1) then Role1.InitQualifiers(moldAssociation.Roles[0].Qualifiers); if assigned(Role2) then Role2.InitQualifiers(moldAssociation.Roles[1].Qualifiers); - + PropagateToSubClasses(Role1, LinkObjectRole1, moldAssociation.Roles[0].moldClass); PropagateToSubClasses(Role2, LinkObjectRole2, moldAssociation.Roles[1].moldClass); end; @@ -1297,7 +1690,7 @@ constructor TBoldRoleRTInfo.Create(ClassTypeInfo: TBoldClassTypeInfo; MoldRole: SetElementFlag(befIsSingleRole, not MoldRole.Multi); SetElementFlag(befQualifiedMulti, MoldRole.QualifiedMulti); if IsMultiRole then - SetElementFlag(befDelayedFetch, True); // FIXME: + SetElementFlag(befDelayedFetch, True); SetElementFlag(befMandatory, MoldRole.Mandatory); SetElementFlag(befIsStoredInObject, MoldRole.EffectiveEmbedded and (not MoldRole.Multi) and Persistent); @@ -1323,13 +1716,25 @@ constructor TBoldRoleRTInfo.Create(ClassTypeInfo: TBoldClassTypeInfo; MoldRole: fDeleteAction := MoldRole.EffectiveDeleteAction; fChangeability := MoldRole.Changeability; fAssociationStereotype := MoldRole.Association.Stereotype; + + if IsSingleRole then + begin + if IsIndirect then + fStreamName := BoldContentName_ObjectIdRefPair + else + fStreamName := BoldContentName_ObjectIdRef; + end + else + if IsIndirect then + fStreamName := BoldContentName_ObjectIdListRefPair + else + fStreamName := BoldContentName_ObjectIdListRef; end; constructor TBoldRoleRTInfo.CreateInnerLinkRole(ClassTypeInfo: TBoldClassTypeInfo; MoldRole: TMoldRole; Dummy: Smallint; TypeNameDictionary: TBoldTypeNameDictionary); begin inherited Create(ClassTypeInfo, MoldRole, TypeNameDictionary); fRoleType := rtInnerLInkRole; -// FIsInnerLinkRole := True; SetElementFlag(befIsMultiRole, False); SetElementFlag(befIsSingleRole, true); SetElementFlag(befIsStoredInObject, Persistent); @@ -1345,6 +1750,7 @@ constructor TBoldRoleRTInfo.CreateInnerLinkRole(ClassTypeInfo: TBoldClassTypeInf fAggregation := akNone; fDeleteAction := daAllow; fChangeability := ckFrozen; + fStreamName := BoldContentName_ObjectIdRef; end; constructor TBoldRoleRTInfo.CreateLinkObjectRole(ClassTypeInfo: TBoldClassTypeInfo; MainRole: TMoldRole; TypeNameDictionary: TBoldTypeNameDictionary; Dummy: smallint); @@ -1352,7 +1758,6 @@ constructor TBoldRoleRTInfo.CreateLinkObjectRole(ClassTypeInfo: TBoldClassTypeIn aLinkClass: TMoldClass; begin aLinkClass := MainRole.Association.LinkClass; - // when both link-roles will occur in a class, they must use another namingscheme if MainRole.MoldClass.ChildTo(MainRole.OtherEnd.MoldClass) or MainRole.OtherEnd.MoldClass.ChildTo(MainRole.MoldClass) then inherited CreateWithoutMoldMember(ClassTypeInfo, @@ -1370,7 +1775,7 @@ constructor TBoldRoleRTInfo.CreateLinkObjectRole(ClassTypeInfo: TBoldClassTypeIn SetElementFlag(befIsMultiRole, MainRole.Multi); SetElementFlag(befIsSingleRole, not MainRole.Multi); if IsMultiRole then - SetElementFlag(befDelayedFetch, True); // FIXME: + SetElementFlag(befDelayedFetch, True); SetElementFlag(befMandatory, MainRole.Mandatory); SetElementFlag(befIsStoredInObject, false); SetElementFlag(befIsOrdered, MainRole.EffectiveOrdered); @@ -1378,41 +1783,51 @@ constructor TBoldRoleRTInfo.CreateLinkObjectRole(ClassTypeInfo: TBoldClassTypeIn SetElementFlag(befIsIndirect, false); SetInternalState(BoldDefaultRegionModeMask, BoldDefaultRegionModeShift, integer(aedrmNone)); fRoleType := rtLinkRole; - - // CheckMe Are these correct fAggregation := akNone; fDeleteAction := daAllow; fChangeability := MainRole.Changeability; + if IsMultiRole then + fStreamName := BoldContentName_ObjectIdRef + else + fStreamName := BoldContentName_ObjectIdListRef; +end; + +function TBoldRoleRTInfo.GetStoreInUndo: boolean; +begin + result := not IsDerived and (((RoleType = rtRole) and (not (IsMultiRole or IsIndirect))) or (RoleType = rtInnerLinkRole)); end; function TBoldRoleRTInfo.GetStringRepresentation(Representation: TBoldRepresentation): string; begin Result := ClassTypeInfo.AsString + '.' + ExpressionName; end; + function TBoldRoleRTInfo.GetCanHaveOldValue: Boolean; begin - result := inherited GetCanHaveOldValue and (RoleType in [rtRole, rtInnerLinkRole]); + result := Persistent and (RoleType in [rtRole, rtInnerLinkRole]); end; procedure TBoldRoleRTInfo.SetForceOtherEnd; begin - // should only be called by the region defintions when a multi role is included in a region. SetElementFlag(befForceOtherEnd, true); end; function TBoldRoleRTInfo.GetEncouragesOptimisticLockingOnDeletedOnly: Boolean; begin - // non-embedded roles should validate that they have been - // unchanged in the db when their objects are deleted + result := not IsStoredInObject and Persistent and (RoleType = rtRole); end; - function TBoldRoleRTInfo.GetIsQualified: Boolean; begin result := assigned(Qualifiers) and (Qualifiers.Count > 0); end; +function TBoldRoleRTInfo.GetIsRole: Boolean; +begin + result := true; +end; + function TBoldRoleRTInfo.GetQualifiers: TBoldMemberRTInfoList; begin result := FQualifiers; @@ -1429,43 +1844,6 @@ function TBoldRoleRTInfo.GetMemberClass: TClass; result := TBoldObjectReference; end; -{---TBoldListTypeInfo---} -constructor TBoldListTypeInfo.Create(ListElementTypeInfo: TBoldElementTypeInfo; SystemTypeInfo: TBoldSystemTypeInfo; ListClass: TClass); -begin - if assigned(ListElementTypeInfo) then - inherited Create(ListElementTypeInfo.ModelName + 'List', // do not localize - 'Collection(' + ListElementTypeInfo.ExpressionName + ')', // do not localize - ListElementTypeInfo.Delphiname + 'List', SystemTypeInfo) // do not localize - else - inherited Create('Collection()', 'Collection()', 'Collection()', SystemTypeInfo); // do not localize - fListElementTypeInfo := ListElementTypeInfo; - SetValueType(bvtList); - fListClass := ListClass; -end; - -function TBoldListTypeInfo.ConformsTo(CompareElement: TBoldElementTypeInfo): Boolean; -var - CompareListTypeInfo: TBoldListTypeInfo; -begin - if CompareElement is TBoldListTypeInfo then - begin - CompareListTypeInfo := TBoldListTypeInfo(CompareElement); - Result := not assigned(CompareListTypeInfo.ListElementTypeInfo) or - (assigned(ListElementTypeInfo) and - ListElementTypeInfo.ConformsTo(CompareListTypeInfo.ListElementTypeInfo)); - end - else - Result := False; -end; - -function TBoldListTypeInfo.GetStringRepresentation(Representation: TBoldRepresentation): string; -begin - if assigned(ListElementTypeInfo) then - Result := 'Collection(' + ListElementTypeInfo.AsString + ')' // do not localize - else - Result := 'Collection()'; // do not localize -end; - {---TBoldAttributeRTInfo---} constructor TBoldAttributeRTInfo.Create(ClassTypeInfo: TBoldClassTypeInfo; MoldAttribute: TMoldAttribute; TypeNameDictionary: TBoldTypeNameDictionary); @@ -1473,6 +1851,7 @@ constructor TBoldAttributeRTInfo.Create(ClassTypeInfo: TBoldClassTypeInfo; MoldA Mapping: TBoldTypeNameMapping; begin inherited Create(ClassTypeInfo, MoldAttribute, TypeNameDictionary); + SetElementFlag(befIsAttribute, true); SetElementFlag(befIsStoredInObject, Persistent); SetElementFlag(befAllowNull, MoldAttribute.AllowNull); SetElementFlag(befHasInitalvalue, fInitialvalue <> ''); @@ -1483,7 +1862,7 @@ constructor TBoldAttributeRTInfo.Create(ClassTypeInfo: TBoldClassTypeInfo; MoldA SetElementFlag(befHasInitalvalue, true); Mapping := TypeNameDictionary.MappingForModelName[MoldAttribute.BoldType]; if not assigned(Mapping) then - ClassTypeInfo.SystemTypeInfo.InitializationError(sCannotFindAttributeMapping, + ClassTypeInfo.SystemTypeInfo.InitializationError('Unable to find Mapping for %s.%s: %s', [MoldAttribute.MoldClass.ExpandedExpressionname, MoldAttribute.ExpandedExpressionName, MoldAttribute.BoldType]) @@ -1492,14 +1871,14 @@ constructor TBoldAttributeRTInfo.Create(ClassTypeInfo: TBoldClassTypeInfo; MoldA fBoldType := ClassTypeInfo.SystemTypeInfo.AttributeTypeInfoByExpressionName[Mapping.expressionName]; fStreamName := Mapping.ExpandedContentsName; if not assigned(fBoldType) then - ClassTypeInfo.SystemTypeInfo.InitializationError(sUnableToFindBoldTypeForAttribute, + ClassTypeInfo.SystemTypeInfo.InitializationError('Unable to find BoldType for %s.%s (ExpressionType: %s)', [MoldAttribute.MoldClass.ExpandedExpressionname, MoldAttribute.ExpandedExpressionName, Mapping.ExpressionName]); if assigned(fBoldtype) and not assigned((fBoldType as TBoldAttributeTypeInfo).AttributeClass) then - ClassTypeInfo.SystemTypeInfo.InitializationError(sAttributeHasNoDelphiType, + ClassTypeInfo.SystemTypeInfo.InitializationError('Attribute %s.%s: %s has no registered DelphiType', [MoldAttribute.MoldClass.ExpandedExpressionname, MoldAttribute.ExpandedExpressionName, MoldAttribute.BoldType]); @@ -1507,11 +1886,21 @@ constructor TBoldAttributeRTInfo.Create(ClassTypeInfo: TBoldClassTypeInfo; MoldA end; +function TBoldAttributeRTInfo.GetStoreInUndo: boolean; +begin + result := not IsDerived; +end; + function TBoldAttributeRTInfo.GetStringRepresentation(Representation: TBoldRepresentation): string; begin Result := ClassTypeInfo.AsString + '.' + ExpressionName; end; +function TBoldAttributeRTInfo.GetIsRole: Boolean; +begin + result := false; +end; + function TBoldAttributeRTInfo.GetMemberClass: TClass; begin Assert(BoldType is TBoldAttributeTypeInfo); @@ -1532,33 +1921,45 @@ constructor TBoldAttributeTypeInfo.Create(const ModelName, ExpressionName: strin fSuperAttributeTypeInfo := SuperType; end; +function TBoldAttributeTypeInfo.ElementClass: TBoldElementClass; +begin + result := TBoldMemberClass(AttributeClass); +end; + +function TBoldAttributeTypeInfo.CreateElement: TBoldElement; +begin + result := TBoldMemberClass(AttributeClass).CreateWithTypeInfo(self); +end; + function TBoldAttributeTypeInfo.ConformsTo(CompareElement: TBoldElementTypeInfo): Boolean; begin - Result := False; - if CompareElement is TBoldAttributeTypeInfo then - Result := assigned(AttributeClass) and - AttributeClass.InheritsFrom(TBoldAttributeTypeInfo(CompareElement).AttributeClass) - else if CompareElement is TBoldListTypeInfo then - Result := not assigned(TBoldListTypeInfo(CompareElement).ListElementTypeInfo) or - ConformsTo(TBoldListTypeInfo(CompareElement).ListElementTypeInfo); - // integer conforms to float and currency - if not result and SameText(ExpressionName, 'integer') and // do not localize - (SameText(compareElement.ExpressionName, 'float') or // do not localize - SameText(compareElement.ExpressionName, 'currency')) then // do not localize - result := true + Result := CompareElement = self; + if not Result then + begin + if CompareElement is TBoldAttributeTypeInfo then + Result := assigned(AttributeClass) and AttributeClass.InheritsFrom(TBoldAttributeTypeInfo(CompareElement).AttributeClass) + else if CompareElement is TBoldListTypeInfo then + Result := not assigned(TBoldListTypeInfo(CompareElement).ListElementTypeInfo) or + ConformsTo(TBoldListTypeInfo(CompareElement).ListElementTypeInfo); + if not result and ((SameText(ExpressionName, 'integer') and + (SameText(compareElement.ExpressionName, 'float') or + SameText(compareElement.ExpressionName, 'currency'))) +{$IFDEF DateTimeConformsToDate} + or + (SameText(ExpressionName, 'date') and + SameText(compareElement.ExpressionName, 'datetime')) + or + (SameText(ExpressionName, 'datetime') and + SameText(compareElement.ExpressionName, 'date')) +{$ENDIF} + ) then + result := true + end; end; function TBoldAttributeTypeInfo.BoldIsA(aType: TBoldElementTypeInfo): Boolean; begin - Result := False; - if aType is TBoldAttributeTypeInfo then - begin - if aType = self then - Result := True - else if assigned(SuperAttributeTypeInfo) then - Result := SuperAttributeTypeInfo.BoldIsA(aType); - end else - Result := False; + result := (aType = Self ) or (aType is TBoldAttributeTypeInfo) and Assigned(SuperAttributeTypeInfo) and SuperAttributeTypeInfo.BoldIsA(aType); end; function TBoldRoleRTInfo.GetIndexOfLinkObjectRole: Integer; @@ -1577,16 +1978,34 @@ function TBoldRoleRTInfo.GetIndexOfMainRole: Integer; result := -1; end; +{$IFDEF BOLD_LITE} +class function TBoldClassTypeInfo.NewInstance: TObject; +begin + if G_TheSystemType.TopSortedClasses.Count >= LITE_VERSION_CLASS_LIMIT then + raise EBold.Create('Class limit exceeded'); + + result := InitInstance(addr(G_TheSystemType.fClassTypeInfoMem[G_TheSystemType.TopSortedClasses.Count * + CLASS_TYPE_INFO_MEM_SIZE])); +end; + +procedure TBoldClassTypeInfo.FreeInstance; +begin + CleanUpInstance; +end; +{$ENDIF} + procedure TBoldSystemTypeInfo.ReleaseEvaluator; begin FreeAndNil(fEvaluator); end; -destructor TBoldClassTypeInfo.Destroy; +destructor TBoldClassTypeInfo.destroy; begin assert(not assigned(SystemTypeInfo.TopSortedClasses)); FreeAndNil(fAllMembers); + FreeAndNil(FAllRoles); FreeAndNil(fMethods); + FreeAndNil(fSubClasssesBoldClassTypeInfoList); inherited; end; @@ -1626,10 +2045,10 @@ procedure TBoldClassTypeInfo.InitializeMultiplicityConstraints; Constr: TBoldConstraintRTinfo; begin Constr := TBoldConstraintRTInfo.Create(nil, - Role.ModelName + ' multiplicity constraint', '', '', // do not localize + Role.ModelName + ' multiplicity constraint', '', '', SystemTypeInfo, - format('%s->size %s %d', [role.ExpressionName, ExprFragment, limit]), // do not localize - format(sMultiplicityConstraintMessage,[role.ModelName, moreless, limit, role.ClassTypeInfoOfOtherEnd.ModelName])); + format('%s->size %s %d', [role.ExpressionName, ExprFragment, limit]), + format('Role %s must have %s %d %s',[role.ModelName, moreless, limit, role.ClassTypeInfoOfOtherEnd.ModelName])); AddConstraint(Constr); end; @@ -1645,9 +2064,9 @@ procedure TBoldClassTypeInfo.InitializeMultiplicityConstraints; lower := GetLowerLimitForMultiplicity(RoleRT.Multiplicity); if (upper > 1) and (upper < MaxInt) then - AddMultiplicityConstraint(RoleRT, '<=', sAtMost, upper); + AddMultiplicityConstraint(RoleRT, '<=', 'at most', upper); if (lower > 0) then - AddMultiplicityConstraint(RoleRT, '>=', sAtLeast, lower); + AddMultiplicityConstraint(RoleRT, '>=', 'at least', lower); end; end; end; @@ -1656,11 +2075,13 @@ procedure TBoldClassTypeInfo.InitializeMultiplicityConstraints; procedure TBoldClassTypeInfo.Initialize(MoldClass: TMoldClass; TypeNameDictionary: TBoldTypeNameDictionary; BoldObjectClasses: TBoldGeneratedClassList; BoldObjectListClasses: TBoldGeneratedClassList; SkipMembers: Boolean); var ListClass: TClass; - ListTypeInfo: TBoldListTypeInfo; ListClassDescriptor: TBoldGeneratedClassDescriptor; I: Integer; tempClass: TMoldClass; role: TMoldRole; + AttributeCount: integer; + RoleCount: integer; + MethodCount: integer; begin FTopSortedIndex := SystemTypeInfo.TopSortedClasses.Count; @@ -1677,6 +2098,7 @@ procedure TBoldClassTypeInfo.Initialize(MoldClass: TMoldClass; TypeNameDictionar begin fSuperClassTypeInfo := SystemTypeInfo.ClassTypeInfoByExpressionName[moldClass.SuperClass.ExpandedExpressionName]; fSuperClassTypeInfo.SetElementFlag(befHasSubclasses, True); + fSuperClassTypeInfo.SubClasssesBoldClassTypeInfoList.Add(Self); end; SetObjectClass(BoldObjectClasses); @@ -1691,14 +2113,26 @@ procedure TBoldClassTypeInfo.Initialize(MoldClass: TMoldClass; TypeNameDictionar else ListClass := TBoldObjectList; - ListTypeInfo := TBoldListTypeInfo.Create(Self, SystemTypeInfo, ListClass); + fListTypeInfo := TBoldListTypeInfo.Create(Self, SystemTypeInfo, ListClass); SystemTypeInfo.ListTypes.Add(ListTypeInfo); FFirstOwnMemberIndex := MoldClass.FirstOwnBoldMemberIndex; - if SkipMembers then // this is used if the MoldModel contains errors, and we still need to create a root-class, we want to make it as empty as possible to avoid problems. + if SkipMembers then exit; + RoleCount := 0; + AttributeCount := 0; + for i := 0 to MoldClass.AllBoldMembers.Count - 1 do + begin + if MoldClass.AllBoldMembers[i] is TMoldAttribute then + Inc(AttributeCount) + else + Inc(RoleCount); + end; + fAllRoles.Capacity := RoleCount; + FAllMembers.Capacity := MoldClass.AllBoldMembers.Count; + for i := 0 to MoldClass.AllBoldMembers.Count - 1 do begin if MoldClass.AllBoldMembers[i] is TMoldAttribute then @@ -1717,10 +2151,19 @@ procedure TBoldClassTypeInfo.Initialize(MoldClass: TMoldClass; TypeNameDictionar end; end; fAllMembersCount := FAllMembers.Count; + fAllRolesCount := FAllRoles.Count; fDefaultStringRepresentation := MoldClass.EffectiveDefaultStringRepresentation; - // Install methods backwards to get them in the same index in each class + + MethodCount := 0; + tempClass := moldClass; + repeat + MethodCount := MethodCount + tempClass.Methods.Count; + tempClass := tempClass.SuperClass; + until tempClass = nil; + if MethodCount > 0 then + FMethods.Capacity := MethodCount; for I := 0 to moldClass.Methods.Count - 1 do TBoldMethodRTInfo.Create(self, moldClass.Methods[I], - 1, TypeNameDictionary); @@ -1753,19 +2196,32 @@ function TBoldClassTypeInfo.GetBoldType: TBoldElementTypeInfo; result := SystemTypeInfo.TypeTypeInfo; end; +function TBoldClassTypeInfo.GetDisplayName: String; +begin + result := DelphiName; +end; + +function TBoldClassTypeInfo.GetListTypeInfo: TBoldListTypeInfo; +begin + result := fListTypeInfo; +end; + function TBoldMemberRTInfo.GetCanHaveOldValue: Boolean; begin result := Persistent; end; -function TBoldMemberRTInfo.GetEncouragesOptimisticLockingOnDeletedOnly: Boolean; +function TBoldMemberRTInfo.GetDisplayName: String; begin - result := false; + if Assigned(ClassTypeInfo) then + result := ClassTypeInfo.Displayname + '.' + ExpressionName + else + result := inherited GetDisplayName; end; -function TBoldMemberRTInfo.GetIsAttribute: Boolean; +function TBoldMemberRTInfo.GetEncouragesOptimisticLockingOnDeletedOnly: Boolean; begin - result := not IsSingleRole and not IsMultiRole; + result := false; end; function TBoldMemberRTInfo.GetIsRole: Boolean; @@ -1778,19 +2234,16 @@ procedure TBoldMemberRTInfo.SetBoldType(BoldType: TBoldElementTypeInfo); fBoldType := BoldType; end; -function TBoldListTypeInfo.GetBoldType: TBoldElementTypeInfo; -begin - result := SystemTypeInfo.BoldType; -end; - function TBoldAttributeTypeInfo.GetBoldType: TBoldElementTypeInfo; begin result := SystemTypeInfo.BoldType; end; -function TBoldClassTypeInfo.GetListTypeInfo: TBoldListTypeInfo; +function TBoldAttributeTypeInfo.GetListTypeInfo: TBoldListTypeInfo; begin - result := SystemTypeInfo.ListTypeInfoByElement[self]; + if not Assigned(fListTypeInfo) then + fListTypeInfo := TBoldSystemTypeInfo(SystemTypeInfo).ListTypes.ItemByElement[self]; + result := fListTypeInfo; end; procedure TBoldSystemTypeInfo.InstallAttributeType( @@ -1813,7 +2266,7 @@ procedure TBoldSystemTypeInfo.InstallAttributeType( begin if assigned(TempAttributeType.AttributeClass) and (AnsiCompareText(TempAttributeType.AttributeClass.ClassName, Mapping.ExpandedDelphiName) <> 0) then - InitializationError(sErrorInstallingAttribute, [TypeNameDictionary.Mapping[pos].ExpressionName, TempAttributeType.AttributeClass.ClassName]); + InitializationError('Error installing %s, already mapped to %s', [TypeNameDictionary.Mapping[pos].ExpressionName, TempAttributeType.AttributeClass.ClassName]); exit; end; @@ -1836,7 +2289,7 @@ procedure TBoldSystemTypeInfo.InstallAttributeType( begin SuperDescriptor := BoldMemberTypes.DescriptorByDelphiName[SuperClassName]; if not assigned(SuperDescriptor) then - InitializationError(sErrorInstallingAttribute_MissingSuperType, [TypeNameDictionary.Mapping[pos].ExpressionName, SuperClassName]) + InitializationError('Error installing %s, Super class (%s) not registered', [TypeNameDictionary.Mapping[pos].ExpressionName, SuperClassName]) else begin SuperMapping := TypeNameDictionary.AddMapping; @@ -1953,6 +2406,11 @@ function TBoldElementTypeInfoWithConstraint.GetConstraints(const Name: String): result := nil; end; +function TBoldElementTypeInfoWithConstraint.GetListTypeInfo: TBoldListTypeInfo; +begin + Result := TBoldSystemTypeInfo(SystemTypeInfo).ListTypes.ItemByElement[self]; +end; + function TBoldElementTypeInfoWithConstraint.GetTaggedValueByIndex(Index: integer): string; begin if assigned(fTaggedValues) then @@ -2018,7 +2476,7 @@ destructor TBoldMetaElementWithConstraint.Destroy; begin FreeAndNil(fTaggedValues); FreeAndNil(fConstraints); - inherited; + inherited; end; function TBoldMetaElementWithConstraint.GetConstraintByIndex(Index: integer): TBoldConstraintRTInfo; @@ -2071,6 +2529,11 @@ function TBoldMetaElementWithConstraint.GetTaggedValues(const Tag: string): stri { TBoldConstraintRTInfoList } +function TBoldConstraintRTInfoList.GetEnumerator: TBoldConstraintRTInfoListTraverser; +begin + result := CreateTraverser as TBoldConstraintRTInfoListTraverser; +end; + function TBoldConstraintRTInfoList.GetItem(index: Integer): TBoldConstraintRTInfo; begin result := TBoldConstraintRTInfo(inherited Items[index]); @@ -2081,6 +2544,11 @@ function TBoldConstraintRTInfoList.GetItemByModelName(const ModelName: string): result := TBoldConstraintRTInfo(inherited ItemsByModelName[ModelName]); end; +function TBoldConstraintRTInfoList.TraverserClass: TBoldIndexableListTraverserClass; +begin + result := TBoldConstraintRTInfoListTraverser; +end; + { TBoldConstraintRTInfo } constructor TBoldConstraintRTInfo.create(MoldElement: TMoldElement; const ModelName, ExpressionName, DelphiName: String; SystemTypeInfo: TBoldSystemTypeInfo; const Expression, Description: String); @@ -2088,6 +2556,8 @@ constructor TBoldConstraintRTInfo.create(MoldElement: TMoldElement; const ModelN inherited create(MoldElement, ModelName, ExpressionName, DelphiName, SystemTypeInfo); fExpression := Expression; fDescription := Description; + if Description = '' then + fDescription := ModelName; fBoldType := SystemTYpeInfo.TypeTypeInfo; end; @@ -2096,7 +2566,7 @@ function TBoldConstraintRTInfo.GetBoldType: TBoldElementTypeInfo; result := fBoldType; end; -destructor TBoldRoleRTInfo.Destroy; +destructor TBoldRoleRTInfo.destroy; begin FreeAndNil(FQualifiers); inherited; @@ -2105,7 +2575,7 @@ destructor TBoldRoleRTInfo.Destroy; function TBoldMethodRTInfo.GetBoldType: TBoldElementTypeInfo; begin result := ClassTypeInfo.SystemTypeInfo.ElementTypeInfoByExpressionName[ReturnType]; -end; +end; function TBoldClassTypeInfo.GetQualifiedName: string; begin @@ -2115,5 +2585,89 @@ function TBoldClassTypeInfo.GetQualifiedName: string; result := ModelName ; end; -end. +{---TBoldRoleRTInfoList---} +function TBoldRoleRTInfoList.GetEnumerator: TBoldRoleRTInfoListTraverser; +begin + result := CreateTraverser as TBoldRoleRTInfoListTraverser; +end; + +function TBoldRoleRTInfoList.GetItem(index: Integer): TBoldRoleRTInfo; +begin + Result := TBoldRoleRTInfo(inherited Items[index]); +end; + +function TBoldRoleRTInfoList.GetItemByModelName(const ModelName: string): TBoldRoleRTInfo; +begin + Result := TBoldRoleRTInfo(inherited ItemsByModelName[ModelName]); +end; + +function TBoldRoleRTInfoList.TraverserClass: TBoldIndexableListTraverserClass; +begin + result := TBoldRoleRTInfoListTraverser; +end; + +function TBoldRoleRTInfoList.GetItemByExpressionName(const ExpressionName: string): TBoldRoleRTInfo; +begin + Result := TBoldRoleRTInfo(inherited ItemsByExpressionName[ExpressionName]); +end; + +{ TListClassIndex } + +function TListClassIndex.ItemAsKeyClass(Item: TObject): TClass; +begin + Result := TBoldListTypeInfo(Item).ListClass; +end; + +{ TBoldMemberRTInfoListTraverser } + +function TBoldMemberRTInfoListTraverser.GetCurrent: TBoldMemberRTInfo; +begin + result := inherited GetItem as TBoldMemberRTInfo; +end; + +{ TBoldClassTypeInfoListTraverser } + +function TBoldClassTypeInfoListTraverser.GetCurrent: TBoldClassTypeInfo; +begin + result := inherited GetItem as TBoldClassTypeInfo; +end; + +{ TBoldAttributeTypeInfoListTraverser } + +function TBoldAttributeTypeInfoListTraverser.GetCurrent: TBoldAttributeTypeInfo; +begin + result := inherited GetItem as TBoldAttributeTypeInfo; +end; + +{ TBoldRoleRTInfoListTraverser } + +function TBoldRoleRTInfoListTraverser.GetCurrent: TBoldRoleRTInfo; +begin + result := inherited GetItem as TBoldRoleRTInfo; +end; + +{ TBoldConstraintRTInfoListTraverser } + +function TBoldConstraintRTInfoListTraverser.GetCurrent: TBoldConstraintRTInfo; +begin + result := inherited GetItem as TBoldConstraintRTInfo; +end; + +{ TBoldMethodRTInfoListTraverser } + +function TBoldMethodRTInfoListTraverser.GetCurrent: TBoldMethodRTInfo; +begin + result := inherited GetItem as TBoldMethodRTInfo; +end; + +initialization +{$IFDEF BOLD_LITE} + if CLASS_TYPE_INFO_MEM_SIZE <> TBoldClassTypeInfo.InstanceSize then + Raise EBold.Create('CLASS_TYPE_INFO_MEM_SIZE <> TBoldClassTypeInfo.InstanceSize'); +{$ENDIF} + TBoldClassTypeInfoList.IX_ObjectClass := -1; + TBoldListTypeInfoList.IX_Element := -1; + TBoldListTypeInfoList.IX_ListClass := -1; + +end. diff --git a/Source/ObjectSpace/Undo/BoldUndoHandler.pas b/Source/ObjectSpace/Undo/BoldUndoHandler.pas index 35e88e8e..2202514b 100644 --- a/Source/ObjectSpace/Undo/BoldUndoHandler.pas +++ b/Source/ObjectSpace/Undo/BoldUndoHandler.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUndoHandler; interface @@ -13,6 +16,7 @@ interface BoldSystemRT, Classes; + type {forward declarations} TBoldUndoHandler = class; @@ -24,70 +28,82 @@ TBoldUndoBlock = class(TBoldNonRefCountedObject, IBoldUndoBlock) FName: string; FValueSpace: TBoldFreeStandingValueSpace; FContainsChanges: Boolean; -// procedure GetLinksToObject(const System: TBoldSystem; const ObjectId: TBoldObjectId; const OwnIndexInLinkClass: integer; -// const SingleLinkClassTypeInfo: TBoldClassTypeInfo; SingleLinkIds: TBoldObjectIdList); -// procedure AllIdsInClass(const System: TBoldSystem; const ClassTypeInfo: TBoldClassTypeInfo; IdList: TBoldObjectIdList); - function GetFSValueSpace: TBoldFreeStandingValueSpace; - procedure SetFSValueSpace(const Value: TBoldFreeStandingValueSpace); - function GetName: string; - function GetValueSpace: IBoldValueSpace; - function GetContainsChanges: Boolean; + FCreated: TDateTime; + procedure GetLinksToObject(const System: TBoldSystem; const ObjectId: TBoldObjectId; const OwnIndexInLinkClass: integer; + const SingleLinkClassTypeInfo: TBoldClassTypeInfo; SingleLinkIds: TBoldObjectIdList); + procedure AllIdsInClass(const System: TBoldSystem; const ClassTypeInfo: TBoldClassTypeInfo; IdList: TBoldObjectIdList); + function GetFSValueSpace: TBoldFreeStandingValueSpace; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetFSValueSpace(const Value: TBoldFreeStandingValueSpace); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetName: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetValueSpace: IBoldValueSpace; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetContainsChanges: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetContent: String; + function GetCreated: TDateTime; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected function HasObjectContentsForAnyObjectInList(const ObjectList: TBoldObjectList): Boolean; - function HandleMember(ObjectContents: IBoldObjectContents; MemberIndex: integer; MemberValue: IBoldValue): Boolean; - procedure HandleObject(Obj: IBoldObjectContents; RegardAsExisting: Boolean); + procedure HandleMember(const ObjectContents: IBoldObjectContents; MemberIndex: integer; const MemberValue: IBoldValue); + procedure HandleObject(const Obj: IBoldObjectContents; RegardAsExisting: Boolean); function IsDependantOn(Block: TBoldUndoBlock): Boolean; public constructor CreateNamedBlock(const BlockName: string; const FSVAlueSpace: TBoldFreeStandingValueSpace = nil); destructor Destroy; override; - procedure ApplytranslationList(IdTranslationList: TBoldIdTranslationList); + procedure ApplytranslationList(IdTranslationList: TBoldIdTranslationList); {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure Merge(Block: TBoldUndoBlock; const Overwrite: Boolean); function ValueExists(const ObjectID: TBoldObjectId; const MemberIndex: integer): Boolean; overload; function ValueExists(const ObjectID: TBoldObjectID; const MemberIndex: integer; out Value: IBoldValue): Boolean; overload; + procedure AddObjectsToList(const System: TBoldSystem; const AList: TBoldList); property BlockName: string read FName; property FSValueSpace: TBoldFreeStandingValueSpace read GetFSValueSpace write setFSVAlueSpace; property ValueSpace: IBoldValueSpace read GetValueSpace; property ContainsChanges: Boolean read GetContainsChanges; + property Created: TDateTime read GetCreated; + property Content: String read GetContent; end; TBoldUndoBlockList = class(TBoldNonRefCountedObject, IBoldUndoList) private FList: TStringList; - function GetBlocksByIndex(Index: integer): TBoldUndoBlock; - function GetBlocksByName(BlockName: string): TBoldUndoBlock; + function GetBlockByIndex(Index: integer): TBoldUndoBlock; + function GetBlockByName(const BlockName: string): TBoldUndoBlock; function GetCount: integer; function GetCurrentBlock: TBoldUndoBlock; - function GetAssertedBlocksByName(BlockName: string): TBoldUndoBlock; - function GetAssertedBlocksByIndex(Index: integer): TBoldUndoBlock; - function GetItems(Index: integer): IBoldUndoBlock; - function GetItemsByName(Name: string): IBoldUndoBlock; - function GetTopBlock: IBoldUndoBlock; + function GetAssertedBlockByName(const BlockName: string): TBoldUndoBlock; + function GetAssertedBlockByIndex(Index: integer): TBoldUndoBlock; + function GetItem(Index: integer): IBoldUndoBlock; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemByName(const Name: string): IBoldUndoBlock; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetTopBlock: IBoldUndoBlock; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetContainsChanges: Boolean; protected procedure Clear; - function AddBlock(BlockName: string; const FSVAlueSpace: TBoldFreeStandingValueSpace = nil): TBoldUndoBlock; - property AssertedBlocksByName[BlockName: string]: TBoldUndoBlock read GetAssertedBlocksByName; - property AssertedBlocksByIndex[Index: integer]: TBoldUndoBlock read GetAssertedBlocksByIndex; + function AddBlock(const BlockName: string; const FSVAlueSpace: TBoldFreeStandingValueSpace = nil): TBoldUndoBlock; + property AssertedBlockByName[const BlockName: string]: TBoldUndoBlock read GetAssertedBlockByName; + property AssertedBlockByIndex[Index: integer]: TBoldUndoBlock read GetAssertedBlockByIndex; function AssertedIndexOf(const BlockName: string): integer; - procedure InternalRemoveBlock(BlockName: string); // do not make const + procedure InternalRemoveBlock(const BlockName: string); overload; + procedure InternalRemoveBlock(Block: TBoldUndoBlock); overload; + function GetIsEmpty: boolean; public procedure ApplytranslationList(IdTranslationList: TBoldIdTranslationList); constructor Create; destructor Destroy; override; procedure MoveBlock(CurIndex, NewIndex: integer); - function IndexOf(BlockName: string): integer; - function RemoveBlock(BlockName: string): Boolean; // do not make const - procedure RenameBlock(OldName, NewName: string); // do not make const - procedure MoveToTop(BlockName: string); - procedure MergeBlocks(DestinationBlockName, SourceBlockName: string); - property BlocksbyIndex[Index: integer]: TBoldUndoBlock read GetBlocksByIndex; - property BlocksByName[BlockName: string]: TBoldUndoBlock read GetBlocksByName; + function IndexOf(const BlockName: string): integer; overload; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function IndexOf(Block: TBoldUndoBlock): integer; overload; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function RemoveBlock(const BlockName: string): Boolean; + procedure RenameBlock(const OldName, NewName: string); + procedure MoveToTop(const BlockName: string); + procedure MergeBlocks(const DestinationBlockName, SourceBlockName: string); + property BlockByIndex[Index: integer]: TBoldUndoBlock read GetBlockByIndex; default; + property BlockByName[const BlockName: string]: TBoldUndoBlock read GetBlockByName; function CanMoveBlock(CurIndex, NewIndex: integer): Boolean; function CanMergeBlock(CurIndex, NewIndex: integer): Boolean; - function CanMoveToTop(CurIndex: integer): Boolean; + function CanMoveToTop(CurIndex: integer): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure GetDependantBlocks(const BlockName: string; DependantBlocks: TList); procedure MergeAll; property Count: integer read GetCount; property CurrentBlock: TBoldUndoBlock read GetCurrentBlock; + property ContainsChanges: Boolean read GetContainsChanges; + property IsEmpty: boolean read GetIsEmpty; end; TBoldUndoHandler = class(TBoldAbstractUndoHandler, IBoldUndoHandler) @@ -96,46 +112,330 @@ TBoldUndoHandler = class(TBoldAbstractUndoHandler, IBoldUndoHandler) FRedoBlocks: TBoldUndoBlockList; fUndoState: TBoldUndoState; fEnabled: Boolean; +{ function GetFetchedValueOfIndirectMultiLink(const Member: TBoldMember; const OwningObjectId: TBoldObjectId; + const RoleRTInfo: TBoldRoleRTInfo): TBoldFreeStandingValue; + function GetFetchedValueOfDirectMultiLink (const Member: TBoldMember; const OwningObjectId: TBoldObjectId; + const RoleRTInfo: TBoldRoleRTInfo): TBoldFreeStandingValue; + } procedure DoUndo(UnDoValueSpace: TBoldFreeStandingValueSpace; RedoValueSpace: TBoldFreeStandingValueSpace); procedure DoUndoInTransaction(BlockName: string; FromList, ToList: TBoldUndoBlockList); // Don't make blockname const! - function GetUndoList: IBoldUndoList; - function GetRedoList: IBoldUndoList; - function CanUndoBlock(BlockName: string): Boolean; - function CanRedoBlock(BlockName: string):Boolean; - function GetEnabled: Boolean; + function GetUndoList: IBoldUndoList; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetRedoList: IBoldUndoList; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function CanUndoBlock(const BlockName: string): Boolean; + function CanRedoBlock(const BlockName: string):Boolean; + function GetEnabled: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure SetEnabled(value: Boolean); + function GetCurrentUndoBlock: TBoldUndoBlock; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetIsEmpty: boolean; + function GetCurrentUndoBlockHasChanges: boolean; public constructor Create(System: TBoldSystem); override; destructor Destroy; override; - function GetUniqueBlockName(SuggestedName: string): string; - procedure SetNamedCheckPoint(CheckPointName: string); + function GetUniqueBlockName(const SuggestedName: string): string; + procedure SetNamedCheckPoint(const CheckPointName: string); procedure SetCheckPoint; - procedure HandleMember(ObjectContents: IBoldObjectContents; MemberIndex: integer; MemberValue: IBoldValue); override; - procedure HandleObject(Obj: IBoldObjectContents; RegardAsExisting: Boolean); override; - procedure UndoBlock(BlockName: string); - procedure RedoBlock(BlockName: string); + procedure HandleMember(const ObjectContents: IBoldObjectContents; MemberIndex: integer; const MemberValue: IBoldValue); overload; override; + procedure HandleObject(const Obj: IBoldObjectContents; RegardAsExisting: Boolean); override; + procedure UndoBlock(const BlockName: string); + procedure RedoBlock(const BlockName: string); procedure UnDoLatest; - procedure Redolatest; + procedure RedoLatest; procedure ApplytranslationList(IdTranslationList: TBoldIdTranslationList); override; procedure PrepareUpdate(const ObjectList: TBoldObjectList); override; - procedure ClearAllUndoBlocks; + procedure ClearAllUndoBlocks; {$IFDEF BOLD_INLINE} inline; {$ENDIF} property UndoBlocks: TBoldUndoBlockList read fUndoBlocks; property RedoBlocks: TBoldUndoBlockList read fRedoBlocks; property UndoState: TBoldUndoState read fUndoState write fUndoState; + property Enabled: Boolean read GetEnabled write SetEnabled; + property CurrentUndoBlock: TBoldUndoBlock read GetCurrentUndoBlock; end; implementation uses SysUtils, - BoldUtils, BoldDefs, BoldGuard, - BoldDomainElement, - BoldCoreConsts, - BoldSubscription; + BoldDomainElement; + +const + cUnNamedBlockName = 'Undo'; + +{ TBoldUndoBlock } + +constructor TBoldUndoBlock.CreateNamedBlock(const BlockName: string; const FSVAlueSpace: TBoldFreeStandingValueSpace); +begin + inherited Create; + FContainsChanges := false; + FValueSpace := FSVAlueSpace; + FCreated := now; + FName := {FormatDateTime('hh:nn:ss', FCreated) + ' - ' + }BlockName; +end; + +function TBoldUndoBlock.GetFSValueSpace: TBoldFreeStandingValueSpace; +begin + if not Assigned(FValueSpace) then + FValueSpace := TBoldFreeStandingValueSpace.Create; + Result := FValueSpace; +end; + +function TBoldUndoBlock.IsDependantOn( + Block: TBoldUndoBlock): Boolean; +var + ObjectContents: TBoldFreeStandingObjectContents; + i, j: integer; + aValue: IBoldValue; + ObjectIds: TBoldObjectIdList; + G: IBoldGuard; +begin + G := TBoldGuard.Create(ObjectIds); + ObjectIds := TBoldObjectIdList.Create; + Result := false; + FSValueSpace.AllObjectIds(ObjectIds, True); + for i:= 0 to ObjectIds.Count - 1 do + begin + ObjectContents := FSValueSpace.GetFSObjectContentsByObjectId(ObjectIds[i]); + for j := 0 to ObjectContents.MemberCount - 1 do + begin + Result := Assigned(ObjectContents.ValueByIndex[j]) and Block.ValueExists(ObjectIds[i], j, aValue); + if Result then + Break; + end; + if Result then + Break; + end; +end; + +procedure TBoldUndoBlock.Merge(Block: TBoldUndoBlock; const Overwrite: Boolean); +var + OwnContents, ObjectContents: TBoldFreeStandingObjectContents; + ObjectId: TBoldObjectId; + i, j: integer; + ObjectIds: TBoldObjectIdList; + G: IBoldGuard; +begin + G := TBoldGuard.Create(ObjectIds); + ObjectIds := TBoldObjectIdList.Create; + Block.FSValueSpace.AllObjectIds(ObjectIds, True); + for i:= 0 to ObjectIds.Count - 1 do + begin + ObjectId := ObjectIds[i]; + ObjectContents := Block.FSValueSpace.GetFSObjectContentsByObjectId(ObjectId); + if not FSValueSpace.GetHasContentsForId(ObjectId) then begin + FSValueSpace.EnsureObjectContents(ObjectId); + OwnContents := FSValueSpace.GetFSObjectContentsByObjectId(ObjectId); + // When FSObjectContent is recreated for this block, + // then Existence/PersistenceState must be adopted from source block. + OwnContents.BoldExistenceState := ObjectContents.BoldExistenceState; + OwnContents.BoldPersistenceState := ObjectContents.BoldPersistenceState; + end else begin + OwnContents := FSValueSpace.GetFSObjectContentsByObjectId(ObjectId); + end; + for j:= 0 to ObjectContents.MemberCount - 1 do + if Assigned(ObjectContents.valueByIndex[j]) then + begin + if (OwnContents.MemberCount > j) and Assigned(OwnContents.ValueByIndex[j]) then + begin + if overwrite then + OwnContents.ValueByIndex[j].AssignContent(ObjectContents.ValueByIndex[j]); + end + else + begin + OwnContents.EnsureMemberAndGetValueByIndex(J, ObjectContents.ValueByIndex[j].ContentName).AssignContent(ObjectContents.ValueByIndex[j]); + end; + end; + end; +end; + +function TBoldUndoBlock.ValueExists(const ObjectID: TBoldObjectID; + const MemberIndex: integer; out Value: IBoldValue): Boolean; +var + ObjectContents: TBoldFreeStandingObjectContents; +begin + Value := nil; + ObjectContents := FSValueSpace.GetFSObjectContentsByObjectId(ObjectID); + if Assigned(ObjectContents) and (MemberIndex < ObjectContents.memberCount) then + Value := ObjectContents.ValueByIndex[MemberIndex]; + Result := Assigned(Value); +end; + +function TBoldUndoBlock.ValueExists(const ObjectID: TBoldObjectId; + const MemberIndex: integer): Boolean; +var + Value: IBoldValue; +begin + result := ValueExists(ObjectId, MemberIndex, Value); +end; + +procedure TBoldUndoBlock.HandleMember(const ObjectContents: IBoldObjectContents; MemberIndex: integer; const MemberValue: IBoldValue); +var + ObjectId: TBoldObjectId; + FSObjectContents: TBoldFreeStandingObjectContents; +begin + ObjectId := ObjectContents.ObjectId; + FSObjectContents := FSValueSpace.GetFSObjectContentsByObjectId(ObjectId); + if not Assigned(FSObjectContents) or (MemberIndex >= FSObjectContents.memberCount) or not Assigned(FSObjectContents.ValueByIndex[MemberIndex]) then + begin + FContainsChanges := true; + if not Assigned(FSObjectContents) then + begin + FSObjectContents := FSValueSpace.GetEnsuredFSObjectContentsByObjectId(ObjectId); + FSObjectContents.ApplyObjectContents(ObjectContents, False, false); + end; + FSObjectContents.EnsureMemberAndGetValueByIndex(MemberIndex, MemberValue.ContentName).AssignContent(MemberValue); + end; +end; + +function TBoldUndoBlock.HasObjectContentsForAnyObjectInList( + const ObjectList: TBoldObjectList): Boolean; +var + i: integer; + ObjectId: TBoldObjectId; +begin + Result := false; + for i:= 0 to ObjectList.Count - 1 do + begin + ObjectId := ObjectList.BoldObjects[i].BoldObjectLocator.BoldObjectID; + Result := Assigned(FSValueSpace.GetFSObjectContentsByObjectId(ObjectId)); + if Result then + Break; + end; +end; + +procedure TBoldUndoBlock.GetLinksToObject(const System: TBoldSystem; const ObjectId: TBoldObjectId; const OwnIndexInLinkClass: integer; + const SingleLinkClassTypeInfo: TBoldClassTypeInfo; SingleLinkIds: TBoldObjectIdList); +var + ObjectIds: TBoldObjectIdList; + i: integer; + LinkValue: IBoldValue; +begin + ObjectIds := TBoldObjectIdList.Create; + try + AllIdsInClass(System, SingleLinkClassTypeInfo, ObjectIds); + for i:= 0 to ObjectIds.Count - 1 do + if ValueExists(ObjectIds[i], OwnIndexInLinkClass, LinkValue) and + Assigned((LinkValue as IBoldObjectIdRef).Id) and + ((LinkValue as IBoldObjectIdRef).Id.IsEqual[ObjectId]) then + SingleLinkIds.Add(ObjectIds[i].Clone); + except + FreeAndNil(ObjectIds); + end; +end; + +procedure TBoldUndoBlock.AddObjectsToList(const System: TBoldSystem; + const AList: TBoldList); +var + i: integer; + ObjectIds: TBoldObjectIdList; + G: IBoldGuard; +begin + G := TBoldGuard.Create(ObjectIds); + ObjectIds := TBoldObjectIdList.Create; + FSValueSpace.AllObjectIds(ObjectIds, false); + for i:= 0 to ObjectIds.Count - 1 do + AList.Add(System.Locators.ObjectByID[ObjectIds[i]]); +end; + +procedure TBoldUndoBlock.AllIdsInClass( const System: TBoldSystem; + const ClassTypeInfo: TBoldClassTypeInfo; IdList: TBoldObjectIdList); +var + i: integer; + ObjectIds: TBoldObjectIdList; + G: IBoldGuard; +begin + G := TBoldGuard.Create(ObjectIds); + ObjectIds := TBoldObjectIdList.Create; + FSValueSpace.AllObjectIds(ObjectIds, True); + for i:= 0 to ObjectIds.Count - 1 do + begin + if (System.Locators.ObjectByID[ObjectIds[i]].BoldClassTypeInfo = ClassTypeInfo) then + IdList.Add(ObjectIds[i]); + end; +end; + +procedure TBoldUndoBlock.HandleObject(const Obj: IBoldObjectContents; RegardAsExisting: Boolean); +var + ObjectId: TBoldObjectId; + ObjectContents: TBoldFreeStandingObjectContents; +begin + Assert(assigned(obj)); + ObjectId := Obj.ObjectID; + ObjectContents := FSValueSpace.GetFSObjectContentsByObjectId(ObjectId); + if not Assigned(ObjectContents) then + begin + FContainsChanges := True; + FSValueSpace.EnsureObjectContents(ObjectId); + ObjectContents := FSValueSpace.GetFSObjectContentsByObjectId(ObjectId); + ObjectContents.ApplyObjectContents(Obj, False, false); + if RegardAsExisting then + begin + ObjectContents.BoldPersistenceState := bvpsCurrent; + ObjectContents.BoldExistenceState := besExisting; + end; + end; +end; +destructor TBoldUndoBlock.Destroy; +begin + FreeAndNil(FValueSpace); + inherited; +end; + +procedure TBoldUndoBlock.SetFSValueSpace( + const Value: TBoldFreeStandingValueSpace); +begin + if (FValueSpace <> Value) then + begin + FreeAndNil(FValueSpace); + FValueSpace := Value; + fContainsChanges := TRUE; + end; +end; + +function TBoldUndoBlock.GetName: string; +begin + Result := fName; +end; + +function TBoldUndoBlock.GetValueSpace: IBoldValueSpace; +begin + result := FSValueSpace as IBoldValueSpace; +end; + +function TBoldUndoBlock.GetContainsChanges: Boolean; +begin + result := fContainsChanges; +end; + +function TBoldUndoBlock.GetContent: String; +var + i: integer; + List: TBoldObjectList; +begin + result := ''; + if FContainsChanges then + begin + List := TBoldObjectList.Create; + try + AddObjectsToList(TBoldSystem.DefaultSystem, List); + result := List.AsDebugCommaText(); + finally + List.free; + end; + end; +end; + +function TBoldUndoBlock.GetCreated: TDateTime; +begin + result := fCreated; +end; + +procedure TBoldUndoBlock.ApplytranslationList( + IdTranslationList: TBoldIdTranslationList); +begin + ValueSpace.ApplytranslationList(IdTranslationList); +end; { TBoldUndoHandler } @@ -145,6 +445,7 @@ constructor TBoldUndoHandler.Create(System: TBoldSystem); FUndoBlocks := TBoldUndoBlockList.Create; FRedoBlocks := TBoldUndoBlockList.Create; fUndoState := busNormal; + Enabled := false; end; destructor TBoldUndoHandler.Destroy; @@ -154,180 +455,97 @@ destructor TBoldUndoHandler.Destroy; inherited; end; -(* -function TBoldUndoHandler.GetFetchedValue(Member: TBoldMember): IBoldValue; +procedure TBoldUndoHandler.HandleMember(const ObjectContents: IBoldObjectContents; MemberIndex: integer; const MemberValue: IBoldValue); +begin + if Enabled and (UndoState = busNormal) then + begin + RedoBlocks.Clear; + CurrentUndoBlock.HandleMember(ObjectContents, MemberIndex, MemberValue); + end; +end; + +function TBoldUndoBlockList.GetContainsChanges: Boolean; var i: integer; - RoleRTInfo: TBoldRoleRTInfo; - HasLinkObject: Boolean; - ObjectID: TBoldObjectID; begin - //TODO: finish implementation - Result := nil; - if Member.BoldMemberRTInfo.IsDerived then - Exit; - if Member.BoldMemberRTInfo.IsMultiRole then //if multilink - begin - ObjectID := Member.OwningObject.BoldObjectLocator.BoldObjectID; - RoleRTInfo := TBoldRoleRTInfo(Member.BoldMemberRTInfo); - HasLinkObject := Assigned(RoleRTInfo.LinkClassTypeInfo); - if HasLinkObject then - Result := (GetFetchedValueOfIndirectMultiLink(Member, ObjectId, RoleRTInfo) as IBoldValue) - else - // no links - Result := GetFetchedValueOfDirectMultiLink(Member, ObjectId, RoleRtInfo); - end + result := true; + for I := Count - 1 downto 0 do + if BlockByIndex[i].ContainsChanges then + exit; + result := false; +end; + +function TBoldUndoBlockList.GetCount: integer; +begin + Result := fList.Count; +end; + +function TBoldUndoBlockList.GetBlockByIndex( + Index: integer): TBoldUndoBlock; +begin + if (Index >= 0) and (Index < FList.Count) then + Result := FList.Objects[Index] as TBoldUndoBlock else - for i:= 0 to UndoBlocks.Count - 1 do - if UndoBlocks.BlocksbyIndex[i].ValueExists(Member.OwningObject.BoldObjectLocator.BoldObjectID, - Member.BoldMemberRTInfo.index, Result) then - Break; + Result := nil; end; -*) -procedure TBoldUndoHandler.HandleMember(ObjectContents: IBoldObjectContents; MemberIndex: integer; MemberValue: IBoldValue); +function TBoldUndoBlockList.GetBlockByName(const BlockName: string): TBoldUndoBlock; +var + Idx: integer; begin - if fEnabled and (UndoState = busNormal) then - begin - RedoBlocks.Clear; - UndoBlocks.CurrentBlock.HandleMember(ObjectContents, MemberIndex, MemberValue); - end; + Idx := FList.IndexOf(blockName); + if Idx <> - 1 then + Result := FList.Objects[Idx] as TBoldUndoBlock + else + Result := nil; end; + procedure TBoldUndoHandler.PrepareUpdate(const ObjectList: TBoldObjectList); var aBlock: TBoldUndoBlock; i: integer; begin + if not Enabled then + exit; RedoBlocks.Clear; i := 0; while i < UnDoBlocks.Count do begin - aBlock := UndoBlocks.BlocksbyIndex[i]; //UndoBlocks.CurrentBlock; + aBlock := UndoBlocks.BlockByIndex[i]; if aBlock.HasObjectContentsForAnyObjectInList(ObjectList) then begin - UnDoBlocks.InternalRemoveBlock(aBlock.BlockName) + UnDoBlocks.InternalRemoveBlock(aBlock) end else inc(i); end; - UndoBlocks.MergeAll; -end; - -procedure TBoldUndoHandler.SetNamedCheckPoint(CheckPointName: string); -begin - if Assigned(UndoBlocks.GetBlocksByName(CheckPointName)) or Assigned(RedoBlocks.GetBlocksByName(CheckPointName)) then - raise EBold.CreateFmt(sBlockNameInUse, [Classname, CheckPointName]) - else if not (UndoBlocks.CurrentBlock.ContainsChanges) then - UndoBlocks.RenameBlock(UndoBlocks.CurrentBlock.BlockName, CheckPointName) - else - UndoBlocks.AddBlock(CheckPointName); + UndoBlocks.MergeAll; // this was not original behavior + SendExtendedEvent(self, beUndoChanged, []); end; -procedure TBoldUndoHandler.UndoBlock(BlockName: string); +procedure TBoldUndoHandler.UndoBlock(const BlockName: string); begin if System.InTransaction then - raise EBold.CreateFmt(sCannotUndoInTransaction, [ClassName]); + raise EBold.CreateFmt('%s.UndoBlock: the Undo-mechanism can only be invoked outside a transaction', [ClassName]); UndoState := busUndoing; try DoUndoInTransaction(BlockName, UndoBlocks, RedoBlocks); + SendExtendedEvent(self, beUndoBlock, [BlockName]); finally UndoState := busNormal; end; end; -(* -function TBoldUndoHandler.GetFetchedValueOfDirectMultiLink( - const Member: TBoldMember; const OwningObjectId: TBoldObjectId; - const RoleRTInfo: TBoldRoleRTInfo): TBoldFreeStandingValue; -var - CurrentValue: IBoldObjectIdListRef; - FetchedValue: TBFSObjectIdListRef; - ObjectIds, IdList: TBoldObjectIdList; - i: integer; - aValue: IBoldValue; - G: IBoldGuard; -begin - G := TBoldGuard.Create(ObjectIds, IdList); - //TODO: implement FetchedValues for LinkObjects?? - FetchedValue := TBFSObjectIdListRef.Create; - CurrentValue := Member.AsIBoldValue[bdepContents] as IBoldObjectIdListRef; - if Assigned(CurrentValue) then - begin - FetchedValue.AssignContent(CurrentValue); - ObjectIds := TBoldObjectIdList.Create; - IdList := TBoldObjectIdList.Create; - // non modified links - for i:= 0 to CurrentValue.Count - 1 do - if not NonUndoableBlock.ValueExists(CurrentValue.IdList[i], RoleRTInfo.IndexOfOtherEnd, aValue) then - IdList.Add(CurrentValue.IdList[i].Clone); - // deleted links - NonUndoableBlock.AllIdsInClass(System, RoleRTInfo.ClassTypeInfoOfOtherEnd, ObjectIds); - for i:= 0 to ObjectIds.Count - 1 do - begin - if NonUndoableBlock.ValueExists(Objectids[i], RoleRTInfo.IndexOfOtherEnd, aValue) and - Assigned((aValue as IBoldObjectIdRef).Id) and (aValue as IBoldObjectIdRef).Id.IsEqual[OwningObjectId] then - IdList.Add(ObjectIds[i]); - end; - FetchedValue.SetFromIdList(IdList); - end; - Result := FetchedValue; -end; - -function TBoldUndoHandler.GetFetchedValueOfIndirectMultiLink( - const Member: TBoldMember; const OwningObjectId: TBoldObjectId; - const RoleRTInfo: TBoldRoleRTInfo): TBoldFreeStandingValue; -var - CurrentValue: IBoldObjectIdListRefPair; - FetchedValue: TBFSObjectIdListrefPair; - i: integer; - ObjectIds, IdList1, IdList2: TBoldObjectIdList; // Idlist1 is the list of ids of the linkobjects - LinkObjectId : TBoldObjectId; - LinkValue: IBoldValue; -begin - //TODO: implement - CurrentValue := Member.AsIBoldValue[bdepContents] as IBoldObjectIdListRefPair; - FetchedValue := TBFSObjectIdListRefPair.Create; - FetchedValue.AssignContent(CurrentValue); - ObjectIds := TBoldObjectIdList.Create; - IdList1 := TBoldObjectIdList.Create; - IdList2 := TBoldObjectIdList.Create; - try - //non modified links - for i:= 0 to CurrentValue.Count - 1 do - begin - LinkObjectId := CurrentValue.IdList1[i]; //id1 is link object - if not Assigned(NonUndoableBlock.FSValueSpace.GetFSObjectContentsByObjectId(LinkObjectId)) then // link not modified - begin - IdList1.Add(CurrentValue.IdList1[i].Clone); - IdList2.Add(CurrentValue.IdList2[i].Clone); - end; - end; - //deleted links - NonUndoableBlock.GetLinksToObject(System, OwningObjectId, RoleRTInfo.OwnIndexInLinkClass, RoleRtInfo.LinkClassTypeInfo, ObjectIds); - for i:= 0 to ObjectIds.Count - 1 do - begin - IdList1.Add(ObjectIds[i].Clone); - NonUndoableBlock.ValueExists(ObjectIds[i],RoleRtInfo.OtherIndexInLinkClass, LinkValue); - IdList2.Add((LinkValue as IBoldObjectIdRef).Id.Clone); - end; - finally - FetchedValue.SetFromIdLists(IdList1, IdList2); - Result := FetchedValue; - FreeAndNil(ObjectIds); - FreeAndNil(IdList1); - FreeAndNil(IdList2); - end; -end; -*) -procedure TBoldUndoHandler.RedoBlock(BlockName: string); +procedure TBoldUndoHandler.RedoBlock(const BlockName: string); begin if System.InTransaction then - raise EBold.CreateFmt(sCannotUndoInTransaction, [ClassName]); + raise EBold.CreateFmt('%s.RedoBlock: the Undo-mechanism can only be invoked outside a transaction', [ClassName]); UndoState := busRedoing; try DoUndoInTransaction(BlockName, RedoBlocks, UndoBlocks); + SendExtendedEvent(self, beRedoBlock, [BlockName]); finally UndoState := busNormal; end; @@ -342,19 +560,17 @@ procedure TBoldUndoHandler.RedoLatest; procedure TBoldUndoHandler.UndoLatest; begin if (UndoBlocks.Count > 0) then - UndoBlock(UndoBlocks.CurrentBlock.BlockName); + UndoBlock(CurrentUndoBlock.BlockName); end; -procedure TBoldUndoHandler.HandleObject(Obj: IBoldObjectContents; RegardAsExisting: Boolean); +procedure TBoldUndoHandler.HandleObject(const Obj: IBoldObjectContents; RegardAsExisting: Boolean); begin - if fEnabled and (UndoState = busNormal) then + if Enabled and (UndoState = busNormal) then begin RedoBlocks.Clear; - UndoBlocks.CurrentBlock.HandleObject(Obj, RegardAsExisting); + CurrentUndoBlock.HandleObject(Obj, RegardAsExisting); end; end; - -// Perform Undo, Fill in valuespace for Redoing procedure TBoldUndoHandler.DoUndo(UnDoValueSpace: TBoldFreeStandingValueSpace; RedoValueSpace: TBoldFreeStandingValueSpace); type @@ -365,19 +581,18 @@ procedure TBoldUndoHandler.DoUndo(UnDoValueSpace: TBoldFreeStandingValueSpace; procedure GetInnerLinkIndices(BoldObject: TBoldObject; var MemberIndex1, MemberIndex2: Integer); var i: integer; - MemberRTInfo: TBoldMemberRTInfo; + RoleRTInfo: TBoldRoleRTInfo; begin MemberIndex1 := -1; MemberIndex2 := -1; - for i:= 0 to BoldObject.BoldMemberCount - 1 do + for RoleRTInfo in BoldObject.BoldClassTypeInfo.AllRoles do begin - MemberRTInfo := BoldObject.BoldClassTypeInfo.AllMembers[i]; - if MemberRTInfo.IsRole and ((MemberRTInfo as TBoldRoleRTInfo).RoleType = rtInnerLinkRole) then + if RoleRTInfo.RoleType = rtInnerLinkRole then begin if (MemberIndex1 = -1) then - MemberIndex1 := i + MemberIndex1 := RoleRTInfo.index else if (MemberIndex2 = -1) then - MemberIndex2 := i + MemberIndex2 := RoleRTInfo.index else Break; end; @@ -406,9 +621,8 @@ procedure TBoldUndoHandler.DoUndo(UnDoValueSpace: TBoldFreeStandingValueSpace; Value1 := ObjectContents.valueByIndex[MemberIndex1] as IBoldObjectIdRef; if Assigned(Value0) and Assigned(Value1) then begin - // Very clumsy, but seems to work - // Problem is that when first assigment is done, other linkobject-link is not set yet, so - // otherend will be nil. This means that things will not be set upp properly. + + SavIdValue := TBFSObjectIdRef.Create; SavIdValue.AssignContent(Member1.AsIBoldValue[bdepContents]); Member1.AsIBoldValue[bdepContents].AssignContent(Value1); @@ -455,18 +669,20 @@ procedure TBoldUndoHandler.DoUndo(UnDoValueSpace: TBoldFreeStandingValueSpace; procedure UnDoLinks(BoldObject: TBoldObject; ObjectContents: IBoldObjectContents); var - i: Integer; aValue: IBoldValue; BoldMember: TBoldMember; + RoleRTInfo: TBoldRoleRTInfo; begin - for i := 0 to BoldObject.BoldMemberCount - 1 do + for RoleRTInfo in BoldObject.BoldClassTypeInfo.AllRoles do begin - aValue := ObjectContents.valueByIndex[i]; - if assigned(aValue) then + if RoleRTInfo.IsSingleRole and (RoleRTInfo.RoleType = rtRole) then begin - BoldMember := BoldObject.BoldMembers[i]; - if (BoldMember is TBoldObjectReference) and (TBoldObjectReference(BoldMember).BoldRoleRTInfo.RoleType = rtRole) then + aValue := ObjectContents.valueByIndex[RoleRTInfo.Index]; + if assigned(aValue) then + begin + BoldMember := BoldObject.BoldMembers[RoleRTInfo.Index]; BoldMember.AsIBoldValue[bDepUndo].AssignContent(aValue); + end; end; end; if BoldObject.BoldClassTypeInfo.IsLinkClass then @@ -477,12 +693,11 @@ procedure TBoldUndoHandler.DoUndo(UnDoValueSpace: TBoldFreeStandingValueSpace; var oid: TBoldObjectId; FSObjectContents: TBoldFreeStandingObjectContents; + FSRedoObjectContents: TBoldFreeStandingObjectContents; i, M: integer; + Value: IBoldValue; BoldObject: TBoldObject; - MemberId: TBoldMemberId; - G: IBoldGuard; begin - G := TBoldGuard.Create(MemberId); for i:= 0 to ObjectIds.Count - 1 do begin oid := ObjectIds[i]; @@ -491,22 +706,24 @@ procedure TBoldUndoHandler.DoUndo(UnDoValueSpace: TBoldFreeStandingValueSpace; FSObjectContents := UndoValueSpace.GetFSObjectContentsByObjectId(oid); if Assigned(BoldObject) then begin - if FSObjectContents.BoldExistenceState = besExisting then // just keep changed values + if FSObjectContents.BoldExistenceState = besExisting then begin RedoValueSpace.GetFSObjectContentsByObjectId(oid).ApplyObjectContents( FSObjectContents, true, false); RedoValueSpace.GetFSObjectContentsByObjectId(oid).UpdateObjectContentsFrom(BoldObject.AsIBoldObjectContents[bdepContents]) end - else // Object going away, keep all + else begin RedoValueSpace.GetFSObjectContentsByObjectId(oid).ApplyObjectContents(BoldObject.AsIBoldObjectContents[bdepContents], False, false); for M := 0 to BoldObject.BoldMemberCount -1 do if BoldObject.BoldMemberAssigned[M] and BoldObject.BoldMembers[M].StoreInUndo then begin - MemberId := TBoldMemberId.Create(M); - RedoValueSpace.GetFSObjectContentsByObjectId(oid).EnsureMember(MemberId, BoldObject.BoldMembers[M].AsIBoldValue[bdepContents].ContentName); - RedoValueSpace.GetFSObjectContentsByObjectId(oid).ValueByIndex[M].AssignContent(BoldObject.BoldMembers[M].AsIBoldValue[bdepContents]); - FreeAndNil(MemberId); + FSRedoObjectContents := RedoValueSpace.GetFSObjectContentsByObjectId(oid); + if FSRedoObjectContents is TBoldSystemFreeStandingObjectContents then + Value := TBoldSystemFreeStandingObjectContents(FSRedoObjectContents).EnsureMemberAndGetValueByIndex(BoldObject.BoldMembers[M]) + else + Value := FSRedoObjectContents.EnsureMemberAndGetValueByIndex(M, BoldObject.BoldMembers[M].AsIBoldValue[bdepContents].ContentName); + Value.AssignContent(BoldObject.BoldMembers[M].AsIBoldValue[bdepContents]); end; end; end @@ -520,7 +737,7 @@ procedure TBoldUndoHandler.DoUndo(UnDoValueSpace: TBoldFreeStandingValueSpace; function GetObjectAction( FSObjectContents: TBoldFreeStandingObjectContents; BoldObject: TBoldObject): TObjectAction; begin - result := oaUse; // stupid compiler + result := oaUse; if Assigned(BoldObject) then begin if FSObjectContents.BoldExistenceState = besExisting then @@ -540,14 +757,14 @@ procedure TBoldUndoHandler.DoUndo(UnDoValueSpace: TBoldFreeStandingValueSpace; bvpsTransient: Result := oaTransient; else - raise EBold.create(sInternalError); + raise EBold.create('Internal error?'); end; besNotCreated, besDeleted: case FSObjectContents.BoldPersistenceState of bvpsCurrent, bvpsModified, bvpsTransient: Result := oaDelete; else - raise EBold.create(sInternalError); + raise EBold.create('Internal error?'); end; end; end; @@ -566,7 +783,6 @@ procedure TBoldUndoHandler.DoUndo(UnDoValueSpace: TBoldFreeStandingValueSpace; ObjectIds := TBoldObjectIdList.Create; UndoValueSpace.AllObjectIds(ObjectIds, false); SaveOldValues; - // pass one, create all Objects, and set attributes for i:= 0 to ObjectIds.Count - 1 do begin oid := ObjectIds[i]; @@ -592,7 +808,6 @@ procedure TBoldUndoHandler.DoUndo(UnDoValueSpace: TBoldFreeStandingValueSpace; if ObjectAction <> oaDelete then UnDoObjectAndAttributes(BoldObject, UndoValueSpace.GetFSObjectContentsByObjectId(oid)); end; - // Pass 2, update links once all objects are in place for i:= 0 to ObjectIds.Count - 1 do begin oid := ObjectIds[i]; @@ -601,7 +816,6 @@ procedure TBoldUndoHandler.DoUndo(UnDoValueSpace: TBoldFreeStandingValueSpace; if Assigned(BoldObject) then UnDoLinks(BoldObject, UndoValueSpace.GetFSObjectContentsByObjectId(oid)); end; - // Pass 3, delete objects for i:= 0 to ObjectIds.Count - 1 do begin @@ -617,6 +831,16 @@ procedure TBoldUndoHandler.DoUndo(UnDoValueSpace: TBoldFreeStandingValueSpace; end; end; +function TBoldUndoBlockList.IndexOf(const BlockName: string): integer; +begin + Result := fList.IndexOf(BlockName); +end; + +function TBoldUndoBlockList.IndexOf(Block: TBoldUndoBlock): integer; +begin + Result := fList.IndexOfObject(Block); +end; + procedure TBoldUndoHandler.DoUndoInTransaction(BlockName: string; FromList, ToList: TBoldUndoBlockList); var @@ -625,34 +849,58 @@ procedure TBoldUndoHandler.DoUndoInTransaction(BlockName: string; G: IBoldGuard; begin G := TBoldGuard.Create(RedoValueSpace); - aBlock := FromList.BlocksByName[BlockName]; + aBlock := FromList.BlockByName[BlockName]; if Not Assigned(aBlock) then - raise EBold.CreateFmt(sInvalidBlockName, [BlockName]); + raise EBold.CreateFmt('%s is not a valid blockname for this operation', [BlockName]); if not FromList.CanMoveToTop(FromList.IndexOf(BlockName)) then - raise EBold.CreateFmt(sCannotMoveToTop, [BlockName]); + raise EBold.CreateFmt('%s Can''t be moved to top', [BlockName]); RedoValueSpace := TBoldFreeStandingValueSpace.Create; System.StartTransaction; try DoUndo(aBlock.FSValueSpace, RedoValueSpace); FromList.InternalRemoveBlock(BlockName); ToList.AddBlock(BlockName).FSValueSpace := RedoValueSpace; - RedoValueSpace := nil; // now owned by Redo-block + RedoValueSpace := nil; System.CommitTransaction; except System.RollbackTransaction; end; end; -function TBoldUndoHandler.CanRedoBlock(BlockName: string): Boolean; +function TBoldUndoHandler.CanRedoBlock(const BlockName: string): Boolean; begin Result := RedoBlocks.CanMoveToTop(RedoBlocks.AssertedIndexOf(BlockName)); end; -function TBoldUndoHandler.CanUndoBlock(BlockName: string): Boolean; +function TBoldUndoHandler.CanUndoBlock(const BlockName: string): Boolean; begin Result := UnDoBlocks.CanMoveToTop(UndoBlocks.AssertedIndexOf(BlockName)); end; +function TBoldUndoHandler.GetCurrentUndoBlock: TBoldUndoBlock; +begin + if UndoBlocks.IsEmpty then + SetCheckPoint; + result := UndoBlocks.CurrentBlock; +end; + +function TBoldUndoHandler.GetCurrentUndoBlockHasChanges: boolean; +begin + result := false; + if not UndoBlocks.IsEmpty then + result := GetCurrentUndoBlock.ContainsChanges; +end; + +function TBoldUndoHandler.GetEnabled: Boolean; +begin + result := fEnabled; +end; + +function TBoldUndoHandler.GetIsEmpty: boolean; +begin + result := UndoBlocks.Count = 0; +end; + function TBoldUndoHandler.GetRedoList: IBoldUndoList; begin Result := FRedoBlocks; @@ -660,11 +908,10 @@ function TBoldUndoHandler.GetRedoList: IBoldUndoList; function TBoldUndoHandler.GetUndoList: IBoldUndoList; begin - Result := FUndoBlocks; + Result := FUndoBlocks; end; -function TBoldUndoHandler.GetUniqueBlockName( - SuggestedName: string): string; +function TBoldUndoHandler.GetUniqueBlockName(const SuggestedName: string): string; var i: integer; begin @@ -672,11 +919,17 @@ function TBoldUndoHandler.GetUniqueBlockName( Result := SuggestedName; while ((UndoBlocks.IndexOf(Result) <> -1) or (RedoBlocks.IndexOf(Result) <> -1)) do begin - Result := Format('%s %d', [SuggestedName, i]); // do not localize + Result := Format('%s %d', [SuggestedName, i]); inc(i); end; end; +{function TBoldUndoHandler.GetNonUndoableBlock: IBoldUndoBlock; +begin + Result := FNonUndoableBlock; +end; +} + procedure TBoldUndoHandler.ApplytranslationList( IdTranslationList: TBoldIdTranslationList); begin @@ -684,42 +937,54 @@ procedure TBoldUndoHandler.ApplytranslationList( RedoBlocks.ApplytranslationList(IdTranslationList); end; -procedure TBoldUndoHandler.SetCheckPoint; +procedure TBoldUndoHandler.SetNamedCheckPoint(const CheckPointName: string); begin - SetNamedCheckPoint(GetUniqueBlockName('')); + if Assigned(UndoBlocks.GetBlockByName(CheckPointName)) or Assigned(RedoBlocks.GetBlockByName(CheckPointName)) then + raise EBold.CreateFmt('%s.SetCheckPoint: An Undo/Redo block named %s is already defined', [Classname, CheckPointName]) + else if (not UndoBlocks.IsEmpty and not UndoBlocks.CurrentBlock.ContainsChanges) then + UndoBlocks.RenameBlock(CurrentUndoBlock.BlockName, CheckPointName) // reuse/rename if current block is empty + else + UndoBlocks.AddBlock(CheckPointName); + SendExtendedEvent(self, beUndoSetCheckpoint, [CheckPointName]); end; -procedure TBoldUndoHandler.ClearAllUndoBlocks; +procedure TBoldUndoHandler.SetCheckPoint; begin - FUndoBlocks.Clear; - FRedoBlocks.Clear; + if UndoBlocks.IsEmpty or UndoBlocks.CurrentBlock.ContainsChanges then + SetNamedCheckPoint(GetUniqueBlockName(cUnNamedBlockName)); end; -function TBoldUndoHandler.GetEnabled: Boolean; +procedure TBoldUndoHandler.ClearAllUndoBlocks; begin - result := fEnabled; + FUndoBlocks.Clear; + FRedoBlocks.Clear; + SendExtendedEvent(self, beUndoChanged, []); end; procedure TBoldUndoHandler.SetEnabled(value: Boolean); begin - fEnabled := value; + if fEnabled <> value then + begin + fEnabled := value; + SendExtendedEvent(self, beUndoChanged, []) + end; end; { TBoldUndoBlockList } -function TBoldUndoBlockList.AddBlock( - BlockName: string; const FSVAlueSpace: TBoldFreeStandingValueSpace): TBoldUndoBlock; +function TBoldUndoBlockList.AddBlock(const BlockName: string; + const FSVAlueSpace: TBoldFreeStandingValueSpace): TBoldUndoBlock; var Idx: integer; begin - if FList.IndexOfName(BlockName) = -1 then + if FList.IndexOf(BlockName) = -1 then begin Idx := FList.Add(BlockName); Result := TBoldUndoBlock.CreateNamedBlock(BlockName, FSVAlueSpace); FList.Objects[Idx] := Result; end else - raise EBold.CreateFmt(sBlockNameInUse, [ClassName, BlockName]); + raise EBold.CreateFmt('%s.AddBlock: a block named %s already exists', [ClassName, BlockName]); end; function TBoldUndoBlockList.CanMoveBlock(CurIndex, @@ -728,22 +993,22 @@ function TBoldUndoBlockList.CanMoveBlock(CurIndex, i: integer; CurBlock, NewBlock: TBoldUndoBlock; begin - CurBlock := AssertedBlocksByIndex[CurIndex]; - NewBlock := AssertedBlocksByIndex[NewIndex]; + CurBlock := AssertedBlockByIndex[CurIndex]; + NewBlock := AssertedBlockByIndex[NewIndex]; Result := (CurIndex = NewIndex) or not CurBlock.IsDependantOn(NewBlock); if Result then begin - if (CurIndex < NewIndex) then //moving up + if (CurIndex < NewIndex) then for i:= CurIndex + 1 to NewIndex do begin - Result := not CurBlock.IsDependantOn(BlocksByIndex[i]); + Result := not CurBlock.IsDependantOn(BlockByIndex[i]); if not Result then Break; end - else //moving down + else for i:= CurIndex - 1 downto NewIndex do begin - Result := not CurBlock.IsDependantOn(BlocksByIndex[i]); + Result := not CurBlock.IsDependantOn(BlockByIndex[i]); if not Result then Break; end; @@ -779,81 +1044,55 @@ procedure TBoldUndoBlockList.MoveBlock(CurIndex, NewIndex: integer); begin if not CanMoveBlock(CurIndex, NewIndex) then - raise EBold.Create(sCannotMoveBlock); + raise EBold.Create('can''t move Block'); FList.Move(CurIndex, NewIndex); end; -function TBoldUndoBlockList.GetBlocksByIndex( - Index: integer): TBoldUndoBlock; +procedure TBoldUndoBlockList.MoveToTop(const BlockName: string); begin - if (Index >= 0) and (Index < FList.Count) then - Result := FList.Objects[Index] as TBoldUndoBlock - else - Result := nil; + MoveBlock(IndexOf(BlockName), FList.Count - 1); end; -function TBoldUndoBlockList.GetBlocksByName( - BlockName: string): TBoldUndoBlock; +procedure TBoldUndoBlockList.InternalRemoveBlock(Block: TBoldUndoBlock); var - Idx: integer; -begin - Idx := FList.IndexOf(blockName); - if Idx <> - 1 then - Result := FList.Objects[Idx] as TBoldUndoBlock - else - Result := nil; -end; - -function TBoldUndoBlockList.GetCount: integer; -begin - Result := fList.Count; -end; - -function TBoldUndoBlockList.IndexOf(BlockName: string): integer; -begin - Result := fList.IndexOf(BlockName); -end; - -procedure TBoldUndoBlockList.MoveToTop( - BlockName: string); + idx: integer; begin - MoveBlock(IndexOf(BlockName), FList.Count - 1); + idx := IndexOf(Block); + FList.Delete(idx); + FreeAndNil(Block); end; -procedure TBoldUndoBlockList.InternalRemoveBlock(BlockName: string); +procedure TBoldUndoBlockList.InternalRemoveBlock(const BlockName: string); var idx: integer; - obj: TObject; + Block: TBoldUndoBlock; begin idx := AssertedIndexOf(BlockName); - obj := FList.Objects[idx]; - FreeAndNil(obj); - FList.Delete(idx); + Block := FList.Objects[idx] as TBoldUndoBlock; + InternalRemoveBlock(Block); end; -procedure TBoldUndoBlockList.RenameBlock(OldName, - NewName: string); +procedure TBoldUndoBlockList.RenameBlock(const OldName, NewName: string); var aBlock: TBoldUndoBlock; begin - if Assigned(GetBlocksByName(NewName)) then - raise EBold.Create(sCannotRenameBlock); - aBlock := AssertedBlocksByName[OldName]; + if Assigned(GetBlockByName(NewName)) then + raise EBold.CreateFmt('Can''t rename block, %s already exists.', [NewName]); + aBlock := AssertedBlockByName[OldName]; FList.Strings[IndexOf(OldName)] := NewName; aBlock.FName := NewName; end; - procedure TBoldUndoBlockList.MergeBlocks(DestinationBlockName, - SourceBlockName: string); + procedure TBoldUndoBlockList.MergeBlocks(const DestinationBlockName, SourceBlockName: string); var DestinationBlock, SourceBlock: TBoldUndoBlock; begin - DestinationBlock := AssertedBlocksbyName[DestinationBlockName]; - SourceBlock := AssertedBlocksByName[SourceBlockName]; + DestinationBlock := AssertedBlockByName[DestinationBlockName]; + SourceBlock := AssertedBlockByName[SourceBlockName]; if not CanMergeBlock(IndexOf(SourceBlockName), IndexOf(DestinationBlockName)) then - raise EBold.Create(sCannotMergeBlocks); + raise EBold.Create('Can''t merge blocks'); DestinationBlock.Merge(SourceBlock, IndexOf(DestinationBlockName) > IndexOf(SourceBlockName)); - InternalRemoveBlock(SourceBlockName); + InternalRemoveBlock(SourceBlock); end; function TBoldUndoBlockList.CanMergeBlock(CurIndex, @@ -863,21 +1102,21 @@ function TBoldUndoBlockList.CanMergeBlock(CurIndex, CurBlock, NewBlock: TBoldUndoBlock; begin Result := true; - CurBlock := AssertedBlocksByIndex[CurIndex]; - NewBlock := AssertedBlocksByIndex[CurIndex]; - if CurIndex < NewIndex then //moving up + CurBlock := AssertedBlockByIndex[CurIndex]; + NewBlock := AssertedBlockByIndex[CurIndex]; + if CurIndex < NewIndex then begin for i:= CurIndex + 1 to NewIndex - 1 do begin - Result := not CurBlock.IsDependantOn(BlocksByIndex[i]); + Result := not CurBlock.IsDependantOn(BlockByIndex[i]); if not Result then Break; end end - else if CurIndex > NewIndex then //moving down + else if CurIndex > NewIndex then for i:= CurIndex - 1 downto NewIndex + 1 do begin - Result := not NewBlock.IsDependantOn(BlocksByIndex[i]); + Result := not NewBlock.IsDependantOn(BlockByIndex[i]); if not Result then Break; end; @@ -886,18 +1125,19 @@ function TBoldUndoBlockList.CanMergeBlock(CurIndex, function TBoldUndoBlockList.GetCurrentBlock: TBoldUndoBlock; begin Result := nil; - if (Count = 0) then - Result := AddBlock('UnNamed') // do not localize - else if Count > 0 then - Result := FList.Objects[Count - 1] as TBoldUndoBlock; +{ if (Count = 0) then + Result := AddBlock(cUnNamedBlockName) + else} + if Count > 0 then + Result := FList.Objects[Count - 1] as TBoldUndoBlock; end; -function TBoldUndoBlockList.GetAssertedBlocksByName( - BlockName: string): TBoldUndoBlock; +function TBoldUndoBlockList.GetAssertedBlockByName( + const BlockName: string): TBoldUndoBlock; begin - Result := BlocksByName[BlockName]; + Result := BlockByName[BlockName]; if not Assigned(Result) then - raise EBold.CreateFmt(sNoSuchBlock, [BlockName]); + raise EBold.CreateFmt('There is no block named %s', [BlockName]); end; function TBoldUndoBlockList.CanMoveToTop(CurIndex: integer): Boolean; @@ -910,18 +1150,22 @@ function TBoldUndoBlockList.AssertedIndexOf( begin Result := IndexOf(BlockName); if Result = -1 then - raise EBold.CreateFmt(sNoSuchBlock, [BlockName]); + raise EBold.CreateFmt('There is no block named %s', [BlockName]); +end; + +function TBoldUndoBlockList.GetItemByName(const Name: string): IBoldUndoBlock; +begin + result := BlockByName[Name] as IBoldUndoBlock; end; -function TBoldUndoBlockList.GetItemsByName( - Name: string): IBoldUndoBlock; +function TBoldUndoBlockList.GetIsEmpty: boolean; begin - result := BlocksByName[Name] as IBoldUndoBlock; + result := Count = 0; end; -function TBoldUndoBlockList.GetItems(Index: integer): IBoldUndoBlock; +function TBoldUndoBlockList.GetItem(Index: integer): IBoldUndoBlock; begin - Result := BlocksbyIndex[Index] as IBoldUndoBlock ; + Result := BlockByIndex[Index] as IBoldUndoBlock ; end; function TBoldUndoBlockList.GetTopBlock: IBoldUndoBlock; @@ -935,7 +1179,7 @@ procedure TBoldUndoBlockList.ApplytranslationList( i: integer; begin for i := 0 to count-1 do - BlocksbyIndex[i].ApplytranslationList(IdTranslationList); + BlockByIndex[i].ApplytranslationList(IdTranslationList); end; procedure TBoldUndoBlockList.MergeAll; @@ -946,9 +1190,9 @@ procedure TBoldUndoBlockList.MergeAll; i:= Count - 1; while i > 0 do begin - aBlock := BlocksByIndex[i]; - BlocksByIndex[i - 1].Merge(aBlock, True); - InternalRemoveBlock(aBlock.BlockName); + aBlock := BlockByIndex[i]; + BlockByIndex[i - 1].Merge(aBlock, True); + InternalRemoveBlock(aBlock); dec(i); end; end; @@ -964,11 +1208,11 @@ procedure TBoldUndoBlockList.GetDependantBlocks(const BlockName: string; G: IBOldGuard; begin G := TBoldGuard.Create(ObjectIds); - aBlock := GetAssertedBlocksByName(BlockName); + aBlock := GetAssertedBlockByName(BlockName); if Assigned(aBlock) then begin if not Assigned(DependantBlocks) then - raise EBold.CreateFmt(sParameterNotDefined, [ClassName]); + raise EBold.CreateFmt('%s.GetDependantBlocks: parameter DependantBlocks not assigned', [ClassName]); ObjectIds := TBoldObjectIdList.Create; aBlock.FSValueSpace.AllObjectIds(ObjectIds, true); DependantBlocks.Clear; @@ -978,24 +1222,24 @@ procedure TBoldUndoBlockList.GetDependantBlocks(const BlockName: string; for j:= 0 to ObjectContents.MemberCount - 1 do for b := AssertedIndexOf(aBlock.BlockName)-1 downto 0 do begin - CurBlock := BlocksbyIndex[b]; + CurBlock := BlockByIndex[b]; if Assigned(ObjectContents.ValueByIndex[j]) and CurBlock.ValueExists(ObjectIds.ObjectIds[i], j, aValue) and (DependantBlocks.IndexOf(CurBlock) = - 1) then DependantBlocks.Add(CurBlock); - end;//for b - end;//for i + end; + end; end; end; -function TBoldUndoBlockList.GetAssertedBlocksByIndex( +function TBoldUndoBlockList.GetAssertedBlockByIndex( Index: integer): TBoldUndoBlock; begin - Result := BlocksByIndex[Index]; + Result := BlockByIndex[Index]; if not Assigned(Result) then - raise EBold.CreateFmt(sNoSuchBlockIndex, [Index]); + raise EBold.CreateFmt('There is no block with index %d', [Index]); end; -function TBoldUndoBlockList.RemoveBlock(BlockName: string): Boolean; +function TBoldUndoBlockList.RemoveBlock(const BlockName: string): Boolean; var idx: integer; begin @@ -1005,256 +1249,5 @@ function TBoldUndoBlockList.RemoveBlock(BlockName: string): Boolean; InternalRemoveBlock(BlockName); end; -{ TBoldUndoBlock } - -constructor TBoldUndoBlock.CreateNamedBlock(const BlockName: string; const FSVAlueSpace: TBoldFreeStandingValueSpace); -begin - inherited Create; - FContainsChanges := false; - FName := BlockName; - FValueSpace := FSVAlueSpace; -end; - - -function TBoldUndoBlock.IsDependantOn( - Block: TBoldUndoBlock): Boolean; -var - ObjectContents: TBoldFreeStandingObjectContents; - i, j: integer; - aValue: IBoldValue; - ObjectIds: TBoldObjectIdList; - G: IBoldGuard; -begin - G := TBoldGuard.Create(ObjectIds); - ObjectIds := TBoldObjectIdList.Create; - Result := false; - FSValueSpace.AllObjectIds(ObjectIds, True); - for i:= 0 to ObjectIds.Count - 1 do - begin - ObjectContents := FSValueSpace.GetFSObjectContentsByObjectId(ObjectIds[i]); - for j := 0 to ObjectContents.MemberCount - 1 do - begin - Result := Assigned(ObjectContents.ValueByIndex[j]) and Block.ValueExists(ObjectIds[i], j, aValue); - if Result then - Break; - end; - if Result then - Break; - end; -end; - -procedure TBoldUndoBlock.Merge(Block: TBoldUndoBlock; const Overwrite: Boolean); -var - OwnContents, ObjectContents: TBoldFreeStandingObjectContents; - ObjectId: TBoldObjectId; - MemberId: TBoldMemberId; - i, j: integer; - ObjectIds: TBoldObjectIdList; - G: IBoldGuard; -begin - G := TBoldGuard.Create(MemberId, ObjectIds); - // Todo: Same as ApplyValueSpace??? - ObjectIds := TBoldObjectIdList.Create; - Block.FSValueSpace.AllObjectIds(ObjectIds, True); - for i:= 0 to ObjectIds.Count - 1 do - begin - ObjectId := ObjectIds[i]; - ObjectContents := Block.FSValueSpace.GetFSObjectContentsByObjectId(ObjectId); - if not FSValueSpace.GetHasContentsForId(ObjectId) then - FSValueSpace.EnsureObjectContents(ObjectId); - OwnContents :=FSValueSpace.GetFSObjectContentsByObjectId(ObjectId); - for j:= 0 to ObjectContents.MemberCount - 1 do - if Assigned(ObjectContents.valueByIndex[j]) then - begin - MemberId := TBoldMemberId.Create(j); - if (OwnContents.MemberCount > j) and Assigned(OwnContents.ValueByIndex[j]) then // CHECKCME - begin - if overwrite then - OwnContents.ValueByIndex[j].AssignContent(ObjectContents.ValueByIndex[j]); - end - else - begin - OwnContents.EnsureMember(MemberId, ObjectContents.ValueByIndex[j].ContentName); - OwnContents.ValueByIndex[j].AssignContent(ObjectContents.ValueByIndex[j]); - end; - FreeAndNil(memberId); - end; - end; -end; - -function TBoldUndoBlock.ValueExists(const ObjectID: TBoldObjectID; - const MemberIndex: integer; out Value: IBoldValue): Boolean; -var - ObjectContents: TBoldFreeStandingObjectContents; -begin - Value := nil; - ObjectContents := FSValueSpace.GetFSObjectContentsByObjectId(ObjectID); - if Assigned(ObjectContents) and (MemberIndex < ObjectContents.memberCount) then - Value := ObjectContents.ValueByIndex[MemberIndex]; - Result := Assigned(Value); -end; - -function TBoldUndoBlock.ValueExists(const ObjectID: TBoldObjectId; - const MemberIndex: integer): Boolean; -var - OC: TBoldFreeStandingObjectContents; -begin - OC := FSValueSpace.GetFSobjectContentsByObjectId(ObjectID); - Result := Assigned(OC) and (MemberIndex < OC.memberCount) and - Assigned(OC.ValueByIndex[MemberIndex]); -end; - -function TBoldUndoBlock.HandleMember(ObjectContents: IBoldObjectContents; MemberIndex: integer; MemberValue: IBoldValue): Boolean; -var - MemberId: TBoldMemberId; - ObjectId: TBoldObjectId; - FSObjectContents: TBoldFreeStandingObjectContents; - G: IBoldGuard; -begin - G := TBoldGuard.Create(MemberId); - ObjectId := ObjectContents.ObjectId; - Result := not ValueExists(ObjectId, MemberIndex); - if Result then - begin - FContainsChanges := true; - MemberId := TBoldMemberId.Create(MemberIndex); - FSObjectContents := FSValueSpace.GetFSObjectContentsByObjectId(ObjectId); - if not Assigned(FSObjectContents) then - begin - FSValueSpace.EnsureObjectContents(ObjectId); - FSObjectContents := FSValueSpace.GetFSObjectContentsByObjectId(ObjectId); - FSObjectContents.ApplyObjectContents(ObjectContents, False, false); - end; - FSObjectContents.EnsureMember(MemberId, MemberValue.ContentName); - FSObjectContents.ValueByIndex[MemberIndex].AssignContent(MemberValue); - end; -end; - -function TBoldUndoBlock.HasObjectContentsForAnyObjectInList( - const ObjectList: TBoldObjectList): Boolean; -var - i: integer; - ObjectId: TBoldObjectId; -begin - Result := false; - for i:= 0 to ObjectList.Count - 1 do - begin - ObjectId := ObjectList.BoldObjects[i].BoldObjectLocator.BoldObjectID; - Result := Assigned(FSValueSpace.GetFSObjectContentsByObjectId(ObjectId)); - if Result then - Break; - end; -end; - -(* -procedure TBoldUndoBlock.GetLinksToObject(const System: TBoldSystem; const ObjectId: TBoldObjectId; const OwnIndexInLinkClass: integer; - const SingleLinkClassTypeInfo: TBoldClassTypeInfo; SingleLinkIds: TBoldObjectIdList); -var - ObjectIds: TBoldObjectIdList; - i: integer; - LinkValue: IBoldValue; -begin - // TODO: new implementation - ObjectIds := TBoldObjectIdList.Create; - try - AllIdsInClass(System, SingleLinkClassTypeInfo, ObjectIds); - for i:= 0 to ObjectIds.Count - 1 do - if ValueExists(ObjectIds[i], OwnIndexInLinkClass, LinkValue) and - Assigned((LinkValue as IBoldObjectIdRef).Id) and - ((LinkValue as IBoldObjectIdRef).Id.IsEqual[ObjectId]) then - SingleLinkIds.Add(ObjectIds[i].Clone); - except - FreeAndNil(ObjectIds); - end; -end; -*) - -(* -procedure TBoldUndoBlock.AllIdsInClass( const System: TBoldSystem; - const ClassTypeInfo: TBoldClassTypeInfo; IdList: TBoldObjectIdList); -var - i: integer; - ObjectIds: TBoldObjectIdList; - G: IBoldGuard; -begin -{ TODO : Won't work with really deleted objects } - G := TBoldGuard.Create(ObjectIds); - ObjectIds := TBoldObjectIdList.Create; - FSValueSpace.AllObjectIds(ObjectIds, True); - for i:= 0 to ObjectIds.Count - 1 do - begin - if (System.Locators.ObjectByID[ObjectIds[i]].BoldClassTypeInfo = ClassTypeInfo) then - IdList.Add(ObjectIds[i]); - end; -end; -*) - -procedure TBoldUndoBlock.HandleObject(Obj: IBoldObjectContents; RegardAsExisting: Boolean); -var - ObjectId: TBoldObjectId; - ObjectContents: TBoldFreeStandingObjectContents; -begin - Assert(assigned(obj)); - ObjectId := Obj.ObjectID; - ObjectContents := FSValueSpace.GetFSObjectContentsByObjectId(ObjectId); - if not Assigned(ObjectContents) then - begin - FContainsChanges := True; - FSValueSpace.EnsureObjectContents(ObjectId); - ObjectContents := FSValueSpace.GetFSObjectContentsByObjectId(ObjectId); - ObjectContents.ApplyObjectContents(Obj, False, false); - if RegardAsExisting then - begin - ObjectContents.BoldPersistenceState := bvpsCurrent; - ObjectContents.BoldExistenceState := besExisting; - end; - end; -end; - -function TBoldUndoBlock.GetFSValueSpace: TBoldFreeStandingValueSpace; -begin - if not Assigned(FValueSpace) then - FValueSpace := TBoldFreeStandingValueSpace.Create; - Result := FValueSpace; -end; - -destructor TBoldUndoBlock.Destroy; -begin - FreeAndNil(FValueSpace); - inherited; -end; - -procedure TBoldUndoBlock.SetFSValueSpace( - const Value: TBoldFreeStandingValueSpace); -begin - if (FValueSpace <> Value) then - begin - FreeAndNil(FValueSpace); - FValueSpace := Value; - fContainsChanges := TRUE; - end; -end; - -function TBoldUndoBlock.GetName: string; -begin - Result := fName; -end; - -function TBoldUndoBlock.GetValueSpace: IBoldValueSpace; -begin - result := FSValueSpace as IBoldValueSpace; -end; - -function TBoldUndoBlock.GetContainsChanges: Boolean; -begin - result := fContainsChanges; -end; - -procedure TBoldUndoBlock.ApplytranslationList( - IdTranslationList: TBoldIdTranslationList); -begin - ValueSpace.ApplytranslationList(IdTranslationList); -end; - end. diff --git a/Source/ObjectSpace/Unloader/BoldUnloader.pas b/Source/ObjectSpace/Unloader/BoldUnloader.pas index 9be664a9..dc1808b7 100644 --- a/Source/ObjectSpace/Unloader/BoldUnloader.pas +++ b/Source/ObjectSpace/Unloader/BoldUnloader.pas @@ -1,3 +1,6 @@ +///////////////////////////////////////////////////////// + + unit BoldUnloader; interface @@ -13,6 +16,8 @@ interface { Forward declaration of classes } TBoldInvalidateMemberEvent = procedure(Member: TBoldMember; var Invalidate: Boolean) of object; TBoldUnloadObjectEvent = procedure(BoldObject: TBoldObject; var Unload: Boolean) of object; + TBoldReportUnloadEvent = procedure(const Scanned, UnloadedObjects, InvalidatedMembers: integer) of object; + TBoldMayUnloadStartEvent = procedure(var aStart: boolean) of object; TBoldUnLoader = class; @@ -24,11 +29,18 @@ TBoldUnLoader = class(TBoldMemoryManagedObject) fScanPerTick: integer; fActive: boolean; fWaitCount: integer; + fScanned: integer; + fInvalidatedMemberCount: integer; + fUnloadedObjectCount: integer; + fScanTime: TDateTime; fTraverser: TBoldLocatorListTraverser; fOnMayInvalidate: TBoldInvalidateMemberEvent; fOnMayUnload: TBoldUnloadObjectEvent; - procedure Scan; - procedure ScanObject(BoldObject: TBoldObject); + fOnMayStart: TBoldMayUnloadStartEvent; + fOnReportUnload: TBoldReportUnloadEvent; + FUnloadFromCurrentClassList: boolean; + function Scan: boolean; + function ScanObject(BoldObject: TBoldObject): boolean; procedure SetActive(const Value: boolean); procedure SetBoldSystem(const Value: TBoldSystem); procedure StartScan; @@ -36,13 +48,20 @@ TBoldUnLoader = class(TBoldMemoryManagedObject) public destructor Destroy; override; procedure Tick; + property InvalidatedMemberCount: integer read fInvalidatedMemberCount; + property UnloadedObjectCount: integer read fUnloadedObjectCount; + property Scanned: integer read fScanned; + property ScanTime: TDateTime read fScanTime; property BoldSystem: TBoldSystem read fBoldSystem write SetBoldSystem; - property ScanPerTick: integer read fScanPerTick write fScanPerTick; - property MinAgeForUnload: integer read fMinAgeForUnload write fMinAgeForUnload; + property ScanPerTick: integer read fScanPerTick write fScanPerTick; // milliseconds to spend in itterating on each tick + property MinAgeForUnload: integer read fMinAgeForUnload write fMinAgeForUnload; // unit for MinAgeForUnload is TickInterval property UnloadDelayedFetch: boolean read fUnloadDelayedFetch write fUnloadDelayedFetch; + property UnloadFromCurrentClassList: boolean read FUnloadFromCurrentClassList write FUnloadFromCurrentClassList; property Active: boolean read fActive write SetActive; property OnMayInvalidate: TBoldInvalidateMemberEvent read fOnMayInvalidate write fOnMayInvalidate; property OnMayUnload: TBoldUnloadObjectEvent read fOnMayUnload write fOnMayUnload; + property OnMayStart: TBoldMayUnloadStartEvent read fOnMayStart write fOnMayStart; + property OnReportUnload: TBoldReportUnloadEvent read fOnReportUnload write fOnReportUnload; end; @@ -50,8 +69,14 @@ implementation uses SysUtils, + Windows, + DateUtils, BoldUtils, - BoldCoreConsts; + BoldCoreConsts, + BoldSystemRT, + BoldIndex, + BoldElements, + BoldSubscription; { TBoldUnLoader } @@ -63,9 +88,9 @@ procedure TBoldUnLoader.SetActive(const Value: boolean); if Value then begin if Assigned(BoldSystem) then - StartScan + Tick else - raise EBold.CreateFmt(sNeedSystemToActivate, [ClassName]); + raise EBold.Create('TBoldUnLoader: Attempt to set Active without BoldSystem'); end else FreeAndNil(fTraverser); @@ -90,46 +115,64 @@ procedure TBoldUnLoader.StartWait; fWaitCount := 0; end; -procedure TBoldUnLoader.Scan; +function TBoldUnLoader.Scan: boolean; var Locator: TBoldObjectLocator; - Scanned: integer; + vScanned, vUnloadedObjectCount, vInvalidatedMemberCount: integer; + lStartTime: Int64; + lNow: Int64; + lTimeOut: boolean; begin - Scanned := 0; - while (not fTraverser.EndOfList) and (Scanned < ScanPerTick) do + lStartTime := GetTickCount; + lNow := lStartTime; + vScanned := Scanned; + vUnloadedObjectCount := UnloadedObjectCount; + vInvalidatedMemberCount := InvalidatedMemberCount; + lTimeOut := false; + while not lTimeOut and (fTraverser.MoveNext) do begin Locator := fTraverser.Locator; - if assigned(Locator.BoldObject) and (Locator.BoldObject.BoldExistenceState = besExisting) then + if assigned(Locator.BoldObject) and (Locator.BoldObject.BoldExistenceState = besExisting) and not Locator.BoldObject.BoldDirty then ScanObject(Locator.BoldObject); - fTraverser.Next; - inc(Scanned); + inc(fScanned); + lNow := GetTickCount; + lTimeOut := (lNow - lStartTime > scanPerTick) or (lNow < lStartTime); end; + IncMilliSecond(ScanTime, lNow-lStartTime); + if Assigned(fOnReportUnload) then + fOnReportUnload(Scanned - vScanned, UnloadedObjectCount - vUnloadedObjectCount, InvalidatedMemberCount - vInvalidatedMemberCount); + result := lTimeOut; end; -procedure TBoldUnLoader.ScanObject(BoldObject: TBoldObject); +function TBoldUnLoader.ScanObject(BoldObject: TBoldObject): boolean; procedure ScanMembers; var m: integer; Member: TBoldMember; - DoInvalidate: Boolean; + lDoInvalidate: Boolean; begin for m := 0 to BoldObject.BoldMemberCount-1 do - if BoldObject.BoldMemberAssigned[m] then begin - Member := BoldObject.BoldMembers[m]; - with BoldObject.BoldMembers[m] do + Member := BoldObject.BoldMemberIfAssigned[m]; + if Assigned(Member) then begin - if (not Touched) then + with Member do begin - if (Derived and (BoldPersistenceState = bvpsTransient)) or - (UnloadDelayedFetch and (BoldMemberRTInfo.DelayedFetch = True) and (BoldPersistenceState = bvpsCurrent)) then + if (not Touched) then begin - DoInvalidate := not MemberHasSubscribers; - if Assigned(OnMayInvalidate) then - OnMayInvalidate(Member, DoInvalidate); - if DoInvalidate then - Invalidate; + if (Derived and (BoldPersistenceState = bvpsTransient)) or + ((BoldPersistenceState = bvpsCurrent) and (not BoldMemberRTInfo.DelayedFetch or UnloadDelayedFetch)) then + begin + lDoInvalidate := not MemberHasSubscribers; + if Assigned(OnMayInvalidate) then + OnMayInvalidate(Member, lDoInvalidate); + if lDoInvalidate then + begin + inc(fInvalidatedMemberCount); + Invalidate; + end; + end; end; end; end; @@ -137,37 +180,56 @@ procedure TBoldUnLoader.ScanObject(BoldObject: TBoldObject); end; var - DoUnload: Boolean; - + vDoUnload: Boolean; begin + result := false; Scanmembers; - if BoldObject.Touched then - BoldObject.ClearTouched - else if BoldObject.BoldPersistent and not BoldObject.BoldDirty then + with BoldObject do begin - DoUnload := not BoldObject.ObjectHasSubscribers; - if Assigned(OnMayUnload) then - OnMayUnload(BoldObject, DoUnload); - if DoUnload then - BoldObject.BoldObjectLocator.UnloadBoldObject + if Touched then + ClearTouched + else if BoldPersistent and not BoldDirty and not ObjectHasSubscribers then + begin + vDoUnload:= UnloadFromCurrentClassList or (BoldSystem.Classes[BoldClassTypeInfo.TopSortedIndex].BoldPersistenceState <> bvpsCurrent); + if Assigned(OnMayUnload) then + OnMayUnload(BoldObject, vDoUnload); + if vDoUnload then + begin + BoldObjectLocator.UnloadBoldObject; + inc(fUnloadedObjectCount); + result := true; + end; + end; end; end; procedure TBoldUnLoader.Tick; +var + lStart: boolean; begin if Active then + begin + if BoldSystem.InTransaction or BoldSystem.IsProcessingTransactionOrUpdatingDatabase or BoldSystem.IsDerivingMembers then + exit; + if Assigned(fOnMayStart) then + begin + lStart := true; + fOnMayStart(lStart); + if not lStart then + exit; + end; if Assigned(fTraverser) then // in a Scan begin - Scan; - if fTraverser.EndOfList then + if not Scan then StartWait; end else // waiting begin INC(fWaitCount); - if fWaitCount > MinAgeForUnload then + if fWaitCount >= MinAgeForUnload then StartScan; end; + end; end; destructor TBoldUnLoader.Destroy; @@ -177,7 +239,3 @@ destructor TBoldUnLoader.Destroy; end; end. - - - - diff --git a/Source/ObjectSpace/UtilsGUI/BoldComponentValidator.pas b/Source/ObjectSpace/UtilsGUI/BoldComponentValidator.pas index ed0a7e3e..4ce1d267 100644 --- a/Source/ObjectSpace/UtilsGUI/BoldComponentValidator.pas +++ b/Source/ObjectSpace/UtilsGUI/BoldComponentValidator.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComponentValidator; interface @@ -19,15 +22,18 @@ TBoldComponentValidator = class; { TBoldComponentValidator } TBoldComponentValidator = class + private + fValidateCount: integer; protected - function ValidateOCLComponent(Component: IBoldOCLComponent; Name: String): Boolean; function ValidateValidateableComponent(Component: IBoldValidateableComponent; NamePrefix: String): Boolean; procedure InitializeLog; procedure CompleteLog; public function ValidateComponent(Component: TPersistent; NamePrefix: String = ''; TraverseSubComponents: Boolean = false): Boolean; - function ValidateExpressionInContext(Expression: string; Context: TBoldElementTypeInfo; Name: String): Boolean; + function ValidateExpressionInContext(Expression: string; Context: TBoldElementTypeInfo; Name: String; const VariableList: TBoldExternalVariableList = nil): Boolean; procedure ValidateApplication; + function ValidateOCLComponent(Component: IBoldOCLComponent; Name: String): Boolean; + property ValidateCount: integer read fValidateCount write fValidateCount; end; implementation @@ -35,54 +41,68 @@ implementation uses SysUtils, BoldLogHandler, - BoldEnvironment, - BoldCoreConsts; + BoldDefs, + BoldEnvironment; { TBoldComponentValidator } + function TBoldComponentValidator.ValidateComponent(Component: TPersistent; NamePrefix: String = ''; TraverseSubComponents: Boolean = false): Boolean; var OCLComponent: IBoldOCLComponent; ValidateableComponent: IBoldValidateableComponent; i: integer; + vCounter: integer; + vIsFormOrDataModule: boolean; begin - if BoldEffectiveEnvironment.IsFormOrDataModule(Component) then - BoldLog.LogHeader := Format(sValidatingHeader, [(Component as TComponent).Name]); + vCounter := ValidateCount; + vIsFormOrDataModule := BoldEffectiveEnvironment.IsFormOrDataModule(Component); + if vIsFormOrDataModule then + BoldLog.LogFmt('Validating %s', [(Component as TComponent).Name], ltInfo); result := true; - if Component.GetInterface(IBoldOCLComponent, OCLComponent) then + if Supports(Component, IBoldValidateableComponent, ValidateableComponent) then + result := result and ValidateValidateableComponent(ValidateableComponent, NamePrefix + Component.GetNamePath) + else + if Supports(Component, IBoldOCLComponent, OCLComponent) then result := result and ValidateOCLComponent(OclComponent, NamePrefix + Component.GetNamePath); - if Component.GetInterface(IBoldValidateableComponent, ValidateableComponent) then - result := result and ValidateValidateableComponent(ValidateableComponent, NamePrefix); - if TraverseSubComponents and (Component is TComponent) then for i := 0 to (Component as TComponent).ComponentCount - 1 do result := result and ValidateComponent((Component as TComponent).Components[i], NamePrefix + Component.GetNamePath + '.', TraverseSubComponents); + if vIsFormOrDataModule then + begin + if result then + BoldLog.LogFmt('%s ok, checked %d expressions.', [(Component as TComponent).Name, ValidateCount - vCounter], ltInfo) + else + BoldLog.LogFmt('%s failed, checked %d expressions.', [(Component as TComponent).Name, ValidateCount - vCounter], ltWarning); + end; end; -function TBoldComponentValidator.ValidateExpressionInContext(Expression: string; Context: TBoldElementTypeInfo; Name: String): Boolean; + +function TBoldComponentValidator.ValidateExpressionInContext(Expression: string; Context: TBoldElementTypeInfo; Name: String; const VariableList: TBoldExternalVariableList = nil): Boolean; begin + inc(fValidateCount); result := true; if not assigned(Context) then begin result := false; - BoldLog.LogFmt(sNoContext, [Name]); + BoldLog.LogFmt('No context for %s', [Name], ltWarning); end else begin try - Context.Evaluator.ExpressionType(Expression, Context, true); + Context.Evaluator.ExpressionType(Expression, Context, true, VariableList); except on e: exception do begin result := false; - BoldLog.LogFmt(sValidationError, [Name, e.Message]); + BoldLog.LogFmt('Error in %s: %s', [Name, e.Message], ltError); end; end; + if not Result then + BoldLog.LogFmt('Expression: %s', [Expression], ltWarning); end; - if not Result then - BoldLog.LogFmt(sValidationExpression, [Expression]); end; procedure TBoldComponentValidator.ValidateApplication; @@ -98,9 +118,10 @@ procedure TBoldComponentValidator.ValidateApplication; function TBoldComponentValidator.ValidateOCLComponent(Component: IBoldOCLComponent; Name: String): Boolean; begin - result := ValidateExpressionInContext(Component.Expression, Component.ContextType, Name); + result := ValidateExpressionInContext(Component.Expression, Component.ContextType, Name, Component.VariableList); end; + function TBoldComponentValidator.ValidateValidateableComponent(Component: IBoldValidateableComponent; NamePrefix: String): Boolean; begin result := Component.ValidateComponent(self, NamePrefix); @@ -109,7 +130,7 @@ function TBoldComponentValidator.ValidateValidateableComponent(Component: IBoldV procedure TBoldComponentValidator.InitializeLog; begin BoldLog.Show; - BoldLog.StartLog(sComponentValidation); + BoldLog.StartLog('Component validation'); end; procedure TBoldComponentValidator.CompleteLog; diff --git a/Source/ObjectSpace/UtilsGUI/BoldOCLGraphicRTDebug.pas b/Source/ObjectSpace/UtilsGUI/BoldOCLGraphicRTDebug.pas index c2eb2b53..4a1c6bd5 100644 --- a/Source/ObjectSpace/UtilsGUI/BoldOCLGraphicRTDebug.pas +++ b/Source/ObjectSpace/UtilsGUI/BoldOCLGraphicRTDebug.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOCLGraphicRTDebug; interface @@ -37,8 +40,7 @@ implementation Controls, Dialogs, BoldOcl, - BoldOclPropEditor, - BoldCoreConsts; + BoldOclPropEditor; function CaseSensitiveIndexOf(Strings: TStrings; Str: String): integer; @@ -61,10 +63,13 @@ function TBoldOclGraphicRTDebugger.AddFixFor(const Ocl: String; Fixform := TBoldOclPropEditForm.Create(nil); fixform.Context := Context; FixForm.OclExpr := ocl; - FixForm.Caption := sIllegalExpressionEncountered; - FixForm.ExpressionPage.Caption := Format(sInComponent, [Componentpath]); -// BoldDeActivateDisplayQueue; - ShowMessage(format(sIncorrectMessage, [ocl, BOLDCRLF, Componentpath, BOLDCRLF, Message, BOLDCRLF, Context.AsString])); + FixForm.Caption := 'Runtime OCL Debugger: Illegal expression encountered, Please try to fix it'; + FixForm.ExpressionPage.Caption := 'In component: ' + Componentpath; + ShowMessage(format( + 'Incorrect OCL-expression: %s' + BOLDCRLF + + 'In Component: %s' + BOLDCRLF + + 'Message: %s' + BOLDCRLF + + 'Context: %s', [ocl, Componentpath, Message, Context.AsString])); if (FixForm.ShowModal = mrOK) and (ocl <> FixForm.OclExpr) then begin @@ -81,7 +86,6 @@ function TBoldOclGraphicRTDebugger.AddFixFor(const Ocl: String; else result := false; BoldOCLRTDebugger := self; -// BoldActivateDisplayQueue; end; function TBoldOclGraphicRTDebugger.GetFixFor(const Ocl: String; @@ -124,8 +128,7 @@ function TBoldOclGraphicRTDebugger.MatchString(Context: TBoldElementTypeInfo; if assigned(Context) then result := Context.AsString + '.' + Ocl else - result := '.' + Ocl; //do not localize + result := '.' + Ocl; end; end. - diff --git a/Source/ObjectSpace/UtilsGUI/BoldOclPropEditor.dfm b/Source/ObjectSpace/UtilsGUI/BoldOclPropEditor.dfm index de8ef806..1b983b33 100644 --- a/Source/ObjectSpace/UtilsGUI/BoldOclPropEditor.dfm +++ b/Source/ObjectSpace/UtilsGUI/BoldOclPropEditor.dfm @@ -1,10 +1,10 @@ object BoldOclPropEditForm: TBoldOclPropEditForm Left = 167 Top = 187 - Width = 644 - Height = 357 HelpContext = 10 Caption = 'OCL Expression Editor' + ClientHeight = 352 + ClientWidth = 720 Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText @@ -39,12 +39,14 @@ object BoldOclPropEditForm: TBoldOclPropEditForm 000000000000000000000000000000000000000000000000000000000000} OldCreateOrder = True Position = poScreenCenter + OnCreate = FormCreate + OnDestroy = FormDestroy PixelsPerInch = 96 TextHeight = 13 object ExpBottomPanel: TPanel Left = 0 - Top = 297 - Width = 636 + Top = 319 + Width = 720 Height = 33 Align = alBottom BevelOuter = bvNone @@ -2178,7 +2180,7 @@ object BoldOclPropEditForm: TBoldOclPropEditForm OnClick = imgModelErrorsClick end object pnlOKCancel: TPanel - Left = 350 + Left = 434 Top = 0 Width = 286 Height = 33 @@ -2190,13 +2192,13 @@ object BoldOclPropEditForm: TBoldOclPropEditForm Top = 2 Width = 81 Height = 25 - Caption = 'OK' + Caption = '&OK' TabOrder = 0 OnClick = OKClick end object btnCancel: TButton - Left = 194 - Top = 2 + Left = 193 + Top = 1 Width = 81 Height = 25 Cancel = True @@ -2218,52 +2220,58 @@ object BoldOclPropEditForm: TBoldOclPropEditForm object TabControlPanel: TPanel Left = 0 Top = 0 - Width = 636 - Height = 297 + Width = 720 + Height = 319 Align = alClient BevelOuter = bvNone BorderWidth = 5 Caption = 'TabControlPanel' TabOrder = 0 + object SplitterRight: TSplitter + Left = 489 + Top = 5 + Width = 6 + Height = 309 + Align = alRight + end + object SplitterLeft: TSplitter + Left = 225 + Top = 5 + Width = 6 + Height = 309 + end object ExprEditPageControl: TPageControl - Left = 5 + Left = 231 Top = 5 - Width = 626 - Height = 287 + Width = 258 + Height = 309 ActivePage = ExpressionPage Align = alClient TabOrder = 0 object ExpressionPage: TTabSheet HelpContext = 20 Caption = 'Expression' - object Splitter1: TSplitter - Left = 427 - Top = 0 - Width = 6 - Height = 259 - Align = alRight - end - object pnlLeftSide: TPanel + object pnlClient: TPanel Left = 0 Top = 0 - Width = 427 - Height = 259 + Width = 250 + Height = 281 Align = alClient BevelOuter = bvNone Caption = 'Panel1' TabOrder = 0 object Splitter2: TSplitter Left = 0 - Top = 139 - Width = 427 + Top = 161 + Width = 250 Height = 6 Cursor = crVSplit Align = alBottom end object ExpParserPanel: TPanel Left = 0 - Top = 145 - Width = 427 + Top = 167 + Width = 250 Height = 114 Align = alBottom BevelOuter = bvNone @@ -2272,14 +2280,14 @@ object BoldOclPropEditForm: TBoldOclPropEditForm object pnlEditButtons: TPanel Left = 0 Top = 0 - Width = 427 + Width = 250 Height = 37 Align = alTop BevelOuter = bvNone Constraints.MinHeight = 37 TabOrder = 0 DesignSize = ( - 427 + 250 37) object ParserMsg: TLabel Left = 1 @@ -2298,7 +2306,7 @@ object BoldOclPropEditForm: TBoldOclPropEditForm OnClick = SyntaxcbClick end object Clear: TButton - Left = 345 + Left = 168 Top = 4 Width = 81 Height = 25 @@ -2308,7 +2316,7 @@ object BoldOclPropEditForm: TBoldOclPropEditForm OnClick = ClearClick end object RemoveLast: TButton - Left = 253 + Left = 76 Top = 4 Width = 81 Height = 25 @@ -2321,7 +2329,7 @@ object BoldOclPropEditForm: TBoldOclPropEditForm object ParserMessages: TMemo Left = 0 Top = 37 - Width = 427 + Width = 250 Height = 77 TabStop = False Align = alClient @@ -2341,8 +2349,8 @@ object BoldOclPropEditForm: TBoldOclPropEditForm object EditPanel: TPanel Left = 0 Top = 0 - Width = 427 - Height = 139 + Width = 250 + Height = 161 Align = alClient BevelOuter = bvNone Caption = 'Panel2' @@ -2350,11 +2358,12 @@ object BoldOclPropEditForm: TBoldOclPropEditForm object EditMemo: TMemo Left = 0 Top = 0 - Width = 427 - Height = 139 + Width = 250 + Height = 161 Align = alClient Constraints.MinHeight = 50 - Constraints.MinWidth = 427 + Constraints.MinWidth = 250 + PopupMenu = MRUPopupMenu ScrollBars = ssBoth TabOrder = 0 WordWrap = False @@ -2366,19 +2375,67 @@ object BoldOclPropEditForm: TBoldOclPropEditForm end end end + end + end + object VariablesPageControl: TPageControl + Left = 5 + Top = 5 + Width = 220 + Height = 309 + ActivePage = OclVariablesTabSheet + Align = alLeft + TabOrder = 1 + object OclVariablesTabSheet: TTabSheet + Caption = 'OCL Variables' + object pnlOclVariables: TPanel + Left = 0 + Top = 0 + Width = 212 + Height = 281 + Align = alClient + BevelOuter = bvNone + TabOrder = 0 + object VariablesListBox: TListBox + Left = 0 + Top = 0 + Width = 212 + Height = 281 + Style = lbOwnerDrawFixed + Align = alClient + Constraints.MinWidth = 140 + ItemHeight = 17 + Sorted = True + TabOrder = 0 + OnDblClick = SelectBoxDblClick + OnDrawItem = SelectBoxDrawItem + OnKeyPress = SelectBoxKeyPress + end + end + end + end + object ExpressionTypePageControl: TPageControl + Left = 495 + Top = 5 + Width = 220 + Height = 309 + ActivePage = ExpressionTypeTabSheet + Align = alRight + TabOrder = 2 + object ExpressionTypeTabSheet: TTabSheet + Caption = 'Available expressions' object pnlRightSide: TPanel - Left = 433 + Left = 0 Top = 0 - Width = 185 - Height = 259 - Align = alRight + Width = 212 + Height = 281 + Align = alClient BevelOuter = bvNone - TabOrder = 1 + TabOrder = 0 object SelectBox: TListBox Left = 0 - Top = 0 - Width = 185 - Height = 242 + Top = 21 + Width = 212 + Height = 243 Style = lbOwnerDrawFixed Align = alClient Constraints.MinWidth = 140 @@ -2390,27 +2447,64 @@ object BoldOclPropEditForm: TBoldOclPropEditForm OnKeyDown = SelectBoxKeyDown OnKeyPress = SelectBoxKeyPress end - object pnlShowTypes: TPanel + object pnlFilterPersistence: TPanel Left = 0 - Top = 242 - Width = 185 + Top = 264 + Width = 212 Height = 17 Align = alBottom BevelOuter = bvNone TabOrder = 1 - DesignSize = ( - 185 - 17) - object Typescb: TCheckBox - Left = 1 - Top = 1 - Width = 159 + object Derivedcb: TCheckBox + Left = 2 + Top = 0 + Width = 100 Height = 17 - Anchors = [akTop, akRight] - Caption = '&Show Types' + Caption = '&Derived' + Checked = True + State = cbChecked TabOrder = 0 - OnClick = TypescbClick + OnClick = FilterClick end + object Persistentcb: TCheckBox + Left = 60 + Top = 0 + Width = 68 + Height = 17 + Caption = '&Persistent' + Checked = True + State = cbChecked + TabOrder = 1 + OnClick = FilterClick + end + object Transientcb: TCheckBox + Left = 130 + Top = 0 + Width = 68 + Height = 17 + Caption = '&Transient' + Checked = True + State = cbChecked + TabOrder = 2 + OnClick = FilterClick + end + end + object filterCombo: TComboBox + Left = 0 + Top = 0 + Width = 212 + Height = 21 + Align = alTop + TabOrder = 2 + Text = '< All >' + OnChange = filterComboChange + OnExit = filterComboExit + Items.Strings = ( + '< All >' + '< Attributes >' + '< Single links >' + '< Multi links >' + '< Operations >') end end end @@ -2420,136 +2514,8 @@ object BoldOclPropEditForm: TBoldOclPropEditForm Left = 470 Top = 50 Bitmap = { - 494C010105000900040010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 - 0000000000003600000028000000400000003000000001002000000000000030 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + 494C010105000700040010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 + 0000000000003600000028000000400000002000000001002000000000000020 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 @@ -2807,12 +2773,8 @@ object BoldOclPropEditForm: TBoldOclPropEditForm 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000424D3E000000000000003E000000 - 2800000040000000300000000100010000000000800100000000000000000000 - 000000000000000000000000FFFFFF0000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000FFFF000000000000C01F000000000000 + 2800000040000000200000000100010000000000000100000000000000000000 + 000000000000000000000000FFFFFF00FFFF000000000000C01F000000000000 801F000000000000801F000000000000801F000000000000801F000000000000 801F000000000000801F000000000000801F000000000000801F000000000000 801F000000000000801F000000000000801F000000000000801F000000000000 @@ -2831,4 +2793,8 @@ object BoldOclPropEditForm: TBoldOclPropEditForm OnClick = Copymessagestoclipboard1Click end end + object MRUPopupMenu: TPopupMenu + Left = 345 + Top = 223 + end end diff --git a/Source/ObjectSpace/UtilsGUI/BoldOclPropEditor.pas b/Source/ObjectSpace/UtilsGUI/BoldOclPropEditor.pas index 040e8647..cb42f749 100644 --- a/Source/ObjectSpace/UtilsGUI/BoldOclPropEditor.pas +++ b/Source/ObjectSpace/UtilsGUI/BoldOclPropEditor.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOclPropEditor; interface @@ -30,7 +33,7 @@ TBoldOclPropEditForm = class(TForm) TabControlPanel: TPanel; ExprEditPageControl: TPageControl; ExpressionPage: TTabSheet; - pnlLeftSide: TPanel; + pnlClient: TPanel; ExpParserPanel: TPanel; EditPanel: TPanel; EditMemo: TMemo; @@ -42,26 +45,35 @@ TBoldOclPropEditForm = class(TForm) PopupMenu1: TPopupMenu; Copymessagestoclipboard1: TMenuItem; ParserMessages: TMemo; - Splitter1: TSplitter; ParserMsg: TLabel; Splitter2: TSplitter; - pnlRightSide: TPanel; - SelectBox: TListBox; - pnlShowTypes: TPanel; - Typescb: TCheckBox; imgModelErrors: TImage; pnlOKCancel: TPanel; btnOK: TButton; btnCancel: TButton; btnShowInfo: TButton; + VariablesPageControl: TPageControl; + OclVariablesTabSheet: TTabSheet; + pnlOclVariables: TPanel; + VariablesListBox: TListBox; + ExpressionTypePageControl: TPageControl; + ExpressionTypeTabSheet: TTabSheet; + pnlRightSide: TPanel; + SelectBox: TListBox; + pnlFilterPersistence: TPanel; + Derivedcb: TCheckBox; + SplitterRight: TSplitter; + SplitterLeft: TSplitter; + filterCombo: TComboBox; + MRUPopupMenu: TPopupMenu; + Persistentcb: TCheckBox; + Transientcb: TCheckBox; procedure SelectBoxDblClick(Sender: TObject); procedure EditMemoEnter(Sender: TObject); procedure SelectBoxKeyPress(Sender: TObject; var Key: Char); procedure EditMemoChange(Sender: TObject); procedure ClearClick(Sender: TObject); procedure RemoveLastClick(Sender: TObject); - procedure SyntaxcbClick(Sender: TObject); - procedure TypescbClick(Sender: TObject); procedure EditMemoMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure EditMemoKeyPress(Sender: TObject; var Key: Char); @@ -76,52 +88,74 @@ TBoldOclPropEditForm = class(TForm) procedure Copymessagestoclipboard1Click(Sender: TObject); procedure imgModelErrorsClick(Sender: TObject); procedure InfoBrowserClick(Sender: TObject); + procedure SyntaxcbClick(Sender: TObject); + procedure FilterClick(Sender: TObject); + procedure filterComboChange(Sender: TObject); + procedure filterComboExit(Sender: TObject); + procedure VariableTypescbClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormDestroy(Sender: TObject); private { Private declarations } fContext: TBoldElementTypeInfo; fSystemTypeInfo: TBoldSystemTypeInfo; fOclEvaluator: TBoldOcl; fVariables: TBoldExternalVariableList; + fCompleteSelectList: TStrings; + fMRUExpressionList: TStringList; + FOnExpressionChanged: TNotifyEvent; procedure SetOclExpr(Expr: String); function GetOclExpr: String; procedure SetContext(Context: TBoldElementTypeInfo); procedure SetSelection; procedure CleanParserMsg; procedure MemberHelp(Ocl: String); - Procedure OperationHelp(Ocl: String); + procedure OperationHelp(Ocl: String); + procedure ApplyFilter; + procedure UpdateVariables; function CheckOcl(Ocl: String): TBoldElementTypeInfo; - function GetOclEvaluator:TBoldOcl; + function GetOclEvaluator: TBoldOcl; procedure WMGetMinMaxInfo(Var Msg: TWMGetMinMaxINfo); message WM_GETMINMAXINFO; procedure SetVariables(const Value: TBoldExternalVariableList); + procedure AddExpressionToMRUList; + procedure FetchMRUExpressionList; + procedure MRUPopUpMenuClick(Sender: TObject); + function HasVariables: boolean; + procedure UpdateWidth; + procedure SetOclEvaluator(const Value: TBoldOCL); public { Public declarations } ShowSyntaxErrors: Boolean; - ShowTypes: Boolean; - Property OclEvaluator: TBoldOCL read GetOclEvaluator; + ShowDerived, ShowPersistent, ShowTransient: Boolean; constructor Create(AOwner: TComponent); override; destructor Destroy; override; + property OclEvaluator: TBoldOCL read GetOclEvaluator write SetOclEvaluator; property Context: TBoldElementTypeInfo read fContext write SetContext; property SystemTypeInfo: TBoldSystemTypeInfo read fSystemTypeInfo; property OclExpr: String read GetOclExpr write SetOclExpr; property Variables: TBoldExternalVariableList read fVariables write SetVariables; + property OnExpressionChanged: TNotifyEvent read FOnExpressionChanged write FOnExpressionChanged; end; implementation uses SysUtils, + StrUtils, + BoldUtils, BoldDefs, BoldRegistry, BoldOclError, BoldSystem, - BoldCoreConsts, BoldOclClasses; {$R *.dfm} const - OCLInfoURL = 'http://info.borland.com/techpubs/delphi/boldfordelphi/?Mech_OclAndSubscription.htm'; - OCLInfoLocal = 'doc\oclinfo.html'; + OCLInfoURL = 'https://www.omg.org/spec/OCL/'; + cMRUExpressionRegKey = '\MRU'; + cMRUExpressionRegKeyName = 'OCL Expression'; + cHiddenOCLVariables: array[0..3] of string = ('Nil', 'True', 'False', 'TimeStampNow'); type ModeType = (Arrow, Dot, unKnown); @@ -131,51 +165,63 @@ procedure TBoldOclPropEditForm.CleanParserMsg; ParserMessages.lines.clear; end; +procedure TBoldOclPropEditForm.ClearClick(Sender: TObject); +begin + EditMemo.Lines.Clear; + EditMemoChange(Sender) +end; + constructor TBoldOclPropEditForm.Create(AOwner: TComponent); begin inherited; - ExpressionPAge.TabVisible := false; + fCompleteSelectList := TStringList.Create; + ShowDerived := true; + ShowPersistent := true; + ShowTransient := true; ExprEditPageControl.ActivePage := ExpressionPage; SetFocusedControl(EditMemo); - fOclEvaluator := nil; end; -destructor TBoldOclPropEditForm.Destroy; +destructor TBoldOclPropEditForm.destroy; begin - FreeAndNil(fOclEvaluator); + fCompleteSelectList.free; inherited; end; function TBoldOclPropEditForm.GetOclEvaluator; begin - if not assigned(fOclEvaluator) then - fOclEvaluator := TBoldOcl.Create(SystemTypeInfo, nil); result := fOclEvaluator; + if not Assigned(result) and Assigned(SystemTypeInfo) then + result := SystemTypeInfo.Evaluator as TBoldOcl +end; + +procedure TBoldOclPropEditForm.SetOclEvaluator(const Value: TBoldOCL); +begin + fOclEvaluator := Value; end; procedure TBoldOclPropEditForm.SetContext(Context: TBoldElementTypeInfo); -var - OldSystemTypeInfo: TBoldSystemTypeInfo; -// j, i: integer; begin - OldSystemTypeInfo := SystemTypeInfo; fContext := Context; -// ContextCombo.Items.Clear; if assigned(Context) then begin fSystemTypeInfo := Context.SystemTypeInfo as TBoldSystemTypeInfo; - Caption:= 'OCL expression editor - Context: ' + Context.AsString; // do not localize + Caption:= 'OCL expression editor - Context: ' + Context.AsString; end else begin - Caption:= 'OCL expression editor - Context: '; // do not localize + Caption:= 'OCL expression editor - Context: '; CleanParserMsg; - ParserMessages.lines.Add(sNoContextNoSupport); + ParserMessages.lines.Add('No Context, No design support'); end; if (not assigned(SystemTypeInfo)) and (TBoldSystem.DefaultSystem <> nil) then fSystemTypeInfo := TBoldSystem.DefaultSystem.BoldType as tBoldSystemTypeInfo; + filterCombo.ItemIndex := 0; + + UpdateWidth; + { if assigned( Model) then begin @@ -199,12 +245,6 @@ procedure TBoldOclPropEditForm.SetContext(Context: TBoldElementTypeInfo); ContextCombo.ItemIndex := i; } - if OldSystemTypeInfo <> fSystemTypeInfo then - begin - fOclEvaluator.Free; - fOclEvaluator := TBoldOcl.Create(SystemTypeInfo, nil); - end; - EditMemoChange(nil); imgModelErrors.visible := assigned(SystemTypeInfo) and (SystemTypeInfo.InitializationLog.count > 0); end; @@ -213,39 +253,103 @@ procedure TBoldOclPropEditForm.SetOclExpr(Expr: String); var i: integer; begin - while Expr <> '' do - begin - if pos(BOLDCR, Expr) = 0 then - begin - EditMemo.Lines.Add(Expr); - Expr := ''; - end - else - begin - EditMemo.Lines.Add(copy(Expr, 1, pos(BOLDCR, Expr))); - Delete(Expr, 1, pos(BOLDCR, Expr)); - end; - end; -// EditMemo.Text := EditMemo.Text + ' '; + EditMemo.Text := Expr; i := Length(EditMemo.Text); EditMemo.SelStart := i - 2; EditMemoChange(nil); end; function TBoldOclPropEditForm.GetOclExpr: String; +begin + result := EditMemo.Text; +end; + +function TBoldOclPropEditForm.HasVariables: boolean; +begin + result := (Assigned(fVariables) and (fVariables.count > 0)) or (Assigned(OclEvaluator) and (OclEvaluator.VariableCount > Length(cHiddenOCLVariables))); +end; + +procedure TBoldOclPropEditForm.AddExpressionToMRUList; +var + lRegistry: TBoldRegistry; +begin + if fMRUExpressionList.IndexOf(EditMemo.Text) = -1 then + begin + lRegistry := TBoldRegistry.Create; + try + fMRUExpressionList.insert(0, EditMemo.Text); + if fMRUExpressionList.Count > 10 then + begin + fMRUExpressionList.Delete(10); + end; + if lRegistry.OpenKey(cMRUExpressionRegKey) then + begin + lRegistry.WriteString(cMRUExpressionRegKeyName, fMRUExpressionList.CommaText); + lRegistry.CloseKey; + end; + finally + lRegistry.free; + end; + end; +end; + +type + TFilterType = (ftAll, ftAttribute, ftSingleLink, ftMultilink, ftOperation, ftType, ftText); + +procedure TBoldOclPropEditForm.ApplyFilter; + + function ExtractFilterType(const AString: string): TFilterType; + var + c: char; + begin + result := ftAll; + if (copy(AString, 3,1) = '|') and (Length(AString) > 4) then + begin + c := AString[1]; + case c of + '1': result := ftAttribute; + '2': result := ftSingleLink; + '3': result := ftMultiLink; + '4': result := ftType; + '5': result := ftOperation; + end; + end; + end; + var i: integer; + vElementType: TFilterType; + vFilterType: TFilterType; + vInclude: boolean; + vFilterText: string; begin - with EditMemo do + case filterCombo.ItemIndex of + -1: vFilterType := ftText; + Ord(ftAttribute)..Ord(ftType): vFilterType := TFilterType(filterCombo.ItemIndex); + else + vFilterType := ftAll; + end; + vFilterText := Trim(FilterCombo.Text); + + for I := 0 to fCompleteSelectList.Count - 1 do begin - result := ''; - For i := 0 to Lines.Count - 1 do - Result := Result + Lines[i] + BOLDCR; + vInclude := vFilterType = ftAll; + if vFilterType <> ftAll then + begin + vElementType := ExtractFilterType(fCompleteSelectList[i]); + case vFilterType of + ftAll: vInclude := true; + ftAttribute..ftOperation: vInclude := vElementType = vFilterType; + ftType: vInclude := true; + ftText: vInclude := (vFilterText = '') or AnsiContainsText(Copy(fCompleteSelectList[i], 5, MaxInt), vFilterText); + end; + end; + if vInclude then + SelectBox.Items.Add(fCompleteSelectList[i]); end; - Delete(result, length(result), 1); end; -function TBoldOClPropEditForm.CheckOcl(Ocl: String): TBoldElementTypeInfo; +function TBoldOclPropEditForm.CheckOcl(Ocl: String): TBoldElementTypeInfo; procedure ShowError(Ocl: String; ErrorPointer: String; message: string); var @@ -275,7 +379,7 @@ function TBoldOClPropEditForm.CheckOcl(Ocl: String): TBoldElementTypeInfo; if Ocl = '' then begin Result := Context; - ParserMessages.lines.Add(sEmptyExpression); + ParserMessages.lines.Add('Empty Expression'); exit; end; @@ -286,12 +390,12 @@ function TBoldOClPropEditForm.CheckOcl(Ocl: String): TBoldElementTypeInfo; begin Result := nil; ParserMessages.lines.BeginUpdate; - if (Pos('SSYacc', e.Message) > 0) or (Pos('SSLex', e.Message) > 0) then // do not localize + if (Pos('SSYacc', e.Message) > 0) or (Pos('SSLex', e.Message) > 0) then begin if ShowSyntaxErrors then ShowError(e.Ocl, e.ErrorPointer, e.Message) else - ParserMessages.lines.add(sSyntaxError); + ParserMessages.lines.add('Unable to complete parse, syntax error'); end else ShowError(e.Ocl, e.ErrorPointer, e.Message); ParserMessages.lines.EndUpdate; @@ -300,7 +404,7 @@ function TBoldOClPropEditForm.CheckOcl(Ocl: String): TBoldElementTypeInfo; on e: EBoldOclInternalError do begin Result := nil; - e.Ocl := 'Internal Error: ' + e.ocl; // do not localize + e.Ocl := 'Internal Error: ' + e.ocl; ShowError(e.Ocl, e.ErrorPointer, e.Message); exit; end; @@ -318,12 +422,12 @@ function TBoldOClPropEditForm.CheckOcl(Ocl: String): TBoldElementTypeInfo; end; end; ParserMessages.lines.BeginUpdate; - ParserMessages.lines.Add(sSyntaxOK); + ParserMessages.lines.Add('Syntax is OK'); ParserMessages.lines.Add(''); if assigned(result) then - ParserMessages.lines.Add(Format(sCurrentTypeIsX, [Result.AsString])) + ParserMessages.lines.Add('Current type is: ' + Result.AsString) else - ParserMessages.lines.Add(sCurrentTypeIsUnknown); + ParserMessages.lines.Add('Current type is: unknown'); ParserMessages.SelStart := 0; ParserMessages.SelLength := 0; ParserMessages.lines.EndUpdate; @@ -356,7 +460,7 @@ procedure TBoldOclPropEditForm.OperationHelp(Ocl: String); assigned(TBoldListTypeInfo(ExpressionType).ListElementTypeInfo) and TBoldListTypeInfo(ExpressionType).ListElementTypeInfo.ConformsTo(Symbol.FormalArguments[0]))) and symbol.IsPostFix then begin - Addition := 'O | ' + prefix[Symbol.IsDotNotation] + Symbol.SymbolName; // do not localize + Addition := '5 | ' + prefix[Symbol.IsDotNotation] + Symbol.SymbolName; if Symbol.NumberofArgs > 1 then begin Addition := Addition + '('; @@ -367,24 +471,51 @@ procedure TBoldOclPropEditForm.OperationHelp(Ocl: String); begin ListExprType := Symbol.FormalArguments[j] as TBoldListTypeInfo; if Assigned(LIstExprType.ListElementTypeInfo) then - Addition := Addition + '«List<' + (Symbol.FormalArguments[j] as TBoldListTypeInfo).ListElementTypeInfo.ExpressionName + '>»,' // do not localize + Addition := Addition + '«List<' + (Symbol.FormalArguments[j] as TBoldListTypeInfo).ListElementTypeInfo.ExpressionName + '>»,' else - Addition := Addition + '«List»,' // do not localize // do not localize + Addition := Addition + '«List»,' end else Addition := Addition + '«' + Symbol.FormalArguments[j].ExpressionName + '»,' end else - Addition := Addition + '«AnyArg»,'; // do not localize + Addition := Addition + '«AnyArg»,'; Delete(Addition, Length(Addition), 1); Addition := Addition + ')'; end; - SelectBox.Items.AddObject(Addition + ' ', Symbol); + if Assigned(Symbol.ResultType) then + fCompleteSelectList.AddObject(Addition + ' : ' + Symbol.ResultType.ExpressionName , Symbol) + else + fCompleteSelectList.AddObject(Addition + ' ', Symbol); end; end; end; end; +procedure TBoldOclPropEditForm.RemoveLastClick(Sender: TObject); +var + line: string; +procedure RemovePrefix; +begin + if line = '' then + exit; + if line[length(line)] = '.' then + delete(line, length(line), 1) + else if Copy(line, Length(line) - 1, 2) = '->' then + delete(line, length(line) - 1, 2); +end; + +begin + Line := trim(EditMemo.Text); + if Line = '' then exit; + while (line <> '') and + (not CharInSet(line[length(line)], ['.', ' ']) and + (Copy(line, Length(line) - 1, 2) <> '->')) do + delete(line, length(line), 1); + RemovePrefix; + Editmemo.Text := trim(Line); +end; + procedure TBoldOclPropEditForm.MemberHelp(Ocl: String); const prefix: array[false..true] of string = ('', '.'); @@ -392,6 +523,7 @@ procedure TBoldOclPropEditForm.MemberHelp(Ocl: String); I: Integer; ClassInfo: TBoldClasstypeInfo; SystemInfo: TBoldSystemtypeInfo; + Member: TBoldMemberRTInfo; ExpressionType: TBoldElementTypeInfo; Attr: TBoldAttributeRTInfo; Role: TBoldRoleRTInfo; @@ -408,53 +540,64 @@ procedure TBoldOclPropEditForm.MemberHelp(Ocl: String); begin ClassInfo := ExpressionType as TBoldClasstypeInfo; for I := 0 to ClassInfo.AllMembers.Count - 1 do + begin + Member := ClassInfo.AllMembers[I]; + if not ShowDerived and Member.IsDerived then continue; + if not ShowPersistent and Member.Persistent then continue; + if not ShowTransient and not (Member.Persistent or Member.IsDerived) then continue; if ClassInfo.AllMembers[I] is TBoldAttributeRTInfo then begin Attr := ClassInfo.AllMembers[I] as TBoldAttributeRTInfo; - Exprname := 'M | ' + Prefix[ocl <> ''] + Attr.ExpressionName; // do not localize - if ShowTypes then - SelectBox.Items.Add(Exprname + ': ' + Attr.BoldType.ExpressionName) - else - SelectBox.Items.Add(Exprname + ' '); + Exprname := '1 | ' + Prefix[ocl <> ''] + Attr.ExpressionName; + fCompleteSelectList.Add(Exprname + ': ' + Attr.BoldType.ExpressionName) end else if ClassInfo.AllMembers[I] is TBoldRoleRTInfo then begin Role := ClassInfo.AllMembers[I] as TBoldRoleRTInfo; if role.IsNavigable then begin - Exprname := 'A | ' + Prefix[ocl <> ''] + Role.ExpressionName; // do not localize - if ShowTypes then - begin - if role.IsMultiRole then - SelectBox.Items.Add(ExprName + ': List<' + Role.ClassTypeInfoOfOtherEnd.Expressionname + '>') // do not localize // do not localize - else - SelectBox.Items.Add(ExprName + ': ' + Role.ClassTypeInfoOfOtherEnd.Expressionname) - end + if role.IsMultiRole then + Exprname := '3 | ' + Prefix[ocl <> ''] + Role.ExpressionName + else + Exprname := '2 | ' + Prefix[ocl <> ''] + Role.ExpressionName; + if role.IsMultiRole then + fCompleteSelectList.Add(ExprName + ': List<' + Role.ClassTypeInfoOfOtherEnd.Expressionname + '>') else - SelectBox.Items.Add(ExprName + ' '); + fCompleteSelectList.Add(ExprName + ': ' + Role.ClassTypeInfoOfOtherEnd.Expressionname) end; end; + end; end else if ExpressionType is TBoldSystemTypeInfo then begin SystemInfo := ExpressionType as TBoldSystemTypeInfo; for i := 0 to SystemInfo.TopSortedClasses.Count - 1 do with SystemInfo.TopSortedClasses[i] do - if ShowTypes then - SelectBox.Items.Add('C | ' + ExpressionName + ': ' + DelphiName) // do not localize - else - SelectBox.Items.Add('C | ' + ExpressionName + ' '); // do not localize + fCompleteSelectList.Add('4 | ' + ExpressionName + ': ' + DelphiName); end; end; +procedure TBoldOclPropEditForm.MRUPopUpMenuClick(Sender: TObject); +var + lMenuItem: TMenuItem; +begin + lMenuItem := (Sender as TMenuItem); + EditMemo.Text := fMRUExpressionList[lMenuItem.Parent.IndexOf(lMenuItem)]; +end; + procedure TBoldOclPropEditForm.SelectBoxDblClick(Sender: TObject); var Addition: String; + vListBox: TListBox; begin if not assigned(Context) then exit; - if SelectBox.ItemIndex = -1 then - SelectBox.ItemIndex := 0; - Addition := SelectBox.Items[SelectBox.ItemIndex]; + if not(Sender is TListBox) then + exit; + + vListBox := Sender as TListBox; + if vListBox.ItemIndex = -1 then + vListBox.ItemIndex := 0; + Addition := vListBox.Items[vListBox.ItemIndex]; if pos(' | ', Addition) <> 0 then Delete(Addition, 1, Pos(' | ', Addition) + 2); @@ -468,12 +611,14 @@ procedure TBoldOclPropEditForm.SelectBoxDblClick(Sender: TObject); EditMemo.Lines[EditMemo.Lines.Count - 1] + Addition; + if filterCombo.ItemIndex = -1 then + filterCombo.Clear; + EditMemoChange(Sender); end; procedure TBoldOclPropEditForm.EditMemoEnter(Sender: TObject); begin -// Context := DefaultBoldSystem.BoldSystemRtInfo; EditMemoChange(Sender); end; @@ -496,9 +641,23 @@ procedure TBoldOclPropEditForm.EditMemoChange(Sender: TObject); } Ocl := trim(EditMemo.Text); - SelectBox.Items.Clear; - MemberHelp(Ocl); - OperationHelp(Ocl); + VariablesListBox.Items.BeginUpdate; + SelectBox.Items.BeginUpdate; + fCompleteSelectList.BeginUpdate; + try + SelectBox.Clear; + fCompleteSelectList.Clear; + MemberHelp(Ocl); + OperationHelp(Ocl); + ApplyFilter; + UpdateVariables; + finally + VariablesListBox.Items.EndUpdate; + SelectBox.Items.EndUpdate; + fCompleteSelectList.EndUpdate; + end; + if Assigned(fOnExpressionChanged) then + OnExpressionChanged(self); { if Ocl = '' then begin @@ -517,55 +676,99 @@ procedure TBoldOclPropEditForm.EditMemoChange(Sender: TObject); } end; -procedure TBoldOclPropEditForm.ClearClick(Sender: TObject); +procedure TBoldOclPropEditForm.SyntaxcbClick(Sender: TObject); begin - EditMemo.Lines.Clear; - EditMemoChange(Sender) + ShowSyntaxErrors := syntaxcb.Checked; + EditMemoChange(Sender); end; -procedure TBoldOclPropEditForm.RemoveLastClick(Sender: TObject); +procedure TBoldOclPropEditForm.FilterClick(Sender: TObject); var - line: string; - -procedure RemovePrefix; + OldIndex: Integer; + OldTop: Integer; begin - if line = '' then - exit; - if line[length(line)] = '.' then - delete(line, length(line), 1) - else if Copy(line, Length(line) - 1, 2) = '->' then - delete(line, length(line) - 1, 2); + OldIndex := SelectBox.ItemIndex; + OldTop := SelectBox.TopIndex; + ShowDerived := Derivedcb.Checked; + ShowPersistent := Persistentcb.Checked; + ShowTransient := Transientcb.Checked; + EditMemoChange(Sender); + SelectBox.ItemIndex := OldIndex; + SelectBox.TopIndex := OldTop; end; +procedure TBoldOclPropEditForm.UpdateVariables; + + procedure AddVariable(const AName: string; AValueType: TBoldElementTypeInfo); + var + s: string; + begin + if not Assigned(AValueType) then + begin + VariablesListBox.Items.Add('5 | ' + AName + ': ' + 'Nil'); + exit; + end; + if AValueType is TBoldListTypeInfo then + s := '3 | ' + else + if AValueType is TBoldAttributeTypeInfo then + s := '1 | ' + else + if AValueType is TBoldClassTypeInfo then + s := '2 | ' + else + if AValueType is TBoldSystemTypeInfo then + s := '4 | ' + else + if AValueType is TBoldTypeTypeInfo then + s := '5 | ' + else + Assert(False, 'Unhandled ValueType: ' + AValueType.ClassName); + s := s + AName + ': ' + AValueType.ExpressionName; +// if VariablesListBox.Items.IndexOf(s) = -1 then + VariablesListBox.Items.Add(s); + end; + +var + i: integer; begin - // rewrite this entire procedure... - Line := trim(EditMemo.Text); - if Line = '' then exit; - while (line <> '') and - (not (line[length(line)] in ['.', ' ']) and - (Copy(line, Length(line) - 1, 2) <> '->')) do - delete(line, length(line), 1); - RemovePrefix; - Editmemo.Text := trim(Line); + VariablesPageControl.Visible := HasVariables; + VariablesListBox.Items.BeginUpdate; + VariablesListBox.Clear; + try + if Assigned(fVariables) then + for I := 0 to Variables.Count - 1 do + AddVariable(Variables[i].Name, Variables[i].ValueType); + for i := 0 to OclEvaluator.VariableCount - 1 do + with OclEvaluator.Variables[i] as TBoldOCLVariableBinding do + if AnsiIndexText(VariableName, cHiddenOCLVariables) = -1 then + AddVariable(VariableName, BoldType); + finally + VariablesListBox.Items.EndUpdate; + end; end; -procedure TBoldOclPropEditForm.SyntaxcbClick(Sender: TObject); +procedure TBoldOclPropEditForm.UpdateWidth; begin - ShowSyntaxErrors := syntaxcb.Checked; - EditMemoChange(Sender); + if not visible then + begin + if HasVariables then + Width := 900 + else + Width := 720; + end; end; -procedure TBoldOclPropEditForm.TypescbClick(Sender: TObject); +procedure TBoldOclPropEditForm.VariableTypescbClick(Sender: TObject); var OldIndex: Integer; OldTop: Integer; begin - OldIndex := SelectBox.ItemIndex; - OldTop := SelectBox.TopIndex; - ShowTypes := Typescb.checked; + OldIndex := VariablesListBox.ItemIndex; + OldTop := VariablesListBox.TopIndex; EditMemoChange(Sender); - SelectBox.ItemIndex := OldIndex; - SelectBox.TopIndex := OldTop; + VariablesListBox.ItemIndex := OldIndex; + VariablesListBox.TopIndex := OldTop; end; procedure TBoldOclPropEditForm.SetSelection; @@ -575,14 +778,14 @@ procedure TBoldOclPropEditForm.SetSelection; if EditMemo.SelLength = 0 then begin i := EditMemo.SelStart; - while (i > 0) and not (EditMemo.Text[i] in ['«', '»']) do + while (i > 0) and not CharInSet(EditMemo.Text[i], ['«', '»']) do dec(i); if (i = 0)or (EditMemo.Text[i] = '»') then exit; j := i + 1; - while (j <= Length(EditMemo.Text)) and not (EditMemo.Text[j] in ['«', '»']) do + while (j <= Length(EditMemo.Text)) and not CharInSet(EditMemo.Text[j], ['«', '»']) do Inc(j); if (j > Length(EditMemo.Text)) or (EditMemo.Text[j] = '«') then @@ -599,6 +802,56 @@ procedure TBoldOclPropEditForm.EditMemoMouseDown(Sender: TObject; SetSelection; end; +procedure TBoldOclPropEditForm.FetchMRUExpressionList; +var + lRegistry: TBoldRegistry; + lIndex: Integer; + lMenuItem: TMenuItem; +begin + lRegistry := TBoldRegistry.Create; + try + if lRegistry.OpenKey(cMRUExpressionRegKey) then + begin + fMRUExpressionList.CommaText := lRegistry.ReadString(cMRUExpressionRegKeyName, ''); + lRegistry.CloseKey; + end; + finally + lRegistry.free; + end; + for lIndex := 0 to fMRUExpressionList.Count - 1 do + begin + lMenuItem := TMenuItem.Create(Self); + lMenuItem.Caption := '&' + IntToStr(lIndex+1) + ': ' + fMRUExpressionList[lIndex]; + lMenuItem.OnClick := MRUPopUpMenuClick; + MRUPopupMenu.Items.Add(lMenuItem); + end; +end; + +procedure TBoldOclPropEditForm.filterComboChange(Sender: TObject); +begin + EditMemoChange(Sender); +end; + +procedure TBoldOclPropEditForm.filterComboExit(Sender: TObject); +begin + if (FilterCombo.ItemIndex = -1) and (FilterCombo.Text = '') then + begin + FilterCombo.ItemIndex := 0; + EditMemoChange(Sender); + end; +end; + +procedure TBoldOclPropEditForm.FormCreate(Sender: TObject); +begin + fMRUExpressionList := TStringList.Create; + FetchMRUExpressionList; +end; + +procedure TBoldOclPropEditForm.FormDestroy(Sender: TObject); +begin + fMRUExpressionList.free; +end; + procedure TBoldOclPropEditForm.EditMemoKeyPress(Sender: TObject; var Key: Char); begin SetSelection; @@ -609,6 +862,7 @@ procedure TBoldOclPropEditForm.EditMemoKeyPress(Sender: TObject; var Key: Char); procedure TBoldOclPropEditForm.OKClick(Sender: TObject); begin Modalresult := mrOK; + AddExpressionToMRUList; end; procedure TBoldOclPropEditForm.CancelClick(Sender: TObject); @@ -678,22 +932,59 @@ procedure TBoldOclPropEditForm.ContextComboChange(Sender: TObject); procedure TBoldOclPropEditForm.SelectBoxDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); var StringfromSelect: String; + s: string; + r: TRect; + vXOffset: integer; begin with (Control as TListBox) do begin Canvas.FillRect(Rect); StringFromSelect := (Control as TListBox).items[Index]; case StringFromSelect[1] of - 'M': ImageList1.Draw(Canvas, Rect.Left + 2, Rect.Top, 0); //Member - 'C': ImageList1.Draw(Canvas, Rect.Left + 2, Rect.Top, 1); //Class - 'A': ImageList1.Draw(Canvas, Rect.Left + 2, Rect.Top, 2); //Assoc/role - 'E': ImageList1.Draw(Canvas, Rect.Left + 2, Rect.Top, 3); //Method - 'O': ImageList1.Draw(Canvas, Rect.Left + 2, Rect.Top, 4); //Operation (OCL) + '1': ImageList1.Draw(Canvas, Rect.Left + 2, Rect.Top, 0); + '2': ImageList1.Draw(Canvas, Rect.Left + 2, Rect.Top, 2); + '3': ImageList1.Draw(Canvas, Rect.Left + 2, Rect.Top, 3); + '4': ImageList1.Draw(Canvas, Rect.Left + 2, Rect.Top, 1); + '5': ImageList1.Draw(Canvas, Rect.Left + 2, Rect.Top, 4); end; if pos(' | ', StringFromSelect) <> 0 then Delete(StringFromSelect, 1, Pos(' | ', StringFromSelect) + 2); - Canvas.TextOut(ImageList1.Width + Rect.Left + 2, Rect.Top, StringfromSelect); + vXOffset := 2 + ImageList1.Width; + if not ((odFocused in State) or (odSelected in State)) then + begin + s := StringFromSelect; + + if pos(':', s) <> 0 then + Delete(s, Pos(':', s), MaxInt); + + if pos(' ', s) <> 0 then + Delete(s, Pos(' ', s), MaxInt); + + if pos('(', s) <> 0 then + Delete(s, Pos('(', s), MaxInt); + + r := Rect; + r.Left := r.Left + vXOffset; + Canvas.Font.Color := clBlack; + DrawText(Canvas.Handle, + PChar(S), + Length(S), + r, + DT_LEFT or DT_WORDBREAK or DT_CALCRECT); + + DrawText(Canvas.Handle, + PChar(S), + Length(S), + r, + DT_LEFT or DT_WORDBREAK); + + vXOffset := r.Right; + Canvas.Font.Color := $00A0A0A0;; + StringFromSelect := Copy(StringfromSelect, Length(s)+1, MaxInt); + end; + + Canvas.TextOut(Rect.Left + vXOffset, Rect.Top, StringFromSelect); end; end; @@ -728,6 +1019,7 @@ procedure TBoldOclPropEditForm.SetVariables(const Value: TBoldExternalVariableLi begin fVariables := Value; EditMemoChange(nil); + UpdateWidth; end; procedure TBoldOclPropEditForm.Copymessagestoclipboard1Click(Sender: TObject); @@ -735,31 +1027,28 @@ procedure TBoldOclPropEditForm.Copymessagestoclipboard1Click(Sender: TObject); s: string; begin if Assigned(Context) then - s := 'Context: ' + Context.ExpressionName + BOLDCRLF // do not localize + s := 'Context: ' + Context.ExpressionName + BOLDCRLF else s := ''; ClipBoard.AsText := s + - 'OCL Expression: ' + BOLDCRLF + // do not localize + 'OCL Expression: ' + BOLDCRLF + EditMemo.Text + BOLDCRLF + BOLDCRLF + - 'Parser messages: ' + BOLDCRLF + // do not localize + 'Parser messages: ' + BOLDCRLF + ParserMessages.lines.text; + end; procedure TBoldOclPropEditForm.imgModelErrorsClick(Sender: TObject); begin - Showmessage(Format(sModelContainsErrors, [BoldCRLF, BoldCRLF, SystemTypeInfo.InitializationLog.text])); + Showmessage('The model contains errors: ' + BoldCRLF + BoldCRLF+ SystemTypeInfo.InitializationLog.text); end; procedure TBoldOclPropEditForm.InfoBrowserClick(Sender: TObject); var URL: String; begin - if (GetBoldBasePath <> '') and fileexists(GetBoldBasePath+'\'+OCLInfoLocal) then - URL := GetBoldBasePath+'\'+OCLInfoLocal - else - URL := OCLInfoURL; - - ShellExecute(0, 'open', PChar(URL), '', '', SW_SHOWMAXIMIZED); // do not localize + URL := OCLInfoURL; + ShellExecute(0, 'open', PChar(URL), '', '', SW_SHOWMAXIMIZED); end; end. diff --git a/Source/ObjectSpace/UtilsGUI/BoldTypeNameSelector.dfm b/Source/ObjectSpace/UtilsGUI/BoldTypeNameSelector.dfm index d7a94e32..16482fba 100644 --- a/Source/ObjectSpace/UtilsGUI/BoldTypeNameSelector.dfm +++ b/Source/ObjectSpace/UtilsGUI/BoldTypeNameSelector.dfm @@ -56,8 +56,6 @@ object frmBoldTypeNameSelector: TfrmBoldTypeNameSelector TabOrder = 0 OnChange = tvMetaTypesChange OnDblClick = tvMetaTypesDblClick - ExplicitWidth = 344 - ExplicitHeight = 288 end object pnButtons: TPanel Left = 0 @@ -67,8 +65,6 @@ object frmBoldTypeNameSelector: TfrmBoldTypeNameSelector Align = alBottom BevelOuter = bvNone TabOrder = 1 - ExplicitTop = 288 - ExplicitWidth = 344 DesignSize = ( 336 40) @@ -100,7 +96,7 @@ object frmBoldTypeNameSelector: TfrmBoldTypeNameSelector Left = 228 Top = 164 Bitmap = { - 494C010101000400080010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 + 494C010101000400040010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 0000000000003600000028000000400000001000000001002000000000000010 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 diff --git a/Source/ObjectSpace/UtilsGUI/BoldTypeNameSelector.pas b/Source/ObjectSpace/UtilsGUI/BoldTypeNameSelector.pas index 988ad859..d01ca9dc 100644 --- a/Source/ObjectSpace/UtilsGUI/BoldTypeNameSelector.pas +++ b/Source/ObjectSpace/UtilsGUI/BoldTypeNameSelector.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldTypeNameSelector; interface @@ -12,7 +15,8 @@ interface StdCtrls, BoldSystemRT, BoldElements, - ImgList, Menus; + ImgList, + Menus; type TNodeType = (ntClass, ntClasses, ntAttributes, ntList, ntAttribute, ntClassList, @@ -48,7 +52,7 @@ implementation BoldUtils; {$R *.dfm} -{.$R BoldTypeNameSelector.res} +{$R BoldTypeNameSelector.res} { TfrmBoldTypeNameSelector } @@ -66,16 +70,16 @@ function TfrmBoldTypeNameSelector.Select(var StringValue: String; SystemTypeInfo procedure TfrmBoldTypeNameSelector.FormCreate(Sender: TObject); begin - ilImages.GetInstRes(HInstance, rtBitmap, 'SMALLUMLMODELROOTBITMAP', 16, [], clWhite); // do not localize - ilImages.GetInstRes(HInstance, rtBitmap, 'SMALLUMLCLASSBITMAP', 16, [], clWhite); // do not localize - ilImages.GetInstRes(HInstance, rtBitmap, 'SMALLUMLCLASSESBITMAP', 16, [], clWhite); // do not localize - ilImages.GetInstRes(HInstance, rtBitmap, 'SMALLUMLATTRIBUTEBITMAP', 16, [], clWhite); // do not localize - ilImages.GetInstRes(HInstance, rtBitmap, 'SMALLUMLATTRIBUTESBITMAP', 16, [], clWhite); // do not localize - ilImages.GetInstRes(HInstance, rtBitmap, 'SMALLLISTBITMAP', 16, [], clWhite); // do not localize - ilImages.GetInstRes(HInstance, rtBitmap, 'SMALLUMLCLASSLISTBITMAP', 16, [], clWhite); // do not localize - ilImages.GetInstRes(HInstance, rtBitmap, 'SMALLUMLATTRIBUTELISTBITMAP', 16, [], clWhite); // do not localize - ilImages.GetInstRes(HInstance, rtBitmap, 'SMALLSYSTEMBITMAP', 16, [], clWhite); // do not localize - ilImages.GetInstRes(HInstance, rtBitmap, 'SMALLTYPEBITMAP', 16, [], clWhite); // do not localize + ilImages.GetInstRes(HInstance, rtBitmap, 'SMALLUMLMODELROOTBITMAP', 16, [], clWhite); + ilImages.GetInstRes(HInstance, rtBitmap, 'SMALLUMLCLASSBITMAP', 16, [], clWhite); + ilImages.GetInstRes(HInstance, rtBitmap, 'SMALLUMLCLASSESBITMAP', 16, [], clWhite); + ilImages.GetInstRes(HInstance, rtBitmap, 'SMALLUMLATTRIBUTEBITMAP', 16, [], clWhite); + ilImages.GetInstRes(HInstance, rtBitmap, 'SMALLUMLATTRIBUTESBITMAP', 16, [], clWhite); + ilImages.GetInstRes(HInstance, rtBitmap, 'SMALLLISTBITMAP', 16, [], clWhite); + ilImages.GetInstRes(HInstance, rtBitmap, 'SMALLUMLCLASSLISTBITMAP', 16, [], clWhite); + ilImages.GetInstRes(HInstance, rtBitmap, 'SMALLUMLATTRIBUTELISTBITMAP', 16, [], clWhite); + ilImages.GetInstRes(HInstance, rtBitmap, 'SMALLSYSTEMBITMAP', 16, [], clWhite); + ilImages.GetInstRes(HInstance, rtBitmap, 'SMALLTYPEBITMAP', 16, [], clWhite); end; procedure TfrmBoldTypeNameSelector.GenerateNodes( @@ -85,96 +89,89 @@ procedure TfrmBoldTypeNameSelector.GenerateNodes( begin with tvMetaTypes do begin - // add the root node - Node := Items.AddObject(nil, 'Types in the system', nil); // do not localize - SetImageIndex(Node, ntRoot); + Items.BeginUpdate; + try + Node := Items.AddObject(nil, 'Types in the system', nil); + SetImageIndex(Node, ntRoot); - if bvtClass in ApprovedTypes then - begin - if SystemTypeInfo.TopSortedClasses.Count > 0 then + if bvtClass in ApprovedTypes then begin - // add the classes root node - Node2 := Items.AddChildObject(Node, 'Classes', nil); // do not localize - SetImageIndex(Node2, ntClasses); - // add the classes - for Index := 0 to SystemTypeInfo.TopSortedClasses.Count - 1 do + if SystemTypeInfo.TopSortedClasses.Count > 0 then begin - with SystemTypeInfo.TopSortedClasses[Index] do + Node2 := Items.AddChildObject(Node, 'Classes', nil); + SetImageIndex(Node2, ntClasses); + for Index := 0 to SystemTypeInfo.TopSortedClasses.Count - 1 do begin - Node := Items.AddChildObject(Node2, ExpressionName, Pointer(SystemTypeInfo.TopSortedClasses[Index])); - SetImageIndex(Node, ntClass); - SelectCurrentNode(CurrentStringValue, Node); + with SystemTypeInfo.TopSortedClasses[Index] do + begin + Node := Items.AddChildObject(Node2, ExpressionName, Pointer(SystemTypeInfo.TopSortedClasses[Index])); + SetImageIndex(Node, ntClass); + SelectCurrentNode(CurrentStringValue, Node); + end; end; + Node2.AlphaSort; end; - Node2.AlphaSort; end; - end; - - if bvtList in ApprovedTypes then - begin - // add the list root node - Node2 := Items.GetFirstNode; - ListRoot := Items.AddChildObject(Node2, 'Lists', nil); // do not localize - SetImageIndex(ListRoot, ntList); - // add the class list root node - Node2 := Items.AddChildObject(ListRoot, 'Class lists', nil); // do not localize - SetImageIndex(Node2, ntClassLists); - // add the class list nodes - for Index := 0 to SystemTypeInfo.TopSortedClasses.Count - 1 do + if bvtList in ApprovedTypes then begin - Node := Items.AddChildObject(Node2, SystemTypeInfo.ListTypeInfoByElement[SystemTypeInfo.TopSortedClasses[Index]].ExpressionName, Pointer(SystemTypeInfo.ListTypeInfoByElement[SystemTypeInfo.TopSortedClasses[Index]])); - SetImageIndex(Node, ntClassList); - SelectCurrentNode(CurrentStringValue, Node); - end; - Node2.AlphaSort; + Node2 := Items.GetFirstNode; + ListRoot := Items.AddChildObject(Node2, 'Lists', nil); + SetImageIndex(ListRoot, ntList); + Node2 := Items.AddChildObject(ListRoot, 'Class lists', nil); + SetImageIndex(Node2, ntClassLists); + for Index := 0 to SystemTypeInfo.TopSortedClasses.Count - 1 do + begin + Node := Items.AddChildObject(Node2, SystemTypeInfo.TopSortedClasses[Index].ListTypeInfo.ExpressionName, Pointer(SystemTypeInfo.TopSortedClasses[Index].ListTypeInfo)); + SetImageIndex(Node, ntClassList); + SelectCurrentNode(CurrentStringValue, Node); + end; + Node2.AlphaSort; + Node2 := Items.AddChildObject(ListRoot, 'Attribute lists', nil); + SetImageIndex(Node2, ntAttributeLists); + for Index := 0 to SystemTypeInfo.AttributeTypes.Count - 1 do + begin - // add the attribute list root node - Node2 := Items.AddChildObject(ListRoot, 'Attribute lists', nil); // do not localize - SetImageIndex(Node2, ntAttributeLists); + Node := Items.AddChildObject(Node2, SystemTypeInfo.AttributeTypes[Index].ListTypeInfo.ExpressionName, Pointer(SystemTypeInfo.AttributeTypes[Index].ListTypeInfo)); + SetImageIndex(Node, ntAttributeList); + SelectCurrentNode(CurrentStringValue, Node); + end; + Node2.AlphaSort; + end; - // add the attribute list nodes - for Index := 0 to SystemTypeInfo.AttributeTypes.Count - 1 do + if bvtAttr in ApprovedTypes then begin - Node := Items.AddChildObject(Node2, SystemTypeInfo.ListTypeInfoByElement[SystemTypeInfo.AttributeTypes[Index]].ExpressionName, Pointer(SystemTypeInfo.ListTypeInfoByElement[SystemTypeInfo.AttributeTypes[Index]])); - SetImageIndex(Node, ntAttributeList); - SelectCurrentNode(CurrentStringValue, Node); + Node := Items.GetFirstNode; + Node2 := Items.AddChildObject(Node, 'Attributes', nil); + SetImageIndex(Node2, ntAttributes); + for Index := 0 to SystemTypeInfo.AttributeTypes.Count - 1 do + begin + Node := Items.AddChildObject(Node2, SystemTypeInfo.AttributeTypes[Index].ExpressionName, Pointer(SystemTypeInfo.AttributeTypes[Index])); + SetImageIndex(Node, ntAttribute); + SelectCurrentNode(CurrentStringValue, Node); + end; + Node2.AlphaSort; end; - Node2.AlphaSort; - end; - if bvtAttr in ApprovedTypes then - begin - // add the attributes node - Node := Items.GetFirstNode; - Node2 := Items.AddChildObject(Node, 'Attributes', nil); // do not localize - SetImageIndex(Node2, ntAttributes); - for Index := 0 to SystemTypeInfo.AttributeTypes.Count - 1 do + if bvtSystem in ApprovedTypes then begin - // add the attribute nodes - Node := Items.AddChildObject(Node2, SystemTypeInfo.AttributeTypes[Index].ExpressionName, Pointer(SystemTypeInfo.AttributeTypes[Index])); - SetImageIndex(Node, ntAttribute); - SelectCurrentNode(CurrentStringValue, Node); + Node := Items.GetFirstNode; + Node2 := Items.AddChildObject(Node, SystemTypeInfo.ExpressionName , Pointer(SystemTypeInfo)); + SetImageIndex(Node2, ntSystem); + SelectCurrentNode(CurrentStringValue, Node2); end; - Node2.AlphaSort; - end; - - if bvtSystem in ApprovedTypes then - begin - Node := Items.GetFirstNode; - Node2 := Items.AddChildObject(Node, SystemTypeInfo.ExpressionName , Pointer(SystemTypeInfo)); - SetImageIndex(Node2, ntSystem); - SelectCurrentNode(CurrentStringValue, Node2); - end; - if bvtType in ApprovedTypes then - begin - Node := Items.GetFirstNode; - Node2 := Items.AddChildObject(Node, SystemTypeInfo.TypeTypeInfo.ExpressionName, Pointer(SystemTypeInfo.TypeTypeInfo)); - SetImageIndex(Node2, ntType); - SelectCurrentNode(CurrentStringValue, Node2); + if bvtType in ApprovedTypes then + begin + Node := Items.GetFirstNode; + Node2 := Items.AddChildObject(Node, SystemTypeInfo.TypeTypeInfo.ExpressionName, Pointer(SystemTypeInfo.TypeTypeInfo)); + SetImageIndex(Node2, ntType); + SelectCurrentNode(CurrentStringValue, Node2); + end; + Items.GetFirstNode.Expand(False); + finally + tvMetaTypes.Items.EndUpdate; end; - Items.GetFirstNode.Expand(False); end; end; diff --git a/Source/ObjectSpace/UtilsGUI/BoldTypeNameSelector.res b/Source/ObjectSpace/UtilsGUI/BoldTypeNameSelector.res new file mode 100644 index 00000000..391b0764 Binary files /dev/null and b/Source/ObjectSpace/UtilsGUI/BoldTypeNameSelector.res differ diff --git a/Source/PMapper/Core/BoldAbstractObjectUpgrader.pas b/Source/PMapper/Core/BoldAbstractObjectUpgrader.pas index 4be98daf..e0f5c443 100644 --- a/Source/PMapper/Core/BoldAbstractObjectUpgrader.pas +++ b/Source/PMapper/Core/BoldAbstractObjectUpgrader.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAbstractObjectUpgrader; interface @@ -17,7 +20,7 @@ TBoldObjectUpgraderConfigItemClass = class of TBoldObjectUpgraderConfiguration TBoldObjectUpgraderConfigClass = class of TBoldObjectUpgraderConfiguration; TBoldObjectUpgraderConfigurationItem = class(TBoldUniquelyNamedCollectionItemWithNameStorage) - private + private FUpgradeOlderThanVersion: integer; procedure SetExpressionName(const Value: String); procedure SetUpgradeOlderThanVersion(const Value: integer); @@ -64,7 +67,6 @@ implementation uses SysUtils, BoldNameExpander, - BoldPMConsts, BoldTaggedValueSupport; { TBoldObjectUpgraderConfigurationItem } @@ -88,10 +90,11 @@ function TBoldObjectUpgraderConfigurationItem.GetDisplayName: string; if ExpressionName <> '' then result := ExpressionName else - result := sDisplayNameUnassigned; - result := Format(sUpgradeIfOlderThan, [Result, UpgradeOlderThanVersion]); + result := ''; + result := 'Upgrade ' + result + ' if older than ' + intToStr(UpgradeOlderThanVersion); end; + procedure TBoldObjectUpgraderConfigurationItem.SetExpressionName(const Value: String); begin UniqueName := BoldExpandName(Value, '', xtExpression, -1, nccDefault); @@ -145,4 +148,6 @@ function TBoldAbstractObjectUpgrader.NeedsManualUpdate(ExpressionName: string; V result := assigned(anItem) and (anItem.UpgradeOlderThanVersion > Version); end; +initialization + end. diff --git a/Source/PMapper/Core/BoldPMConsts.pas b/Source/PMapper/Core/BoldPMConsts.pas index d7f3b832..fbf42e31 100644 --- a/Source/PMapper/Core/BoldPMConsts.pas +++ b/Source/PMapper/Core/BoldPMConsts.pas @@ -212,3 +212,4 @@ interface implementation end. + diff --git a/Source/PMapper/Core/BoldPMapper.pas b/Source/PMapper/Core/BoldPMapper.pas index e7cb4680..ec74302a 100644 --- a/Source/PMapper/Core/BoldPMapper.pas +++ b/Source/PMapper/Core/BoldPMapper.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPMapper; interface @@ -17,10 +20,12 @@ TBoldPersistenceMapper = class(TBoldSubscribableObject) implementation + {---TBoldPersistenceMapper---} procedure TBoldPersistenceMapper.CreatePersistentStorage; begin end; -end. +initialization +end. diff --git a/Source/PMapper/Core/BoldPMapperLists.pas b/Source/PMapper/Core/BoldPMapperLists.pas index 341cd77d..f06ef816 100644 --- a/Source/PMapper/Core/BoldPMapperLists.pas +++ b/Source/PMapper/Core/BoldPMapperLists.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPMapperLists; interface @@ -32,13 +35,15 @@ TBoldPersistenceMapperDescriptor = class {---TBoldMemberPersistenceMapperList---} TBoldMemberPersistenceMapperDescriptorList = class(TBoldIndexableList) private - function GetDescriptorBydelphiName(name: string): TBoldMemberPersistenceMapperDescriptor; - function GetDescriptors(index: Integer): TBoldMemberPersistenceMapperDescriptor; + class var IX_MemberPMapperName: integer; + class var IX_MemberPMapperClass: integer; + function GetDescriptorBydelphiName(name: string): TBoldMemberPersistenceMapperDescriptor; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetDescriptors(index: Integer): TBoldMemberPersistenceMapperDescriptor; {$IFDEF BOLD_INLINE}inline;{$ENDIF} public constructor Create; procedure AddDescriptor(MemberPersistenceMapperClass: TBoldMemberPersistenceMapperClass; const AbstractionLevel: TBoldAbstractionLevel); - procedure RemoveDescriptorByClass(aClass: TBoldMemberPersistenceMapperClass); + procedure RemoveDescriptorByClass(aClass: TBoldMemberPersistenceMapperClass); {$IFDEF BOLD_INLINE}inline;{$ENDIF} function DescriptorForModelNameWithDefaultSupport(ModelName, DefaultMapperName: String; TypeNameDictionary: TBoldTypeNameDictionary): TBoldMemberPersistenceMapperDescriptor; property DescriptorByDelphiName[name: string]: TBoldMemberPersistenceMapperDescriptor read GetDescriptorByDelphiName; property Descriptors[index: integer]: TBoldMemberPersistenceMapperDescriptor read GetDescriptors; @@ -48,23 +53,24 @@ TBoldMemberPersistenceMapperDescriptorList = class(TBoldIndexableList) TBoldMemberPersistenceMapperDescriptor = class(TBoldPersistenceMapperDescriptor) private fAbstractionLevel: TBoldAbstractionLevel; - function GetMemberPersistenceMapperClass: TBoldMemberPersistenceMapperClass; + function GetMemberPersistenceMapperClass: TBoldMemberPersistenceMapperClass; {$IFDEF BOLD_INLINE}inline;{$ENDIF} public constructor Create(MemberPersistenceMapperClass: TBoldMemberPersistenceMapperClass; const AbstractionLevel: TBoldAbstractionLevel); property MemberPersistenceMapperClass: TBoldMemberPersistenceMapperClass read GetMemberPersistenceMapperClass; property AbstractionLevel: TBoldAbstractionLevel read fAbstractionLevel; - function CanStore(ContentName: string):Boolean; + function CanStore(const ContentName: string):Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} end; {---TBoldSystemPersistenceMapperList---} TBoldSystemPersistenceMapperDescriptorList = class(TBoldIndexableList) private - function GetDescriptorByName(name: string): TBoldSystemPersistenceMapperDescriptor; - function GetDescriptors(index: Integer): TBoldSystemPersistenceMapperDescriptor; + class var IX_SystemPMapperName: integer; + function GetDescriptorByName(name: string): TBoldSystemPersistenceMapperDescriptor; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetDescriptors(index: Integer): TBoldSystemPersistenceMapperDescriptor; {$IFDEF BOLD_INLINE}inline;{$ENDIF} public constructor Create; - procedure RemoveDescriptorByName(const Name: string); + procedure RemoveDescriptorByName(const Name: string); {$IFDEF BOLD_INLINE}inline;{$ENDIF} property DescriptorByName[name: string]: TBoldSystemPersistenceMapperDescriptor read GetDescriptorByName; property Descriptors[index: integer]: TBoldSystemPersistenceMapperDescriptor read GetDescriptors; end; @@ -72,7 +78,7 @@ TBoldSystemPersistenceMapperDescriptorList = class(TBoldIndexableList) {---TBoldSystemPersistenceMapperDescriptor---} TBoldSystemPersistenceMapperDescriptor = class(TBoldPersistenceMapperDescriptor) private - function GetSystemPersistenceMapperClass: TBoldSystemPersistenceMapperClass; + function GetSystemPersistenceMapperClass: TBoldSystemPersistenceMapperClass; {$IFDEF BOLD_INLINE}inline;{$ENDIF} public constructor Create(const name: string; BoldSystemPersistenceMapperClass: TBoldSystemPersistenceMapperClass); property SystemPersistenceMapperClass: TBoldSystemPersistenceMapperClass read GetSystemPersistenceMapperClass; @@ -81,11 +87,12 @@ TBoldSystemPersistenceMapperDescriptor = class(TBoldPersistenceMapperDescripto {---TBoldObjectPersistenceMapperList---} TBoldObjectPersistenceMapperDescriptorList = class(TBoldIndexableList) private - function GetDescriptorByName(name: string): TBoldObjectPersistenceMapperDescriptor; - function GetDescriptors(index: Integer): TBoldObjectPersistenceMapperDescriptor; + class var IX_ObjectPMapperName: integer; + function GetDescriptorByName(name: string): TBoldObjectPersistenceMapperDescriptor; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetDescriptors(index: Integer): TBoldObjectPersistenceMapperDescriptor; {$IFDEF BOLD_INLINE}inline;{$ENDIF} public constructor Create; - procedure RemoveDescriptorByName(const Name: string); + procedure RemoveDescriptorByName(const Name: string); {$IFDEF BOLD_INLINE}inline;{$ENDIF} property DescriptorByName[name: string]: TBoldObjectPersistenceMapperDescriptor read GetDescriptorByName; property Descriptors[index: integer]: TBoldObjectPersistenceMapperDescriptor read GetDescriptors; end; @@ -93,13 +100,12 @@ TBoldObjectPersistenceMapperDescriptorList = class(TBoldIndexableList) {---TBoldObjectPersistenceMapperDescriptor---} TBoldObjectPersistenceMapperDescriptor = class(TBoldPersistenceMapperDescriptor) private - function GetObjectPersistenceMapperClass: TBoldObjectPersistenceMapperClass; + function GetObjectPersistenceMapperClass: TBoldObjectPersistenceMapperClass; {$IFDEF BOLD_INLINE}inline;{$ENDIF} public constructor Create(const name: string; BoldObjectPersistenceMapperClass: TBoldObjectPersistenceMapperClass); property ObjectPersistenceMapper: TBoldObjectPersistenceMapperClass read GetObjectPersistenceMapperClass; end; - // Access points to PersistenceMapperDescriptor-lists objects function BoldMemberPersistenceMappers: TBoldMemberPersistenceMapperDescriptorList; function BoldMemberPersistenceMappersAssigned: Boolean; function BoldSystemPersistenceMappers: TBoldSystemPersistenceMapperDescriptorList; @@ -119,11 +125,6 @@ implementation G_BoldSystemPersistenceMappers: TBoldSystemPersistenceMapperDescriptorList = nil; G_BoldObjectPersistenceMappers: TBoldObjectPersistenceMapperDescriptorList = nil; - IX_SystemPMapperName: integer = -1; - IX_ObjectPMapperName: integer = -1; - IX_MemberPMapperName: integer = -1; - IX_MemberPMapperClass: integer = -1; - type {---TBoldMemberPMapperNameIndex---} TBoldMemberPMapperNameIndex = class(TBoldStringHashIndex) @@ -231,7 +232,7 @@ constructor TBoldMemberPersistenceMapperDescriptorList.Create; function TBoldMemberPersistenceMapperDescriptorList.GetDescriptorByDelphiName(name: string): TBoldMemberPersistenceMapperDescriptor; begin - Result := TBoldMemberPersistenceMapperDescriptor(TBoldMemberPMapperNameIndex(Indexes[IX_MemberPMapperName]).FindByString(Name)) + Result := TBoldMemberPersistenceMapperDescriptor(TBoldStringHashIndex(Indexes[IX_MemberPMapperName]).FindByString(Name)) end; function TBoldMemberPersistenceMapperDescriptorList.GetDescriptors(index: integer): TBoldMemberPersistenceMapperDescriptor; @@ -266,7 +267,7 @@ function TBoldMemberPersistenceMapperDescriptor.GetMemberPersistenceMapperClass: Result := TBoldMemberPersistenceMapperClass(PersistenceMapperClass); end; -function TBoldMemberPersistenceMapperDescriptor.CanStore(ContentName: String): Boolean; +function TBoldMemberPersistenceMapperDescriptor.CanStore(const ContentName: String): Boolean; begin Result := MemberPersistenceMapperClass.CanStore(ContentName); end; @@ -281,7 +282,7 @@ constructor TBoldSystemPersistenceMapperDescriptorList.Create; function TBoldSystemPersistenceMapperDescriptorList.GetDescriptorByName(name: string): TBoldSystemPersistenceMapperDescriptor; begin - Result := TBoldSystemPersistenceMapperDescriptor(TBoldSystemPMapperNameIndex(Indexes[IX_SystemPMapperName]).FindByString(Name)) + Result := TBoldSystemPersistenceMapperDescriptor(TBoldStringHashIndex(Indexes[IX_SystemPMapperName]).FindByString(Name)) end; function TBoldSystemPersistenceMapperDescriptorList.GetDescriptors(index: Integer): TBoldSystemPersistenceMapperDescriptor; @@ -316,7 +317,7 @@ constructor TBoldObjectPersistenceMapperDescriptorList.Create; function TBoldObjectPersistenceMapperDescriptorList.GetDescriptorByName(name: string): TBoldObjectPersistenceMapperDescriptor; begin - Result := TBoldObjectPersistenceMapperDescriptor(TBoldObjectPMapperNameIndex(Indexes[IX_ObjectPMapperName]).FindByString(Name)) + Result := TBoldObjectPersistenceMapperDescriptor(TBoldStringHashIndex(Indexes[IX_ObjectPMapperName]).FindByString(Name)) end; function TBoldObjectPersistenceMapperDescriptorList.GetDescriptors(index: Integer): TBoldObjectPersistenceMapperDescriptor; @@ -366,6 +367,10 @@ function TBoldMemberPersistenceMapperDescriptorList.DescriptorForModelNameWithDe end; initialization + TBoldMemberPersistenceMapperDescriptorList.IX_MemberPMapperName := -1; + TBoldMemberPersistenceMapperDescriptorList.IX_MemberPMapperClass := -1; + TBoldSystemPersistenceMapperDescriptorList.IX_SystemPMapperName := -1; + TBoldObjectPersistenceMapperDescriptorList.IX_ObjectPMapperName := -1; finalization FreeAndNil(G_BoldMemberPersistenceMappers); diff --git a/Source/PMapper/Core/BoldPMappers.pas b/Source/PMapper/Core/BoldPMappers.pas index 1106419f..bc6cd3cf 100644 --- a/Source/PMapper/Core/BoldPMappers.pas +++ b/Source/PMapper/Core/BoldPMappers.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPMappers; interface @@ -21,7 +24,7 @@ interface BoldValueSpaceInterfaces; type - {forward declarations} + {forward declarations} TBoldSystemPersistenceMapper = class; TBoldObjectPersistenceMapper = class; TBoldMemberPersistenceMapper = class; @@ -34,6 +37,7 @@ TBoldMemberPersistenceMapperList = class; TBoldPreparePSParams = procedure(PSParams: TBoldPSParams) of object; + { TBoldSystemPersistenceMapper } TBoldSystemPersistenceMapper = class(TBoldPersistenceMapper) private @@ -54,58 +58,64 @@ TBoldSystemPersistenceMapper = class(TBoldPersistenceMapper) fObjectUpgrader: TBoldAbstractObjectUpgrader; function GetPSSystemDescription: TBoldPSSystemDescription; procedure fPMCreate(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); procedure fPMDelete(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; - Old_Values: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; + const Old_Values: IBoldValueSpace; TranslationList: TBoldIdTranslationList); procedure fPMUpdate(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; - Old_Values: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; + const Old_Values: IBoldValueSpace; TranslationLIst: TBoldIdTranslationList); function GetSupportsObjectUpgrading: Boolean; protected FCurrentTimeStamp: TBoldTimeStampType; + fTimeOfTimeStamp: TDateTime; procedure InitializePSDescriptions; virtual; procedure FillPSParams(PSParams: TBoldPSParams); virtual; abstract; function CreatePSParams: TBoldPSParams; virtual; abstract; function CreatePSSystemDescription: TBoldPSSystemDescription; virtual; abstract; procedure ReserveID; virtual; abstract; - function NextExternalObjectId(ValueSpace: IBoldValueSpace; + function NextExternalObjectId(const ValueSpace: IBoldValueSpace; ObjectID: TBoldObjectId): TBoldObjectId; - procedure StartTransaction(ValueSpace: IBoldValueSpace); virtual; abstract; - procedure Commit(ValueSpace: IBoldValueSpace); virtual; abstract; - procedure RollBack(ValueSpace: IBoldValueSpace); virtual; abstract; + procedure StartTransaction(const ValueSpace: IBoldValueSpace); virtual; abstract; + procedure Commit(const ValueSpace: IBoldValueSpace); virtual; abstract; + procedure RollBack(const ValueSpace: IBoldValueSpace); virtual; abstract; + + procedure StartSQLBatch; virtual; abstract; + procedure EndSQLBatch; virtual; abstract; + procedure FailSQLBatch; virtual; abstract; procedure GetNewTimeStamp; virtual; abstract; function EnsurePrecondition(Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList): Boolean; virtual; abstract; - procedure FetchDeletedObjects(ObjectIdList: TBoldObjectIdList; ValieSpace: IBoldValueSpace); virtual; abstract; + procedure FetchDeletedObjects(ObjectIdList: TBoldObjectIdList; const ValieSpace: IBoldValueSpace); virtual; abstract; procedure EnsurePSDescription; public - constructor CreateFromMold(MoldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary); + constructor CreateFromMold(MoldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; DefaultObjectMapperName: string); destructor Destroy; override; procedure PMFetch(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; TranslationList: TBoldIdTranslationList); virtual; procedure PMFetchClassWithCondition(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; BoldCondition: TBoldCondition; FetchMode: Integer; TranslationList: TBoldIdTranslationList); virtual; procedure PMUpdate(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; - Old_Values: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; + const Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; - var TimeStamp: TBoldTimeStampType); + var TimeStamp: TBoldTimeStampType; + var TimeOfLatestUpdate: TDateTime); function CommonSuperClassObjectMapper(ObjectIdList: TBoldObjectIdList): TBoldObjectPersistenceMapper; procedure CreatePersistentStorage; override; function GetCorrectTime: TDateTime; procedure SubscribeToPersistenceEvents(Subscriber: TBoldSubscriber); - procedure ReserveNewIds(ValueSpace: IBoldValueSpace; ObjectIdList: TBoldObjectIdList; + procedure ReserveNewIds(const ValueSpace: IBoldValueSpace; ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); property ObjectPersistenceMappers: TBoldObjectPersistenceMapperList @@ -115,6 +125,7 @@ TBoldSystemPersistenceMapper = class(TBoldPersistenceMapper) read fRootClassObjectPMapper; property OnPreparePSParams: TBoldPreparePSParams read fPreparePSParams write fPreparePSParams; property CurrentTimeStamp: TBoldTimeStampType read FCurrentTimeStamp; + property TimeOfTimeStamp: TDateTime read fTimeOfTimeStamp; procedure PMTranslateToGlobalIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); virtual; abstract; procedure PMTranslateToLocalIds(GlobalIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); virtual; abstract; procedure PMSetReadonlyness(ReadOnlyList, WriteableList: TBoldObjectIdList); virtual; abstract; @@ -151,47 +162,47 @@ TBoldObjectPersistenceMapper = class(TBoldPersistenceMapper) fMemberMapperIndexByMemberIndex: array of integer; function GetLinkClassRole1: TBoldMemberPersistenceMapper; function GetLinkClassRole2: TBoldMemberPersistenceMapper; - procedure FillInMembers(MyMoldClass, CurrentMoldClass: TMoldClass; TypeNameDictionary: TBoldTypeNameDictionary); function LeastCommonSuperClassMapper(ObjectMapper: TBoldObjectPersistenceMapper): TBoldObjectPersistenceMapper; function GetMemberMapperIndexByMemberIndex(const MemberIndex: Integer): integer; protected fObjectIdClass: String; + procedure FillInMembers(MyMoldClass, CurrentMoldClass: TMoldClass; TypeNameDictionary: TBoldTypeNameDictionary); virtual; procedure PMFetchWithCondition(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; BoldCondition: TBoldCondition; FetchMode: Integer; TranslationList: TBoldIdTranslationList); virtual; abstract; - function NextExternalObjectId(ValueSpace: IBoldValueSpace; + function NextExternalObjectId(const ValueSpace: IBoldValueSpace; ObjectID: TBoldObjectId): TBoldObjectId; virtual; abstract; procedure InitializePSDescriptions; virtual; public constructor CreateFromMold(MoldClass: TMoldClass; Owner: TBoldSystemPersistenceMapper; TypeNameDictionary: TBoldTypeNameDictionary); virtual; destructor Destroy; override; procedure MakeIDsExact(ObjectIDList: TBoldObjectIdList; - TranslationList: TBoldIdTranslationList); virtual; abstract; + TranslationList: TBoldIdTranslationList; HandleNonExisting: Boolean); virtual; abstract; procedure EnsureIDsExact(ObjectIDList: TBoldObjectIdList; - TranslationList: TBoldIdTranslationList); virtual; + TranslationList: TBoldIdTranslationList; HandleNonExisting: Boolean); virtual; procedure PMFetchExactIDList(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; TranslationList:TBoldIdTranslationList; MissingList: TBoldObjectIdList); virtual; abstract; procedure PMFetchApproximateIDList(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; TranslationList: TBoldIdTranslationList); virtual; procedure PMCreate(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; TranslationList:TBoldIdTranslationList); virtual; abstract; procedure PMDelete(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; - Old_Values: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; + const Old_Values: IBoldValueSpace; TranslationList: TBoldIdTranslationList); virtual; abstract; procedure PMUpdate(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; - Old_Values: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; + const Old_Values: IBoldValueSpace; TranslationLIst: TBoldIdTranslationList); virtual; abstract; function BoldIsA(ObjectPMapper: TBoldObjectPersistenceMapper): Boolean; function LeastCommonSuperMapper(ObjectPMapper: TBoldObjectPersistenceMapper): TBoldObjectPersistenceMapper; @@ -240,18 +251,18 @@ TBoldMemberPersistenceMapper = class(TBoldPersistenceMapper) property MemberIndex: Integer read fMemberIndex; property ContentName: string read fContentName; property ExpressionName: string read fExpressionName; - function GetValue(ObjectContents: IBoldObjectContents): IBoldValue; - function GetEnsuredValue(ObjectContents: IBoldObjectContents): IBoldValue; - function IsDirty(ObjectContents: IBoldObjectContents): Boolean; virtual; - function ShouldFetch(ObjectContents: IBoldObjectContents): Boolean; virtual; - procedure PMCreate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; + function GetValue(const ObjectContents: IBoldObjectContents): IBoldValue; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetEnsuredValue(const ObjectContents: IBoldObjectContents): IBoldValue; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function IsDirty(const ObjectContents: IBoldObjectContents): Boolean; virtual; + function ShouldFetch(const ObjectContents: IBoldObjectContents): Boolean; virtual; + procedure PMCreate(ObjectIdList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); virtual; - procedure PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; + procedure PMUpdate(ObjectIdList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); virtual; - procedure PMDelete(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; + procedure PMDelete(ObjectIdList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); virtual; procedure PMFetch(ObjectIdList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; FetchMode: Integer; TranslationList: TBoldIdTranslationList; FailureList: TBoldObjectIdList); virtual; property SupportsPolymorphicFetch: Boolean read GetSupportsPolymorphicFetch; @@ -260,7 +271,7 @@ TBoldMemberPersistenceMapper = class(TBoldPersistenceMapper) { TBoldObjectPersistenceMapperList } TBoldObjectPersistenceMapperList = class(TBoldIndexableList) private - function GetItem(index: Integer): TBoldObjectPersistenceMapper; + function GetItem(index: Integer): TBoldObjectPersistenceMapper; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public property Items[index: Integer]: TBoldObjectPersistenceMapper read GetItem; default; end; @@ -268,8 +279,9 @@ TBoldObjectPersistenceMapperList = class(TBoldIndexableList) { TBoldMemberPersistenceMapperList } TBoldMemberPersistenceMapperList = class(TBoldIndexableList) private - function GetItem(index: Integer): TBoldmemberPersistenceMapper; - function GetMemberMapperByExpressionName(ExpressionName: string): TBoldMemberPersistenceMapper; + class var IX_MemberMapper: integer; + function GetItem(index: Integer): TBoldmemberPersistenceMapper; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetMemberMapperByExpressionName(ExpressionName: string): TBoldMemberPersistenceMapper; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public constructor Create; property Items[index: Integer]: TBoldMemberPersistenceMapper read GetItem; default; @@ -279,7 +291,7 @@ TBoldMemberPersistenceMapperList = class(TBoldIndexableList) { TBoldMemberMapperIndex } TBoldMemberMapperIndex = class(TBoldStringHashIndex) protected - function ItemAsKeyString(Item: TObject): string; override; + function ItemASKeyString(Item: TObject): string; override; end; procedure BoldPMLog(const s: string); @@ -296,28 +308,33 @@ implementation BoldPMConsts, BoldGuard, BoldDefaultStreamNames, - BoldPMapperLists; - -var - IX_MemberMapper: integer = -1; + BoldPMapperLists, + BoldIsoDateTime; procedure BoldPMLog(const s: string); begin if assigned(BoldPMLogHandler) then - BoldPMLogHandler.Log(formatDateTime('c: ', now) + trim(s)); // do not localize + BoldPMLogHandler.Log(AsISODateTimeMS(now)+':'+trim(s)); end; procedure BoldPMLogFmt(const s: string; const Args: array of const); begin if assigned(BoldPMLogHandler) then - BoldPMLogHandler.LogFmt(formatDateTime('c: ', now) + trim(s), Args); // do not localize + BoldPMLogHandler.LogFmt(AsISODateTimeMS(now)+':'+trim(s), Args); +end; + +{ TBoldObjectPersistenceMapperList } +function TBoldObjectPersistenceMapperList.GetItem(index: Integer): TBoldObjectPersistenceMapper; +begin + Result := TBoldObjectPersistenceMapper(inherited Items[index]); end; { TBoldSystemPersistenceMapper } -constructor TBoldSystemPersistenceMapper.CreateFromMold(MoldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary); +constructor TBoldSystemPersistenceMapper.CreateFromMold(MoldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; DefaultObjectMapperName: string); var i: integer; ObjectPmapper: TBoldObjectPersistenceMapper; + ObjectMapperName: string; ObjectMapperDescriptor: TBoldObjectPersistenceMapperDescriptor; MoldClass: TMoldClass; begin @@ -333,14 +350,18 @@ constructor TBoldSystemPersistenceMapper.CreateFromMold(MoldModel: TMoldModel; T fUseClockLog := MoldModel.UseClockLog; fUpdateWholeObjects := MoldModel.UpdateWholeObjects; fObjectPersistenceMappers := TBoldObjectPersistenceMapperList.Create; + ObjectPersistenceMappers.Capacity := MoldModel.Classes.Count; for i := 0 to MoldModel.Classes.Count - 1 do begin if MoldModel.Classes[i].EffectivePersistent and (MoldModel.Classes[i].Storage in [bsInternal, bsPartiallyExternal]) then begin MoldClass := MoldModel.Classes[i]; - ObjectMapperDescriptor := BoldObjectPersistenceMappers.DescriptorByName[MoldClass.PMapperName]; + ObjectMapperName := MoldClass.PMapperName; + if BoldNamesEqual(ObjectMapperName, DEFAULTNAMELITERAL) and (DefaultObjectMapperName <> '') then + ObjectMapperName := DefaultObjectMapperName; + ObjectMapperDescriptor := BoldObjectPersistenceMappers.DescriptorByName[ObjectMapperName]; if not assigned(ObjectMapperDEscriptor) then - raise EBold.CreateFmt(sUnableToFindPMapperForClass, [MoldClass.PMapperName, MoldClass.Name]); + raise EBold.CreateFmt('Unable to find PersistenceMapper (%s) for class %s', [ObjectMapperName, MoldClass.Name]); ObjectPMapper := ObjectMapperDescriptor.ObjectPersistenceMapper.CreatefromMold(MoldClass, Self, TypeNameDictionary); end else @@ -358,7 +379,7 @@ destructor TBoldSystemPersistenceMapper.Destroy; end; procedure TBoldSystemPersistenceMapper.PMFetch(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; TranslationList: TBoldIdTranslationList); @@ -367,7 +388,7 @@ procedure TBoldSystemPersistenceMapper.PMFetch(ObjectIDList: TBoldObjectIdList; end; procedure TBoldSystemPersistenceMapper.PMFetchClassWithCondition(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; BoldCondition: TBoldCondition; FetchMode: Integer; TranslationList: TBoldIdTranslationList); @@ -376,16 +397,16 @@ procedure TBoldSystemPersistenceMapper.PMFetchClassWithCondition(ObjectIDList: T with ObjectPersistenceMappers[(BoldCondition as TBoldConditionWithClass).TopSortedIndex] do PMFetchWithCondition(ObjectIdList, ValueSpace, BoldCondition, FetchMode, TranslationList) else - raise EBold.CreateFmt(sConditionMustBeConditionWithClass , [ClassName, BoldCondition.Classname]); + raise EBold.CreateFmt('%s.PMFetchClassWithCondition: Condition must be a ConditionWithClass, not a %s', [ClassName, BoldCondition.Classname]); end; -function tBoldSystemPersistenceMapper.NextExternalObjectId(ValueSpace: IBoldValueSpace; ObjectID: TBoldObjectId): TBoldObjectId; +function tBoldSystemPersistenceMapper.NextExternalObjectId(const ValueSpace: IBoldValueSpace; ObjectID: TBoldObjectId): TBoldObjectId; begin result := ObjectPersistenceMappers[ObjectId.TopSortedIndex].NextExternalObjectID(ValueSpace, ObjectId); end; procedure TBoldSystemPersistenceMapper.fPMCreate(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; TranslationList:TBoldIdTranslationList); var TempList, @@ -394,32 +415,27 @@ procedure TBoldSystemPersistenceMapper.fPMCreate(ObjectIDList: TBoldObjectIdList i: integer; g: IBoldGuard; begin - g := TBoldGuard.Create(TempList); + g := TBoldGuard.Create(TempList, ActionList); tempList := Objectidlist.Clone; + ActionList := TBoldObjectIdList.Create; while TempList.Count > 0 do begin - ActionList := TBoldObjectIdList.Create; - try - CurrentPMapper := ObjectPersistenceMappers[TempList[0].TopSortedIndex]; - i := 0; - while i < TempList.Count do - if ObjectPersistenceMappers[TempList[i].TopSortedIndex] = CurrentPMapper then - begin - ActionList.Add(TempList[i]); - TempList.RemoveByIndex(i); - end - else - Inc(i); - CurrentPMapper.PMCreate(ActionList, ValueSpace, translationlist); - finally - ActionList.Free; - end; + i := TempList.Count -1; + CurrentPMapper := ObjectPersistenceMappers[TempList[i].TopSortedIndex]; + ActionList.Clear; + for i := i downto 0 do + if ObjectPersistenceMappers[TempList[i].TopSortedIndex] = CurrentPMapper then + begin + ActionList.Add(TempList[i]); + TempList.RemoveByIndex(i); + end; + CurrentPMapper.PMCreate(ActionList, ValueSpace, translationlist); end; end; procedure TBoldSystemPersistenceMapper.fPMDelete(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; - Old_Values: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; + const Old_Values: IBoldValueSpace; TranslationList: TBoldIdTranslationList); var TempList, @@ -428,32 +444,27 @@ procedure TBoldSystemPersistenceMapper.fPMDelete(ObjectIDList: TBoldObjectIdList i: integer; g: IBoldGuard; begin - g := TBoldGuard.Create(TempList); + g := TBoldGuard.Create(TempList, ActionList); tempList := ObjectidList.Clone; + ActionList := TBoldObjectIdList.Create; while TempList.Count > 0 do begin - ActionList := TBoldObjectIdList.Create; - try - CurrentPMapper := ObjectPersistenceMappers[TempList[0].topSortedIndex]; - i := 0; - while i < TempList.Count do - if ObjectPersistenceMappers[TempList[i].topSortedIndex] = CurrentPMapper then - begin - ActionList.Add(TempList[i]); - TempList.RemoveByIndex(i); - end - else - Inc(i); - CurrentPMapper.PMDelete(ActionList, ValueSpace, Old_Values, TranslationList); - finally - ActionList.Free; - end; + i := TempList.Count -1; + CurrentPMapper := ObjectPersistenceMappers[TempList[i].topSortedIndex]; + ActionList.clear; + for i := i downto 0 do + if ObjectPersistenceMappers[TempList[i].topSortedIndex] = CurrentPMapper then + begin + ActionList.Add(TempList[i]); + TempList.RemoveByIndex(i); + end; + CurrentPMapper.PMDelete(ActionList, ValueSpace, Old_Values, TranslationList); end; end; procedure TBoldSystemPersistenceMapper.fPMUpdate(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; - Old_Values: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; + const Old_Values: IBoldValueSpace; TranslationLIst: TBoldIdTranslationList); var TempList, @@ -462,26 +473,21 @@ procedure TBoldSystemPersistenceMapper.fPMUpdate(ObjectIDList: TBoldObjectIdList i: integer; g: IBoldGuard; begin - g := TBoldGuard.Create(TempList); + g := TBoldGuard.Create(TempList, ActionList); tempList := ObjectidList.Clone; + ActionList := TBoldObjectIdList.Create; while TempList.Count > 0 do begin - ActionList := TBoldObjectIdList.Create; - try - CurrentPMapper := ObjectPersistenceMappers[TempList[0].topSortedIndex]; - i := 0; - while i < TempList.Count do - if ObjectPersistenceMappers[TempList[i].topSortedIndex] = CurrentPMapper then - begin - ActionList.Add(TempList[i]); - TempList.RemoveByIndex(i); - end - else - Inc(i); - CurrentPMapper.PMUpdate(ActionList, ValueSpace, Old_Values, TranslationList); - finally - ActionList.Free; - end; + i := TempList.Count -1; + CurrentPMapper := ObjectPersistenceMappers[TempList[i].topSortedIndex]; + ActionList.Clear; + for i := i downto 0 do + if ObjectPersistenceMappers[TempList[i].topSortedIndex] = CurrentPMapper then + begin + ActionList.Add(TempList[i]); + TempList.RemoveByIndex(i); + end; + CurrentPMapper.PMUpdate(ActionList, ValueSpace, Old_Values, TranslationList); end; end; @@ -506,101 +512,94 @@ procedure TBoldSystemPersistenceMapper.CreatePersistentStorage; end; procedure TBoldSystemPersistenceMapper.PMUpdate(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; - Old_Values: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; + const Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; - var TimeStamp: TBoldTimeStampType); + var TimeStamp: TBoldTimeStampType; + var TimeOfLatestUpdate: TDateTime); var i: Integer; ModifiedObjectIDList, NewObjectIDList, DeletedObjectIDList: TBoldObjectIdList; ObjectContents: IBoldObjectContents; + Guard: IBoldGuard; begin if ObjectIDList.Count = 0 then Exit; + Guard := TBoldGuard.Create(ModifiedObjectIDList, NewObjectIDList, DeletedObjectIDList); + DeletedObjectIDList := TBoldObjectIdList.Create; + NewObjectIDList := TBoldObjectIdList.Create; + ModifiedObjectIDList := TBoldObjectIdList.Create; + + // downto order is important here - Daniel + for i := ObjectIDList.Count - 1 downto 0 do + begin + ObjectContents := ValueSpace.ObjectContentsByObjectId[ObjectIdList[i]]; + if ObjectContents.BoldPersistenceState = bvpsModified then + begin + if ObjectContents.BoldExistenceState = besDeleted then + DeletedObjectIDList.Add(ObjectIDList[i]) + else + NewObjectIDList.Add(ObjectIDList[i]); + end else + ModifiedObjectIDList.Add(ObjectIDList[i]); + end; ReserveNewIds(ValueSpace, ObjectIdList, TranslationList); + if UseTimestamp then + GetNewTimeStamp; StartTransaction(ValueSpace); try - if UseTimestamp then - GetNewTimeStamp; - except - RollBack(ValueSpace); - raise; - end; - Commit(valueSpace); + if assigned(Precondition) then + begin + if not EnsurePrecondition(Precondition, translationList) then + begin + Commit(valueSpace); + exit; + end; + end; - StartTransaction(ValueSpace); + StartSQLBatch; + if DeletedObjectIDList.Count > 0 then + fPMDelete(DeletedObjectIDList, ValueSpace, Old_Values, TranslationList); - try - if assigned(Precondition) and not EnsurePrecondition(Precondition, translationList) then - begin - RollBack(ValueSpace); - end - else + if NewObjectIDList.Count > 0 then + fPMCreate(NewObjectIDList, ValueSpace, translationList); + + if ModifiedObjectIDList.Count > 0 then + fPMUpdate(ModifiedObjectIDList, ValueSpace, Old_Values, TranslationList); + + if UseTimestamp then begin - DeletedObjectIDList := TBoldObjectIdList.Create; - NewObjectIDList := TBoldObjectIdList.Create; - ModifiedObjectIDList := TBoldObjectIdList.Create; - try - for i := ObjectIDList.Count - 1 downto 0 do - begin - ObjectContents := ValueSpace.ObjectContentsByObjectId[ObjectIdList[i]]; - if ObjectContents.BoldPersistenceState = bvpsModified then - begin - if ObjectContents.BoldExistenceState = besDeleted then - DeletedObjectIDList.Add(ObjectIDList[i]) - else - NewObjectIDList.Add(ObjectIDList[i]); - end else - ModifiedObjectIDList.Add(ObjectIDList[i]); - end; - - // the order below is important, delete must come before create - // due to a solution made for linkobjects in PMCreate to avoid duplicates - - if DeletedObjectIDList.Count > 0 then - fPMDelete(DeletedObjectIDList, ValueSpace, Old_Values, TranslationList); - - if NewObjectIDList.Count > 0 then - fPMCreate(NewObjectIDList, ValueSpace, translationList); - - if ModifiedObjectIDList.Count > 0 then - fPMUpdate(ModifiedObjectIDList, ValueSpace, Old_Values, TranslationList); - finally - ModifiedObjectIDList.Free; - NewObjectIDList.Free; - DeletedObjectIDList.Free; - end; - if UseTimestamp then - TimeStamp := CurrentTimeStamp; - Commit(valueSpace); - end; + TimeStamp := CurrentTimeStamp; + TimeOfLatestUpdate := fTimeOfTimeStamp; + end; + EndSQLBatch; + Commit(valueSpace); except RollBack(ValueSpace); + FailSQLBatch; raise; end; end; -procedure TBoldSystemPersistenceMapper.ReserveNewIds(ValueSpace: IBoldValueSpace; +procedure TBoldSystemPersistenceMapper.ReserveNewIds(const ValueSpace: IBoldValueSpace; ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); var i: integer; newId: TBoldObjectID; begin - if ObjectIdList.Count = 0 then //FIXME: Rather unnecessary optimization I'd think? --jeho + if ObjectIdList.Count = 0 then Exit; with ObjectIdList do begin - // Reserve IDs for new objects for i := 0 to Count - 1 do if not ObjectIdList[i].IsStorable then ReserveId; - // Generate IDs for objects for i := 0 to Count - 1 do if not ObjectIDList[i].IsStorable then begin @@ -626,20 +625,18 @@ constructor TBoldObjectPersistenceMapper.CreateFromMold(MoldClass: TMoldClass; O fLinkRoleMapperIndex1 := -1; fLinkRoleMapperIndex2 := -1; if MoldClass.Versioned then - begin fVersioned := true; - end; if MoldClass.Versioned and assigned(MoldClass.SuperClass) and not MoldClass.SuperClass.Versioned then - raise EBold.CreateFmt(sSuperClassNotVersioned, [MoldClass.ExpandedExpressionName, MoldClass.SuperClass.ExpandedExpressionname]); + raise EBold.CreateFmt('Class %s is versioned, but not it''s superclass %s', [MoldClass.ExpandedExpressionName, MoldClass.SuperClass.ExpandedExpressionname]); if Assigned(MoldClass.SuperClass) then begin fSuperClass := SystemPersistenceMapper.ObjectPersistencemappers[MoldClass.SuperClass.TopSortedIndex]; if not Assigned(fSuperClass) then - raise EBold.CreateFmt(sSuperClassNotPersistent, [MoldClass.ExpandedExpressionName, MoldClass.SuperClass.ExpandedExpressionname]); + raise EBold.CreateFmt('Class %s has a nonpersistent superclass %s', [MoldClass.ExpandedExpressionName, MoldClass.SuperClass.ExpandedExpressionname]); SuperClass.fHasSubClasses := true; end; @@ -655,18 +652,18 @@ procedure TBoldObjectPersistenceMapper.CreatePersistentStorage; MemberPersistenceMappers[i].CreatePersistentStorage; end; -procedure TBoldObjectPersistenceMapper.PMFetchApproximateIDList(ObjectIDList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; TranslationList: TBoldIdTranslationList); +procedure TBoldObjectPersistenceMapper.PMFetchApproximateIDList(ObjectIDList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; TranslationList: TBoldIdTranslationList); var ActionList, - TempList, MissingList: TBoldObjectIdList; + TempList, NewTempList: array of TBoldObjectId; + NewTempCount: integer; MemberMapper: TBoldMemberPersistenceMapper; MemberMapperIndex: integer; TempMapper, CurrentPMapper: TBoldObjectPersistenceMapper; i: integer; - function ObjectMapperForNewID(OldID: TBoldObjectId): TBoldObjectPersistenceMapper; - // Only objects with inexact ClassIds can have changed their ClassID + function ObjectMapperForNewID(const OldID: TBoldObjectId; const TranslationList: TBoldIdTranslationList): TBoldObjectPersistenceMapper; var NewId: TBoldObjectId; begin @@ -674,84 +671,103 @@ procedure TBoldObjectPersistenceMapper.PMFetchApproximateIDList(ObjectIDList: TB NewId := OldID else NewId := TranslationList.TranslateToNewId[OldID]; - result := SystemPersistenceMapper.ObjectPersistenceMappers[NewID.topSortedIndex]; + Result := SystemPersistenceMapper.ObjectPersistenceMappers[NewID.topSortedIndex]; + end; + + procedure EnsureActionList; + begin + if not Assigned(ActionList) then + ActionList := TBoldObjectIdList.Create; end; begin - EnsureIDsExact(ObjectIDList, translationList); - tempList := ObjectidLIst.Clone; + EnsureIDsExact(ObjectIDList, translationList, false); + SetLength(TempList, ObjectIdList.Count); + SetLength(NewTempList, ObjectIdList.Count); + for i := 0 to ObjectidList.Count - 1 do + TempList[i] := ObjectIdList[i]; MissingList := TBoldObjectIdList.Create; + NewTempCount := 0; + ActionList := nil; try - while TempList.Count > 0 do + while Length(TempList) > 0 do begin - ActionList := TBoldObjectIdList.Create; + EnsureActionList; try - CurrentPMapper := ObjectMapperForNewID(TempList[0]); - if (TempList.Count > 1) and Assigned(MemberIdList) and (MemberIdList.Count = 1) then + CurrentPMapper := ObjectMapperForNewID(TempList[0], TranslationList); + if (Length(TempList) > 1) and Assigned(MemberIdList) and (MemberIdList.Count = 1) then begin - // Find the most Common ObjectMapper - for i := 1 to TempList.Count - 1 do + for i := 1 to Length(TempList) - 1 do begin - TempMapper := ObjectMapperForNewID(TempList[i]); + TempMapper := ObjectMapperForNewID(TempList[i], TranslationList); CurrentPMapper := CurrentPMapper.LeastCommonSuperMapper(TempMapper); end; - // mnake sure it has the member requested MemberMapperIndex := CurrentPMapper.MemberMapperIndexByMemberIndex[MemberIdList[0].MemberIndex]; if MemberMapperIndex <> -1 then begin MemberMapper := CurrentPMapper.MemberPersistenceMappers[MemberMapperIndex]; if MemberMapper.SupportsPolymorphicFetch then begin - ActionList.AddList(TempList); - TempList.Clear; + for i := 0 to Length(TempList) - 1 do + ActionList.Add(TempList[i]); + SetLength(TempList, 0); end; end; - // check if it was OK to fetch polymorphic, otherwise restore old PMapper. if ActionList.Count = 0 then - CurrentPMapper := ObjectMapperForNewID(TempList[0]); + CurrentPMapper := ObjectMapperForNewID(TempList[0], TranslationList); end; - i := 0; - while i < TempList.Count do - if ObjectMapperForNewID(TempList[i]) = CurrentPMapper then + for i := 0 to Length(TempList) - 1 do + if ObjectMapperForNewID(TempList[i], TranslationList) = CurrentPMapper then begin ActionList.Add(TempList[i]); - TempList.RemoveByIndex(i); end else - Inc(i); + begin + NewTempList[NewTempCount] := TempList[i]; + INC(NewTempCount); + end; CurrentPMapper.PMFetchExactIDList(ActionList, ValueSpace, MemberIdList, FetchMode, TranslationList, MissingList); finally - ActionList.Free; + ActionList.Clear; end; + SetLength(NewTempList, NewTempCount); + TempList:= NewTempList; + NewTempList := nil; + SetLength(NewTempList, NewTempCount); + NewTempCount := 0; end; if FetchMode = fmDistributable then if MissingList.Count > 0 then SystemPersistenceMapper.FetchDeletedObjects(MissingList, ValueSpace); finally - TempList.Free; + ActionList.free; MissingList.Free; end; end; -procedure TBoldObjectPersistenceMapper.EnsureIDsExact(ObjectIDList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); +procedure TBoldObjectPersistenceMapper.EnsureIDsExact(ObjectIDList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; HandleNonExisting: Boolean); var InexactIDList: TBoldObjectIdList; - ObjectID: TBoldObjectId; i: integer; g: IBoldGuard; begin g := TBoldGuard.Create(InexactIDList); - InexactIDList := TBoldObjectIdList.Create; - + InexactIDList := nil; for i := 0 to ObjectIDList.Count - 1 do begin - ObjectID := ObjectIDList[i]; - if not ObjectId.TopSortedIndexExact then - InexactIDList.Add(ObjectID); + if not ObjectIDList[i].TopSortedIndexExact then + begin + if not Assigned(InexactIDList) then + begin + InexactIDList := TBoldObjectIdList.Create; + InexactIDList.Capacity := ObjectIDList.Count-i; + end; + InexactIDList.Add(ObjectIDList[i]); + end; end; - if InExactIDList.Count > 0 then - MakeIDsExact(InexactIDList, TranslationList); + if Assigned(InexactIDList) and (InExactIDList.Count > 0) then + MakeIDsExact(InexactIDList, TranslationList, HandleNonExisting); end; procedure TBoldObjectPersistenceMapper.FillInMembers(MyMoldClass, CurrentMoldClass: TMoldClass; TypeNameDictionary: TBoldTypeNameDictionary); @@ -791,10 +807,10 @@ procedure TBoldObjectPersistenceMapper.FillInMembers(MyMoldClass, CurrentMoldCla MapperName := Mapping.ExpandedMapperName; end; - raise EBold.CreateFmt( sUnableToFindPMapperForX+ BOLDCRLF + - sUnableReason1 + BOLDCRLF + - sUnableReason2 + BOLDCRLF + - sUnableReason3, [ + raise EBold.CreateFmt('Unable to find persistence mapper for %s.%s (type: %s, mapper: %s). possible reasons: '+BOLDCRLF + + '* Typo'+BOLDCRLF+ + '* The mapper is not correctly installed in the initialization clause'+BOLDCRLF+ + '* The unit with the mapper is not included in the project', [ MoldAttribute.MoldClass.ExpandedExpressionName, MoldAttribute.ExpandedExpressionName, MoldAttribute.BoldType, @@ -816,34 +832,34 @@ procedure TBoldObjectPersistenceMapper.FillInMembers(MyMoldClass, CurrentMoldCla IsIndirect := assigned(MoldRole.Association.LinkClass); if MoldRole.Multi then if IsIndirect then - MemberDescriptor := BoldMemberPersistenceMappers.DescriptorByDelphiName['TBoldIndirectMultiLinkDefaultMapper'] // do not localize + MemberDescriptor := BoldMemberPersistenceMappers.DescriptorByDelphiName['TBoldIndirectMultiLinkDefaultMapper'] else - MemberDescriptor := BoldMemberPersistenceMappers.DescriptorByDelphiName['TBoldDirectMultiLinkDefaultMapper'] // do not localize + MemberDescriptor := BoldMemberPersistenceMappers.DescriptorByDelphiName['TBoldDirectMultiLinkDefaultMapper'] else if MoldRole.EffectiveEmbedded then - MemberDescriptor := BoldMemberPersistenceMappers.DescriptorByDelphiName['TBoldEmbeddedSingleLinkDefaultMapper'] // do not localize + MemberDescriptor := BoldMemberPersistenceMappers.DescriptorByDelphiName['TBoldEmbeddedSingleLinkDefaultMapper'] else if IsIndirect then - MemberDescriptor := BoldMemberPersistenceMappers.DescriptorByDelphiName['TBoldIndirectSingleLinkDefaultMapper'] // do not localize + MemberDescriptor := BoldMemberPersistenceMappers.DescriptorByDelphiName['TBoldIndirectSingleLinkDefaultMapper'] else - MemberDescriptor := BoldMemberPersistenceMappers.DescriptorByDelphiName['TBoldDirectSingleLinkDefaultMapper']; // do not localize + MemberDescriptor := BoldMemberPersistenceMappers.DescriptorByDelphiName['TBoldDirectSingleLinkDefaultMapper']; end else begin MemberDescriptor := BoldMemberPersistenceMappers.DescriptorByDelphiName[MoldRole.PMapperName]; if not assigned(MemberDescriptor) then - raise EBold.CreateFmt(sUnableToFindPMapperForXY, [MoldRole.MoldClass.ExpandedExpressionName, MoldRole.ExpandedExpressionName, MoldRole.PMappername]); + raise EBold.CreateFmt('Unable to find PersistenceMapper for %s.%s (mapper: %s)', [MoldRole.MoldClass.ExpandedExpressionName, MoldRole.ExpandedExpressionName, MoldRole.PMappername]); end; end; rtLinkRole: if MoldRole.MainRole.EffectivePersistent then begin if MoldRole.MainRole.Multi then - MemberDescriptor := BoldMemberPersistenceMappers.DescriptorByDelphiName['TBoldDirectMultiLinkDefaultMapper'] // do not localize + MemberDescriptor := BoldMemberPersistenceMappers.DescriptorByDelphiName['TBoldDirectMultiLinkDefaultMapper'] else - MemberDescriptor := BoldMemberPersistenceMappers.DescriptorByDelphiName['TBoldDirectSingleLinkDefaultMapper'] // do not localize + MemberDescriptor := BoldMemberPersistenceMappers.DescriptorByDelphiName['TBoldDirectSingleLinkDefaultMapper'] end; rtInnerLinkRole: begin if MoldRole.EffectivePersistent and CurrentMoldClass.EffectivePersistent then - MemberDescriptor := BoldMemberPersistenceMappers.DescriptorByDelphiName['TBoldEmbeddedSingleLinkDefaultMapper']; // do not localize + MemberDescriptor := BoldMemberPersistenceMappers.DescriptorByDelphiName['TBoldEmbeddedSingleLinkDefaultMapper']; if fLinkRoleMapperIndex1 = -1 then fLinkRoleMapperIndex1 := MemberPersistenceMappers.Count else @@ -877,6 +893,11 @@ function TBoldObjectPersistenceMapper.BoldIsA(ObjectPMapper: TBoldObjectPersiste result := fSuperClass.BoldIsA(ObjectPMapper); end; +function TBoldMemberPersistenceMapperList.GetMemberMapperByExpressionName(ExpressionName: string): TBoldMemberPersistenceMapper; +begin + result := (Indexes[IX_MemberMapper] as TBoldMemberMapperIndex).FindByString(ExpressionName) as TBoldMemberPersistenceMapper; +end; + { TBoldMemberPersistenceMapper } class function TBoldMemberPersistenceMapper.CanStore(const ContentName: string): Boolean; begin @@ -895,7 +916,7 @@ constructor TBoldMemberPersistenceMapper.CreateFromMold(Moldmember: TMoldmember; fExpressionName := MoldMember.ExpandedExpressionName; if assigned(Owner.MemberPersistenceMappers.MemberMapperByExpressionName[fExpressionName]) then - raise EBold.CreateFmt(sDuplicatePMappersForXInY, [fExpressionName, Owner.ExpressionName]); + raise EBold.CreateFmt('Duplicate memberMappers called "%s" in class %s', [fExpressionName, Owner.ExpressionName]); if MoldMember is TMoldAttribute then begin @@ -927,33 +948,28 @@ constructor TBoldMemberPersistenceMapper.CreateFromMold(Moldmember: TMoldmember; end; end; -procedure TBoldMemberPersistenceMapper.PMCreate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); +procedure TBoldMemberPersistenceMapper.PMCreate(ObjectIdList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); begin - raise EBold.CreateFmt(sCallToAbstractMethodOnCustomMapper, ['TBoldMemberPersistenceMapper', 'PMCreate', classname, 'PMCreate']); // do not localize + raise EBold.CreateFmt(sCallToAbstractMethodOnCustomMapper, ['TBoldMemberPersistenceMapper', 'PMCreate', classname, 'PMCreate']); end; -procedure TBoldMemberPersistenceMapper.PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace;TranslationList: TBoldIdTranslationList); +procedure TBoldMemberPersistenceMapper.PMUpdate(ObjectIdList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace;TranslationList: TBoldIdTranslationList); begin - raise EBold.CreateFmt(sCallToAbstractMethodOnCustomMapper, ['TBoldMemberPersistenceMapper', 'PMUpDate', classname, 'PMUpDate']); // do not localize + raise EBold.CreateFmt(sCallToAbstractMethodOnCustomMapper, ['TBoldMemberPersistenceMapper', 'PMUpDate', classname, 'PMUpDate']); end; -procedure TBoldMemberPersistenceMapper.PMDelete(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); +procedure TBoldMemberPersistenceMapper.PMDelete(ObjectIdList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); begin - raise EBold.CreateFmt(sCallToAbstractMethodOnCustomMapper, ['TBoldMemberPersistenceMapper', 'PMDelete', classname, 'PMDelete']); // do not localize + raise EBold.CreateFmt(sCallToAbstractMethodOnCustomMapper, ['TBoldMemberPersistenceMapper', 'PMDelete', classname, 'PMDelete']); end; -procedure TBoldMemberPersistenceMapper.PMFetch(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; FetchMode: Integer; TranslationList: TBoldIdTranslationList; FailureList: TBoldObjectIdList); +procedure TBoldMemberPersistenceMapper.PMFetch(ObjectIdList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; FetchMode: Integer; TranslationList: TBoldIdTranslationList; FailureList: TBoldObjectIdList); begin - raise EBold.CreateFmt(sCallToAbstractMethodOnCustomMapper, ['TBoldMemberPersistenceMapper', 'PMFetch', classname, 'PMFetch']); // do not localize -end; - -{ TBoldObjectPersistenceMapperList } -function TBoldObjectPersistenceMapperList.GetItem(index: Integer): TBoldObjectPersistenceMapper; -begin - Result := TBoldObjectPersistenceMapper(inherited Items[index]); + raise EBold.CreateFmt(sCallToAbstractMethodOnCustomMapper, ['TBoldMemberPersistenceMapper', 'PMFetch', classname, 'PMFetch']); end; { TBoldMemberPersistenceMapperList } + constructor TBoldMemberPersistenceMapperList.Create; begin inherited; @@ -994,16 +1010,25 @@ procedure TBoldObjectPersistenceMapper.BuildMemberFetchLists( end; var - i: integer; + i, MapperIndex: integer; begin assert(not assigned(DefaultFetchMemberList) or not DefaultFetchMemberList.OwnsEntries, 'Cannot put member mappers in a member mapper list that owns its entries.'); assert(not assigned(CustomFetchMemberList) or not CustomFetchMemberList.OwnsEntries, 'Cannot put member mappers in a member mapper list that owns its entries.'); if assigned(MemberIdList) then for i := 0 to MemberIdList.Count - 1 do - TestAdd(MemberPersistenceMappers[MemberMapperIndexByMemberIndex[MemberIdList[i].MemberIndex]]) + begin + MapperIndex := MemberMapperIndexByMemberIndex[MemberIdList[i].MemberIndex]; + if MapperIndex = -1 then + raise EBold.CreateFmt('%s.BuildMemberFetchLists: MemberMapperIndexByMemberIndex not found. Possibly TimeStamp tag not selected in the model', [classname]); + TestAdd(MemberPersistenceMappers[MapperIndex]); + end else + begin + if Assigned(DefaultFetchMemberList) then + DefaultFetchMemberList.Capacity := MemberPersistenceMappers.Count; for i := 0 to MemberPersistenceMappers.Count - 1 do TestAdd(MemberPersistenceMappers[i]); + end; end; function TBoldObjectPersistenceMapper.GetLinkClassRole1: TBoldMemberPersistenceMapper; @@ -1033,11 +1058,6 @@ procedure TBoldSystemPersistenceMapper.SubscribeToPersistenceEvents( AddSubscription(Subscriber, bpeFetchId, bpeFetchId); end; -function TBoldMemberPersistenceMapperList.GetMemberMapperByExpressionName(ExpressionName: string): TBoldMemberPersistenceMapper; -begin - result := (Indexes[IX_MemberMapper] as TBoldMemberMapperIndex).FindByString(ExpressionName) as TBoldMemberPersistenceMapper; -end; - { TBoldMemberMapperIndex } function TBoldMemberMapperIndex.ItemASKeyString(Item: TObject): string; @@ -1051,7 +1071,7 @@ function TBoldSystemPersistenceMapper.CommonSuperClassObjectMapper( i: Integer; begin if ObjectIdList.Count = 0 then - raise EBold.CreateFmt(sObjectIDListIsEmpty, [classname]); + raise EBold.CreateFmt('%s.CommonSuperClassObjectMapper: ObjectIdList is empty', [classname]); result := ObjectPersistenceMappers[ObjectIdList[0].TopSortedIndex]; for i := 1 to ObjectIdList.Count - 1 do @@ -1117,7 +1137,7 @@ procedure TBoldMemberPersistenceMapper.InitializePSDescriptions; end; function TBoldMemberPersistenceMapper.IsDirty( - ObjectContents: IBoldObjectContents): Boolean; + const ObjectContents: IBoldObjectContents): Boolean; var aValue: IBoldValue; begin @@ -1133,7 +1153,7 @@ function TBoldMemberPersistenceMapper.IsDirty( end; end; -function TBoldMemberPersistenceMapper.GetValue(ObjectContents: IBoldObjectContents): IBoldValue; +function TBoldMemberPersistenceMapper.GetValue(const ObjectContents: IBoldObjectContents): IBoldValue; begin if MemberIndex <> -1 then result := ObjectContents.ValueByIndex[MemberIndex] @@ -1141,21 +1161,15 @@ function TBoldMemberPersistenceMapper.GetValue(ObjectContents: IBoldObjectConten result := nil; end; -function TBoldMemberPersistenceMapper.GetEnsuredValue(ObjectContents: IBoldObjectContents): IBoldValue; -var - MemberId: TBoldMemberId; - g: IBoldGuard; +function TBoldMemberPersistenceMapper.GetEnsuredValue(const ObjectContents: IBoldObjectContents): IBoldValue; begin - g := TBoldGuard.Create(MemberId); if MemberIndex <> -1 then - begin - MemberId := TBoldMemberId.Create(MemberINdex); - ObjectContents.EnsureMember(MemberId, ContentName); - end; - result := GetValue(ObjectContents); + Result := ObjectContents.EnsureMemberAndGetValueByIndex(MemberIndex, ContentName) + else + Result := nil; end; -function TBoldMemberPersistenceMapper.ShouldFetch(ObjectContents: IBoldObjectContents): Boolean; +function TBoldMemberPersistenceMapper.ShouldFetch(const ObjectContents: IBoldObjectContents): Boolean; var aValue: IBoldValue; begin @@ -1175,11 +1189,6 @@ function TBoldObjectPersistenceMapper.GetMemberMapperIndexByMemberIndex(const Me else if MemberIndex < 0 then begin result := -1; - // the Timestamp-member has memberindex below 0 since it is a technical member... - // unfortunately it is also among the last members so this will be a bit slow. - // think of a better solution - // currently it is only called once per update-operation, and only on the rootclass - // mapper which does normally not have that many members, so the problem is more theoretical. for i := 0 to MemberPersistenceMappers.count - 1 do if MemberPersistenceMappers[i].MemberIndex = MemberIndex then begin @@ -1212,4 +1221,8 @@ function TBoldMemberPersistenceMapper.GetSupportsPolymorphicFetch: Boolean; result := false; end; +initialization + TBoldMemberPersistenceMapperList.IX_MemberMapper := -1; + end. + diff --git a/Source/PMapper/Core/BoldPSDescriptions.pas b/Source/PMapper/Core/BoldPSDescriptions.pas index 33d156fe..50c46214 100644 --- a/Source/PMapper/Core/BoldPSDescriptions.pas +++ b/Source/PMapper/Core/BoldPSDescriptions.pas @@ -1,20 +1,24 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPSDescriptions; interface uses + BoldBase, BoldPSParams; - + type TBoldPSDescriptionElement = class; TBoldPSSystemDescription = class; {---TBoldPSDescriptionElement---} - TBoldPSDescriptionElement = class + TBoldPSDescriptionElement = class(TBoldMemoryManagedObject) private fOwner: TBoldPSDescriptionElement; public - constructor Create(aOwner: TBoldPSDescriptionElement); + constructor Create(aOwner: TBoldPSDescriptionElement); property Owner: TBoldPSDescriptionElement read fOwner; end; @@ -26,10 +30,13 @@ TBoldPSSystemDescription = class(TBoldPSDescriptionElement) implementation + {---TBoldPSDescriptionElement---} constructor TBoldPSDescriptionElement.Create(aOwner: TBoldPSDescriptionElement); begin fOwner := aOwner; end; +initialization + end. diff --git a/Source/PMapper/Core/BoldPSParams.pas b/Source/PMapper/Core/BoldPSParams.pas index 3c7fdb5f..17de5b60 100644 --- a/Source/PMapper/Core/BoldPSParams.pas +++ b/Source/PMapper/Core/BoldPSParams.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPSParams; interface @@ -11,9 +14,12 @@ TBoldPSParams = class implementation + constructor TBoldPSParams.Create; begin inherited; end; +initialization + end. diff --git a/Source/PMapper/DbEvolutor/BoldDbEvolutor.pas b/Source/PMapper/DbEvolutor/BoldDbEvolutor.pas index 4cfa5568..73e73237 100644 --- a/Source/PMapper/DbEvolutor/BoldDbEvolutor.pas +++ b/Source/PMapper/DbEvolutor/BoldDbEvolutor.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDbEvolutor; interface @@ -52,16 +55,18 @@ TBoldDataBaseEvolutor = class procedure MoveDataAction(NewMemberMapping, OldMemberMapping: TBoldMemberMappingInfo; Param: TObject); procedure DetectTypeClashesAction(NewMemberMapping, OldMemberMapping: TBoldMemberMappingInfo; Param: TObject); procedure DetectMapperChange(NewMemberMapping, OldMemberMapping: TBoldMemberMappingInfo; Param: TObject); - procedure AddCommandToScript(Script: TStrings; s: string); + function DifferenceInColumns(const AColumns, BColumns: String): string; protected procedure InitializeTableData(TableList, ColumnList: TStringList; MappingInfo: TBoldSQLMappingInfo); procedure AddNewTables; procedure AddNewColumns; procedure AddNewInstances; + procedure AddNewIndexes; procedure MoveData; procedure DeleteOldInstances; procedure DropOldColumns; procedure DropOldTables; + procedure DropOldIndexes; procedure MergeOldDbTypes; procedure DetectTypeClashes; property OldMapping: TBoldSQLMappingInfo read fOldMapping; @@ -97,21 +102,22 @@ implementation BoldDbInterfaces, SysUtils, BoldUtils, - BoldPMConsts; + BoldGuard; { TBoldDataBaseEvolutor } procedure TBoldDataBaseEvolutor.AddNewColumns; var - i: integer; + i, dotIndex: integer; TableName, ColumnName: String; NewTable: TBoldSQLTableDescription; NewColumn: TBoldSQLColumnDescription; begin for i := 0 to NewColumns.Count - 1 do begin - TableName := Copy(NewColumns[i], 1, pos('.', NewColumns[i]) - 1); - ColumnName := Copy(NewColumns[i], pos('.', NewColumns[i]) + 1, maxint); + dotIndex := pos('.', NewColumns[i]); + TableName := Copy(NewColumns[i], 1, dotIndex - 1); + ColumnName := Copy(NewColumns[i], dotIndex + 1, maxint); if (OldColumns.IndexOf(NewColumns[i]) = -1) and (OldTables.IndexOf(TableName) <> -1) then begin NewTable := NewPSDescription.SQLTablesList.ItemsBySQLName[TableName]; @@ -122,48 +128,85 @@ procedure TBoldDataBaseEvolutor.AddNewColumns; end; end; +function ContainsIndex(IndexDefs: TBoldIndexDescriptionArray; Columns: WideString): Boolean; +var + i: Integer; +begin + for I := 0 to Length(IndexDefs) - 1 do + if BoldNamesEqual(IndexDefs[i].IndexedColumns, Columns) then + begin + Result := true; + Exit; + end; + Result := false; +end; + +procedure TBoldDataBaseEvolutor.AddNewIndexes; +var + Def, i: integer; + TableName: String; + BoldTable: TBoldSQLTableDescription; + AllTables: TStringList; + IndexDefs: TBoldIndexDescriptionArray; + g: IBoldGuard; +begin + g := TBoldGuard.Create(AllTables); + AllTables := TStringList.Create; + PersistenceHandle.DataBaseInterface.AllTableNames('', true, AllTables); + AllTables.CaseSensitive := false; + for i := 0 to AllTables.Count - 1 do + begin + TableName := UpperCase(AllTables[i]); + BoldTable := NewPSDescription.SQLTablesList.ItemsBySQLName[TableName]; + if not Assigned(BoldTable) then + Continue; + IndexDefs := PersistenceHandle.DataBaseInterface.GetIndexDescriptions(TableName); + for Def := 0 to BoldTable.IndexList.Count - 1 do + begin + if not ContainsIndex(IndexDefs, BoldTable.IndexList[Def].IndexedFields) then + Script.AddIndex(BoldTable.IndexList[Def]); + end; + end; +end; + procedure TBoldDataBaseEvolutor.AddNewInstances; var i, t: integer; NewTables: TStringList; OldExprName, ExprName: String; OldAllInstances: TBoldAllInstancesMappingArray; + g: IBoldGuard; begin - // in order not to add data more than once, we must loop over the PMapper, and not the mappinginfo + g := TBoldGuard.Create(NewTables); OldAllInstances := nil; NewTables := TStringList.Create; - try - for i := 0 to PMapper.ObjectPersistenceMappers.Count - 1 do + for i := 0 to PMapper.ObjectPersistenceMappers.Count - 1 do + begin + if assigned(PMapper.ObjectPersistenceMappers[i]) then begin - if assigned(PMapper.ObjectPersistenceMappers[i]) then + ExprName := PMapper.ObjectPersistenceMappers[i].ExpressionName; + OldExprName := TranslateClassExpressionName(ExprName, NewMapping, OldMapping); + if (OldExprName <> '') and HasOldInstances(OldExprName) then begin - ExprName := PMapper.ObjectPersistenceMappers[i].ExpressionName; - OldExprName := TranslateClassExpressionName(ExprName, NewMapping, OldMapping); - if (OldExprName <> '') and HasOldInstances(OldExprName) then + GetAllTablesForClass(ExprName, NewMapping, NewTables); + for t := 0 to NewTables.Count - 1 do begin - GetAllTablesForClass(ExprName, NewMapping, NewTables); - for t := 0 to NewTables.Count - 1 do + if not HasStorageMapping(OldExprName, NewTables[t], OldMapping) then begin - if not HasStorageMapping(OldExprName, NewTables[t], OldMapping) then - begin - OldAllInstances := OldMapping.GetAllInstancesMapping(OldExprName); - // what if more than 1 or = 0 - if Length(OldAllInstances) = 1 then - Script.CopyInstances( - ExprName, - OldAllInstances[0].TableName, - NewTables[t], - GetCommonPrimaryKeyColumns( - GetPrimaryIndexForExistingTable(OldAllInstances[0].TableName), - GetPrimaryIndexForNewTable(NewTables[t])), - OldMapping.GetDbTypeMapping(OldExprName)) - end; + OldAllInstances := OldMapping.GetAllInstancesMapping(OldExprName); + if Length(OldAllInstances) = 1 then + Script.CopyInstances( + ExprName, + OldAllInstances[0].TableName, + NewTables[t], + GetCommonPrimaryKeyColumns( + GetPrimaryIndexForExistingTable(OldAllInstances[0].TableName), + GetPrimaryIndexForNewTable(NewTables[t])), + OldMapping.GetDbTypeMapping(OldExprName)) end; end; end; end; - finally - NewTables.free; end; end; @@ -180,7 +223,7 @@ procedure TBoldDataBaseEvolutor.AddNewTables; Script.AddTable(NewTable); Script.AddSQLStatement( - format('INSERT INTO %s (%s) VALUES (''%s'')', [ // do not localize + format('INSERT INTO %s (%s) VALUES (''%s'')', [ BoldExpandPrefix(TABLETABLE_NAME, '', PersistenceHandle.SQLDataBaseConfig.SystemTablePrefix, NewPSDescription.SQLDatabaseConfig.MaxDBIdentifierLength, NewPSDescription.NationalCharConversion), TABLENAMECOLUMN_NAME, Newtable.SQLName])); @@ -221,7 +264,6 @@ procedure TBoldDataBaseEvolutor.DeleteOldInstances; OldExprName := OldMapping.ObjectStorageMappings[i].ClassExpressionName; OldTableName := OldMapping.ObjectStorageMappings[i].TableName; NewExprName := TranslateClassExpressionName(OldExprName, OldMapping, NewMapping); - // either the class does not exist anymore, or it is no longer stored in that table if HasOldInstances(OldExprName) and (Newtables.IndexOf(OldtableName) <> -1) and ((NewExprName = '') or not HasStorageMapping(NewExprName, OldTableName, NewMapping)) then @@ -248,42 +290,78 @@ destructor TBoldDataBaseEvolutor.destroy; procedure TBoldDataBaseEvolutor.DropOldColumns; var - Def, i: integer; - TableName, ColumnName: String; - Table: IBoldTable; + Def, i, index, dotIndex: integer; + s, TableName, ColumnName: String; IndexedColumns: TStringList; + AllTables: TStringList; + IndexDefs: TBoldIndexDescriptionArray; + t: Integer; + g: IBoldGuard; begin + g := TBoldGuard.Create(AllTables, IndexedColumns); IndexedColumns := TStringList.Create; IndexedColumns.Sorted := true; OldColumns.Sort; - Table := PersistenceHandle.DataBaseInterface.GetTable; - try - for i := 0 to OldColumns.Count - 1 do + AllTables := TStringList.Create; + PersistenceHandle.DataBaseInterface.AllTableNames('', true, AllTables); + AllTables.CaseSensitive := false; + for i := 0 to OldColumns.Count - 1 do + begin + dotIndex := pos('.', OldColumns[i]); + s := Copy(OldColumns[i], 1, dotIndex - 1); + if s <> TableName then begin - TableName := Copy(OldColumns[i], 1, pos('.', OldColumns[i]) - 1); - ColumnName := Copy(OldColumns[i], pos('.', OldColumns[i]) + 1, maxint); - if (NewColumns.IndexOf(OldColumns[i]) = -1) and (NewTables.IndexOf(TableName) <> -1) then + TableName := s; + index := AllTables.IndexOf(TableName); + if index < 0 then + continue; // raise Exception.Create(TableName + ' not found at index ' + IntToStr(i)); + IndexDefs := PersistenceHandle.DataBaseInterface.GetIndexDescriptions(TableName); + end; + ColumnName := Copy(OldColumns[i], dotIndex + 1, maxint); + if (NewColumns.IndexOf(OldColumns[i]) = -1) and (NewTables.IndexOf(TableName) <> -1) then + begin + for Def := 0 to Length(IndexDefs) - 1 do begin - // first time and every new table - if (i = 0) or (TableName <> Table.TableName) then - begin - // retrieve fresh indexdefs - Table.Tablename := TableName; - Table.IndexDefs.Update; - end; - // see if any indices needs to be dropped - for Def := 0 to Table.IndexDefs.Count - 1 do + IndexedColumns.CommaText := UpperCase(StringReplace(IndexDefs[Def].IndexedColumns, ';', ',', [rfReplaceAll])); + if IndexedColumns.IndexOf(UpperCase(ColumnName)) <> -1 then begin - IndexedColumns.CommaText := UpperCase(StringReplace(Table.IndexDefs[Def].Fields, ';', ',', [rfReplaceAll])); - if IndexedColumns.IndexOf(UpperCase(ColumnName)) <> -1 then - Script.DropIndex(Table.IndexDefs[Def].Name, Table.Tablename); + if not fPreScript.HasDropIndex(IndexDefs[Def].IndexName, Tablename) then + Script.DropIndex(IndexDefs[Def].IndexName, Tablename); end; - Script.DropColumn(TableName, ColumnName); end; + if not fPreScript.HasDropColumn(TableName, ColumnName) then + Script.DropColumn(TableName, ColumnName); + end; + end; +end; + +procedure TBoldDataBaseEvolutor.DropOldIndexes; +var + Def, i: integer; + TableName: String; + BoldTable: TBoldSQLTableDescription; + AllTables: TStringList; + IndexDefs: TBoldIndexDescriptionArray; + g: IBoldGuard; +begin + g := TBoldGuard.Create(AllTables); + AllTables := TStringList.Create; + PersistenceHandle.DataBaseInterface.AllTableNames('', true, AllTables); + AllTables.CaseSensitive := false; + for i := 0 to AllTables.Count - 1 do + begin + TableName := UpperCase(AllTables[i]); + BoldTable := NewPSDescription.SQLTablesList.ItemsBySQLName[TableName]; + if not Assigned(BoldTable) then + Continue; + IndexDefs := PersistenceHandle.DataBaseInterface.GetIndexDescriptions(TableName); + for Def := 0 to Length(IndexDefs) - 1 do + begin + if PersistenceHandle.SQLDataBaseConfig.EvolveDropsUnknownIndexes and + not Assigned(BoldTable.IndexList.ItemsByIndexFields[IndexDefs[Def].IndexedColumns]) and + not fPreScript.HasDropIndex(IndexDefs[Def].IndexName, Tablename) then + Script.DropIndex(IndexDefs[Def].IndexName, Tablename); end; - finally - IndexedColumns.Free; - PersistenceHandle.DataBaseInterface.releaseTable(Table); end; end; @@ -296,7 +374,7 @@ procedure TBoldDataBaseEvolutor.DropOldTables; begin Script.DropTable(OldTables[i]); Script.AddSQLStatement( - Format('DELETE FROM %s WHERE UPPER(%s)=''%s''', [ // do not localize + Format('DELETE FROM %s WHERE UPPER(%s)=''%s''', [ BoldExpandPrefix(TABLETABLE_NAME, '', PersistenceHandle.SQLDataBaseConfig.SystemTablePrefix, NewPSDescription.SQLDatabaseConfig.MaxDBIdentifierLength, NewPSDescription.NationalCharConversion), TABLENAMECOLUMN_NAME, uppercase(OldTables[i])])); @@ -306,9 +384,9 @@ procedure TBoldDataBaseEvolutor.DropOldTables; procedure TBoldDataBaseEvolutor.CalculateScript; begin if PersistenceHandle.Active then - raise EBold.CreateFmt(sPersistenceHandleActive, [classname, PersistenceHandle.Name]); + raise EBold.CreateFmt('%s.CalculateScript: PersistenceHandle %s is active. unable to execute', [classname, PersistenceHandle.Name]); - BoldLog.LogHeader := sInitializingScript; + BoldLog.LogHeader := 'Initializing Script'; BoldLog.ProgressMax := 10; try PMapper.OpenDatabase(false, false); @@ -317,7 +395,7 @@ procedure TBoldDataBaseEvolutor.CalculateScript; BoldLog.ProgressStep; fUnHandledMemberMappings.Clear; fUnhandledMemberMappings.FillFromList(OldMapping.MemberMappings); - + if not GenericScript then LoadExistingInstances; @@ -330,9 +408,13 @@ procedure TBoldDataBaseEvolutor.CalculateScript; AddNewTables; BoldLog.ProgressStep; AddNewColumns; BoldLog.ProgressStep; AddNewINstances; BoldLog.ProgressStep; + AddNewIndexes; BoldLog.ProgressStep; MoveData; BoldLog.ProgressStep; - DeleteOldInstances; BoldLog.ProgressStep; - DropOldColumns; BoldLog.ProgressStep; + DropOldIndexes; BoldLog.ProgressStep; + DeleteOldInstances; + BoldLog.ProgressStep; + DropOldColumns; + BoldLog.ProgressStep; DropOldTables; BoldLog.ProgressStep; Script.OptimizeScript; MergeOldDbTypes; @@ -385,23 +467,21 @@ function TBoldDataBaseEvolutor.HasOldInstances(const OldExpressionName: String): function TBoldDataBaseEvolutor.HasStorageMapping(const ExpressionName, TableName: String; Mapping: TBoldSQLMappingInfo): Boolean; var - tables: TStringList; + Tables: TStringList; i: integer; + g: IBoldGuard; begin + g := TBoldGuard.Create(Tables); result := false; Tables := TStringList.Create; - try - GetAllTablesForClass(ExpressionName, Mapping, Tables); - for i := 0 to Tables.Count - 1 do + GetAllTablesForClass(ExpressionName, Mapping, Tables); + for i := 0 to Tables.Count - 1 do + begin + if SameText(Tables[i], TableName) then begin - if SameText(Tables[i], TableName) then - begin - result := true; - break; - end; + result := true; + break; end; - finally - Tables.Free; end; end; @@ -414,23 +494,21 @@ procedure TBoldDataBaseEvolutor.InitializeTableData(TableList, ColumnList: TStri var i, j: integer; Columns: TStringList; + g: IBoldGuard; begin + g := TBoldGuard.Create(Columns); for i := 0 to MappingInfo.ObjectStorageMappings.Count - 1 do AddName(MappingInfo.ObjectStorageMappings[i].TableName, TableList); for i := 0 to MappingInfo.AllInstancesMappings.Count - 1 do AddName(MappingInfo.AllInstancesMappings[i].TableName, TableList); Columns := TStringList.Create; - try - for i := 0 to MappingInfo.MemberMappings.Count - 1 do - begin - AddName(MappingInfo.MemberMappings[i].TableName, TableList); - Columns.CommaText := MappingInfo.MemberMappings[i].Columns; - for j := 0 to Columns.Count - 1 do - AddName(MappingInfo.MemberMappings[i].TableName + '.' + Columns[j], ColumnList); - end; - finally - Columns.Free; - end + for i := 0 to MappingInfo.MemberMappings.Count - 1 do + begin + AddName(MappingInfo.MemberMappings[i].TableName, TableList); + Columns.CommaText := MappingInfo.MemberMappings[i].Columns; + for j := 0 to Columns.Count - 1 do + AddName(MappingInfo.MemberMappings[i].TableName+'.' + Columns[j], ColumnList); + end; end; procedure TBoldDataBaseEvolutor.LoadExistingInstances; @@ -439,7 +517,7 @@ procedure TBoldDataBaseEvolutor.LoadExistingInstances; begin query := PersistenceHandle.DataBaseInterface.GetQuery; try - query.AssignSQLText(format('SELECT DISTINCT BOLD_TYPE FROM %s', [OldRootTableName])); // do not localize + query.AssignSQLText(format('SELECT DISTINCT BOLD_TYPE FROM %s', [OldRootTableName])); Query.Open; while not QUery.Eof do begin @@ -459,7 +537,6 @@ procedure TBoldDataBaseEvolutor.ForEachMemberMappingPair(Action: TBoldMemberMapp OldMemberMappings: TBoldMemberMappingArray; NewMemberName, OldMemberName, NewExprName, OldExprName: String; begin - // in order not to move data more than once, we must loop over the PMapper, and not the mappinginfo OldMemberMappings := nil; NewMemberMappings := nil; for i := 0 to PMapper.ObjectPersistenceMappers.Count - 1 do @@ -476,7 +553,6 @@ procedure TBoldDataBaseEvolutor.ForEachMemberMappingPair(Action: TBoldMemberMapp begin NewMemberName := PMapper.ObjectPersistenceMappers[i].MemberPersistenceMappers[j].ExpressionName; NewMemberMappings := NewMapping.GetMemberMappings(NewExprName, NewMemberName); - // do we need to worry about lengths = 0, lengths > 1? if length(NewMemberMappings) = 1 then begin OldMemberName := TranslateMemberName(NewExprName, NewMemberName, OldExprName, NewMapping, OldMapping); @@ -514,26 +590,23 @@ procedure TBoldDataBaseEvolutor.MoveDataBetweenMappings(NewMemberMapping, OldMem var NewColumns, OldColumns: TStringList; i: integer; + g: IBoldGuard; begin + g := TBoldGuard.Create(NewColumns, OldColumns); NewColumns := TStringList.Create; OldColumns := TStringList.Create; - try - NewColumns.CommaText := NewMemberMapping.Columns; - OldColumns.CommaText := OldMemberMapping.Columns; - for i := 0 to MinIntValue([NewColumns.Count, OldColumns.Count]) - 1 do - begin - Script.MoveData(OldMemberMapping.TableName, - NewMemberMapping.TableName, - OldColumns[i], - NewColumns[i], - GetCommonPrimaryKeyColumns( - GetPrimaryIndexForExistingTable(OldMemberMapping.TableName), - GetPrimaryIndexForNewTable(NewMemberMapping.TableName)), - OldMapping.GetDbTypeMapping(OldMemberMapping.ClassExpressionName)); - end; - finally - NewColumns.Free; - OldColumns.Free; + NewColumns.CommaText := NewMemberMapping.Columns; + OldColumns.CommaText := OldMemberMapping.Columns; + for i := 0 to MinIntValue([NewColumns.Count, OldColumns.Count]) - 1 do + begin + Script.MoveData(OldMemberMapping.TableName, + NewMemberMapping.TableName, + OldColumns[i], + NewColumns[i], + GetCommonPrimaryKeyColumns( + GetPrimaryIndexForExistingTable(OldMemberMapping.TableName), + GetPrimaryIndexForNewTable(NewMemberMapping.TableName)), + OldMapping.GetDbTypeMapping(OldMemberMapping.ClassExpressionName)); end; end; @@ -543,13 +616,12 @@ function TBoldDataBaseEvolutor.OldRootTableName: String; tables: TStringList; TableName: String; begin - result := 'BOLD_OBJECT'; // do not localize + result := 'BOLD_OBJECT'; Tables := TStringList.create; try if (OldMapping.ObjectStorageMappings.Count = 0) and (OldMapping.AllInstancesMappings.Count = 1) then begin - // there is only the rootclass, it has no objectstorage, only AllInstances-mapping TableName := OldMapping.AllInstancesMappings[0].TableName; Tables.Values[TableName] := IntToStr(StrToIntDef(Tables.Values[TableName], 0) + 1); end; @@ -583,14 +655,13 @@ function TBoldDataBaseEvolutor.TranslateClassExpressionName(const ExpressionName begin dbType := SourceMapping.GetDbTypeMapping(ExpressionName); if dbType = NO_CLASS then - raise EBold.CreateFmt(sUnableToFindDBID, [classname, expressionName]); + raise EBold.CreateFmt('%s.TranslateClassExpressionName: Unable to find source dbid for %s', [classname, expressionName]); for i := 0 to SourceMapping.DbTypeMappings.Count - 1 do begin TestName := SourceMapping.DbTypeMappings[i].ClassExpressionName; if (SourceMapping.DbTypeMappings[i].DbType = dbType) and (DestMapping.GetDbTypeMapping(TestName) <> NO_CLASS) then begin - // oh, we found the testname in the destination mapping, then it is what we were looking for. result := TestName; break; end; @@ -619,7 +690,6 @@ function TBoldDataBaseEvolutor.TranslateMemberName( Mapping := SourceMemberMappings[0].TableName + '.' + SourceMemberMappings[0].Columns; for i := 0 to SourceMapping.MemberMappings.Count - 1 do begin - // if they have the same class name, and the same mapping, it is the same member if SameText(SourceMapping.MemberMappings[i].ClassExpressionName, SourceExprName) and SameText(SourceMapping.MemberMappings[i].TableName + '.' + SourceMapping.MemberMappings[i].Columns, Mapping) then begin @@ -646,7 +716,7 @@ procedure TBoldDataBaseEvolutor.ExecuteScript; fMergedMapping.WriteDataToDB(PersistenceHandle.DataBaseInterface); finally PersistenceHandle.DataBaseInterface.Close; - end; + end; end; procedure TBoldDataBaseEvolutor.MergeOldDbTypes; @@ -667,7 +737,6 @@ procedure TBoldDataBaseEvolutor.MergeOldDbTypes; DbType := OldMapping.GetDbTypeMapping(OldExprName); if DbType = NO_CLASS then begin - // try to locate a previously added type with the same dbtype in the new typemapping for j := 0 to i - 1 do begin if NewMapping.DbTypeMappings[i].DbType = NewMapping.DbTypeMappings[j].dbtype then @@ -698,9 +767,13 @@ procedure TBoldDataBaseEvolutor.GenerateScript(DbScript, MappingScript: TStrings dbScript.EndUpdate; MappingScript.BeginUpdate; - AddCommandToScript(MappingScript, PersistenceHandle.SQLDataBaseConfig.SqlScriptStartTransaction); - fMergedMapping.ScriptForWriteData(MappingScript, PersistenceHandle.SQLDataBaseConfig.SqlScriptSeparator, true, PersistenceHandle.SQLDataBaseConfig.SqlScriptTerminator); - AddCommandToScript(MappingScript, PersistenceHandle.SQLDataBaseConfig.SqlScriptCommitTransaction); + fMergedMapping.ScriptForWriteData( + PersistenceHandle.DatabaseInterface, + MappingScript, + True, + PersistenceHandle.SQLDataBaseConfig.SqlScriptSeparator, + PersistenceHandle.SQLDataBaseConfig.SqlScriptTerminator + ); MappingScript.EndUpdate; end; @@ -713,7 +786,6 @@ procedure TBoldDataBaseEvolutor.MarkMemberMappingHandled(UnhandledMemberMappings if OldDbType <> NO_CLASS then begin for i := UnhandledMemberMappings.Count - 1 downto 0 do - // if the dbtype, table and columns match then it is the same attribute... if (OldMapping.GetDbTypeMapping(UnhandledMemberMappings[i].ClassExpressionName) = OldDbType) and SameText(UnhandledMemberMappings[i].TableName, OldMemberMapping.TableName) and SameText(UnhandledMemberMappings[i].Columns, OldMemberMapping.Columns) then @@ -724,10 +796,9 @@ procedure TBoldDataBaseEvolutor.MarkMemberMappingHandled(UnhandledMemberMappings procedure TBoldDataBaseEvolutor.DetectMapperChange(NewMemberMapping, OldMemberMapping: TBoldMemberMappingInfo; Param: TObject); begin - if (NewMemberMapping.MapperName <> OldMemberMapping.MapperName) and (OldMemberMapping.MapperName <> '') then - begin + if (OldMemberMapping.MapperName <> '') and not NewMemberMapping.CompareMapping(OldMemberMapping) then (Param as TStrings).Add( - format(sMemberChangedMapper, [ + format('Member %s.%s changed mapper (%s->%s). Column[s] (%s) in table %s will be dropped and (%s) will be created in table %s, data loss!', [ NewMemberMapping.ClassExpressionName, NewMemberMapping.MemberName, OldMemberMapping.MapperName, @@ -737,7 +808,6 @@ procedure TBoldDataBaseEvolutor.DetectMapperChange(NewMemberMapping, OldMemberMa NewMemberMapping.Columns, NewMemberMapping.TableName])); end; -end; procedure TBoldDataBaseEvolutor.GenerateWarnings(Info: TStrings); var @@ -754,7 +824,6 @@ procedure TBoldDataBaseEvolutor.GenerateWarnings(Info: TStrings); if assigned(PMapper.ObjectPersistenceMappers[i]) and (length(NewMapping.GetObjectStorageMapping(PMapper.ObjectPersistenceMappers[i].ExpressionName)) = 0) then begin - // New class is persistent and abstract NewExprName := PMapper.ObjectPersistenceMappers[i].ExpressionName; oldExprName := TranslateClassExpressionName(NewExprName, NewMapping, OldMapping); if OldExprName <> '' then @@ -762,9 +831,9 @@ procedure TBoldDataBaseEvolutor.GenerateWarnings(Info: TStrings); if length(OldMapping.GetObjectStorageMapping(OldExprName)) > 0 then begin if GenericScript then - Info.Add(format(sClassBecameAbstract, [OldExprName, NewExprName])) + Info.Add(format('Class %s is concrete in old model, but %s is Abstract in new model', [OldExprName, NewExprName])) else if HasOldInstances(OldExprName) then - Info.Add(format(sUnableToHandleInstancesOfAbstract, [OldExprName, NewExprName])); + Info.Add(format('ERROR: There are instances of class %s, but %s is abstract in new model', [OldExprName, NewExprName])); end; end; end; @@ -777,7 +846,7 @@ procedure TBoldDataBaseEvolutor.GenerateWarnings(Info: TStrings); begin if HasOldInstances(UnhandledMemberMappings[0].ClassExpressionName) then begin - s := format(sDataStoredInXForYWillBeLost, [ + s := format('Data stored in column %s.%s for member %s.%s will be lost', [ UnhandledMemberMappings[0].TableName, UnhandledMemberMappings[0].columns, UnhandledMemberMappings[0].ClassExpressionName, @@ -786,9 +855,9 @@ procedure TBoldDataBaseEvolutor.GenerateWarnings(Info: TStrings); if newClassExpressionName <> UnhandledMemberMappings[0].ClassExpressionName then begin if NewClassExpressionname = '' then - s := s + sClassNoLongerExists + s := s + ' (class no longer exists)' else - s := s + format(sNewNameForClass, [NewClassExpressionName]); + s := s + format(' (class now called %s)', [NewClassExpressionName]); end; info.add(s); end; @@ -804,7 +873,6 @@ function TBoldDataBaseEvolutor.CanHaveOldInstances(const OldExpressionName: Stri dbTypeMapping: TBoldDbType; begin dbTypeMapping := OldMapping.GetDbTypeMapping(OldExpressionName); - // Abstract classes has no ObjectStorage mapping result := (dbTypeMapping <> NO_CLASS) and (length(OldMapping.GetObjectStorageMapping(OldExpressionName)) > 0); end; @@ -812,45 +880,38 @@ function TBoldDataBaseEvolutor.GetCommonPrimaryKeyColumns(const PrimaryKey1, Pri var i: integer; Fields1, Fields2: TStringList; + g: IBoldGuard; begin + g := TBoldGuard.Create(Fields1, Fields2); Fields1 := TStringList.Create; Fields2 := TStringList.Create; - result := ''; // perhaps should default to BOLD_ID... - try - Fields1.CommaText := PrimaryKey1; - Fields2.CommaText := UpperCase(PrimaryKey2); - Fields2.Sorted := true; - for i := Fields1.Count - 1 downto 0 do - if Fields2.IndexOf(UpperCase(Fields1[i])) = -1 then - Fields1.delete(i); - result := Fields1.CommaText; - finally - Fields1.Free; - Fields2.Free; - end; + result := ''; + Fields1.CommaText := PrimaryKey1; + Fields2.CommaText := UpperCase(PrimaryKey2); + Fields2.Sorted := true; + for i := Fields1.Count - 1 downto 0 do + if Fields2.IndexOf(UpperCase(Fields1[i])) = -1 then + Fields1.delete(i); + result := Fields1.CommaText; end; function TBoldDataBaseEvolutor.GetPrimaryIndexForExistingTable(const TableName: String): String; var - Table: IBoldTable; + IndexDefs: TBoldIndexDescriptionArray; i: integer; begin - Table := PersistenceHandle.DataBaseInterface.GetTable; - try - Table.Tablename := tableName; - result := ''; - Table.IndexDefs.Update; - for i := 0 to Table.IndexDefs.Count - 1 do + result := ''; + IndexDefs := PersistenceHandle.DataBaseInterface.GetIndexDescriptions(TableName); + for i := 0 to Length(IndexDefs)-1 do + begin + if IndexDefs[i].IsPrimary then begin - if ixPrimary in Table.IndexDefs[i].Options then - begin - result := StringReplace(Table.IndexDefs[i].Fields, ';', ',', [rfReplaceAll]); - exit; - end; + result := StringReplace(IndexDefs[i].IndexedColumns, ';', ',', [rfReplaceAll]); + exit; end; - finally - PersistenceHandle.DataBaseInterface.ReleaseTable(Table); end; + if result = '' then + raise EBold.CreateFmt('%s.GetPrimaryIndexForExistingTable: Table "%s" has no primary key.', [ClassName, TableName]); end; function TBoldDataBaseEvolutor.GetPrimaryIndexForNewTable(const TableName: String): String; @@ -858,13 +919,13 @@ function TBoldDataBaseEvolutor.GetPrimaryIndexForNewTable(const TableName: Strin TableDesc: TBoldSQLTableDescription; i: integer; begin - result := ''; + result := IDCOLUMN_NAME; // Fallback: see GetPrimaryIndexForExistingTable TableDesc := PMapper.PSSystemDescription.SQLTablesList.ItemsBySQLName[tableName]; if assigned(TableDesc) then for i := 0 to TableDesc.IndexList.Count - 1 do - if ixPrimary in TableDesc.IndexList[i].IndexOptions then + if BoldPSDescriptionsSQL.ixPrimary in TableDesc.IndexList[i].IndexOptions then begin - result := TableDesc.IndexList[i].IndexedFieldsForSQL; // this has commas instead of semicolons as separator + result := TableDesc.IndexList[i].IndexedFieldsForSQL; exit; end; end; @@ -877,24 +938,73 @@ procedure TBoldDataBaseEvolutor.DetectTypeClashes; procedure TBoldDataBaseEvolutor.DetectTypeClashesAction(NewMemberMapping, OldMemberMapping: TBoldMemberMappingInfo; Param: TObject); var i: integer; - columns: TStringList; + OldColumns: TStringList; + NewColumns: TStringList; ColumnDesc: TBoldSQlColumnDescription; TableDesc: TBoldSQLTableDescription; + SameTable: boolean; + SameTableAndMapper: boolean; + IsOrderedEvolve: boolean; + g: IBoldGuard; begin - if (NewMemberMapping.MapperName <> OldMemberMapping.MapperName) and (OldMemberMapping.MapperName <> '') then + if (OldMemberMapping.MapperName <> '') and (not NewMemberMapping.CompareMapping(OldMemberMapping)) then begin - Columns := TStringList.create; - Columns.CommaText := OldMemberMapping.Columns; - for i := 0 to Columns.Count - 1 do - fPreScript.DropColumn(OldMemberMapping.TableName, Columns[i]); + g := TBoldGuard.Create(NewColumns, OldColumns); + OldColumns := TStringList.create; + OldColumns.CommaText := OldMemberMapping.Columns; + NewColumns := TStringList.create; + NewColumns.CommaText := NewMemberMapping.Columns; + SameTable := (OldMemberMapping.TableName = NewMemberMapping.TableName); + SameTableAndMapper := SameTable and (OldMemberMapping.MapperName = NewMemberMapping.MapperName); + IsOrderedEvolve := SameTableAndMapper and (DifferenceInColumns(NewMemberMapping.Columns, OldMemberMapping.Columns) = NewColumns[0] + ORDERCOLUMN_SUFFIX); + if not IsOrderedEvolve and SameTable then + for i := 0 to OldColumns.Count - 1 do + fScript.DropColumn(OldMemberMapping.TableName, OldColumns[i]); TableDesc := NewPSDescription.SQLTablesList.ItemsBySQLName[NewMemberMapping.TableName]; - Columns.CommaText := NewMemberMapping.Columns; - for i := 0 to Columns.Count - 1 do + if SameTable then + for i := 0 to NewColumns.Count - 1 do + begin + if not IsOrderedEvolve or (i = ORDERCOLUMN_INDEX) then + begin + ColumnDesc := TableDesc.ColumnsList.ItemsBySQLName[NewColumns[i]] as TBoldSQLColumnDescription; + fScript.AddColumn(ColumnDesc); + end; + end; + end; +end; + +function TBoldDataBaseEvolutor.DifferenceInColumns(const AColumns, + BColumns: String): string; +var + i,j : integer; + a: TStringList; + b: TStringList; + c: TStringList; +begin + a := TStringList.Create; + b := TStringList.Create; + c := TStringList.Create; + try + a.CommaText := AColumns; + b.CommaText := BColumns; + for i := 0 to a.Count - 1 do + begin + j := b.IndexOf(a[i]); + if j = -1 then + c.Add(a[i]) + end; + for i := 0 to b.Count - 1 do begin - ColumnDesc := TableDesc.ColumnsList.ItemsBySQLName[Columns[i]] as TBoldSQLColumnDescription; - fScript.AddColumn(ColumnDesc); + j := a.IndexOf(b[i]); + if j = -1 then + c.Add(b[i]) end; + result := c.CommaText; + finally + a.free; + b.free; + c.free; end; end; @@ -905,11 +1015,6 @@ procedure TBoldDataBaseEvolutor.GenerateExecutedStatements(Info: TStrings); Info.AddStrings(Script.InternalLog); end; -procedure TBoldDataBaseEvolutor.AddCommandToScript(Script: TStrings; s: string); -begin - Script.Add(s+PersistenceHandle.SQLDataBaseConfig.SqlScriptTerminator); - if PersistenceHandle.SQLDataBaseConfig.SqlScriptSeparator <> '' then - Script.Add(PersistenceHandle.SQLDataBaseConfig.SqlScriptSeparator); -end; +initialization end. diff --git a/Source/PMapper/DbEvolutor/BoldDbEvolutorForm.dfm b/Source/PMapper/DbEvolutor/BoldDbEvolutorForm.dfm index 43dc78cc..2fd4618c 100644 --- a/Source/PMapper/DbEvolutor/BoldDbEvolutorForm.dfm +++ b/Source/PMapper/DbEvolutor/BoldDbEvolutorForm.dfm @@ -1,9 +1,9 @@ object frmBoldDbEvolutor: TfrmBoldDbEvolutor Left = 510 Top = 257 - Width = 640 - Height = 480 Caption = 'Db Evolution' + ClientHeight = 387 + ClientWidth = 460 Color = clBtnFace Constraints.MinHeight = 200 Constraints.MinWidth = 322 @@ -43,16 +43,16 @@ object frmBoldDbEvolutor: TfrmBoldDbEvolutor OnCreate = FormCreate OnDestroy = FormDestroy DesignSize = ( - 632 - 446) + 460 + 387) PixelsPerInch = 96 TextHeight = 13 object PageControl1: TPageControl - Left = 0 - Top = 0 - Width = 632 - Height = 388 - ActivePage = tsMappingInfo + Left = 4 + Top = 4 + Width = 450 + Height = 320 + ActivePage = tsActions Anchors = [akLeft, akTop, akRight, akBottom] Images = ImageList1 TabOrder = 0 @@ -61,8 +61,8 @@ object frmBoldDbEvolutor: TfrmBoldDbEvolutor object mmoActions: TMemo Left = 0 Top = 0 - Width = 624 - Height = 359 + Width = 442 + Height = 291 Align = alClient ReadOnly = True ScrollBars = ssBoth @@ -75,8 +75,8 @@ object frmBoldDbEvolutor: TfrmBoldDbEvolutor object mmoWarnings: TMemo Left = 0 Top = 0 - Width = 624 - Height = 359 + Width = 442 + Height = 291 Align = alClient ReadOnly = True ScrollBars = ssBoth @@ -89,8 +89,8 @@ object frmBoldDbEvolutor: TfrmBoldDbEvolutor object mmoSQLScript: TMemo Left = 0 Top = 0 - Width = 624 - Height = 359 + Width = 442 + Height = 291 Align = alClient ReadOnly = True ScrollBars = ssBoth @@ -103,8 +103,8 @@ object frmBoldDbEvolutor: TfrmBoldDbEvolutor object mmoMappingInfoScript: TMemo Left = 0 Top = 0 - Width = 624 - Height = 359 + Width = 442 + Height = 291 Align = alClient ReadOnly = True ScrollBars = ssBoth @@ -114,16 +114,16 @@ object frmBoldDbEvolutor: TfrmBoldDbEvolutor end object ProgressBar1: TProgressBar Left = 8 - Top = 397 - Width = 617 + Top = 330 + Width = 444 Height = 16 Anchors = [akLeft, akRight, akBottom] Smooth = True TabOrder = 1 end object btnCancel: TButton - Left = 545 - Top = 421 + Left = 371 + Top = 354 Width = 81 Height = 25 Anchors = [akRight, akBottom] @@ -132,8 +132,8 @@ object frmBoldDbEvolutor: TfrmBoldDbEvolutor TabOrder = 2 end object btnExecute: TButton - Left = 457 - Top = 421 + Left = 284 + Top = 354 Width = 81 Height = 25 Anchors = [akRight, akBottom] @@ -142,14 +142,15 @@ object frmBoldDbEvolutor: TfrmBoldDbEvolutor ModalResult = 1 TabOrder = 3 end - object Button1: TButton - Left = 373 - Top = 421 + object btnSaveScript: TButton + Left = 523 + Top = 604 Width = 75 Height = 25 + Anchors = [akRight, akBottom] Caption = 'Save scripts' TabOrder = 4 - OnClick = Button1Click + OnClick = btnSaveScriptClick end object ImageList1: TImageList Left = 52 diff --git a/Source/PMapper/DbEvolutor/BoldDbEvolutorForm.pas b/Source/PMapper/DbEvolutor/BoldDbEvolutorForm.pas index 58a4a1e1..a885e9f8 100644 --- a/Source/PMapper/DbEvolutor/BoldDbEvolutorForm.pas +++ b/Source/PMapper/DbEvolutor/BoldDbEvolutorForm.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDbEvolutorForm; interface @@ -31,16 +34,19 @@ TfrmBoldDbEvolutor = class(TForm, IBoldLogReceiver) tsWarnings: TTabSheet; mmoWarnings: TMemo; ImageList1: TImageList; - Button1: TButton; SaveDialog1: TSaveDialog; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); - procedure Button1Click(Sender: TObject); + procedure btnSaveScriptClick(Sender: TObject); private { Private declarations } + fSQLScript: TStringList; + fMappingInfoScript: TStringList; fWarnings: TStringList; fSessionName: String; + procedure SqlScriptChange(Sender: TObject); + procedure MappingInfoScriptChange(Sender: TObject); procedure SetProgress(const Value: integer); procedure SetLogHeader(const Value: string); procedure SetProgressMax(const Value: integer); @@ -58,12 +64,13 @@ TfrmBoldDbEvolutor = class(TForm, IBoldLogReceiver) function GetWarnings: TStrings; procedure UpdateWarningCount(Sender: TObject); public - constructor Create(Owner: TComponent); override; - destructor Destroy; override; + constructor create(Owner: TComponent); override; + destructor destroy; override; class procedure EvolveDB(PersistenceHandle: TBoldAbstractPersistenceHandleDB; GenerateGenericScript: Boolean); property SQLScript: TStrings read GetSQLScript; property MappingInfoScript: TStrings read GetMappingInfoScript; property Warnings: TStrings read GetWarnings; + { Public declarations } end; @@ -73,21 +80,39 @@ implementation SysUtils, BoldUtils, BoldDbEvolutor, - BoldPMConsts, + BoldIsoDateTime, BoldGuard; {$R *.DFM} { TfrmBoldDbEvolutor } +procedure TfrmBoldDbEvolutor.btnSaveScriptClick(Sender: TObject); +var + sl: TStringList; +begin + if SaveDialog1.Execute then + begin + sl := TStringList.Create; + try + sl.Add('-- Mapping Info Script'); + sl.AddStrings(MappingInfoScript); + sl.Add('-- SQL Script'); + sl.AddStrings(SQLScript); + SQLScript.SaveToFile(SaveDialog1.FileName); + finally + sl.free; + end; + end; +end; + procedure TfrmBoldDbEvolutor.Clear; begin -// mmoActions.lines.Clear; end; procedure TfrmBoldDbEvolutor.EndLog; begin - Log(format(sDone, [formatDateTime('c', now), fSessionName])); // do not localize + Log(format('%s: Done %s', [AsIsoDateTime(now), fSessionName])); end; procedure TfrmBoldDbEvolutor.Hide; @@ -115,7 +140,6 @@ procedure TfrmBoldDbEvolutor.SetProgress(const Value: integer); procedure TfrmBoldDbEvolutor.SetLogHeader(const Value: string); begin - // intentionally left empty end; procedure TfrmBoldDbEvolutor.SetProgressMax(const Value: integer); @@ -129,9 +153,19 @@ procedure TfrmBoldDbEvolutor.Show; inherited Show; end; +procedure TfrmBoldDbEvolutor.SqlScriptChange(Sender: TObject); +begin + mmoSQLScript.Lines.Assign(Sender as TStrings); +end; + +procedure TfrmBoldDbEvolutor.MappingInfoScriptChange(Sender: TObject); +begin + mmoMappingInfoScript.Lines.Assign(Sender as TStrings); +end; + procedure TfrmBoldDbEvolutor.StartLog(const SessionName: String); begin - Log(format(sStarting, [formatDateTime('c', now), sessionName])); // do not localize + Log(format('%s: Starting %s', [AsIsoDateTime(now), sessionName])); fSessionName := SessionName; Show; end; @@ -143,6 +177,10 @@ procedure TfrmBoldDbEvolutor.FormCreate(Sender: TObject); GetInterface(IBoldLogReceiver, LogReceiver); BoldLog.RegisterLogReceiver(LogReceiver); PageControl1.ActivePage := tsActions; + fSQLScript := TStringList.Create; + fMappingInfoScript := TStringList.Create; + fSQLScript.OnChange := SqlScriptChange; + fMappingInfoScript.OnChange := MappingInfoScriptChange; end; procedure TfrmBoldDbEvolutor.FormDestroy(Sender: TObject); @@ -151,6 +189,8 @@ procedure TfrmBoldDbEvolutor.FormDestroy(Sender: TObject); begin GetInterface(IBoldLogReceiver, LogReceiver); BoldLog.UnRegisterLogReceiver(LogReceiver); + FreeAndNil(fSQLScript); + FreeAndNil(fMappingInfoScript); end; procedure TfrmBoldDbEvolutor.FormClose(Sender: TObject; var Action: TCloseAction); @@ -160,12 +200,12 @@ procedure TfrmBoldDbEvolutor.FormClose(Sender: TObject; var Action: TCloseAction function TfrmBoldDbEvolutor.GetMappingInfoScript: TStrings; begin - result := mmoMappingInfoScript.Lines; + result := fMappingInfoScript; //mmoMappingInfoScript.Lines; end; function TfrmBoldDbEvolutor.GetSQLScript: TStrings; begin - result := mmoSQLScript.Lines; + result := fSQLScript; //mmoSQLScript.Lines; end; function TfrmBoldDbEvolutor.GetWarnings: TStrings; @@ -183,7 +223,7 @@ constructor TfrmBoldDbEvolutor.create(Owner: TComponent); destructor TfrmBoldDbEvolutor.destroy; begin FreeAndNil(fWarnings); - inherited; + inherited; end; procedure TfrmBoldDbEvolutor.UpdateWarningCount(Sender: TObject); @@ -192,12 +232,11 @@ procedure TfrmBoldDbEvolutor.UpdateWarningCount(Sender: TObject); mmoWarnings.lines.Clear; mmoWarnings.lines.AddStrings(fWarnings); mmoWarnings.Lines.EndUpdate; - tsWarnings.Caption := format(sWarnings, [fWarnings.Count]); + tsWarnings.Caption := format('Warnings (%d)', [fWarnings.Count]); end; procedure TfrmBoldDbEvolutor.ProcessInterruption; begin - // intentionally left blank end; procedure TfrmBoldDbEvolutor.Sync; @@ -219,7 +258,7 @@ class procedure TfrmBoldDbEvolutor.EvolveDB(PersistenceHandle: TBoldAbstractPers EvolutorForm := TfrmBoldDbEvolutor.Create(nil); EvolutorForm.Show; try - BoldLog.StartLog(sDetectingChanges); + BoldLog.StartLog('Detecting changes'); Evolutor.GenericScript := GenerateGenericScript; try Evolutor.CalculateScript; @@ -230,7 +269,7 @@ class procedure TfrmBoldDbEvolutor.EvolveDB(PersistenceHandle: TBoldAbstractPers except on e: Exception do begin - showMessage(Format(sFailedToDetectChanges, [e.message])); + showMessage('Failed to detect changes: ' + e.message); exit; end; end; @@ -238,31 +277,35 @@ class procedure TfrmBoldDbEvolutor.EvolveDB(PersistenceHandle: TBoldAbstractPers BoldLog.EndLog; if EvolutorForm.SQLScript.Count = 0 then begin - ShowMessage(sNoUpdateNeeded); + ShowMessage('No update needed!'); EvolutorForm.Close; EvolutorForm := nil; end else begin - ShowMessage(Format(sInspectChanges, [BOLDCRLF, BOLDCRLF])); + ShowMessage( + 'Please inspect the planned actions and decide if you want to execute them' + BOLDCRLF + + BOLDCRLF + + 'Make sure you back up your critical data before upgrading the database!!!'); EvolutorForm.Hide; ModalResult := EvolutorForm.ShowModal; EvolutorForm := nil; if ModalResult = mrOK then begin try - BoldLog.StartLog(sUpdateDatabase); + BoldLog.StartLog('Update database'); Evolutor.ExecuteScript; BoldLog.EndLog; - ShowMessage(sUpdateSuccessful); + ShowMessage('Database successfully updated'); except on e: Exception do begin - showMessage(Format(sEvolveFailed, [e.Message, BOLDCRLF, BOLDCRLF])); + showMessage('Failed to Evolve database: ' + e.message + BOLDCRLF + BOLDCRLF + + 'See LogWindow for executed statements'); ExecutedStatements := TStringList.Create; BoldLog.Separator; - BoldLog.Log(sExecutedStatements); + BoldLog.Log('The following statements were executed before evolution failed: '); BoldLog.Separator; Evolutor.GenerateExecutedStatements(ExecutedStatements); for i := 0 to ExecutedStatements.Count - 1 do @@ -279,14 +322,4 @@ class procedure TfrmBoldDbEvolutor.EvolveDB(PersistenceHandle: TBoldAbstractPers end; end; -procedure TfrmBoldDbEvolutor.Button1Click(Sender: TObject); -begin - SaveDialog1.FileName := 'EvolutionScript.sql'; - if SaveDialog1.Execute then - mmoSQLScript.Lines.SaveToFile(SaveDialog1.FileName); - SaveDialog1.FileName := 'MappingInfoScript.sql'; - if SaveDialog1.Execute then - mmoMappingInfoScript.Lines.SaveToFile(SaveDialog1.FileName); -end; - end. diff --git a/Source/PMapper/DbEvolutor/BoldDbEvolutorScript.pas b/Source/PMapper/DbEvolutor/BoldDbEvolutorScript.pas index 4a9b0f2f..a2ec68f7 100644 --- a/Source/PMapper/DbEvolutor/BoldDbEvolutorScript.pas +++ b/Source/PMapper/DbEvolutor/BoldDbEvolutorScript.pas @@ -1,3 +1,5 @@ +{ Global compiler directives } +{$include bold.inc} unit BoldDbEvolutorScript; interface @@ -6,6 +8,7 @@ interface db, Classes, BoldDefs, + BoldBase, BoldLogHandler, BoldDBInterfaces, BoldPSDescriptionsSQL, @@ -26,7 +29,7 @@ TBoldTwoColumnOperation = class; TBoldMoveData = class; TBoldDataBaseEvolutorScript = class; - TBoldScriptOperation = class + TBoldScriptOperation = class(TBoldMemoryManagedObject) private fScript: TBoldDataBaseEvolutorScript; public @@ -37,6 +40,8 @@ TBoldScriptOperation = class TBoldTableOperation = class(TBoldScriptOperation) private fTableName: string; + protected + function GetDebugInfo: string; override; public constructor Create(Script: TBoldDataBaseEvolutorScript; const TableName: String); property TableName: string read fTableName; @@ -45,6 +50,8 @@ TBoldTableOperation = class(TBoldScriptOperation) TBoldAddTable = class(TBoldScriptOperation) private fTableDescr: TBoldSQLTableDescription; + protected + function GetDebugInfo: string; override; public constructor Create(Script: TBoldDataBaseEvolutorScript; TableDescr: TBoldSQLTableDescription); procedure Execute; @@ -60,6 +67,8 @@ TBoldDeleteInstances = class(TBoldTableOperation) private fExpressionName: String; fDbType: TBoldDbType; + protected + function GetDebugInfo: string; override; public constructor Create(Script: TBoldDataBaseEvolutorScript; const ExpressionName, TableName: String; DbType: TBoldDbType); procedure Execute; @@ -70,6 +79,8 @@ TBoldDeleteInstances = class(TBoldTableOperation) TBoldColumnOperation = class(TBoldTableOperation) private fColumnName: String; + protected + function GetDebugInfo: string; override; public constructor Create(Script: TBoldDataBaseEvolutorScript; const TableName, ColumnName: String); property ColumnName: String read fColumnName; @@ -78,6 +89,8 @@ TBoldColumnOperation = class(TBoldTableOperation) TBoldAddColumn = class(TBoldScriptOperation) private fColumnDesc: TBoldSQLColumnDescription; + protected + function GetDebugInfo: string; override; public constructor Create(Script: TBoldDataBaseEvolutorScript; ColumnDesc: TBoldSQLColumnDescription); procedure Execute; @@ -93,6 +106,8 @@ TBoldDropIndex = class(TBoldScriptOperation) private fIndexName: String; fTableName: String; + protected + function GetDebugInfo: string; override; public constructor Create(Script: TBoldDataBaseEvolutorScript; const IndexName: String; const TableName: String); procedure Execute; @@ -100,10 +115,23 @@ TBoldDropIndex = class(TBoldScriptOperation) property TableName: string read fTableName; end; + TBoldAddIndex = class(TBoldScriptOperation) + private + fIndexDescription: TBoldSQLIndexDescription; + protected + function GetDebugInfo: string; override; + public + constructor Create(Script: TBoldDataBaseEvolutorScript; IndexDescription: TBoldSQLIndexDescription); + procedure Execute; + property IndexDescription: TBoldSQLIndexDescription read fIndexDescription; + end; + TBoldTwoTableOperation = class(TBoldScriptOperation) private fSourceTable: String; fTargetTable: String; + protected + function GetDebugInfo: string; override; public constructor Create(Script: TBoldDataBaseEvolutorScript; const SourceTable, TargetTable: String); property SourceTable: String read fSourceTable; @@ -142,6 +170,8 @@ TBoldMoveData = class(TBoldTwoColumnOperation) fdbTypes: string; fAlsoMoveData: TBoldMoveData; function GetSignature: String; + protected +// function GetDebugInfo: string; override; public constructor Create(Script: TBoldDataBaseEvolutorScript; const SourceTable, TargetTable, SourceColumn, TargetColumn, IdColumns: String; dbType: TBoldDbType); destructor Destroy; override; @@ -162,6 +192,7 @@ TBoldDataBaseEvolutorScript = class fDroppedTables: TBoldObjectArray; fMovedData: TBoldObjectArray; fDroppedIndices: TBoldObjectArray; + fAddedIndices: TBoldObjectArray; fScript: TStrings; fDataBase: IBoldDataBase; fSQLDataBaseConfig: TBoldSQLDatabaseConfig; @@ -178,6 +209,7 @@ TBoldDataBaseEvolutorScript = class function GetMovedData(index: integer): TBoldMoveData; function GetDeletedInstances(index: integer): TBoldDeleteInstances; function GetDroppedIndices(index: integer): TBoldDropIndex; + function GetAddedIndices(index: integer): TBoldAddIndex; procedure ExtendSchema; procedure AdjustContents; procedure ReduceSchema; @@ -185,6 +217,8 @@ TBoldDataBaseEvolutorScript = class procedure StartTransaction; procedure CommitTransaction; procedure RollBackTransaction; + function CopyInstancesExists(const sExpressionName, sSourceTable, + sTargetTable, sidColumns: string; aSourceDbType: TBoldDbType): Boolean; protected procedure Execute; property AddedTables[index: integer]: TBoldAddTable read GetAddedTables; @@ -192,15 +226,21 @@ TBoldDataBaseEvolutorScript = class property DroppedTables[index: integer]: TBoldDropTable read GetDroppedTables; property DroppedColumns[index: integer]: TBoldDropColumn read GetDroppedColumns; property DroppedIndices[index: integer]: TBoldDropIndex read GetDroppedIndices; + property AddedIndices[index: integer]: TBoldAddIndex read GetAddedIndices; property CopiedInstances[index: integer]: TBoldCopyInstances read GetCopiedInstances; property MovedData[index: integer]: TBoldMoveData read GetMovedData; property DeletedInstances[index: integer]: TBoldDeleteInstances read GetDeletedInstances; public constructor Create; destructor Destroy; override; + function HasDropColumn(const TableName, ColumnName: String): boolean; + function HasDropIndex(const IndexName: String; const TableName: string): boolean; + function HasAddIndex(IndexDescription: TBoldSQLIndexDescription): boolean; + function HasAddColumn(ColumnDesc: TBoldSQLColumnDescription): boolean; procedure AddTable(TableDescr: TBoldSQLTableDescription); procedure AddColumn(ColumnDesc: TBoldSQLColumnDescription); procedure DropIndex(const IndexName: String; const TableName: string); + procedure AddIndex(IndexDescription: TBoldSQLIndexDescription); procedure DropColumn(const TableName, ColumnName: String); procedure DropTable(const TableName: String); procedure CopyInstances(const ExpressionName, SourceTable, TargetTable, IdColumns: String; SourceDbType: TBoldDbType); @@ -213,14 +253,13 @@ TBoldDataBaseEvolutorScript = class property InternalLog: TStringList read fInternalLog; end; - implementation uses SysUtils, BoldGuard, BoldUtils, - BoldPMConsts; + Boldrev; { TBoldAddTable } @@ -235,9 +274,9 @@ procedure TBoldAddTable.Execute; i: integer; index: TBoldSQLIndexDescription; begin - Script.Comment(sAddTable, [TableDescr.SQLName]); + Script.Comment('Add table %s', [TableDescr.SQLName]); Script.ExecuteSQL(TableDescr.SQLForCreateTable(Script.fDataBase), []); - for i := 0 to TableDescr.IndexList.Count - 1 do + for i := 0 to TableDescr.IndexList.Count-1 do begin index := TableDescr.IndexList[i] as TBoldSQLIndexDescription; if not (ixPrimary in Index.IndexOptions) then @@ -245,26 +284,56 @@ procedure TBoldAddTable.Execute; end; end; +function TBoldAddTable.GetDebugInfo: string; +begin + result := ClassName + ':' + TableDescr.SQLName; +end; + { TBoldDataBaseEvolutorScript } procedure TBoldDataBaseEvolutorScript.AddColumn(ColumnDesc: TBoldSQLColumnDescription); +begin + if not HasAddColumn(ColumnDesc) then + fAddedColumns.Add(TBoldAddColumn.Create(self, ColumnDesc)); +end; + +procedure TBoldDataBaseEvolutorScript.AddTable(TableDescr: TBoldSQLTableDescription); var i: integer; begin - for i := 0 to fAddedColumns.Count - 1 do - if AddedColumns[i].ColumnDesc = ColumnDesc then + for i := 0 to fAddedTables.Count - 1 do + if AddedTables[i].TableDescr = TableDescr then exit; - fAddedColumns.Add(TBoldAddColumn.Create(self, ColumnDesc)); + fAddedTables.Add(TBoldAddTable.Create(self, TableDescr)); end; -procedure TBoldDataBaseEvolutorScript.AddTable(TableDescr: TBoldSQLTableDescription); +function TBoldDataBaseEvolutorScript.CopyInstancesExists(const sExpressionName, + sSourceTable, sTargetTable, sidColumns: string; + aSourceDbType: TBoldDbType): Boolean; +var + i: Integer; + aCopyInstances: TBoldCopyInstances; begin - fAddedTables.Add(TBoldAddTable.Create(self, TableDescr)); + Result := False; + for i := 0 to (fCopiedInstances.Count - 1) do begin + aCopyInstances := GetCopiedInstances(i); + Result := (aCopyInstances.fExpressionName = sExpressionName) + and (aCopyInstances.fSourceTable = sSourceTable) + and (aCopyInstances.fTargetTable = sTargetTable) + and (aCopyInstances.fIdColumns = sidColumns) + and (aCopyInstances.fSourceDbType = aSourceDbType); + if Result then begin + Break; + end; + end; end; procedure TBoldDataBaseEvolutorScript.CopyInstances(const ExpressionName, SourceTable, TargetTable, IdColumns: String; SourceDbType: TBoldDbType); begin - fCopiedInstances.Add(TBoldCopyInstances.Create(self, ExpressionName, SourceTable, TargetTable, IdColumns, SourceDbType)); + // prevent, that 2 identical instances of TBoldCopyInstance are added here: + if not CopyInstancesExists(ExpressionName, SourceTable, TargetTable, idColumns, SourceDbType) then begin + fCopiedInstances.Add(TBoldCopyInstances.Create(self, ExpressionName, SourceTable, TargetTable, IdColumns, SourceDbType)); + end; end; constructor TBoldDataBaseEvolutorScript.Create; @@ -276,9 +345,9 @@ constructor TBoldDataBaseEvolutorScript.Create; fDeletedInstances := TBoldObjectArray.Create(10, [bcoDataOwner]); fDroppedColumns := TBoldObjectArray.Create(10, [bcoDataOwner]); fDroppedTables := TBoldObjectArray.Create(10, [bcoDataOwner]); - // the MoveData-list can not own its instances since they will be moved from there during OptimizeScript fMovedData := TBoldObjectArray.Create(10, []); fDroppedIndices := TBoldObjectArray.Create(10, [bcoDataOwner]); + fAddedIndices := TBoldObjectArray.Create(10, [bcoDataOwner]); fSQLStatements := TStringList.Create; fInternalLog := TStringList.Create; end; @@ -299,7 +368,8 @@ destructor TBoldDataBaseEvolutorScript.Destroy; FreeAndNil(fDroppedColumns); FreeAndNil(fDroppedTables); FreeAndNil(fDroppedIndices); - for i := 0 to fMovedData.Count - 1 do + FreeAndNil(fAddedIndices); + for i := 0 to fMovedData.Count-1 do fMovedData[i].Free; FreeAndNil(fMovedData); FreeAndNil(fSQLStatements); @@ -308,19 +378,18 @@ destructor TBoldDataBaseEvolutorScript.Destroy; end; procedure TBoldDataBaseEvolutorScript.DropColumn(const TableName, ColumnName: String); -var - i: integer; begin - for i := 0 to fDroppedColumns.Count - 1 do - if SameText(DroppedColumns[i].TableName, TableName) and - SameText(DroppedColumns[i].ColumnName, ColumnName) then - exit; - - fDroppedColumns.Add(TBoldDropColumn.Create(self, TableName, ColumnName)); + if not HasDropColumn(TableName, ColumnName) then + fDroppedColumns.Add(TBoldDropColumn.Create(self, TableName, ColumnName)); end; procedure TBoldDataBaseEvolutorScript.DropTable(const TableName: String); +var + i: integer; begin + for i := 0 to fDroppedTables.Count - 1 do + if DroppedTables[i].TableName = TableName then + exit; fDroppedTables.Add(TBoldDropTable.Create(self, TableName)); end; @@ -361,7 +430,7 @@ function TBoldDataBaseEvolutorScript.GetAddedTables(index: integer): TBoldAddTab procedure TBoldDataBaseEvolutorScript.MoveData(const SourceTable, TargetTable, SourceColumn, TargetColumn, IdColumns: String; dbType: TBoldDbType); begin - if not SameText(TargetTable + '.' + TargetColumn, SourceTable + '.' + SourceColumn) then + if not SameText(TargetTable+'.'+TargetColumn, SourceTable+'.'+SourceColumn) then fMovedData.Add(TBoldMoveData.Create(self, SourceTable, TargetTable, SourceColumn, TargetColumn, IdColumns, dbType)); end; @@ -410,6 +479,12 @@ function TBoldDataBaseEvolutorScript.GetAddedColumns(index: integer): TBoldAddCo result := TBoldAddColumn(fAddedColumns[index]); end; +function TBoldDataBaseEvolutorScript.GetAddedIndices( + index: integer): TBoldAddIndex; +begin + result := fAddedIndices[Index] as TBoldAddIndex; +end; + function TBoldDataBaseEvolutorScript.GetDroppedColumns(index: integer): TBoldDropColumn; begin result := TBoldDropColumn(fDroppedColumns[index]); @@ -431,6 +506,64 @@ function TBoldDataBaseEvolutorScript.GetMovedData( result := TBoldMoveData(fMovedData[index]); end; +function TBoldDataBaseEvolutorScript.HasAddColumn( + ColumnDesc: TBoldSQLColumnDescription): boolean; + var + i: integer; +begin + result := false; + for i := 0 to fAddedColumns.Count-1 do + if AddedColumns[i].ColumnDesc=ColumnDesc then + begin + result := true; + exit; + end; +end; + +function TBoldDataBaseEvolutorScript.HasAddIndex( + IndexDescription: TBoldSQLIndexDescription): boolean; +var + i: integer; +begin + result := false; + for i := 0 to fAddedIndices.Count - 1 do + if AddedIndices[i].IndexDescription=IndexDescription then + begin + result := true; + exit; + end; +end; + +function TBoldDataBaseEvolutorScript.HasDropColumn(const TableName, + ColumnName: String): boolean; +var + i: integer; +begin + result := false; + for i := 0 to fDroppedColumns.Count - 1 do + if AnsiSameText(DroppedColumns[i].TableName, TableName) and + AnsiSameText(DroppedColumns[i].ColumnName, ColumnName) then + begin + result := true; + exit; + end; +end; + +function TBoldDataBaseEvolutorScript.HasDropIndex(const IndexName, + TableName: string): boolean; +var + i: integer; +begin + result := false; + for I := 0 to fDroppedIndices.Count - 1 do + if AnsiSameText(DroppedIndices[i].IndexName, IndexName) + and AnsiSameText(DroppedIndices[i].TableName, TableName) then + begin + result := true; + exit; + end; +end; + function TBoldDataBaseEvolutorScript.GetDeletedInstances(index: integer): TBoldDeleteInstances; begin result := TBoldDeleteInstances(fDeletedInstances[index]); @@ -462,7 +595,7 @@ procedure TBoldDataBaseEvolutorScript.OptimizeScript; i := 0; while i < fMovedData.Count do begin - for j := fMovedData.Count - 1 downto i + 1 do + for j := fMovedData.Count-1 downto i+1 do begin if (MovedData[j].DbTypes = MovedData[i].DbTypes) and SameText(MovedData[j].SourceTable, MovedData[i].SourceTable) and @@ -478,26 +611,29 @@ procedure TBoldDataBaseEvolutorScript.OptimizeScript; MoveDataSignatures := TStringList.Create; try - for i := 0 to fMovedData.Count - 1 do + for i := 0 to fMovedData.Count-1 do MoveDataSignatures.AddObject(MovedData[i].Signature, MovedData[i]); MoveDataSignatures.Sort; - for i := 1 to MoveDataSignatures.Count - 1 do - if MoveDataSignatures[i - 1] = MoveDataSignatures[i] then + for i := 1 to MoveDataSignatures.Count-1 do + if MoveDataSignatures[i-1] = MoveDataSignatures[i] then begin - MoveData1 := TBoldMoveData(MoveDataSignatures.Objects[i - 1]); + MoveData1 := TBoldMoveData(MoveDataSignatures.Objects[i-1]); MoveData2 := TBoldMoveData(MoveDataSignatures.Objects[i]); - MoveData2.fdbTypes := MoveData2.dbTypes + ', ' + MoveData1.dbTypes; + MoveData2.fdbTypes := MoveData2.dbTypes + ', '+ MoveData1.dbTypes; fMovedData.Remove(MoveData1); - MoveData1.Free; + MoveData1.Free; end; finally MoveDataSignatures.free; end; + + end; procedure TBoldDataBaseEvolutorScript.DropIndex(const IndexName: String; const TableNAme: String); begin - fDroppedIndices.Add(TBoldDropIndex.Create(self, IndexName, TableName)); + if not HasDropIndex(IndexName, TableName) then + fDroppedIndices.Add(TBoldDropIndex.Create(self, IndexName, TableName)); end; function TBoldDataBaseEvolutorScript.GetDroppedIndices(index: integer): TBoldDropIndex; @@ -505,6 +641,12 @@ function TBoldDataBaseEvolutorScript.GetDroppedIndices(index: integer): TBoldDro result := fDroppedIndices[Index] as TBoldDropIndex; end; +procedure TBoldDataBaseEvolutorScript.AddIndex(IndexDescription: TBoldSQLIndexDescription); +begin + if not HasAddIndex(IndexDescription) then + fAddedIndices.Add(TBoldAddIndex.Create(self, IndexDescription )); +end; + procedure TBoldDataBaseEvolutorScript.AddSQLStatement(const sql: String); begin fSQLStatements.Add(sql); @@ -521,13 +663,13 @@ procedure TBoldDataBaseEvolutorScript.AdjustContents; // and Interbase does not make metadata changes visible inside the transaction StartTransaction; try - for i := 0 to fCopiedInstances.Count - 1 do + for i := 0 to fCopiedInstances.Count-1 do CopiedInstances[i].Execute; - for i := 0 to fMovedData.Count - 1 do + for i := 0 to fMovedData.Count-1 do MovedData[i].Execute; - for i := 0 to fDeletedInstances.Count - 1 do + for i := 0 to fDeletedInstances.Count-1 do DeletedInstances[i].Execute; CommitTransaction; @@ -541,25 +683,25 @@ procedure TBoldDataBaseEvolutorScript.ExtendSchema; var i: integer; begin - if fAddedTables.Count + fAddedColumns.Count = 0 then + if fAddedTables.Count + fAddedColumns.Count + fAddedIndices.Count = 0 then Exit; // wrap all non MetaData changes in a transaction. // Many databases do not allow them in a transaction, // and Interbase does not make metadata changes visible inside the transaction - if fSQLDataBaseConfig.AllowMetadataChangesInTransaction then - StartTransaction; + StartTransaction; try - for i := 0 to fAddedTables.Count - 1 do + for i := 0 to fAddedTables.Count-1 do AddedTables[i].Execute; - for i := 0 to fAddedColumns.Count - 1 do + for i := 0 to fAddedColumns.Count-1 do AddedColumns[i].Execute; - if fSQLDataBaseConfig.AllowMetadataChangesInTransaction then - CommitTransaction; + for i := 0 to fAddedIndices.Count-1 do + AddedIndices[i].Execute; + + CommitTransaction; except - if fSQLDataBaseConfig.AllowMetadataChangesInTransaction then - RollBackTransaction; + RollBackTransaction; raise; end; @@ -571,8 +713,7 @@ procedure TBoldDataBaseEvolutorScript.ReduceSchema; begin if fDroppedIndices.Count + fDroppedColumns.Count + fDroppedtables.Count = 0 then Exit; - if fSQLDataBaseConfig.AllowMetadataChangesInTransaction then - StartTransaction; + StartTransaction; try for i := 0 to fDroppedIndices.Count - 1 do DroppedIndices[i].Execute; @@ -583,11 +724,9 @@ procedure TBoldDataBaseEvolutorScript.ReduceSchema; for i := 0 to fDroppedTables.Count - 1 do DroppedTables[i].Execute; - if fSQLDataBaseConfig.AllowMetadataChangesInTransaction then - CommitTransaction; + CommitTransaction; except - if fSQLDataBaseConfig.AllowMetadataChangesInTransaction then - RollBackTransaction; + RollBackTransaction; raise; end; end; @@ -620,6 +759,8 @@ procedure TBoldDataBaseEvolutorScript.AddCommandToScript(s: string); procedure TBoldDataBaseEvolutorScript.StartTransaction; begin + if not fSQLDataBaseConfig.AllowMetadataChangesInTransaction then + exit; if assigned(fDataBase) then fDataBase.StartTransaction; if assigned(fScript) then @@ -627,7 +768,11 @@ procedure TBoldDataBaseEvolutorScript.StartTransaction; end; procedure TBoldDataBaseEvolutorScript.CommitTransaction; +const + sCommittingToDB = 'Committing changes to database'; begin + if not fSQLDataBaseConfig.AllowMetadataChangesInTransaction then + exit; if assigned(fDataBase) and fDatabase.InTransaction then begin BoldLog.Log(sCommittingToDB); @@ -635,17 +780,21 @@ procedure TBoldDataBaseEvolutorScript.CommitTransaction; end; if assigned(fScript) then AddCommandToScript(fSQLDataBaseConfig.SqlScriptCommitTransaction); - end; procedure TBoldDataBaseEvolutorScript.RollBackTransaction; +const + sRollingBackDB = 'Rolling back database changes'; begin + if not fSQLDataBaseConfig.AllowMetadataChangesInTransaction then + exit; if assigned(fDataBase) and fDatabase.InTransaction then begin BoldLog.Log(sRollingBackDB); fDataBase.RollBack; end; - AddCommandToScript(fSQLDataBaseConfig.SqlScriptRollBackTransaction); + if assigned(fScript) then + AddCommandToScript(fSQLDataBaseConfig.SqlScriptRollBackTransaction); end; { TBoldAddColumn } @@ -661,15 +810,14 @@ procedure TBoldAddColumn.Execute; i: integer; index: TBoldSQLIndexDescription; begin - Script.Comment(sAddColumn, [ColumnDesc.TableDescription.SQLName, ColumnDesc.SQLName]); - Script.ExecuteSQL( 'ALTER TABLE %s ADD %s', [ColumnDesc.TableDescription.SQLName, ColumnDesc.GetSQLForColumn(Script.fDataBase)]); // do not localize + Script.Comment('Add column %s.%s', [ColumnDesc.TableDescription.SQLName, ColumnDesc.SQLName]); + Script.ExecuteSQL( 'ALTER TABLE %s ADD %s', [ColumnDesc.TableDescription.SQLName, ColumnDesc.GetSQLForColumn(Script.fDataBase)]); + // There was code to also add index here, but we removed it as indexes are handled by separate AddIndex Operation +end; - for i := 0 to ColumnDesc.TableDescription.IndexList.Count - 1 do - begin - Index := ColumnDesc.TableDescription.IndexList[i] as TBoldSQLIndexDescription; - if SameText(Index.IndexedFields, ColumnDesc.SQLName) then - Script.ExecuteSQL(Index.SQLForSecondaryKey, []); - end; +function TBoldAddColumn.GetDebugInfo: string; +begin + result := ClassName + ':' + ColumnDesc.TableDescription.SQLName + '.' + ColumnDesc.SQLName; end; { TBoldCopyInstances } @@ -700,7 +848,7 @@ procedure TBoldCopyInstances.Execute; WhereConds: TStringList; SelectColumn: string; begin - Script.Comment(sAddInstanceOfClassToTable, [ExpressionName, TargetTable]); + Script.Comment('Add Instances of class %s to table %s', [ExpressionName, TargetTable]); SourceColumns := TStringList.Create; TargetColumns := TStringList.Create; IdColumnList := TStringList.Create; @@ -709,7 +857,7 @@ procedure TBoldCopyInstances.Execute; try SourceTables.Add(SourceTable); IdColumnList.Commatext := IdColumns; - for i := 0 to IdColumnLIst.Count - 1 do + for i := 0 to IdColumnLIst.Count-1 do begin SourceColumns.Add(SourceTable + '.' + IdColumnList[i]); TargetColumns.Add(IdColumnList[i]); @@ -717,28 +865,27 @@ procedure TBoldCopyInstances.Execute; LocalMoveData := MoveData; while assigned(LocalMoveData) do begin - Script.Comment(sMoveDataFromXtoY, [LocalMoveData.SourceTable, LocalMoveData.SourceColumn, LocalMoveData.TargetTable, LocalMoveData.TargetColumn, LocalMoveData.DbTypes]); + Script.Comment('Move data from %s.%s to %s.%s (dbtypes: %s)', [LocalMoveData.SourceTable, LocalMoveData.SourceColumn, LocalMoveData.TargetTable, LocalMoveData.TargetColumn, LocalMoveData.DbTypes]); if SourceTables.IndexOf(LocalMoveData.SourceTable) = -1 then SourceTables.Add(LocalMoveData.SourceTable); SelectColumn := LocalMoveData.SourceTable + '.' + LocalMoveData.SourceColumn; - // Renamed column needs alias if not SameText(LocalMoveData.SourceColumn, LocalMoveData.TargetColumn) then - SelectColumn := SelectColumn + ' AS ' + LocalMoveData.TargetColumn; // do not localize + SelectColumn := SelectColumn + ' AS ' + LocalMoveData.TargetColumn; SourceColumns.Add(SelectColumn); TargetColumns.Add(LocalMoveData.TargetColumn); LocalMoveData := LocalMoveData.AlsoMoveData; end; - sql := 'INSERT INTO %s (BOLD_TYPE, %s) SELECT %s.BOLD_TYPE, %s FROM %s%s'; // do not localize + sql := 'INSERT INTO %s (BOLD_TYPE, %s) SELECT %s.BOLD_TYPE, %s FROM %s%s'; - for i := 1 to SourceTables.Count - 1 do - for j := 0 to IdColumnList.Count - 1 do - WhereConds.Add(Format('%s.%s = %s.%s', [ // do not localize + for i := 1 to SourceTables.Count-1 do + for j := 0 to IdColumnList.Count-1 do + WhereConds.Add(Format('%s.%s = %s.%s', [ SourceTables[0], IdColumnList[j], SourceTables[i], IdColumnList[j]])); if SourceDbType <> NO_CLASS then - WhereConds.Add(Format('BOLD_TYPE = %d', [SourceDbType])); // do not localize + WhereConds.Add(Format('BOLD_TYPE = %d', [SourceDbType])); Script.ExecuteSQL(sql, [ TargetTable, @@ -746,7 +893,7 @@ procedure TBoldCopyInstances.Execute; SourceTable, BoldSeparateStringList(SourceColumns, ', ', '', ''), BoldSeparateStringList(SourceTables, ', ', '', ''), - BoldSeparateStringList(WhereConds, ' AND ', ' WHERE ', '')]); // do not localize + BoldSeparateStringList(WhereConds, ' AND ', ' WHERE ', '')]); finally SourceColumns.Free; SourceTables.Free; @@ -767,8 +914,13 @@ constructor TBoldDeleteInstances.Create(Script: TBoldDataBaseEvolutorScript; con procedure TBoldDeleteInstances.Execute; begin - Script.Comment(sDeleteInstancesOfClassFromTable, [ExpressionName, TableName]); - Script.ExecuteSQL('DELETE FROM %s WHERE BOLD_TYPE = %d', [TableName, DbType]); // do not localize + Script.Comment('Delete instances of %s from table %s', [ExpressionName, TableName]); + Script.ExecuteSQL('DELETE FROM %s WHERE BOLD_TYPE = %d', [TableName, DbType]); +end; + +function TBoldDeleteInstances.GetDebugInfo: string; +begin + result := ClassName + ':' + ExpressionName; end; { TBoldTableOperation } @@ -779,6 +931,11 @@ constructor TBoldTableOperation.Create(Script: TBoldDataBaseEvolutorScript; cons fTableName := TableName; end; +function TBoldTableOperation.GetDebugInfo: string; +begin + result := ClassName + ':' + TableName; +end; + { TBoldColumnOperation } constructor TBoldColumnOperation.Create(Script: TBoldDataBaseEvolutorScript; const TableName, ColumnName: String); @@ -787,6 +944,11 @@ constructor TBoldColumnOperation.Create(Script: TBoldDataBaseEvolutorScript; con fColumnName := ColumnName; end; +function TBoldColumnOperation.GetDebugInfo: string; +begin + result := ClassName + ':' + ColumnName; +end; + { TBoldTwoTableOperation } constructor TBoldTwoTableOperation.Create(Script: TBoldDataBaseEvolutorScript; const SourceTable, TargetTable: String); @@ -796,6 +958,11 @@ constructor TBoldTwoTableOperation.Create(Script: TBoldDataBaseEvolutorScript; c fTargetTable := TargetTable; end; +function TBoldTwoTableOperation.GetDebugInfo: string; +begin + result := ClassName + ':' + SourceTable + '->' + TargetTable; +end; + { TBoldTwoColumnOperation } constructor TBoldTwoColumnOperation.Create(Script: TBoldDataBaseEvolutorScript; const SourceTable, TargetTable, SourceColumn, TargetColumn: String); @@ -839,34 +1006,34 @@ procedure TBoldMoveData.Execute; SelectColumns := TStringList.Create; IdColumnList := TStringList.Create; IdColumnJoins := TStringList.Create; - + LocalMoveData := self; while assigned(LocalMoveData) do begin - Script.Comment(sMoveDataFromXtoY, [LocalMoveData.SourceTable, LocalMoveData.SourceColumn, LocalMoveData.TargetTable, LocalMoveData.TargetColumn, LocalMoveData.DbTypes]); + Script.Comment('Move data from %s.%s to %s.%s (dbtype: %s)', [LocalMoveData.SourceTable, LocalMoveData.SourceColumn, LocalMoveData.TargetTable, LocalMoveData.TargetColumn, LocalMoveData.DbTypes]); SourceColumns.Add(LocalMoveData.SourceColumn); TargetColumns.Add(LocalMoveData.TargetColumn); LocalMoveData := LocalMoveData.AlsoMoveData; end; if SameText(SourceTable, TargetTable) then begin - for i := 0 to SourceColumns.Count - 1 do - CopyStatements.Add(format('%s = %s', [TargetColumns[i], SourceColumns[i]])); // do not localize - Script.ExecuteSQL('UPDATE %s SET %s WHERE BOLD_TYPE IN (%s)', [TargetTable, BoldSeparateStringList(CopyStatements, ', ', '', ''), dbTypes]); // do not localize + for i := 0 to SourceColumns.Count-1 do + CopyStatements.Add(format('%s = %s', [TargetColumns[i], SourceColumns[i]])); + Script.ExecuteSQL('UPDATE %s SET %s WHERE BOLD_TYPE IN (%s)', [TargetTable, BoldSeparateStringList(CopyStatements, ', ', '', ''), dbTypes]); end else begin IdColumnList.CommaText := IdColumns; - for i := 0 to IdColumnList.Count - 1 do - IdColumnJoins.Add(format('Source.%s = Target.%s', [IdColumnList[i], IdColumnList[i]])); // do not localize + for i := 0 to IdColumnList.Count-1 do + IdColumnJoins.Add(format('Source.%s = Target.%s', [IdColumnList[i], IdColumnList[i]])); - for i := 0 to SourceColumns.Count - 1 do - SelectColumns.Add(format('%s = (SELECT %s FROM %s Source WHERE %s)', [ // do not localize + for i := 0 to SourceColumns.Count-1 do + SelectColumns.Add(format('%s = (SELECT %s FROM %s Source WHERE %s)', [ SourceColumns[i], TargetColumns[i], SourceTable, - BoldSeparateStringList(IdColumnJoins, ' AND ', '', '')])); // do not localize - Script.ExecuteSQL('UPDATE %s Target SET %s WHERE BOLD_TYPE IN (%s)', [TargetTable, BoldSeparateStringList(SelectColumns, ', ', '', ''), DbTypes]); // do not localize + BoldSeparateStringList(IdColumnJoins, ' AND ', '', '')])); + Script.ExecuteSQL('UPDATE %s Target SET %s WHERE BOLD_TYPE IN (%s)', [TargetTable, BoldSeparateStringList(SelectColumns, ', ', '', ''), DbTypes]); end; end; @@ -902,10 +1069,15 @@ constructor TBoldDropIndex.Create(Script: TBoldDataBaseEvolutorScript; const Ind procedure TBoldDropIndex.Execute; begin - Script.Comment(sDropIndex, [IndexName]); + Script.Comment('Drop index %s', [IndexName]); Script.ExecuteSQL(Script.fSqlDatabaseConfig.GetDropIndexQuery(TableName, IndexName), []); end; +function TBoldDropIndex.GetDebugInfo: string; +begin + result := ClassName + ':' + TableName + '.' + IndexName; +end; + { TBoldScriptOperation } constructor TBoldScriptOperation.Create(Script: TBoldDataBaseEvolutorScript); @@ -918,7 +1090,7 @@ constructor TBoldScriptOperation.Create(Script: TBoldDataBaseEvolutorScript); procedure TBoldDropColumn.Execute; begin - Script.Comment(sDropColumn, [TableName, ColumnName]); + Script.Comment('Drop column %s.%s', [TableName, ColumnName]); Script.ExecuteSQL(Script.fSqlDatabaseConfig.GetDropColumnQuery(TableName, ColumnName), []); end; @@ -926,10 +1098,27 @@ procedure TBoldDropColumn.Execute; procedure TBoldDropTable.Execute; begin - Script.Comment(sDropTable, [TableName]); + Script.Comment('Drop table %s', [TableName]); Script.ExecuteSQL(Script.fSqlDatabaseConfig.GetDropTableQuery(TableName), []); end; -end. +{ TBoldAddIndex } + +constructor TBoldAddIndex.Create(Script: TBoldDataBaseEvolutorScript; IndexDescription: TBoldSQLIndexDescription); +begin + inherited Create(Script); + fIndexDescription := IndexDescription; +end; +procedure TBoldAddIndex.Execute; +begin + Script.Comment('Create index %s %s:[%s] ', [IndexDescription.GeneratedName, IndexDescription.TableDescription.SQLNAme, IndexDescription.IndexedFields]); + Script.ExecuteSQL(IndexDescription.SQLForSecondaryKey, []); +end; +function TBoldAddIndex.GetDebugInfo: string; +begin + result := ClassName + ':' + IndexDescription.IndexedFields; +end; + +end. diff --git a/Source/PMapper/Default/BoldCustomBlobMapper.pas b/Source/PMapper/Default/BoldCustomBlobMapper.pas index 2eabd5c4..52b8ec40 100644 --- a/Source/PMapper/Default/BoldCustomBlobMapper.pas +++ b/Source/PMapper/Default/BoldCustomBlobMapper.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldCustomBlobMapper; interface @@ -16,7 +19,7 @@ interface type TBoldPMBlobWithSeparateTable = class(TBoldMemberDefaultMapper) private - function GetBlobValue(Id: TBoldObjectId; ValueSpace: IBoldValueSpace): IBoldBlobContent; + function GetBlobValue(Id: TBoldObjectId; const ValueSpace: IBoldValueSpace): IBoldBlobContent; function IdListToString(IdList: TBoldObjectIdList): String; protected function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; override; @@ -24,14 +27,14 @@ TBoldPMBlobWithSeparateTable = class(TBoldMemberDefaultMapper) function GetColumnCount: Integer; override; function GetColumnSize(ColumnIndex: Integer): Integer; override; function GetInitialColumnName(ColumnIndex: Integer): string; override; - function CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; procedure InitializePSDescriptions; override; public constructor CreateFromMold(moldMember: TMoldMember; moldClass: TMoldClass; Owner: TBoldObjectPersistenceMapper; const MemberIndex: Integer; TypeNameDictionary: TBoldTypeNameDictionary); override; - procedure PMFetch(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; FetchMode: Integer; TranslationList: TBoldIdTranslationList; FailureList: TBoldObjectIdList); override; - procedure PMCreate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); override; - procedure PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); override; - procedure PMDelete(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); override; + procedure PMFetch(ObjectIdList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; FetchMode: Integer; TranslationList: TBoldIdTranslationList; FailureList: TBoldObjectIdList); override; + procedure PMCreate(ObjectIdList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); override; + procedure PMUpdate(ObjectIdList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); override; + procedure PMDelete(ObjectIdList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); override; class function CanStore(const ContentName: String): Boolean; override; end; @@ -44,13 +47,12 @@ implementation BoldDefs, BoldPMapperLists, BoldMemberTypeDictionary, - BoldDefaultStreamNames, - BoldPMConsts; + BoldDefaultStreamNames; {const MemberNameColumn = 'MEMBERNAME'; } - + const BLOBDATA_TABLENAME = 'BLOBDATATABLE'; BLOBDATA_DATACOLUMNNAME = 'BLOBDATA'; @@ -78,8 +80,8 @@ function TBoldPMBlobWithSeparateTable.GetColumnTypeAsSQL(ColumnIndex: Integer): 0: result := SystemPersistenceMapper.SQLDataBaseConfig.ColumnTypeForInteger; 1: result := format(SystemPersistenceMapper.SQLDataBaseConfig.ColumnTypeForString, [ColumnSize[ColumnIndex]] ); 2: result := SystemPersistenceMapper.SQLDataBaseConfig.ColumnTypeForBlob; - else - raise EBold.CreateFmt(sIllegalColumnIndex, [classname, 'GetColumnTypeAsSQL', columnIndex] ); // do not localize + else + raise EBold.CreateFmt( '%s.GetColumnTypeAsSQL: unknown column (%d)', [classname, columnIndex] ); end; end; @@ -113,15 +115,15 @@ constructor TBoldPMBlobWithSeparateTable.CreateFromMold(moldMember: TMoldMember; begin inherited; if length(ExpressionName) > ColumnSize[1] then - raise EBold.CreateFmt(sMemberNameTooLong, [ClassName, ExpressionName, ColumnSize[1]] ); + raise EBold.CreateFmt( '%s.CreateFromMold: Too long MemberName (%s) - %d characters allowed', [ClassName, ExpressionName, ColumnSize[1]] ); fCustomCreateUpDate := true; fCustomFetch := true; if MoldClass.Versioned then - raise EBold.CreateFmt( sVersionedClassesNotSupported, [ClassName, MoldClass.ExpressionName]); + raise EBold.CreateFmt( '%s.CreateFromMold: Versioned classes (%s) currently not supported by this blobmapper', [ClassName, MoldClass.ExpressionName]); end; -procedure TBoldPMBlobWithSeparateTable.PMFetch(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; FetchMode: Integer; TranslationList: TBoldIdTranslationList; FailureList: TBoldObjectIdList); +procedure TBoldPMBlobWithSeparateTable.PMFetch(ObjectIdList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; FetchMode: Integer; TranslationList: TBoldIdTranslationList; FailureList: TBoldObjectIdList); var q : IBoldQuery; Id: TBoldObjectId; @@ -135,7 +137,7 @@ procedure TBoldPMBlobWithSeparateTable.PMFetch(ObjectIdList: TBoldObjectIdList; try ActionList.AddList(ObjectIdlist); - sql := Format('SELECT %s, %s FROM %s WHERE %s IN (%s) AND UPPER(%s) = ''%s''', [ // do not localize + sql := Format('SELECT %s, %s FROM %s WHERE %s IN (%s) AND UPPER(%s) = ''%s''', [ IDCOLUMN_NAME, BLOBDATA_DATACOLUMNNAME, BLOBDATA_TABLENAME, IDCOLUMN_NAME, IdListToString(ActionList), BLOBDATA_MEMBERCOLUMNNAME, UpperCase(ExpressionName) ] ); @@ -144,7 +146,9 @@ procedure TBoldPMBlobWithSeparateTable.PMFetch(ObjectIdList: TBoldObjectIdList; q.Open; while not q.Eof do begin - Id := SystemPersistenceMapper.NewIdFromQuery(q, -1, 0, BOLDMAXTIMESTAMP); + // ClassId param -1 was added due to changes in signature of NewIdFromQuery, + // check if we can replace -1 with known ClassId if possible in order to get ExactId right away - Daniel + Id := SystemPersistenceMapper.NewIdFromQuery(q, -1, -1, 0, BOLDMAXTIMESTAMP); try value := GetBlobValue(Id, ValueSpace); Value.asBlob := q.Fields[1].AsBlob; @@ -165,29 +169,30 @@ procedure TBoldPMBlobWithSeparateTable.PMFetch(ObjectIdList: TBoldObjectIdList; end; end; -procedure TBoldPMBlobWithSeparateTable.PMCreate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); +procedure TBoldPMBlobWithSeparateTable.PMCreate(ObjectIdList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); var q: IBoldExecQuery; value: IBoldBlobContent; i: integer; - param: IBoldParameter; + IdParam, DataParam: IBoldParameter; begin Q := SystemPersistenceMapper.GetExecQuery; try - q.AssignSQLText(Format('INSERT INTO %s (%s, %s, %s) VALUES (:%s, :%s, :%s)', // do not localize + q.ParamCheck := true; + q.AssignSQLText(Format('INSERT INTO %s (%s, %s, %s) VALUES (:%s, :%s, :%s)', [BLOBDATA_TABLENAME, IDCOLUMN_NAME, BLOBDATA_MEMBERCOLUMNNAME, BLOBDATA_DATACOLUMNNAME, IDCOLUMN_NAME, BLOBDATA_MEMBERCOLUMNNAME, BLOBDATA_DATACOLUMNNAME])); q.ParamByName(BLOBDATA_MEMBERCOLUMNNAME).AsString := UpperCase(ExpressionName); + IdParam := q.ParamByName(IDCOLUMN_NAME); + DataParam := q.ParamByName(BLOBDATA_DATACOLUMNNAME); for i := 0 to ObjectIdList.Count-1 do begin - q.ParamByName(IDCOLUMN_NAME).AsInteger := StrToInt(TranslationList.TranslateToNewId[ObjectIdList[i]].AsString); + IdParam.AsInteger := StrToInt(TranslationList.TranslateToNewId[ObjectIdList[i]].AsString); Value := GetBlobValue(ObjectIdList[i], ValueSpace); - Param := q.ParamByName(BLOBDATA_DATACOLUMNNAME); - Param.DataType := SystemPersistenceMapper.SQLDataBaseConfig.FieldTypeForBlob; -//marco Param.AsBlob := Value.asBlob; + DataParam.AsBlob := Value.asBlob; q.ExecSQL; end; finally @@ -195,35 +200,35 @@ procedure TBoldPMBlobWithSeparateTable.PMCreate(ObjectIdList: TBoldObjectIdList; end; end; -procedure TBoldPMBlobWithSeparateTable.PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); +procedure TBoldPMBlobWithSeparateTable.PMUpdate(ObjectIdList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); var q : IBoldExecQuery; i: integer; sql: string; value: IBoldBlobContent; - param: IBoldParameter; + IdParam, DataParam: IBoldParameter; begin Q := SystemPersistenceMapper.GetExecQuery; try - sql := Format('UPDATE %s SET %s = :%s WHERE %s = :%s AND UPPER(%s) = ''%s''', [ // do not localize + q.ParamCheck := true; + sql := Format('UPDATE %s SET %s = :%s WHERE %s = :%s AND UPPER(%s) = ''%s''', [ BLOBDATA_TABLENAME, BLOBDATA_DATACOLUMNNAME, BLOBDATA_DATACOLUMNNAME, IDCOLUMN_NAME, IDCOLUMN_NAME, BLOBDATA_MEMBERCOLUMNNAME, UpperCase(ExpressionName)]); q.AssignSQLText(sql); + IdParam := q.ParamByName(IDCOLUMN_NAME); + DataParam := q.ParamByName(BLOBDATA_DATACOLUMNNAME); for i := 0 to ObjectIdList.Count-1 do begin Value := GetBlobValue(ObjectIdList[i], ValueSpace); if Value.IsNull then - q.ParamByName(BLOBDATA_DATACOLUMNNAME).Clear + DataParam.Clear else - begin - Param := q.ParamByName(BLOBDATA_DATACOLUMNNAME); - Param.DataType := SystemPersistenceMapper.SQLDataBaseConfig.FieldTypeForBlob; -//marco Param.AsBlob := Value.asBlob; - end; - q.ParamByName(IDCOLUMN_NAME).AsInteger := StrToInt(ObjectIdList[i].AsString); + DataParam.AsBlob := Value.asBlob; + + IdParam.AsInteger := StrToInt(ObjectIdList[i].AsString); q.ExecSQL; end; finally @@ -231,13 +236,13 @@ procedure TBoldPMBlobWithSeparateTable.PMUpdate(ObjectIdList: TBoldObjectIdList; end; end; -procedure TBoldPMBlobWithSeparateTable.PMDelete(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); +procedure TBoldPMBlobWithSeparateTable.PMDelete(ObjectIdList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); var q: IBoldExecQuery; begin Q := SystemPersistenceMapper.GetExecQuery; try - q.AssignSQLText(Format( 'DELETE FROM %s WHERE %s IN (%s) AND UPPER(%s) = ''%s''', [ // do not localize + q.AssignSQLText(Format( 'DELETE FROM %s WHERE %s IN (%s) AND UPPER(%s) = ''%s''', [ BLOBDATA_TABLENAME, IDColumn_NAME, IdListToString(ObjectIdList), BLOBDATA_MEMBERCOLUMNNAME, UpperCase(ExpressionName)])); @@ -252,7 +257,7 @@ class function TBoldPMBlobWithSeparateTable.CanStore(const ContentName: String): result := ContentName = BoldContentName_Blob; end; -function TBoldPMBlobWithSeparateTable.GetBlobValue(Id: TBoldObjectId; ValueSpace: IBoldValueSpace): IBoldBlobContent; +function TBoldPMBlobWithSeparateTable.GetBlobValue(Id: TBoldObjectId; const ValueSpace: IBoldValueSpace): IBoldBlobContent; var ObjectContents: IBoldObjectContents; value: IBoldValue; @@ -260,16 +265,16 @@ function TBoldPMBlobWithSeparateTable.GetBlobValue(Id: TBoldObjectId; ValueSpace begin Objectcontents := ValueSpace.ObjectContentsByObjectId[ID]; if not assigned(ObjectContents) then - raise Exception.CreateFmt(sObjectNotInValueSpace, [ClassName, ObjectpersistenceMapper.ExpressionName, ExpressionName, Id.AsString]); + raise Exception.CreateFmt('%s.GetBlobValue: Trying to get blob value for %s.%s, but the object (ID: %s) is not in the ValueSpace', [ClassName, ObjectpersistenceMapper.ExpressionName, ExpressionName, Id.AsString]); MemberID := TBoldMemberId.Create(MemberIndex); ObjectContents.EnsureMember(MemberID, ContentName); MemberID.Free; value := ObjectContents.ValueByIndex[MemberIndex]; if not assigned(value) then - raise Exception.CreateFmt(sValueNotInValueSpace, [ClassName, ObjectpersistenceMapper.ExpressionName, ExpressionName, Id.AsString]); + raise Exception.CreateFmt('%s.GetBlobValue: Trying to get blob value for %s.%s, but the value (ID: %s) is not in the ValueSpace', [ClassName, ObjectpersistenceMapper.ExpressionName, ExpressionName, Id.AsString]); if not value.QueryInterface(IBoldBlobContent, result) = S_OK then - raise Exception.CreateFmt(sValueNotBlob, [ClassName, ObjectpersistenceMapper.ExpressionName, ExpressionName]); + raise Exception.CreateFmt('%s.GetBlobValue: Trying to get blob value for %s.%s, but the value was not a blob...', [ClassName, ObjectpersistenceMapper.ExpressionName, ExpressionName]); end; function TBoldPMBlobWithSeparateTable.IdListToString(IdList: TBoldObjectIdList): String; @@ -286,11 +291,11 @@ function TBoldPMBlobWithSeparateTable.IdListToString(IdList: TBoldObjectIdList): end; function TBoldPMBlobWithSeparateTable.CompareField( - ObjectContent: IBoldObjectContents; Field: IBoldField; - ColumnIndex: integer; ValueSpace: IBoldValueSpace; + const ObjectContent: IBoldObjectContents; const Field: IBoldField; + ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; begin - raise Exception.CreateFmt(sCustomCompareRequired, [ClassName]); + raise Exception.CreateFmt('%s.CompareField: needs a custom Compare to do this', [ClassName]); end; procedure TBoldPMBlobWithSeparateTable.InitializePSDescriptions; @@ -305,10 +310,9 @@ procedure TBoldPMBlobWithSeparateTable.InitializePSDescriptions; BlobTable.SQLName := BLOBDATA_TABLENAME; BlobTable.AddColumn(InitialColumnName[0], ColumnTypeAsSQL[0], SystemPersistenceMapper.SQLDataBaseConfig.EffectiveSQLForNotNull, ColumnBDEFieldType[0], ColumnSize[0], false, ''); Blobtable.AddColumn(InitialColumnName[1], ColumnTypeAsSQL[1], SystemPersistenceMapper.SQLDataBaseConfig.EffectiveSQLForNotNull, ColumnBDEFieldType[1], ColumnSize[1], false, ''); - // the blob-column must allow null since it is reused for all blobs, and - // one of them might allow null + Blobtable.AddColumn(InitialColumnName[2], ColumnTypeAsSQL[2], '', ColumnBDEFieldType[2], ColumnSize[2], true, ''); - BlobTable.EnsureIndex(InitialColumnName[0] + ',' + InitialColumnName[1], true, true ); + BlobTable.EnsureIndex(InitialColumnName[0] + ',' + InitialColumnName[1], true, true, true ); end; end; @@ -318,5 +322,4 @@ initialization finalization if BoldMemberPersistenceMappersAssigned and BoldMemberTypesAssigned then BoldMemberPersistenceMappers.RemoveDescriptorByClass(TBoldPMBlobWithSeparateTable); - end. diff --git a/Source/PMapper/Default/BoldMappingInfo.pas b/Source/PMapper/Default/BoldMappingInfo.pas index 4df19775..958e84e7 100644 --- a/Source/PMapper/Default/BoldMappingInfo.pas +++ b/Source/PMapper/Default/BoldMappingInfo.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldMappingInfo; interface @@ -9,10 +12,10 @@ interface BoldDbInterfaces; type - { TBoldDefaultMappingInfo } + TBoldDefaultMappingInfo = class(TBoldSQLMappingInfo) private - procedure ScriptForClearData(Script: TStrings; separator: string; terminator: string); + procedure ScriptForClearData(Script: TStrings; Separator: string; Terminator: string); function AITableName: string; function MMTableName: string; function OSTableName: string; @@ -20,7 +23,8 @@ TBoldDefaultMappingInfo = class(TBoldSQLMappingInfo) function ExpandColumn(ColumnName: String): String; public procedure ReadDataFromDB(DataBase: IBoldDataBase; ReadDbTypeFromDB, ReadMappingFromDB: Boolean); override; - procedure ScriptForWriteData(Script: TStrings; Separator: string; ClearFirst: Boolean = true; terminator: string = ''); override; + procedure ScriptForWriteData(DataBase: IBoldDataBase; Script: TStrings; ClearFirst: Boolean; + Separator: String; Terminator: String); override; end; implementation @@ -30,27 +34,48 @@ implementation BoldUtils, BoldDefs; -{ TBoldDeafultMappingInfo } +{ TBoldDefaultMappingInfo } function TBoldDefaultMappingInfo.AITableName: string; begin result := BoldExpandPrefix(AllInstancesMappingTable_NAME, '', fSystemTablePrefix, MaxDBIdentifierLength, NationalCharConversion) end; -procedure TBoldDefaultMappingInfo.ScriptForClearData(Script: TStrings; separator: string; terminator: string); +procedure TBoldDefaultMappingInfo.ScriptForClearData(Script: TStrings; Separator: string; Terminator: string); procedure ClearTable(TableName: string); begin - script.add('DELETE FROM ' + TableName+terminator); // do not localize - if separator <> '' then + script.add('DELETE FROM ' + TableName+Terminator); // do not localize + if Separator <> '' then Script.Add(Separator); end; + procedure AddColumnIndexColumn; + var + sScript: string; + begin + if (FCurrentDatabase <> nil) and + (FCurrentDatabase.SQLDatabaseConfig <> nil) then + begin + sScript := Format('ALTER TABLE %s ADD %s '+FCurrentDatabase.SQLDatabaseConfig.ColumnTypeForInteger+' DEFAULT 0 '+FCurrentDatabase.SQLDatabaseConfig.SQLForNotNull, + [MMTableName, MMT_INDEX_COLUMN]); + sScript := FCurrentDatabase.SQLDatabaseConfig.GetIfColumnNotExistsQuery( + MMTableName, MMT_INDEX_COLUMN, sScript); + sScript := sScript + Terminator; + script.add(sScript); + if Separator <> '' then + Script.Add(Separator); + end; + end; + begin ClearTable(AITableName); ClearTable(MMTableName); ClearTable(OSTableName); ClearTable(DbTypeTableName); +{$IFDEF IndexColumn} + AddColumnIndexColumn; +{$ENDIF} end; @@ -79,17 +104,25 @@ procedure TBoldDefaultMappingInfo.ReadDataFromDB(DataBase: IBoldDataBase; ReadDb SELECTFROM = 'SELECT * FROM '; var q: IBoldQuery; -function GetMappernameFromQuery: String; -var - Field: IBoldField; -begin - Field := Q.FindField(ExpandColumn(MMT_MAPPERNAME_COLUMN)); - if assigned(Field) then - result := Field.AsString - else - result := ''; -end; + function GetMappernameFromQuery: String; + var + Field: IBoldField; + begin + Field := Q.FindField(ExpandColumn(MMT_MAPPERNAME_COLUMN)); + if assigned(Field) then + result := Field.AsString + else + result := ''; + end; +var + bColumnIndex: Boolean; + vClassNameField: IBoldField; + vTableNameField: IBoldField; + vMemberNameField: IBoldField; + vColumnsField: IBoldField; + vClassIdRequiredField: IBoldField; + vTypeColumnield: IBoldField; begin q := DataBase.GetQuery; try @@ -99,11 +132,14 @@ function GetMappernameFromQuery: String; q.AssignSQlText(SELECTFROM + AITableName); q.Open; + vClassNameField := q.FieldByName(ExpandColumn(AID_CLASSNAME_COLUMN)); + vTableNameField := q.FieldByName(ExpandColumn(AID_TABLENAME_COLUMN)); + vClassIdRequiredField := q.FieldByName(ExpandColumn(AID_CLASSIDREQUIRED_COLUMN)); while not Q.Eof do begin - AddAllInstancesMapping(q.FieldByName(ExpandColumn(AID_CLASSNAME_COLUMN)).AsString, - q.FieldByName(ExpandColumn(AID_TABLENAME_COLUMN)).AsString, - q.FieldByName(ExpandColumn(AID_CLASSIDREQUIRED_COLUMN)).AsInteger=1); + AddAllInstancesMapping(vClassNameField.AsString, + vTableNameField.AsString, + vClassIdRequiredField.AsInteger=1); q.Next; end; q.Close; @@ -111,13 +147,25 @@ function GetMappernameFromQuery: String; q.AssignSQLText(SELECTFROM + MMTableName); q.Open; + vClassNameField := q.FieldByName(ExpandColumn(MMT_CLASSNAME_COLUMN)); + vTableNameField := q.FieldByName(ExpandColumn(MMT_TABLENAME_COLUMN)); + vMemberNameField := q.FieldByName(ExpandColumn(MMT_MEMBERNAME_COLUMN)); + vColumnsField := q.FieldByName(ExpandColumn(MMT_COLUMNS_COLUMN)); while not Q.Eof do begin - AddMemberMapping(q.FieldByName(ExpandColumn(MMT_CLASSNAME_COLUMN)).AsString, - q.FieldByName(ExpandColumn(MMT_MEMBERNAME_COLUMN)).AsString, - q.FieldByName(ExpandColumn(MMT_TABLENAME_COLUMN)).AsString, - q.FieldByName(ExpandColumn(MMT_COLUMNS_COLUMN)).AsString, - GetMapperNameFromQuery); + //Fallback, if the old MemberMapping was used + if q.FindField(ExpandColumn(MMT_INDEX_COLUMN)) = nil then begin + bColumnIndex := False; + end else begin + bColumnIndex := q.FieldByName(ExpandColumn(MMT_INDEX_COLUMN)).AsInteger = 1; + end; + AddMemberMapping(vClassNameField.AsString, + vMemberNameField.AsString, + vTableNameField.AsString, + // Remove linebreaks, to make MappingInfo comparable in TBoldDataBaseEvolutor.MoveDataAction + StringReplace(vColumnsField.AsString, #13#10, '', [rfReplaceAll]), + GetMapperNameFromQuery, + bColumnIndex); q.Next; end; q.Close; @@ -125,10 +173,12 @@ function GetMappernameFromQuery: String; q.AssignSQLText(SELECTFROM + OSTableName); q.Open; + vClassNameField := q.FieldByName(ExpandColumn(ST_CLASSNAME_COLUMN)); + vTableNameField := q.FieldByName(ExpandColumn(ST_TABLENAME_COLUMN)); while not Q.Eof do begin - AddObjectStorageMapping(q.FieldByName(ExpandColumn(ST_CLASSNAME_COLUMN)).AsString, - q.FieldByName(ExpandColumn(ST_TABLENAME_COLUMN)).AsString); + AddObjectStorageMapping(vClassNameField.AsString, + vTableNameField.AsString); q.Next; end; q.Close; @@ -141,88 +191,174 @@ function GetMappernameFromQuery: String; q.AssignSQLText(SELECTFROM + DbTypeTableName); q.Open; + vClassNameField := q.FieldByName(ExpandColumn(CLASSNAMECOLUMN_NAME)); + vTypeColumnield := q.FieldByName(ExpandColumn(TYPECOLUMN_NAME)); while not Q.Eof do begin - AddTypeIdMapping(q.FieldByName(ExpandColumn(CLASSNAMECOLUMN_NAME)).AsString, - q.FieldByName(ExpandColumn(TYPECOLUMN_NAME)).AsInteger); + AddTypeIdMapping(vClassNameField.AsString, + vTypeColumnield.AsInteger); q.Next; end; q.Close; end; - finally DataBase.ReleaseQuery(q); end; end; -procedure TBoldDefaultMappingInfo.ScriptForWriteData(Script: TStrings; Separator: string; ClearFirst: Boolean = true; terminator: string = ''); +procedure TBoldDefaultMappingInfo.ScriptForWriteData(DataBase: IBoldDataBase; + Script: TStrings; ClearFirst: Boolean; Separator: String; Terminator: String); var - i: integer; + i,row,Limit: integer; + vInsertSql: string; + sl: TStringList; const Bool2Int: array[Boolean] of integer=(0, 1); begin - if ClearFirst then - ScriptForClearData(Script, Separator, terminator); - - for i := 0 to fAllInstancesMapping.Count - 1 do - begin - Script.Add(format('INSERT INTO %s (%s, %s, %s) VALUES (''%s'', ''%s'', %d)%s', [ // do not localize - AITableName, - ExpandColumn(AID_CLASSNAME_COLUMN), - ExpandColumn(AID_TABLENAME_COLUMN), - ExpandColumn(AID_CLASSIDREQUIRED_COLUMN), - AllInstancesMappingInfo[i].ClassExpressionName, - AllInstancesMappingInfo[i].TableName, - Bool2Int[AllInstancesMappingInfo[i].classIdrequired], - terminator])); - if separator <> '' then - Script.Add(Separator); - end; - - for i := 0 to fMemberMapping.Count - 1 do - begin - Script.Add(format('INSERT INTO %s (%s, %s, %s, %s, %s) VALUES (''%s'', ''%s'', ''%s'', ''%s'', ''%s'')%s', [ // do not localize - MMTableName, - ExpandColumn(MMT_CLASSNAME_COLUMN), - ExpandColumn(MMT_MEMBERNAME_COLUMN), - ExpandColumn(MMT_TABLENAME_COLUMN), - ExpandColumn(MMT_COLUMNS_COLUMN), - ExpandColumn(MMT_MAPPERNAME_COLUMN), - MemberMappingInfo[i].ClassExpressionName, - MemberMappingInfo[i].MemberName, - MemberMappingInfo[i].TableName, - MemberMappingInfo[i].Columns, - MemberMappingInfo[i].MapperName, - terminator])); - if separator <> '' then - Script.Add(Separator); + FCurrentDatabase := DataBase; + sl := TStringList.Create; + sl.LineBreak := ' '; + try + if ClearFirst then + ScriptForClearData(Script, Separator, Terminator); + Limit := FCurrentDatabase.SQLDatabaseConfig.MultiRowInsertLimit; + vInsertSql := format('INSERT INTO %s (%s, %s, %s) VALUES ', [ + AITableName, + ExpandColumn(AID_CLASSNAME_COLUMN), + ExpandColumn(AID_TABLENAME_COLUMN), + ExpandColumn(AID_CLASSIDREQUIRED_COLUMN) + ]); + row := 0; + for i := 0 to fAllInstancesMapping.Count - 1 do + begin + sl.Add(format('(''%s'', ''%s'', %d)%s', [ // do not localize + AllInstancesMappingInfo[i].ClassExpressionName, + AllInstancesMappingInfo[i].TableName, + Bool2Int[AllInstancesMappingInfo[i].classIdrequired], + Terminator])); + if row = 0 then + sl[sl.count-1] := vInsertSql + sl[sl.count-1] + else + sl[sl.count-1] := ',' + sl[sl.count-1]; + inc(row); + if (row = limit) or (i = fAllInstancesMapping.Count - 1) then + begin + Script.Add(sl.Text); + sl.clear; + if Separator <> '' then + Script.Add(Separator); + row := 0; + end; + end; + Assert(row = 0); + Assert(sl.count = 0); +{$IFDEF IndexColumn} + vInsertSql := format('INSERT INTO %s (%s, %s, %s, %s, %s, %s) VALUES ', +{$ELSE} + vInsertSql := format('INSERT INTO %s (%s, %s, %s, %s, %s) VALUES ', +{$ENDIF} + [MMTableName, + ExpandColumn(MMT_CLASSNAME_COLUMN), + ExpandColumn(MMT_MEMBERNAME_COLUMN), + ExpandColumn(MMT_TABLENAME_COLUMN), + ExpandColumn(MMT_COLUMNS_COLUMN), + ExpandColumn(MMT_MAPPERNAME_COLUMN) +{$IFDEF IndexColumn} + ,ExpandColumn(MMT_INDEX_COLUMN) +{$ENDIF} + ]); + for i := 0 to fMemberMapping.Count - 1 do + begin + sl.Add(Format( +{$IFDEF IndexColumn} + '(''%s'', ''%s'', ''%s'', ''%s'', ''%s'', %d)%s', [ // do not localize +{$ELSE} + '(''%s'', ''%s'', ''%s'', ''%s'', ''%s'')%s', [ // do not localize +{$ENDIF} + MemberMappingInfo[i].ClassExpressionName, + MemberMappingInfo[i].MemberName, + MemberMappingInfo[i].TableName, + MemberMappingInfo[i].Columns, + MemberMappingInfo[i].MapperName, +{$IFDEF IndexColumn} + Integer(MemberMappingInfo[i].ColumnIndex), +{$ENDIF} + terminator])); + if row = 0 then + sl[sl.count-1] := vInsertSql + sl[sl.count-1] + else + sl[sl.count-1] := ',' + sl[sl.count-1]; + inc(row); + if (row = limit) or (i = fMemberMapping.Count - 1) then + begin + Script.Add(sl.Text); + sl.clear; + if Separator <> '' then + Script.Add(Separator); + row := 0; + end; + end; + Assert(row = 0); + Assert(sl.count = 0); + vInsertSql := format('INSERT INTO %s (%s, %s) VALUES ', + [OSTableName, + ExpandColumn(ST_CLASSNAME_COLUMN), + ExpandColumn(ST_TABLENAME_COLUMN) + ]); + for i := 0 to fObjectStorageMapping.Count - 1 do + begin + sl.Add(format('(''%s'', ''%s'')%s', [ // do not localize + ObjectStorageMappingInfo[i].ClassExpressionName, + ObjectStorageMappingInfo[i].TableName, + Terminator])); + if row = 0 then + sl[sl.count-1] := vInsertSql + sl[sl.count-1] + else + sl[sl.count-1] := ',' + sl[sl.count-1]; + inc(row); + if (row = limit) or (i = fObjectStorageMapping.Count - 1) then + begin + Script.Add(sl.Text); + sl.clear; + if Separator <> '' then + Script.Add(Separator); + row := 0; + end; + end; + Assert(row = 0); + Assert(sl.count = 0); + vInsertSql := format('INSERT INTO %s (%s, %s) VALUES ', + [DbTypeTableName, + ExpandColumn(TYPECOLUMN_NAME), + ExpandColumn(CLASSNAMECOLUMN_NAME)]); + for i := 0 to fDbTypeMapping.Count - 1 do + begin + sl.Add(format('(%d, ''%s'')%s', [ // do not localize + DbTypeMapping[i].DbType, + DbTypeMapping[i].ClassExpressionName, + Terminator])); + if row = 0 then + sl[sl.count-1] := vInsertSql + sl[sl.count-1] + else + sl[sl.count-1] := ',' + sl[sl.count-1]; + inc(row); + if (row = limit) or (i = fDbTypeMapping.Count - 1) then + begin + Script.Add(sl.Text); + sl.clear; + if Separator <> '' then + Script.Add(Separator); + row := 0; + end; + end; + Assert(row = 0); + Assert(sl.count = 0); + finally + FCurrentDatabase := nil; + sl.free; end; +end; - for i := 0 to fObjectStorageMapping.Count - 1 do - begin - Script.Add(format('INSERT INTO %s (%s, %s) VALUES (''%s'', ''%s'')%s', [ // do not localize - OSTableName, - ExpandColumn(ST_CLASSNAME_COLUMN), - ExpandColumn(ST_TABLENAME_COLUMN), - ObjectStorageMappingInfo[i].ClassExpressionName, - ObjectStorageMappingInfo[i].TableName, - terminator])); - if separator <> '' then - Script.Add(Separator); - end; - for i := 0 to fDbTypeMapping.Count - 1 do - begin - Script.Add(format('INSERT INTO %s (%s, %s) VALUES (%d, ''%s'')%s', [ // do not localize - DbTypeTableName, - ExpandColumn(TYPECOLUMN_NAME), - ExpandColumn(CLASSNAMECOLUMN_NAME), - DbTypeMapping[i].DbType, - DbTypeMapping[i].ClassExpressionName, - terminator])); - if separator <> '' then - Script.Add(Separator); - end; -end; end. diff --git a/Source/PMapper/Default/BoldPMappersAttributeDefault.pas b/Source/PMapper/Default/BoldPMappersAttributeDefault.pas index d5eb4cce..96d1127f 100644 --- a/Source/PMapper/Default/BoldPMappersAttributeDefault.pas +++ b/Source/PMapper/Default/BoldPMappersAttributeDefault.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPMappersAttributeDefault; interface @@ -25,6 +28,7 @@ TBoldPMCurrency = class; TBoldPMDateTime = class; TBoldPMDate = class; TBoldPMTime = class; + TBoldPMGuid = class; {TBoldPMString} TBoldPMString = class(TBoldSingleColumnMember) @@ -34,32 +38,87 @@ TBoldPMString = class(TBoldSingleColumnMember) function GetColumnTypeAsSQL(ColumnIndex: Integer): string; override; function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; override; function GetColumnSize(ColumnIndex: Integer): Integer; override; - function CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; function DefaultDefaultDbValue: String; override; public constructor CreateFromMold(Moldmember: TMoldMember; MoldClass: TMoldClass; Owner: TBoldObjectPersistenceMapper; const MemberIndex: Integer; TypeNameDictionary: TBoldTypeNameDictionary); override; class function CanStore(const ContentName: string): Boolean; override; - procedure ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); override; - procedure ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + function ValueAsVariant(const ObjectContent: IBoldObjectContents; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; override; + end; + + {TBoldPMAnsiString} + TBoldPMAnsiString = class(TBoldPMString) + protected + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; + ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: + TBoldIdTranslationList): Boolean; override; + public + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: + IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: + TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: + IBoldParameter; ColumnIndex: Integer; TranslationList: + TBoldIdTranslationList); override; + end; + + {TBoldPMUnicodeString} + TBoldPMUnicodeString = class(TBoldPMString) + protected + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; + ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: + TBoldIdTranslationList): Boolean; override; + function GetColumnTypeAsSQL(ColumnIndex: Integer): string; override; + function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; override; + public + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: + IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: + TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: + IBoldParameter; ColumnIndex: Integer; TranslationList: + TBoldIdTranslationList); override; end; TBoldPMStringBDECodePageBug = class(TBoldPMString) public - procedure ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; end; + {TBoldPMText} + TBoldPMText = class(TBoldSingleColumnMember) + private + protected + function GetColumnTypeAsSQL(ColumnIndex: Integer): string; override; + function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; override; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + function DefaultDefaultDbValue: String; override; + public + constructor CreateFromMold(Moldmember: TMoldMember; MoldClass: TMoldClass; Owner: TBoldObjectPersistenceMapper; const MemberIndex: Integer; TypeNameDictionary: TBoldTypeNameDictionary); override; + class function CanStore(const ContentName: string): Boolean; override; + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + end; + + {TBoldPMUnicodeText} + TBoldPMUnicodeText = class(TBoldPMText) + protected + function GetColumnTypeAsSQL(ColumnIndex: Integer): string; override; + function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; override; + end; {TBoldPMInteger} TBoldPMInteger = class(TBoldSingleColumnMember) protected function GetColumnTypeAsSQL(ColumnIndex: Integer): string; override; function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; override; - function CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; function DefaultDefaultDbValue: String; override; public class function CanStore(const ContentName: string): Boolean; override; - procedure ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); override; - procedure ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + function ValueAsVariant(const ObjectContent: IBoldObjectContents; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; override; end; {TBoldPMSmallInt} @@ -72,12 +131,12 @@ TBoldPMSmallInt = class(TBoldPMInteger) end; {TBoldPMByte} - TBoldPMByte = class(TBoldPMSmallInt) // No TFieldType value for byte + TBoldPMByte = class(TBoldPMSmallInt) class function CanStore(const ContentName: string): Boolean; override; end; {TBoldPMShortInt} - TBoldPMShortInt = class(TBoldPMSmallInt) // No TFieldType value for ShortInt + TBoldPMShortInt = class(TBoldPMSmallInt) class function CanStore(const ContentName: string): Boolean; override; end; @@ -94,11 +153,12 @@ TBoldPMLogic = class(TBoldSingleColumnMember) protected function GetColumnTypeAsSQL(ColumnIndex: Integer): string; override; function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; override; - function CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; public class function CanStore(const ContentName: string): Boolean; override; - procedure ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); override; - procedure ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + function ValueAsVariant(const ObjectContent: IBoldObjectContents; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; override; end; {TBoldPMFloat} @@ -106,12 +166,13 @@ TBoldPMFloat = class(TBoldSingleColumnMember) protected function GetColumnTypeAsSQL(ColumnIndex: Integer): string; override; function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; override; - function CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; function DefaultDefaultDbValue: String; override; public class function CanStore(const ContentName: string): Boolean; override; - procedure ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); override; - procedure ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + function ValueAsVariant(const ObjectContent: IBoldObjectContents; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; override; end; {TBoldPMCurrency} @@ -119,24 +180,28 @@ TBoldPMCurrency = class(TBoldSingleColumnMember) protected function GetColumnTypeAsSQL(ColumnIndex: Integer): string; override; function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; override; - function CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; function DefaultDefaultDbValue: String; override; public class function CanStore(const ContentName: string): Boolean; override; - procedure ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); override; - procedure ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + function ValueAsVariant(const ObjectContent: IBoldObjectContents; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; override; end; {TBoldPMBlob} TBoldPMBlob = class(TBoldSingleColumnMember) + private + function StoreAsString(ColumnIndex: Integer): Boolean; protected function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; override; function GetColumnTypeAsSQL(ColumnIndex: Integer): string; override; - function CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; public class function CanStore(const ContentName: string): Boolean; override; - procedure ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); override; - procedure ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + function ValueAsVariant(const ObjectContent: IBoldObjectContents; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; override; end; {TBoldPMBlob} @@ -147,10 +212,10 @@ TBoldPMMemoBlob = class(TBoldPMBlob) TBoldPMNonEmptyBlob = class(TBoldPMBlob) protected - function CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; public - procedure ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); override; - procedure ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; end; TBoldPMLiveBlob = class(TBoldPMBlob) @@ -167,11 +232,12 @@ TBoldPMTypedBlob = class(TBoldPMBlob) function GetColumnCount: Integer; override; function GetColumnSize(ColumnIndex: Integer): Integer; override; function GetInitialColumnName(ColumnIndex: Integer): string; override; - function CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; public class function CanStore(const ContentName: string): Boolean; override; - procedure ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); override; - procedure ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + function ValueAsVariant(const ObjectContent: IBoldObjectContents; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; override; end; TBoldPMLiveTypedBlob = class(TBoldPMTypedBlob) @@ -187,35 +253,45 @@ TBoldPMDateTime = class(TBoldSingleColumnMember) protected function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; override; function GetColumnTypeAsSQL(ColumnIndex: Integer): string; override; - function CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + function DefaultDefaultDbValue: String; override; public class function CanStore(const ContentName: string): Boolean; override; - procedure ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); override; - procedure ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + function ValueAsVariant(const ObjectContent: IBoldObjectContents; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; override; end; {TBoldPMDate} TBoldPMDate = class(TBoldPMDateTime) protected function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; override; - function CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; function GetColumnTypeAsSQL(ColumnIndex: Integer): string; override; public class function CanStore(const ContentName: string): Boolean; override; - procedure ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); override; - procedure ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + function ValueAsVariant(const ObjectContent: IBoldObjectContents; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; override; end; {TBoldPMTime} TBoldPMTime = class(TBoldPMDateTime) protected function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; override; - function CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; function GetColumnTypeAsSQL(ColumnIndex: Integer): string; override; public class function CanStore(const ContentName: string): Boolean; override; - procedure ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); override; - procedure ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + function ValueAsVariant(const ObjectContent: IBoldObjectContents; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; override; + end; + + TBoldPMGuid = class(TBoldPMString) + protected + function GetColumnTypeAsSQL(ColumnIndex: Integer): string; override; + function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; override; end; implementation @@ -223,14 +299,14 @@ implementation uses SysUtils, BoldDefs, + BoldUtils, BoldValueInterfaces, BoldPMapperLists, BoldDefaultStreamNames, - BoldPMappersSQL, - BoldPMConsts; + Variants; var - TwoSeconds: TDateTime; // initialized in initizlization-section + TwoSeconds: TDateTime; {---TBoldPMString---} @@ -245,7 +321,7 @@ constructor TBoldPMString.CreateFromMold(Moldmember: TMoldMember; MoldClass: TMo if SystemPersistenceMapper.SQLDataBaseConfig.StoreEmptyStringsAsNULL then begin if (MoldMember as TMoldAttribute).AllowNull then - raise EBold.CreateFmt(sAttributeMustNotAllowNullIfEmptyStringsStoreAsNull, [ + raise EBold.CreateFmt('String attribute must not allow NULL in the model if persistencemapper stores empty strings as NULL (%s.%s)', [ MoldClass.Name, MoldMember.Name]); fAllowNull := True; end; @@ -253,7 +329,7 @@ constructor TBoldPMString.CreateFromMold(Moldmember: TMoldMember; MoldClass: TMo function TBoldPMString.GetColumnTypeAsSQL(ColumnIndex: Integer): string; begin - Result := Format(SystemPersistenceMapper.SQLDataBaseConfig.ColumnTypeForString, [GetColumnSize(ColumnIndex)]); + Result := SystemPersistenceMapper.SQLDataBaseConfig.GetColumnTypeForString(GetColumnSize(ColumnIndex)); end; class function TBoldPMString.CanStore(const ContentName: string): Boolean; @@ -263,7 +339,7 @@ class function TBoldPMString.CanStore(const ContentName: string): Boolean; function TBoldPMString.GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; begin - Result := ftString; + Result := ftMemo; // Changed from ftString to ftMemo as MSSQL truncates string params to 8000 end; function TBoldPMString.GetColumnSize(ColumnIndex: Integer): Integer; @@ -271,7 +347,22 @@ function TBoldPMString.GetColumnSize(ColumnIndex: Integer): Integer; Result := fColumnSize; end; -procedure TBoldPMString.ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); +function TBoldPMString.ValueAsVariant(const ObjectContent: IBoldObjectContents; + ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; +var + aString: IBoldStringContent; +begin + EnsureFirstColumn(ColumnIndex); + aString := GetEnsuredValue(ObjectContent) as IBoldStringContent; + if aString.IsNull then + result := null + else + begin + result := aString.AsString; + end; +end; + +procedure TBoldPMString.ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); var aString: IBoldStringContent; begin @@ -288,7 +379,7 @@ procedure TBoldPMString.ValueFromField(OwningObjectId: TBoldObjectId; ObjectCont aString.AsString := Field.AsString end; -function TBoldPMString.CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; +function TBoldPMString.CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; var aString: IBoldStringContent; begin @@ -306,7 +397,7 @@ function TBoldPMString.CompareField(ObjectContent: IBoldObjectContents; Field: I end; -procedure TBoldPMString.ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); +procedure TBoldPMString.ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); var aString: IBoldStringContent; begin @@ -315,7 +406,12 @@ procedure TBoldPMString.ValueToParam(ObjectContent: IBoldObjectContents; Param: if aString.IsNull then SetParamToNullWithDataType(Param, GetColumnBDEFieldType(0)) else - Param.AsString := aString.AsString + begin + // the setting of Param DataType is a workaround for UniDAC MSSQL param trim to 8000 bug. + if Length(aString.AsString) >= 8000 then + Param.DataType := GetColumnBDEFieldType(0); + Param.AsString := aString.AsString; + end; end; {---TBoldPMInteger---} @@ -335,7 +431,7 @@ function TBoldPMInteger.GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; Result := ftInteger; end; -function TBoldPMInteger.CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; +function TBoldPMInteger.CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; var anInteger: IBoldIntegerContent; begin @@ -345,7 +441,20 @@ function TBoldPMInteger.CompareField(ObjectContent: IBoldObjectContents; Field: result := Field.AsInteger = anInteger.AsInteger; end; -procedure TBoldPMInteger.ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); +function TBoldPMInteger.ValueAsVariant(const ObjectContent: IBoldObjectContents; + ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; +var + anInteger: IBoldIntegerContent; +begin + EnsureFirstColumn(ColumnIndex); + anInteger := GetEnsuredValue(ObjectContent) as IBoldIntegerContent; + if anInteger.IsNull then + result := null + else + Result := anInteger.AsInteger; +end; + +procedure TBoldPMInteger.ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); var anInteger: IBoldIntegerContent; begin @@ -357,7 +466,7 @@ procedure TBoldPMInteger.ValueFromField(OwningObjectId: TBoldObjectId; ObjectCon anInteger.AsInteger := Field.AsInteger; end; -procedure TBoldPMInteger.ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); +procedure TBoldPMInteger.ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); var anInteger: IBoldIntegerContent; begin @@ -411,7 +520,7 @@ function TBoldPMWord.GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; {---TBoldPMLogic---} function TBoldPMLogic.GetColumnTypeAsSQL(ColumnIndex: Integer): string; begin - Result := 'VARCHAR(1)'; // do not localize + Result := 'VARCHAR(1)'; end; class function TBoldPMLogic.CanStore(const ContentName: string): Boolean; @@ -424,8 +533,8 @@ function TBoldPMLogic.GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; Result := ftBoolean; end; -function TBoldPMLogic.CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; - ColumnIndex: integer; ValueSpace: IBoldValueSpace; +function TBoldPMLogic.CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; + ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; var aBoolean: IBoldBooleanContent; @@ -436,7 +545,20 @@ function TBoldPMLogic.CompareField(ObjectContent: IBoldObjectContents; Field: IB result := Field.AsBoolean = aBoolean.AsBoolean; end; -procedure TBoldPMLogic.ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); +function TBoldPMLogic.ValueAsVariant(const ObjectContent: IBoldObjectContents; + ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; +var + aBoolean: IBoldBooleanContent; +begin + EnsureFirstColumn(ColumnIndex); + aBoolean := GetEnsuredValue(ObjectContent) as IBoldBooleanContent; + if aBoolean.IsNull then + result := Null + else + result := aBoolean.asBoolean; +end; + +procedure TBoldPMLogic.ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); var aBoolean: IBoldBooleanContent; begin @@ -448,7 +570,7 @@ procedure TBoldPMLogic.ValueFromField(OwningObjectId: TBoldObjectId; ObjectConte aBoolean.AsBoolean := Field.AsBoolean; end; -procedure TBoldPMLogic.ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); +procedure TBoldPMLogic.ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); var aBoolean: IBoldBooleanContent; begin @@ -476,8 +598,8 @@ function TBoldPMFloat.GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; Result := ftFloat; end; -function TBoldPMFloat.CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; - ColumnIndex: integer; ValueSpace: IBoldValueSpace; +function TBoldPMFloat.CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; + ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; var aFloat: IBoldFloatContent; @@ -488,7 +610,20 @@ function TBoldPMFloat.CompareField(ObjectContent: IBoldObjectContents; Field: IB result := Field.AsFloat = aFloat.AsFloat; end; -procedure TBoldPMFloat.ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); +function TBoldPMFloat.ValueAsVariant(const ObjectContent: IBoldObjectContents; + ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; +var + aFloat: IBoldFloatContent; +begin + EnsureFirstColumn(ColumnIndex); + aFloat := GetEnsuredValue(ObjectContent) as IBoldFloatContent; + if aFloat.IsNull then + result := Null + else + result := aFloat.AsFloat; +end; + +procedure TBoldPMFloat.ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); var aFloat: IBoldFloatContent; begin @@ -500,7 +635,7 @@ procedure TBoldPMFloat.ValueFromField(OwningObjectId: TBoldObjectId; ObjectConte aFloat.AsFloat := Field.AsFloat; end; -procedure TBoldPMFloat.ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); +procedure TBoldPMFloat.ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); var aFloat: IBoldFloatContent; begin @@ -523,7 +658,7 @@ function TBoldPMCurrency.GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType Result := ftCurrency; end; -function TBoldPMCurrency.CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; +function TBoldPMCurrency.CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; var aCurrency: IBoldCurrencyContent; begin @@ -534,7 +669,20 @@ function TBoldPMCurrency.CompareField(ObjectContent: IBoldObjectContents; Field: end; -procedure TBoldPMCurrency.ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); +function TBoldPMCurrency.ValueAsVariant(const ObjectContent: IBoldObjectContents; + ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; +var + aCurrency: IBoldCurrencyContent; +begin + EnsureFirstColumn(ColumnIndex); + aCurrency := GetEnsuredValue(ObjectContent) as IBoldCurrencyContent; + if aCurrency.IsNull then + result := null + else + result := aCurrency.AsCurrency; +end; + +procedure TBoldPMCurrency.ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); var aCurrency: IBoldCurrencyContent; begin @@ -546,7 +694,7 @@ procedure TBoldPMCurrency.ValueFromField(OwningObjectId: TBoldObjectId; ObjectCo aCurrency.AsCurrency := Field.AsCurrency; end; -procedure TBoldPMCurrency.ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); +procedure TBoldPMCurrency.ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); var aCurrency: IBoldCurrencyContent; begin @@ -564,6 +712,11 @@ function TBoldPMBlob.GetColumnTypeAsSQL(ColumnIndex: Integer): string; Result := SystemPersistenceMapper.SQLDataBaseConfig.ColumnTypeForBlob; end; +function TBoldPMBlob.StoreAsString(ColumnIndex: Integer): Boolean; +begin + Result := GetColumnBDEFieldType(ColumnIndex) = ftstring; +end; + class function TBoldPMBlob.CanStore(const ContentName: string): Boolean; begin Result := AnsiCompareText(ContentName, BoldContentName_Blob) = 0; @@ -574,8 +727,8 @@ function TBoldPMBlob.GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; Result := SystemPersistenceMapper.SQLDataBaseConfig.FieldTypeForBlob; end; -function TBoldPMBlob.CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; - ColumnIndex: integer; ValueSpace: IBoldValueSpace; +function TBoldPMBlob.CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; + ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; var aBlob: IBoldBlobContent; @@ -583,22 +736,43 @@ function TBoldPMBlob.CompareField(ObjectContent: IBoldObjectContents; Field: IBo EnsureFirstColumn(ColumnIndex); aBlob := GetValue(ObjectContent) as IBoldBlobContent; if not CheckEitherNull(field, aBlob, result) then - result := Field.AsBlob = aBlob.AsBlob; + begin + if StoreAsString(ColumnIndex) then + result := aBlob.AsString = Field.AsString + else + result := aBlob.AsBlob = Field.AsBlob; + end; end; -procedure TBoldPMBlob.ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); +procedure TBoldPMBlob.ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); var aBlob: IBoldBlobContent; + aBlobStreamContent: IBoldBlobStreamContent; begin EnsureFirstColumn(ColumnIndex); aBlob := GetEnsuredValue(ObjectContent) as IBoldBlobContent; - if Field.IsNull then - aBlob.SetContentToNull - else - aBlob.AsBlob := Field.AsBlob; + if Supports(aBlob, IBoldBlobStreamContent) then + begin + aBlobStreamContent := aBlob as IBoldBlobStreamContent; + aBlobStreamContent.BeginSupressEvents; + end; + try + if Field.IsNull then + aBlob.SetContentToNull + else + begin + if StoreAsString(ColumnIndex) then + aBlob.AsBlob := Field.AsAnsiString + else + aBlob.AsBlob := Field.AsBlob; + end; + finally + if Assigned(aBlobStreamContent) then + aBlobStreamContent.EndSupressEvents; + end; end; -procedure TBoldPMBlob.ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); +procedure TBoldPMBlob.ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); var aBlob: IBoldBlobContent; begin @@ -608,8 +782,25 @@ procedure TBoldPMBlob.ValueToParam(ObjectContent: IBoldObjectContents; Param: IB SetParamToNullWithDataType(Param, GetColumnBDEFieldType(0)) else begin - Param.DataType := ColumnBDEFieldType[ColumnIndex]; -//marco Param.AsBlob := aBlob.AsBlob; + if StoreAsString(ColumnIndex) then + Param.asString := aBlob.asString + else + Param.AsBlob := aBlob.asBlob; + end; +end; + +function TBoldPMBlob.ValueAsVariant(const ObjectContent: IBoldObjectContents; + ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; +var + aBlob: IBoldBlobContent; +begin + EnsureFirstColumn(ColumnIndex); + aBlob := GetEnsuredValue(ObjectContent) as IBoldBlobContent; + if aBlob.IsNull then + result := Null + else + begin + result := aBlob.asBlob; end; end; @@ -645,7 +836,7 @@ function TBoldPMTypedBlob.GetColumnSize(ColumnIndex: Integer): Integer; function TBoldPMTypedBlob.GetInitialColumnName(ColumnIndex: Integer): string; begin if ColumnIndex = 1 then - Result := InitialColumnRootName + '_Content' // do not localize + Result := InitialColumnRootName + '_Content' else Result := inherited GetInitialColumnName(ColumnIndex); end; @@ -655,7 +846,7 @@ class function TBoldPMTypedBlob.CanStore(const ContentName: string): Boolean; Result := AnsiCompareText(ContentName, BoldContentName_TypedBlob) = 0; end; -function TBoldPMTypedBlob.CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; +function TBoldPMTypedBlob.CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; var aTypedBlob: IBoldTypedBlob; begin @@ -669,7 +860,24 @@ function TBoldPMTypedBlob.CompareField(ObjectContent: IBoldObjectContents; Field result := inherited CompareField(ObjectContent, Field, ColumnIndex, ValueSpace, TranslationList); end; -procedure TBoldPMTypedBlob.ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); +function TBoldPMTypedBlob.ValueAsVariant(const ObjectContent: IBoldObjectContents; + ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; +var + aTypedBlob: IBoldTypedBlob; +begin + if ColumnIndex = 1 then + begin + aTypedBlob := GetEnsuredValue(ObjectContent) as IBoldTypedBlob; + if aTypedBlob.IsNull then + result := null + else + result := aTypedBlob.ContentTypeContent; + end + else + result := Inherited ValueAsVariant(ObjectContent, ColumnIndex, TranslationList); +end; + +procedure TBoldPMTypedBlob.ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); var aTypedBlob: IBoldTypedBlob; begin @@ -685,7 +893,7 @@ procedure TBoldPMTypedBlob.ValueFromField(OwningObjectId: TBoldObjectId; ObjectC Inherited; end; -procedure TBoldPMTypedBlob.ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); +procedure TBoldPMTypedBlob.ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); var aTypedBlob: IBoldTypedBlob; begin @@ -714,32 +922,60 @@ class function TBoldPMDateTime.CanStore(const ContentName: string): Boolean; function TBoldPMDateTime.GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; begin - Result := ftDateTime; + Result := ftDateTime; // workaround for DBX is to use ftDate, DBX does not properly support DateTime end; -function TBoldPMDateTime.CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; +function TBoldPMDateTime.CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; var aDateTime: IBoldDateTimeContent; begin EnsureFirstColumn(ColumnIndex); aDateTime := GetValue(ObjectContent) as IBoldDateTimeContent; - if not CheckEitherNull(field, aDateTime, result) then + if Field.IsNull {$IFDEF ConvertZeroDateToDateNil} or (Field.AsDateTime = 0) or (abs(Field.AsDateTime) < TwoSeconds) {$ENDIF} then + result := (aDateTime as IBoldNullableValue).isNull + else if (aDateTime as IBoldNullableValue).IsNull then + result := false + else result := abs(Field.AsDateTime - aDateTime.AsDateTime) < TwoSeconds; end; -procedure TBoldPMDateTime.ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); +function TBoldPMDateTime.DefaultDefaultDbValue: String; +begin + Result := SystemPersistenceMapper.SQLDataBaseConfig.DefaultValueForDateTime; +end; + +function TBoldPMDateTime.ValueAsVariant(const ObjectContent: IBoldObjectContents; + ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; var aDateTime: IBoldDateTimeContent; begin EnsureFirstColumn(ColumnIndex); aDateTime := GetEnsuredValue(ObjectContent) as IBoldDateTimeContent; - if Field.IsNull then + if aDateTime.IsNull then + result := null + else + result := aDateTime.AsDateTime; +end; + +procedure TBoldPMDateTime.ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); +var + aDateTime: IBoldDateTimeContent; +begin + EnsureFirstColumn(ColumnIndex); + aDateTime := GetEnsuredValue(ObjectContent) as IBoldDateTimeContent; + if Field.IsNull {$IFDEF ConvertZeroDateToDateNil} or (Field.AsDateTime = 0) or (abs(Field.AsDateTime) < TwoSeconds) {$ENDIF} then aDateTime.SetContentToNull else + begin +{$IFDEF NoNegativeDates} + if (Field.Value < 0) then + raise EBold.Create(Format('Negative date in Object %s column %s', [OwningObjectId.AsString, Field.FieldName])); +{$ENDIF} aDateTime.AsDateTime := Field.Value; + end; end; -procedure TBoldPMDateTime.ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); +procedure TBoldPMDateTime.ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); var aDateTime: IBoldDateTimeContent; begin @@ -762,7 +998,7 @@ function TBoldPMDate.GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; Result := ftDate; end; -function TBoldPMDate.CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; +function TBoldPMDate.CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; var aDate: IBoldDateContent; begin @@ -777,7 +1013,20 @@ function TBoldPMDate.GetColumnTypeAsSQL(ColumnIndex: Integer): string; Result := SystemPersistenceMapper.SQLDataBaseConfig.ColumnTypeForDate; end; -procedure TBoldPMDate.ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); +function TBoldPMDate.ValueAsVariant(const ObjectContent: IBoldObjectContents; + ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; +var + aDate: IBoldDateContent; +begin + EnsureFirstColumn(ColumnIndex); + aDate := GetEnsuredValue(ObjectContent) as IBoldDateContent; + if aDate.IsNull then + result := null + else + result := aDate.AsDate; +end; + +procedure TBoldPMDate.ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); var aDate: IBoldDateContent; begin @@ -789,7 +1038,7 @@ procedure TBoldPMDate.ValueFromField(OwningObjectId: TBoldObjectId; ObjectConten aDate.AsDate := Field.Value; end; -procedure TBoldPMDate.ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); +procedure TBoldPMDate.ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); var aDate: IBoldDateContent; begin @@ -812,7 +1061,7 @@ function TBoldPMTime.GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; Result := ftTime; end; -function TBoldPMTime.CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; +function TBoldPMTime.CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; var aTime: IBoldTimeContent; begin @@ -828,8 +1077,20 @@ function TBoldPMTime.GetColumnTypeAsSQL(ColumnIndex: Integer): string; Result := SystemPersistenceMapper.SQLDataBaseConfig.ColumnTypeForTime; end; +function TBoldPMTime.ValueAsVariant(const ObjectContent: IBoldObjectContents; + ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; +var + aTime: IBoldTimeContent; +begin + EnsureFirstColumn(ColumnIndex); + aTime := GetEnsuredValue(ObjectContent) as IBoldTimeContent; + if aTime.IsNull then + result := null + else + result := aTime.AsTime; +end; -procedure TBoldPMTime.ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); +procedure TBoldPMTime.ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); var aTime: IBoldTimeContent; begin @@ -841,7 +1102,7 @@ procedure TBoldPMTime.ValueFromField(OwningObjectId: TBoldObjectId; ObjectConten aTime.AsTime := Field.Value; end; -procedure TBoldPMTime.ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); +procedure TBoldPMTime.ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); var aTime: IBoldTimeContent; begin @@ -865,8 +1126,8 @@ function TBoldPMMemoBlob.GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType const InternalEmptyString = '<## Internal Empty ##>'; -function TBoldPMNonEmptyBlob.CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; - ColumnIndex: integer; ValueSpace: IBoldValueSpace; +function TBoldPMNonEmptyBlob.CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; + ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; var aBlobContent: IBoldBlobContent; @@ -877,9 +1138,9 @@ function TBoldPMNonEmptyBlob.CompareField(ObjectContent: IBoldObjectContents; Fi result := Field.Value = aBlobContent.AsBlob; end; -procedure TBoldPMNonEmptyBlob.ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; - ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; - Field: IBoldField; ColumnIndex: Integer); +procedure TBoldPMNonEmptyBlob.ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; + const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; + const Field: IBoldField; ColumnIndex: Integer); var aBlobContent: IBoldBlobContent; begin @@ -889,8 +1150,8 @@ procedure TBoldPMNonEmptyBlob.ValueFromField(OwningObjectId: TBoldObjectId; Obje aBlobContent.AsBlob := ''; end; -procedure TBoldPMNonEmptyBlob.ValueToParam(ObjectContent: IBoldObjectContents; - Param: IBoldParameter; ColumnIndex: Integer; +procedure TBoldPMNonEmptyBlob.ValueToParam(const ObjectContent: IBoldObjectContents; + const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); var EmptyBlobHandled: Boolean; @@ -940,27 +1201,36 @@ function TBoldPMLiveTypedBlob.GetRequiresLiveQuery: Boolean; result := true; end; + function TBoldPMString.DefaultDefaultDbValue: String; begin - if SystemPersistenceMapper.SQLDataBaseConfig.SupportsStringDefaultValues then - result := '''''' - else - result := ''; + result:=''; + if not AllowNull and (SystemPersistenceMapper.SQLDataBaseConfig.SupportsStringDefaultValues) then + result := ''''''; end; function TBoldPMInteger.DefaultDefaultDbValue: String; begin - result := SystemPersistenceMapper.SQLDataBaseConfig.CorrectlyQuotedDefaultValue('0'); + if AllowNull then + result := '' + else + result := SystemPersistenceMapper.SQLDataBaseConfig.CorrectlyQuotedDefaultValue('0'); end; function TBoldPMFloat.DefaultDefaultDbValue: String; begin - result := SystemPersistenceMapper.SQLDataBaseConfig.CorrectlyQuotedDefaultValue('0'); + if AllowNull then + result := '' + else + result := SystemPersistenceMapper.SQLDataBaseConfig.CorrectlyQuotedDefaultValue('0'); end; function TBoldPMCurrency.DefaultDefaultDbValue: String; begin - result := SystemPersistenceMapper.SQLDataBaseConfig.CorrectlyQuotedDefaultValue('0'); + if AllowNull then + result := '' + else + result := SystemPersistenceMapper.SQLDataBaseConfig.CorrectlyQuotedDefaultValue('0'); end; function TBoldPMCurrency.GetColumnTypeAsSQL(ColumnIndex: Integer): string; @@ -968,10 +1238,131 @@ function TBoldPMCurrency.GetColumnTypeAsSQL(ColumnIndex: Integer): string; Result := SystemPersistenceMapper.SQLDataBaseConfig.ColumnTypeForCurrency; end; +{ TBoldPMAnsiString } + +function TBoldPMAnsiString.CompareField(const ObjectContent: IBoldObjectContents; + const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; + TranslationList: TBoldIdTranslationList): Boolean; +var + aString: IBoldAnsiStringContent; +begin + EnsureFirstColumn(ColumnIndex); + aString := GetValue(ObjectContent) as IBoldAnsiStringContent; + result := + SystemPersistenceMapper.SQLDataBaseConfig.StoreEmptyStringsAsNULL and + Field.IsNull and (aString.asAnsiString = ''); + + if not result then + begin + if not CheckEitherNull(field, aString, result) then + result := Field.AsAnsiString = aString.asAnsiString; + end; +end; + +procedure TBoldPMAnsiString.ValueFromField(OwningObjectId: TBoldObjectId; + const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; + TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: + Integer); +var + aString: IBoldAnsiStringContent; +begin + EnsureFirstColumn(ColumnIndex); + aString := GetEnsuredValue(ObjectContent) as IBoldAnsiStringContent; + if Field.IsNull then + begin + if SystemPersistenceMapper.SQLDataBaseConfig.StoreEmptyStringsAsNULL then + aString.AsString := '' + else + aString.SetContentToNull + end + else + aString.asAnsiString := Field.AsAnsiString +end; + +procedure TBoldPMAnsiString.ValueToParam(const ObjectContent: IBoldObjectContents; + const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: + TBoldIdTranslationList); +var + aString: IBoldAnsiStringContent; +begin + EnsureFirstColumn(ColumnIndex); + aString := GetEnsuredValue(ObjectContent) as IBoldAnsiStringContent; + if aString.IsNull then + SetParamToNullWithDataType(Param, GetColumnBDEFieldType(0)) + else + Param.AsAnsiString := aString.asAnsiString +end; + +{ TBoldPMUnicodeString } + +function TBoldPMUnicodeString.CompareField(const ObjectContent: IBoldObjectContents; + const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; + TranslationList: TBoldIdTranslationList): Boolean; +var + aString: IBoldUnicodeStringContent; +begin + EnsureFirstColumn(ColumnIndex); + aString := GetValue(ObjectContent) as IBoldUnicodeStringContent; + result := + SystemPersistenceMapper.SQLDataBaseConfig.StoreEmptyStringsAsNULL and + Field.IsNull and (aString.asUnicodeString = ''); + + if not result then + begin + if not CheckEitherNull(field, aString, result) then + result := Field.AsWideString = aString.asUnicodeString; + end; +end; + +function TBoldPMUnicodeString.GetColumnBDEFieldType(ColumnIndex: Integer): + TFieldType; +begin + Result := ftWideString; +end; + +function TBoldPMUnicodeString.GetColumnTypeAsSQL(ColumnIndex: Integer): string; +begin + Result := SystemPersistenceMapper.SQLDataBaseConfig.GetColumnTypeForUnicodeString(GetColumnSize(ColumnIndex)); +end; + +procedure TBoldPMUnicodeString.ValueFromField(OwningObjectId: TBoldObjectId; + const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; + TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: + Integer); +var + aString: IBoldUnicodeStringContent; +begin + EnsureFirstColumn(ColumnIndex); + aString := GetEnsuredValue(ObjectContent) as IBoldUnicodeStringContent; + if Field.IsNull then + begin + if SystemPersistenceMapper.SQLDataBaseConfig.StoreEmptyStringsAsNULL then + aString.AsString := '' + else + aString.SetContentToNull + end + else + aString.asUnicodeString := Field.AsWideString +end; + +procedure TBoldPMUnicodeString.ValueToParam(const ObjectContent: IBoldObjectContents; + const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: + TBoldIdTranslationList); +var + aString: IBoldUnicodeStringContent; +begin + EnsureFirstColumn(ColumnIndex); + aString := GetEnsuredValue(ObjectContent) as IBoldUnicodeStringContent; + if aString.IsNull then + SetParamToNullWithDataType(Param, GetColumnBDEFieldType(0)) + else + Param.AsWideString := aString.asUnicodeString +end; + { TBoldPMStringBDECodePageBug } procedure TBoldPMStringBDECodePageBug.ValueToParam( - ObjectContent: IBoldObjectContents; Param: IBoldParameter; + const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); var aString: IBoldStringContent; @@ -982,21 +1373,133 @@ procedure TBoldPMStringBDECodePageBug.ValueToParam( SetParamToNullWithDataType(Param, GetColumnBDEFieldType(0)) else begin - // make a copy of the string so that the param can - // mess with it alone + Param.AsString := copy(aString.AsString, 1, maxint); end; end; -initialization +{---TBoldPMText---} +constructor TBoldPMText.CreateFromMold(Moldmember: TMoldMember; MoldClass: TMoldClass; Owner: TBoldObjectPersistenceMapper; const MemberIndex: Integer; TypeNameDictionary: TBoldTypeNameDictionary); +begin + inherited; + if (DefaultDbValue <> '') and + (DefaultDbValue[1] <> '''') and + (DefaultDbValue[1] <> '"') then + DefaultDbValue := '''' + DefaultDbValue + ''''; + if SystemPersistenceMapper.SQLDataBaseConfig.StoreEmptyStringsAsNULL then + begin + if (MoldMember as TMoldAttribute).AllowNull then + raise EBold.CreateFmt('String attribute must not allow NULL in the model if persistencemapper stores empty strings as NULL (%s.%s)', [ + MoldClass.Name, MoldMember.Name]); + fAllowNull := True; + end; +end; - TwoSeconds := EncodeTime(0, 0, 2, 0); +function TBoldPMText.DefaultDefaultDbValue: String; +begin + if SystemPersistenceMapper.SQLDataBaseConfig.SupportsStringDefaultValues then + result := '''''' + else + result := ''; +end; + +function TBoldPMText.GetColumnTypeAsSQL(ColumnIndex: Integer): string; +begin + Result := SystemPersistenceMapper.SQLDataBaseConfig.ColumnTypeForText; +end; + +class function TBoldPMText.CanStore(const ContentName: string): Boolean; +begin + Result := AnsiCompareText(ContentName, BoldContentName_String) = 0; +end; + +function TBoldPMText.GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; +begin + Result := ftMemo; +end; +procedure TBoldPMText.ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); +var + aString: IBoldStringContent; +begin + EnsureFirstColumn(ColumnIndex); + aString := GetEnsuredValue(ObjectContent) as IBoldStringContent; + if Field.IsNull then + begin + if SystemPersistenceMapper.SQLDataBaseConfig.StoreEmptyStringsAsNULL then + aString.AsString := '' + else + aString.SetContentToNull + end + else + aString.AsString := Field.AsString +end; + +function TBoldPMText.CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; +var + aString: IBoldStringContent; +begin + EnsureFirstColumn(ColumnIndex); + aString := GetValue(ObjectContent) as IBoldStringContent; + result := + SystemPersistenceMapper.SQLDataBaseConfig.StoreEmptyStringsAsNULL and + Field.IsNull and (aString.AsString = ''); + + if not result then + begin + if not CheckEitherNull(field, aString, result) then + result := Field.AsString = aString.AsString; + end; +end; + +procedure TBoldPMText.ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); +var + aString: IBoldStringContent; +begin + EnsureFirstColumn(ColumnIndex); + aString := GetEnsuredValue(ObjectContent) as IBoldStringContent; + if aString.IsNull then + SetParamToNullWithDataType(Param, GetColumnBDEFieldType(0)) + else + Param.AsString := aString.AsString +end; + +{ TBoldPMUnicodeText } + +function TBoldPMUnicodeText.GetColumnBDEFieldType(ColumnIndex: Integer): + TFieldType; +begin + Result := ftWideMemo; +end; + +function TBoldPMUnicodeText.GetColumnTypeAsSQL(ColumnIndex: Integer): string; +begin + Result := SystemPersistenceMapper.SQLDataBaseConfig.ColumnTypeForUnicodeText; +end; + +{ TBoldPMGuid } + +function TBoldPMGuid.GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; +begin + result := ftGuid; +end; + +function TBoldPMGuid.GetColumnTypeAsSQL(ColumnIndex: Integer): string; +begin + Result := SystemPersistenceMapper.SQLDataBaseConfig.ColumnTypeForGUID; +end; + +initialization + TwoSeconds := EncodeTime(0, 0, 2, 0); with BoldMemberPersistenceMappers do begin AddDescriptor(TBoldSingleColumnMember, alAbstract); AddDescriptor(TBoldPMString, alConcrete); + AddDescriptor(TBoldPMAnsiString, alConcrete); + AddDescriptor(TBoldPMUnicodeString, alConcrete); AddDescriptor(TBoldPMStringBDECodePageBug, alConcrete); + AddDescriptor(TBoldPMText, alConcrete); + AddDescriptor(TBoldPMUnicodeText, alConcrete); AddDescriptor(TBoldPMInteger, alConcrete); AddDescriptor(TBoldPMSmallInt, alConcrete); AddDescriptor(TBoldPMByte, alConcrete); @@ -1014,6 +1517,7 @@ initialization AddDescriptor(TBoldPMDate, alConcrete); AddDescriptor(TBoldPMTime, alConcrete); AddDescriptor(TBoldPMLogic, alConcrete); + AddDescriptor(TBoldPMGuid, alConcrete); end; {end - initialization} @@ -1023,7 +1527,11 @@ finalization begin RemoveDescriptorByClass(TBoldSingleColumnMember); RemoveDescriptorByClass(TBoldPMString); + RemoveDescriptorByClass(TBoldPMAnsiString); + RemoveDescriptorByClass(TBoldPMUnicodeString); RemoveDescriptorByClass(TBoldPMStringBDECodePageBug); + RemoveDescriptorByClass(TBoldPMText); + RemoveDescriptorByClass(TBoldPMUnicodeText); RemoveDescriptorByClass(TBoldPMInteger); RemoveDescriptorByClass(TBoldPMSmallInt); RemoveDescriptorByClass(TBoldPMByte); @@ -1041,8 +1549,8 @@ finalization RemoveDescriptorByClass(TBoldPMDate); RemoveDescriptorByClass(TBoldPMTime); RemoveDescriptorByClass(TBoldPMLogic); + RemoveDescriptorByClass(TBoldPMGuid); end; {END finalization} end. - diff --git a/Source/PMapper/Default/BoldPMappersDefault.pas b/Source/PMapper/Default/BoldPMappersDefault.pas index a6676bd8..2ba58c56 100644 --- a/Source/PMapper/Default/BoldPMappersDefault.pas +++ b/Source/PMapper/Default/BoldPMappersDefault.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPMappersDefault; interface @@ -20,10 +23,13 @@ interface BoldPSParams, BoldPSDescriptions, BoldPSDescriptionsSQL, + BoldIndexCollection, BoldPSDescriptionsDefault, BoldSQLMappingInfo, BoldPMappers, - BoldPMappersSQL; + BoldPMappersSQL, + BoldElements; + const MEMBERIDCOLUMN_NAME = 'MEMBER_ID'; @@ -37,6 +43,8 @@ TBoldMemberDefaultMapper = class; TBoldModelVersionMember = class; EBoldCantGetID = class(EBold); + TGetNewTimeStampEvent = procedure(out aCurrentTimeStamp: integer; out aLastClockTimestamp: integer; out aLastClock: TDateTime; out aTheNowValue: TDateTime; aClockLogGranularity: TDateTime) of object; + TIDIncrementEvent = function(aNumberOfIdsToReserve: integer): integer of object; { TBoldSystemDefaultMapper } TBoldSystemDefaultMapper = class(TBoldSystemSQLMapper) @@ -44,6 +52,7 @@ TBoldSystemDefaultMapper = class(TBoldSystemSQLMapper) fNextDBID: Longint; fLastReservedDBID: Longint; fReservedCount: Longint; + fCustomIndexes: TBoldIndexCollection; fXFilesTimeStampColumn: TBoldSQLColumnDescription; fXFilesGlobalIdColumn: TBoldSQLColumnDescription; fTimeStampTableTimeStampColumn: TBoldSQLColumnDescription; @@ -53,8 +62,8 @@ TBoldSystemDefaultMapper = class(TBoldSystemSQLMapper) fClockLogTableThisTimeStampColumn: TBoldSQLColumnDescription; fClockLogTableThisClockColumn: TBoldSQLColumnDescription; fClockLogTableLastClockColumn: TBoldSQLColumnDescription; - function GetPSSystemDescription: TBoldDefaultSystemDescription; - function GetRootClassObjectPersistenceMapper: TBoldObjectDefaultMapper; + function GetPSSystemDescription: TBoldDefaultSystemDescription; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetRootClassObjectPersistenceMapper: TBoldObjectDefaultMapper; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure GetChangePointsQuery(Query: IBoldQuery; IdList: TBoldObjectIdList; StartTime: TBoldTimestampType; EndTime: TBoldTimestampType; NameSpace: TBoldSqlnameSpace); protected function CreatePSParams: TBoldPSParams; override; @@ -65,29 +74,32 @@ TBoldSystemDefaultMapper = class(TBoldSystemSQLMapper) property ReservedCount: Longint read fReservedCount write fReservedCount; function NewGlobalIdFromQuery(aQuery: IBoldQuery; BoldDbTypeColumn: Integer): TBoldObjectId; procedure GetNewTimeStamp; override; - procedure FetchDeletedObjects(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace); override; + procedure FetchDeletedObjects(ObjectIdList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace); override; procedure InitializeBoldDbType; override; function CreateMappingInfo: TBoldSQLMappingInfo; override; procedure InitializePSDescriptions; override; function EnsurePrecondition(Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList): Boolean; override; function EnsureOptimisticLocking(Precondition: TBoldOptimisticLockingPrecondition; TranslationList: TBoldIdTranslationList): Boolean; public - constructor CreateFromMold(moldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; SQlDatabaseConfig: TBoldSQLDatabaseConfig; GetDatabaseFunc: TBoldGetDatabaseEvent); + constructor CreateFromMold(moldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; + CustomIndexes: TBoldIndexCollection; SQlDatabaseConfig: TBoldSQLDatabaseConfig; GetDatabaseFunc: TBoldGetDatabaseEvent); procedure PMFetchClassWithCondition(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; BoldCondition: TBoldCondition; FetchMode: Integer; TranslationList: TBoldIdTranslationList); override; - function GetListUsingQuery(ObjectIDList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; aQuery: IBoldQuery; FetchMode: Integer; TranslationList: TBoldIdTranslationList; TimeStamp: TBoldTimeStampType; MaxAnswers: integer = -1; Offset: integer = -1): integer; + function GetListUsingQuery(ObjectIDList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; const aQuery: IBoldQuery; ClassId, BoldDbTypeColumn, ObjectIdColumn: integer; FetchMode: Integer; TranslationList: TBoldIdTranslationList; TimeStamp: TBoldTimeStampType; MaxAnswers: integer = -1; Offset: integer = -1): integer; function EnsureTable(const TableName: string; TableVersioned: Boolean): TBoldSQLTableDescription; override; function EnsureColumn(const TableName, ColumnName, SQLType, SQLAllowNull: string; const BDEType: TFieldType; Length: Integer; const AllowNull, InVersionedTable: Boolean; const DefaultDBValue: String): TBoldSQLColumnDescription; - procedure EnsureIndex(const TableName, Fields: string; const PrimaryIndex, Unique, InVersionedTable: Boolean); + procedure EnsureIndex(const TableName, Fields: string; const PrimaryIndex, + Unique, NonClustered, InVersionedTable: Boolean); procedure PMTranslateToGlobalIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; procedure PMTranslateToLocalIds(GlobalIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; procedure PMSetReadonlyness(ReadOnlyList, WriteableList: TBoldObjectIdList); override; procedure PMTimestampForTime(ClockTime: TDateTime; var Timestamp: TBoldTimestampType); override; procedure PMTimeForTimestamp(Timestamp: TBoldTimestampType; var ClockTime: TDateTime); override; - function NewIdFromQuery(aQuery: IBoldQuery; BoldDbTypeColumn, ObjectIdColumn: integer; Timestamp: TBoldTimeStampType): TBoldObjectId; + function NewIdFromQuery(const aQuery: IBoldQuery; ClassId, BoldDbTypeColumn, ObjectIdColumn: integer; Timestamp: TBoldTimeStampType): TBoldObjectId; + function CanEvaluateInPS(sOCL: string; aSystem: TBoldElement; aContext: TBoldElementTypeInfo = nil; const aVariableList: TBoldExternalVariableList = nil): Boolean; override; property PSSystemDescription: TBoldDefaultSystemDescription read GetPSSystemDescription; property RootClassObjectPersistenceMapper: TBoldObjectDefaultMapper read GetRootClassObjectPersistenceMapper; property XFilesTimeStampColumn: TBoldSQLColumnDescription read fXFilesTimeStampColumn; @@ -101,51 +113,73 @@ TBoldSystemDefaultMapper = class(TBoldSystemSQLMapper) property TimeStampTableTimeStampColumn: TBoldSQLColumnDescription read fTimeStampTableTimeStampColumn; end; + TQueryCacheEntry = record + MemberList: TBoldMemberIdList; + SqlStrings: TStringList; + FetchMode: Integer; + MemberPMList: TBoldMemberPersistenceMapperList; + CustomMembers: TBoldMemberPersistenceMapperList; + end; + + TPMCreateCacheEntry = record + SqlStrings: TStringList; + MemberPMList: TBoldMemberPersistenceMapperList; + end; + + TQueryCache = array of TQueryCacheEntry; + TPMCreateCache = array of TPMCreateCacheEntry; + { TBoldObjectDefaultMapper } TBoldObjectDefaultMapper = class(TBoldObjectSQLMapper) private fSubClassesID: string; fModelVersionMember: TBoldModelVersionMember; fOptimisticLockingMode: TBoldOptimisticLockingMode; - function GetSystemPersistenceMapper: TBoldSystemDefaultMapper; + fQueryCache: TQueryCache; + fPMCreateCache: TPMCreateCache; + fSingleLinkList: TBoldMemberIdList; + function GetSystemPersistenceMapper: TBoldSystemDefaultMapper; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure PMUpdateStopTime(ObjectIDList: TBoldObjectIdList); procedure GetChangePoints(ObjectIDList: TBoldObjectIdList; Condition: TBoldChangePointCondition; NameSpace: TBoldSqlnameSpace); - procedure PMMultiPurposeRetrieveExactIdList(ObjectsToFetch: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; TranslationList: TBoldIdTranslationList; MissingList: TBoldObjectIdList; FailureList: TBoldObjectIdList; TimeStamp: TBoldTimeStampType); - - procedure HandleCompareData(FetchedId: TBoldObjectId; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Query: IBoldQuery; MemberPMList: TBoldMemberPersistenceMapperList; FetchMode: integer; FailureList: TBoldObjectIdList); - function CompareFieldsToMembers(ObjectID: TBoldObjectId; ValueSpace: IBoldValueSpace; DataSet: IBoldDataSet; memberList: TBoldMemberPersistenceMapperList; TranslationList: TBoldIdTranslationList): Boolean; - procedure DetectLinkClassDuplicates(ObjectIdList: TBoldObjectidList; ValueSpace: IBoldvalueSpace; TranslationList: TBoldIdTranslationList; DuplicateList: TBoldObjectIdList); + procedure PMMultiPurposeRetrieveExactIdList(ObjectsToFetch: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; TranslationList: TBoldIdTranslationList; MissingList: TBoldObjectIdList; FailureList: TBoldObjectIdList; TimeStamp: TBoldTimeStampType); + function FindInCache(MemberIdList: TBoldMemberIdList; FetchMode: integer; var MemberPMList, CustomMembers: TBoldMemberPersistenceMapperList; var ASql: TStringList): boolean; + procedure HandleCompareData(FetchedId: TBoldObjectId; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Query: IBoldQuery; MemberPMList: TBoldMemberPersistenceMapperList; FetchMode: integer; FailureList: TBoldObjectIdList); + function CompareFieldsToMembers(ObjectID: TBoldObjectId; const ValueSpace: IBoldValueSpace; const DataSet: IBoldDataSet; memberList: TBoldMemberPersistenceMapperList; TranslationList: TBoldIdTranslationList): Boolean; + procedure DetectLinkClassDuplicates(ObjectIdList: TBoldObjectidList; const ValueSpace: IBoldvalueSpace; TranslationList: TBoldIdTranslationList; DuplicateList: TBoldObjectIdList); procedure GenerateMappingInfo(ExpressionName: String; MoldClass: TMoldClass); - procedure PMTemporalUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldvalueSpace; TranslationList: TBoldIdTranslationList); - procedure FetchPreviousSingleLinkValues(ObjectIdList: TBoldObjectIdLIst; Old_Values: IBoldvalueSpace); - procedure MakeIDsExactUsingTable(ObjectIDList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; Table: TBoldSQLTableDescription); - function InternalIdListSegmentToWhereFragment(IdList: TBoldObjectIdList; Start, Stop: integer; Parameterized: IBoldParameterized): String; - procedure InternalMakeIDsExact(ObjectIDList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); + procedure PMTemporalUpdate(ObjectIdList: TBoldObjectIdList; const ValueSpace: IBoldvalueSpace; TranslationList: TBoldIdTranslationList); + procedure FetchPreviousSingleLinkValues(ObjectIdList: TBoldObjectIdLIst; const Old_Values: IBoldvalueSpace); + procedure MakeIDsExactUsingTable(ObjectIDList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; Table: TBoldSQLTableDescription; EnsureAll: Boolean; HandleNonExisting: Boolean); + function InternalIdListSegmentToWhereFragment(IdList: TBoldObjectIdList; Start, Stop: Integer; AllowParms: Boolean; const Parameterized: IBoldParameterized): String; + procedure InternalMakeIDsExact(ObjectIDList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; EnsureAll: Boolean; HandleNonExisting: Boolean); + procedure FetchRawSqlCondition(ObjectIDList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; RawCondition: TBoldRawSqlCondition; FetchMode: Integer; TranslationList: TBoldIdTranslationList); protected procedure JoinSQLTableByKey(SQL: TStringList; MainTable, JoinTable: TBoldSQLTableDescription); override; procedure SQLForID(Table: TBoldSQLTableDescription; SQL: TStrings; UseAlias: Boolean); override; procedure SQLForDistributed(SQL: TStrings; const SQLStyle: TBoldSQLStyle); override; procedure PMFetchWithCondition(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; BoldCondition: TBoldCondition; FetchMode: Integer; TranslationList: TBoldIdTranslationList); override; - function NextExternalObjectId(ValueSpace: IBoldValueSpace; ObjectId: TBoldObjectId): TBoldObjectId; override; + const ValueSpace: IBoldValueSpace; BoldCondition: TBoldCondition; FetchMode: Integer; TranslationList: TBoldIdTranslationList); override; + function NextExternalObjectId(const ValueSpace: IBoldValueSpace; ObjectId: TBoldObjectId): TBoldObjectId; override; function DistributableTable: TBoldSQLTableDescription; override; - procedure PMCompareExactIDList(ObjectIDList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; TranslationList: TBoldIdTranslationList; FailureList: TBoldObjectIdList); + procedure PMCompareExactIDList(ObjectIDList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; TranslationList: TBoldIdTranslationList; FailureList: TBoldObjectIdList); procedure InitializePSDescriptions; override; + procedure FillInMembers(MyMoldClass, CurrentMoldClass: TMoldClass; TypeNameDictionary: TBoldTypeNameDictionary); override; public constructor CreateFromMold(moldClass: TMoldClass; Owner: TBoldSystemPersistenceMapper; TypeNameDictionary: TBoldTypeNameDictionary); override; + destructor Destroy; override; procedure SQLForKey(Table: TBoldSQLTableDescription; SQL: TStrings; const SQLStyle: TBoldSQLStyle; useAlias: Boolean); override; function UpdatesMembersInTable(aTable: TBoldSQLTableDescription): Boolean; override; - function IdListSegmentToWhereFragment(IdList: TBoldObjectIdList; Start, Stop: integer; Query: IBoldExecQuery): String; overload; - function IdListSegmentToWhereFragment(IdList: TBoldObjectIdList; Start, Stop: integer; Query: IBoldQuery): String; overload; - procedure MakeIDsExact(ObjectIDList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; - procedure PMFetchExactIDList(ObjectIDList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; TranslationList: TBoldIdTranslationList; MissingList: TBoldObjectIdList); override; - procedure PMDelete(ObjectIDList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; TranslationList: TBoldIdTranslationList); override; - procedure PMCreate(ObjectIDList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); override; - procedure PMUpdate(ObjectIDList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; TranslationList: TBoldIdTranslationList); override; - procedure DistributableInfoFromQuery(ObjectID: TBoldObjectId; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; DataSet: IBoldDataSet); - procedure HandleFetchData(FetchedId: TBoldObjectId; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Query: IBoldQuery; MemberPMList: TBoldMemberPersistenceMapperList; FetchMode: integer; FailureList: TBoldObjectIdList); - procedure PortObject(ObjectId: TBoldObjectId; Query: IBoldQuery); - function IsOldVersion(Query: IBoldQuery): Boolean; + function IdListSegmentToWhereFragment(IdList: TBoldObjectIdList; Start, Stop: Integer; AllowParms: Boolean; const Query: IBoldExecQuery): String; overload; + function IdListSegmentToWhereFragment(IdList: TBoldObjectIdList; Start, Stop: Integer; AllowParms: Boolean; const Query: IBoldQuery): String; overload; + procedure MakeIDsExact(ObjectIDList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; HandleNonExisting: Boolean); override; + procedure PMFetchExactIDList(ObjectIDList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; TranslationList: TBoldIdTranslationList; MissingList: TBoldObjectIdList); override; + procedure PMDelete(ObjectIDList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; const Old_Values: IBoldValueSpace; TranslationList: TBoldIdTranslationList); override; + procedure PMCreate(ObjectIDList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); override; + procedure PMUpdate(ObjectIDList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; const Old_Values: IBoldValueSpace; TranslationList: TBoldIdTranslationList); override; + procedure DistributableInfoFromQuery(ObjectID: TBoldObjectId; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const DataSet: IBoldDataSet); + procedure HandleFetchData(FetchedId: TBoldObjectId; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Query: IBoldQuery; MemberPMList: TBoldMemberPersistenceMapperList; FetchMode: integer; FailureList: TBoldObjectIdList); + procedure PortObject(ObjectId: TBoldObjectId; const Query: IBoldQuery); + function IsOldVersion(const Query: IBoldQuery): Boolean; property SubClassesID: string read fSubClassesID write fSubClassesId; property SystemPersistenceMapper: TBoldSystemDefaultMapper read GetSystemPersistenceMapper; property ModelVersionMember: TBoldModelVersionMember read fModelVersionMember; @@ -155,14 +189,15 @@ TBoldObjectDefaultMapper = class(TBoldObjectSQLMapper) TBoldMemberDefaultMapper = class(TBoldMemberSQLMapper) private procedure GenerateMappingInfo(MoldClass: TMoldClass; MoldMember: TMoldMember); - function GetSystemPersistenceMapper: TBoldSystemDefaultMapper; - function GetObjectPersistenceMapper: TBoldObjectDefaultMapper; + function GetSystemPersistenceMapper: TBoldSystemDefaultMapper; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetObjectPersistenceMapper: TBoldObjectDefaultMapper; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected - function CheckEitherNull(field: IBoldField; Value: IBoldValue; var Equal: Boolean): Boolean; + FColumnIndex: Boolean; + function CheckEitherNull(const field: IBoldField; const Value: IBoldValue; var Equal: Boolean): Boolean; function GetAllowNullAsSQL: string; override; procedure GetChangePoints(ObjectIDList: TBoldObjectIdList; Condition: TBoldChangePointCondition; NameSpace: TBoldSqlnameSpace); virtual; - function CompareFields(ObjectContent: IBoldObjectContents; DataSet: IBoldDataSet; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; - function CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; virtual; abstract; + function CompareFields(const ObjectContent: IBoldObjectContents; const DataSet: IBoldDataSet; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; virtual; abstract; procedure InitializePSDescriptions; override; function RequiresMemberMapping: Boolean; virtual; function FindDefiningTable(LocalMoldClass: TMoldClass; MoldMember: TMoldMember): string; virtual; @@ -170,7 +205,7 @@ TBoldMemberDefaultMapper = class(TBoldMemberSQLMapper) public constructor CreateFromMold(moldMember: TMoldMember; moldClass: TMoldClass; Owner: TBoldObjectPersistenceMapper; const MemberIndex: Integer; TypeNameDictionary: TBoldTypeNameDictionary); override; procedure PMFetch(ObjectIdList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; FetchMode: Integer; TranslationList: TBoldIdTranslationList; FailureList: TBoldObjectIdList); override; property ObjectPersistenceMapper: TBoldObjectDefaultMapper read GetObjectPersistenceMapper; @@ -193,15 +228,16 @@ TBoldModelVersionMember = class(TBoldSingleColumnMember) protected function GetColumnTypeAsSQL(ColumnIndex: Integer): string; override; function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; override; - function CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer;const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; function FindDefiningTable(LocalMoldClass: TMoldClass; MoldMember: TMoldMember): string; override; public constructor CreateFromMold(moldMember: TMoldMember; moldClass: TMoldClass; Owner: TBoldObjectPersistenceMapper; const MemberIndex: Integer; TypeNameDictionary: TBoldTypeNameDictionary); override; - function IsDirty(ObjectContents: IBoldObjectContents): Boolean; override; - function ShouldFetch(ObjectContents: IBoldObjectContents): Boolean; override; - procedure ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; - procedure ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); override; - function VersionFromQuery(Query: IBoldQuery): Integer; + function IsDirty(const ObjectContents: IBoldObjectContents): Boolean; override; + function ShouldFetch(const ObjectContents: IBoldObjectContents): Boolean; override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); override; + function ValueAsVariant(const ObjectContent: IBoldObjectContents; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; override; + function VersionFromQuery(const Query: IBoldQuery): Integer; property VersionNumber: Integer read fVersionNumber write fVersionNumber; end; @@ -210,14 +246,32 @@ TBoldReadOnlynessMember = class(TBoldSingleColumnMember) protected function GetColumnTypeAsSQL(ColumnIndex: Integer): string; override; function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; override; - function CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer;const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; function FindDefiningTable(LocalMoldClass: TMoldClass; MoldMember: TMoldMember): string; override; public constructor CreateFromMold(moldMember: TMoldMember; moldClass: TMoldClass; Owner: TBoldObjectPersistenceMapper; const MemberIndex: Integer; TypeNameDictionary: TBoldTypeNameDictionary); override; - function IsDirty(ObjectContents: IBoldObjectContents): Boolean; override; - function ShouldFetch(ObjectContents: IBoldObjectContents): Boolean; override; - procedure ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; - procedure ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); override; + function IsDirty(const ObjectContents: IBoldObjectContents): Boolean; override; + function ShouldFetch(const ObjectContents: IBoldObjectContents): Boolean; override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); override; + function ValueAsVariant(const ObjectContent: IBoldObjectContents; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; override; + end; + + { TBoldNonXFileTimeStampMember } + TBoldNonXFileTimeStampMember = class(TBoldSingleColumnMember) + protected + function GetColumnTypeAsSQL(ColumnIndex: Integer): string; override; + function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; override; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer;const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + function FindDefiningTable(LocalMoldClass: TMoldClass; MoldMember: TMoldMember): string; override; + function SupportsComparingWithoutValue: Boolean; override; + public + constructor CreateFromMold(moldMember: TMoldMember; moldClass: TMoldClass; Owner: TBoldObjectPersistenceMapper; const MemberIndex: Integer; TypeNameDictionary: TBoldTypeNameDictionary); override; + function IsDirty(const ObjectContents: IBoldObjectContents): Boolean; override; + function ShouldFetch(const ObjectContents: IBoldObjectContents): Boolean; override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); override; + function ValueAsVariant(const ObjectContent: IBoldObjectContents; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; override; end; TBoldXFilesMembers = class(TBoldSingleColumnMember) @@ -231,15 +285,16 @@ TBoldTimeStampMember = class(TBoldXFilesMembers) protected function GetColumnTypeAsSQL(ColumnIndex: Integer): string; override; function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; override; - function CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer;const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; function FindDefiningTable(LocalMoldClass: TMoldClass; MoldMember: TMoldMember): string; override; function SupportsComparingWithoutValue: Boolean; override; public constructor CreateFromMold(moldMember: TMoldMember; moldClass: TMoldClass; Owner: TBoldObjectPersistenceMapper; const MemberIndex: Integer; TypeNameDictionary: TBoldTypeNameDictionary); override; - function IsDirty(ObjectContents: IBoldObjectContents): Boolean; override; - function ShouldFetch(ObjectContents: IBoldObjectContents): Boolean; override; - procedure ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; - procedure ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); override; + function IsDirty(const ObjectContents: IBoldObjectContents): Boolean; override; + function ShouldFetch(const ObjectContents: IBoldObjectContents): Boolean; override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); override; + function ValueAsVariant(const ObjectContent: IBoldObjectContents; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; override; end; { TBoldTimeStampMember } @@ -247,16 +302,18 @@ TBoldGlobalIdMember = class(TBoldXFilesMembers) protected function GetColumnTypeAsSQL(ColumnIndex: Integer): string; override; function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; override; - function CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer;const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; function FindDefiningTable(LocalMoldClass: TMoldClass; MoldMember: TMoldMember): string; override; public constructor CreateFromMold(moldMember: TMoldMember; moldClass: TMoldClass; Owner: TBoldObjectPersistenceMapper; const MemberIndex: Integer; TypeNameDictionary: TBoldTypeNameDictionary); override; - function IsDirty(ObjectContents: IBoldObjectContents): Boolean; override; - function ShouldFetch(ObjectContents: IBoldObjectContents): Boolean; override; - procedure ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; - procedure ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); override; + function IsDirty(const ObjectContents: IBoldObjectContents): Boolean; override; + function ShouldFetch(const ObjectContents: IBoldObjectContents): Boolean; override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); override; + function ValueAsVariant(const ObjectContent: IBoldObjectContents; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; override; end; + TExternalIdGenerator = function: string; EBoldOptimisticLockingFailed = class(EBoldOperationFailedForIdList) @@ -266,6 +323,9 @@ EBoldOptimisticLockingFailed = class(EBoldOperationFailedForIdList) var ExternalIDGenerator: TExternalIdGenerator; + NewTimeStampEvent: TGetNewTimeStampEvent; + IDIncrementEvent: TIDIncrementEvent; + CompatibilityMode: boolean; implementation @@ -289,23 +349,218 @@ implementation BoldSqlQueryGenerator, BoldGUIDUtils, BoldGuard, + {$IFDEF RIL} + {$IFNDEF BOLD_UNICODE} + StringBuilder, + {$ENDIF} + {$ENDIF} BoldDefaultStreamNames, - BoldPMConsts; + BoldPMConsts, + BoldOCL, + BoldOclLightWeightNodeMaker, + BoldOCLClasses, + BoldSystem, + BoldSystemRT, + BoldContainers, + BoldIndex, + BoldIndexableList; const TIMESTAMPMEMBERINDEX = -2; {--Supporting functions/procedures---} +function TBoldSystemDefaultMapper.GetPSSystemDescription: TBoldDefaultSystemDescription; +begin + result := (inherited PSSystemDescription) as TBoldDefaultSystemDescription; +end; + +function TBoldObjectDefaultMapper.GetSystemPersistenceMapper: TBoldSystemDefaultMapper; +begin + result := (inherited SystemPersistenceMapper) as TBoldSystemDefaultMapper; +end; + +function TBoldSystemDefaultMapper.GetRootClassObjectPersistenceMapper: TBoldObjectDefaultMapper; +begin + result := (inherited RootClassObjectPersistenceMapper) as TBoldObjectDefaultMapper; +end; + +function TBoldMemberDefaultMapper.GetSystemPersistenceMapper: TBoldSystemDefaultMapper; +begin + result := inherited SystemPersistenceMapper as TBoldSystemDefaultMapper; +end; + +function TBoldMemberDefaultMapper.GetObjectPersistenceMapper: TBoldObjectDefaultMapper; +begin + result := (inherited ObjectPersistenceMapper) as TBoldObjectDefaultMapper; +end; + { TBoldSystemDefaultMapper } -constructor TBoldSystemDefaultMapper.CreateFromMold(moldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; SQlDatabaseConfig: TBoldSQLDatabaseConfig; GetDatabaseFunc: TBoldGetDatabaseEvent); + +function TBoldSystemDefaultMapper.CanEvaluateInPS(sOCL: string; + aSystem: TBoldElement; aContext: TBoldElementTypeInfo; + const aVariableList: TBoldExternalVariableList): Boolean; +var + i: Integer; + aResultEntry: TBoldOclEntry; + aEnv: TBoldOclEnvironment; + aOLWNodeMaker: TBoldOLWNodeMaker; + aOCLCondition: TBoldOCLCondition; + aSQLNodeResolver: TBoldSqlNodeResolver; + aSQLNodeMaker: TBoldSQLNodeMaker; + aBoldSystem: TBoldSystem; + aBoldOCL: TBoldOCL; + aResultType: TBoldElementTypeInfo; + aClassTypeInfo: TBoldClassTypeInfo; + aGlobalNameSpace: TBoldSqlNameSpace; + aSQlGenerator: TBoldSQLQueryGenerator; + aVariableIDLists: TBoldObjectArray; + + procedure FixQueriesForEnv(VarBinding: TBoldSQLVariableBinding; Context: TBoldObjectIdList; NameSpace: TBoldSqlNameSpace); + var + MainTableRef: TBoldSqlTableReference; + BoldID: TBoldDefaultID; + begin + if CompareText(VarBinding.VariableName, 'SELF') = 0 then // do not localize + begin + VarBinding.NewQuery(NameSpace); + + MainTableRef := VarBinding.TableReferenceForTable(VarBinding.ObjectMapper.MainTable, VarBinding.Query, true); + VarBinding.Context := aOclCondition.Context; + VarBinding.Query.AddWCF(TBoldSQLWCFBinaryInfix.CreateWCFForIdList(MainTableRef.GetColumnReference(IDCOLUMN_NAME), aOclCondition.Context)); + end else if VarBinding.IsExternal and (VarBinding.TopSortedIndex > -1) then + begin + VarBinding.NewQuery(NameSpace); + + MainTableRef := VarBinding.TableReferenceForTable(VarBinding.ObjectMapper.MainTable, VarBinding.Query, true); + VarBinding.Context := TBoldObjectIdList.Create; + aVariableIDLists.Add(VarBinding.Context); + BoldID := TBoldDefaultID.CreateWithClassID(VarBinding.ObjectMapper.TopSortedIndex, True); + BoldID.AsInteger := VarBinding.ExternalVarvalue; + VarBinding.Context.Add(BoldID); + VarBinding.Query.AddWCF(TBoldSQLWCFBinaryInfix.CreateWCFForIdList(MainTableRef.GetColumnReference(IDCOLUMN_NAME), VarBinding.Context)); + end; + end; + +begin + Result := False; + // Let all objects point to nil, so there are no problems on free + aResultEntry := nil; + aEnv := nil; + aOLWNodeMaker := nil; + aOCLCondition := nil; + aSQlNodeResolver := nil; + aSQLNodeMaker := nil; + aSQLGenerator := nil; + aGlobalNameSpace := nil; + + // On empty OCL a PS evaluation is unnecessary (objects are loaded already). + // System parameter must be type of TBoldSystem (see TBoldPersistenceController). + // Also OCL evaluator must be type of TBoldOCL, otherwise validation is not possible. + if (sOCL = '') {or not ((aSystem is TBoldSystem) and + (TBoldSystem(aSystem).Evaluator is TBoldOCL))} then + begin + Exit; + end; + + // Validation does not work with collection as context, though evaluation + // would be possible. Therefore always use ListElementTypeInfo. + aBoldSystem := TBoldSystem(aSystem); + if Assigned(aBoldSystem) then + aBoldOCL := TBoldOcl(aBoldSystem.Evaluator) + else + if Assigned(aContext) then + aBoldOCL := TBoldOcl(aContext.Evaluator) + else + raise Exception.Create('No system nor context provided.'); + if Assigned(aContext) and (aContext is TBoldListTypeInfo) then begin + aContext := TBoldListTypeInfo(aContext).ListElementTypeInfo; + end; + aVariableIDLists := TBoldObjectArray.Create(0, [bcoDataOwner]); + Result := True; + try + try + aEnv := TBoldOclEnvironment.Create(aBoldOCL.GlobalEnv); + // OCL semantic check + aResultEntry := aBoldOCL.SemanticCheck(sOCL, aContext, aVariableList, true, aEnv); + aOLWNodeMaker := TBoldOLWNodeMaker.Create(aResultEntry.Ocl, aContext.SystemTypeInfo as TBoldSystemTypeInfo, aBoldSystem, aEnv); + aResultEntry.Ocl.AcceptVisitor(aOLWNodeMaker); + // Can OCL be evaluated in PS in general? + if not aOLWNodeMaker.Failed then begin + aOCLCondition := TBoldOclCondition.Create; + aOCLCondition.OclExpr := sOCL; + + for i := 0 to aOLWNodeMaker.ExternalVarBindings.Count - 1 do + aOCLCondition.Env.Add(TBoldOLWVariableBinding(aOLWNodeMaker.ExternalVarBindings[i])); + aOLWNodeMaker.ExternalVarBindings.Clear; + + aOCLCondition.RootNode := aOLWNodeMaker.RootNode; + + aResultType := aResultEntry.Ocl.BoldType; + if aResultType is TBoldListTypeInfo then begin + aClassTypeInfo := TBoldListTypeInfo(aResultType).ListElementTypeInfo as TBoldClassTypeInfo; + end else begin + aClassTypeInfo := aResultType as TBoldClassTypeInfo; + end; + aOCLCondition.TopSortedIndex := aClassTypeInfo.TopSortedIndex; + + // Can all parts of OCLs be translated to SQL symbols? + aSQLNodeMaker := TBoldSQLNodeMaker.Create(aOCLCondition); + aSQLNodeMaker.Execute; + + aSQLNodeResolver := TBoldSqlNodeResolver.Create(Self, aSQLNodeMaker.RootNode, aSQLNodeMaker.SQLVarBindings); + aSQLNodeResolver.Execute; + // Finally the real check, which checks every symbol (AcceptVisitor). + aGlobalNameSpace := TBoldSqlnameSpace.Create; + + aSQlGenerator := TBoldSqlQueryGenerator.Create(aGlobalNameSpace); + for i := 0 to aSQLNodeMaker.SQLVarBindings.Count - 1 do begin + aSQLNodeMaker.SQLVarBindings[i].AcceptVisitor(aSQlGenerator); + FixQueriesForEnv(aSQLNodeMaker.SQLVarBindings[i] as TBoldSqlVariableBinding, aOclCondition.Context, aGlobalNameSpace); + end; + + aSQLNodeMaker.RootNode.AcceptVisitor(aSQlGenerator); + end else begin + Result := False; + SetBoldLastFailureReason(TBoldFailureReason.CreateFmt('%s at position: %d', [aOLWNodeMaker.FailureReason, aOLWNodeMaker.FailurePosition], nil)); + end; + except + on E:Exception do + begin + SetBoldLastFailureReason(TBoldFailureReason.Create(E.Message, nil)); + Result := False; + end; + end; + finally + if Assigned(aResultEntry) then begin + if aResultEntry.OwnedByDictionary then begin + aResultEntry.UsedByOtherEvaluation := false + end else begin + aResultEntry.Free; + end; + end; + aEnv.Free; + aOLWNodeMaker.Free; + aOCLCondition.Free; + aSQLGenerator.Free; + aSQlNodeResolver.Free; + aGlobalNameSpace.Free; + aSQLNodeMaker.Free; + aVariableIDLists.Free; + end; +end; + +constructor TBoldSystemDefaultMapper.CreateFromMold(moldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; + CustomIndexes: TBoldIndexCollection; SQlDatabaseConfig: TBoldSQLDatabaseConfig; GetDatabaseFunc: TBoldGetDatabaseEvent); begin inherited; NextDBID := -1; LastReservedDBID := -2; ReservedCount := 0; + fCustomIndexes := CustomIndexes; end; + procedure TBoldSystemDefaultMapper.ReserveID; begin Inc(fReservedCount); @@ -355,15 +610,15 @@ function TBoldSystemDefaultMapper.EnsureTable(const TableName: string; TableVers if TableVersioned then begin AddColumn(TIMESTAMPSTARTCOLUMNNAME, SQLDataBaseConfig.ColumnTypeForInteger, SQLDataBaseConfig.EffectiveSQLforNotNull, BOLDTIMESTAMPFIELDTYPE, 0, false, SQLDataBaseConfig.CorrectlyQuotedDefaultValue('0')); - EnsureIndex(IDCOLUMN_NAME + ';' + TIMESTAMPSTARTCOLUMNNAME, True, True); + EnsureIndex(IDCOLUMN_NAME + ';' + TIMESTAMPSTARTCOLUMNNAME, True, True, False); // the following two indices improves performance alot in Interbase, and seems to have no negative impact in SQLServer. - EnsureIndex(TIMESTAMPSTARTCOLUMNNAME, false, false); - EnsureIndex(IDCOLUMN_NAME, false, false); + EnsureIndex(TIMESTAMPSTARTCOLUMNNAME, false, false, false); + EnsureIndex(IDCOLUMN_NAME, false, false, false); end else - EnsureIndex(IDCOLUMN_NAME, True, True); + EnsureIndex(IDCOLUMN_NAME, True, True, false); - EnsureIndex(TYPECOLUMN_NAME, False, False); + EnsureIndex(TYPECOLUMN_NAME, False, False, false); end; Result := Result; end; @@ -392,62 +647,77 @@ function TBoldSystemDefaultMapper.EnsureColumn(const TableName, ColumnName, SQLT end; end; -procedure TBoldSystemDefaultMapper.EnsureIndex(const TableName, Fields: string; const PrimaryIndex, Unique, InVersionedTable: Boolean); +procedure TBoldSystemDefaultMapper.EnsureIndex(const TableName, Fields: string; + const PrimaryIndex, Unique, NonClustered, InVersionedTable: Boolean); var Table: TBoldSQLTableDescription; begin EnsureTable(TableName, InVersionedTable); Table := PSSystemDescription.SQLTablesList.ItemsBySQLName[TableName]; - Table.EnsureIndex(Fields, PrimaryIndex, Unique); + Table.EnsureIndex(Fields, PrimaryIndex, Unique, NonClustered); end; -function TBoldSystemDefaultMapper.NewIdFromQuery(aQuery: IBoldQuery; BoldDbTypeColumn, ObjectIdColumn: integer; Timestamp: TBoldTimeStampType): TBoldObjectId; +function TBoldSystemDefaultMapper.NewIdFromQuery(const aQuery: IBoldQuery; ClassId, BoldDbTypeColumn, ObjectIdColumn: integer; Timestamp: TBoldTimeStampType): TBoldObjectId; var ObjectId: TBoldDefaultId; TopSortedIndex: integer; begin if BoldDbTypeColumn = -1 then - TopSortedIndex := NO_CLASS + TopSortedIndex := ClassId else TopSortedIndex := topSortedIndexForBoldDbType(aQuery.Fields[BoldDbTypeColumn].AsInteger); if TimeStamp <> BoldMaxTimeStamp then - ObjectId := TBoldTimestampedDefaultId.createWithTimeAndClassId(TimeStamp, TopSortedIndex, true) + ObjectId := TBoldTimestampedDefaultId.createWithTimeAndClassId(TimeStamp, TopSortedIndex, BoldDbTypeColumn <> -1) else - ObjectId := TBoldDefaultId.CreateWithClassId(TopSortedIndex, true); + ObjectId := TBoldDefaultId.CreateWithClassId(TopSortedIndex, BoldDbTypeColumn <> -1); ObjectId.AsInteger := aQuery.Fields[ObjectIdColumn].AsInteger; result := ObjectId; end; -function TBoldSystemDefaultMapper.GetListUsingQuery(ObjectIDList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; aQuery: IBoldQuery; FetchMode: Integer; TranslationList: TBoldIdTranslationList; TimeStamp: TBoldTimeStampType; MaxAnswers: integer = -1; Offset: integer = -1): integer; +function TBoldSystemDefaultMapper.GetListUsingQuery(ObjectIDList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; const aQuery: IBoldQuery; ClassId, BoldDbTypeColumn, ObjectIdColumn: integer; FetchMode: Integer; TranslationList: TBoldIdTranslationList; TimeStamp: TBoldTimeStampType; MaxAnswers: integer = -1; Offset: integer = -1): integer; var ObjectId: TBoldObjectId; Counter: integer; + RecordsToProcess: integer; begin + Result := 0; aQuery.Open; if offset <> -1 then - aQuery.MoveBy(Offset); - // when MaxAnswer = -1 the while-test will never occur and we will get all the answers + begin + RecordsToProcess := aQuery.RecordCount - Offset {- aQuery.RecNo}; + if Offset <> 0 then + aQuery.MoveBy(Offset); + end + else + RecordsToProcess := aQuery.RecordCount {- aQuery.RecNo}; +// when MaxAnswer = -1 the while-test will never occur and we will get all the answers Counter := MaxAnswers; + + if (MaxAnswers <> -1) and (MaxAnswers < RecordsToProcess) then + RecordsToProcess := MaxAnswers; + ObjectIDList.Capacity := ObjectIDList.Count + RecordsToProcess; + TranslationList.Capacity := TranslationList.Count + RecordsToProcess; + while not aQuery.EOF and (Counter <> 0) do begin if TimeStamp = BOLDINVALIDTIMESTAMP then - ObjectId := NewIdFromQuery(aQuery, 1, 0, aQuery.FieldByName(TIMESTAMPSTARTCOLUMNNAME).AsInteger) + ObjectId := NewIdFromQuery(aQuery, ClassId, BoldDbTypeColumn, ObjectIdColumn, aQuery.FieldByUpperCaseName(TIMESTAMPSTARTCOLUMNNAMEUPPER).AsInteger) else - ObjectId := NewIdFromQuery(aQuery, 1, 0, TimeStamp); + ObjectId := NewIdFromQuery(aQuery, ClassId, BoldDbTypeColumn, ObjectIdColumn, TimeStamp); ValueSpace.EnsureObjectId(TranslationList.TranslateToNewId[ObjectId]); ObjectIDList.Add(ObjectId); - TranslationList.AddTranslation(nil, ObjectId); + INC(Result); + TranslationList.AddTranslationAdoptNew(nil, ObjectId); SendExtendedEvent(bpeFetchId, [ObjectId]); - ObjectId.Free; aQuery.Next; dec(Counter); end; - if (MaxAnswers < 0) or (Counter > 0) then +{ if (MaxAnswers < 0) or (Counter > 0) then result := MaxAnswers - Counter else - result := aQuery.RecordCount; + result := aQuery.RecordCount;} end; function TBoldSystemDefaultMapper.EnsurePrecondition(Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList): Boolean; @@ -473,10 +743,25 @@ procedure MergeFailures(MasterList, NewList: TBoldObjectIdList); Precondition.AddFailedObject(Newlist[i]); end; +function ContainsMemberId(MemberIdList: TBoldMemberIdList; MemberIndex: integer): boolean; +var + i: integer; +begin + result := false; + for I := 0 to MemberIdList.Count - 1 do + begin + if MemberIdList[i].MemberIndex = MemberIndex then + begin + result := true; + exit; + end; + end; +end; + var OldMemberIdList: TBoldMemberIdList; - SingleObjectList: TBoldObjectIdList; - TimeStampedObjects: TBoldObjectIdList; + SingleClassList: TBoldObjectIdList; + XFileTimeStampedObjects: TBoldObjectIdList; ObjectContents: IBoldObjectContents; Value: IBoldValue; ObjectIdList: TBoldObjectIdList; @@ -484,59 +769,134 @@ procedure MergeFailures(MasterList, NewList: TBoldObjectIdList); ObjectMapper: TBoldObjectDefaultmapper; FailureList: TBoldObjectIdList; BoldGuard: IBoldGuard; + TopSortedIndex: integer; + MemberCount: integer; + FetchBlockSize: integer; begin - BoldGuard := TBoldGuard.Create(TimeStampedObjects, ObjectIdList, FailureList, - SingleObjectlist, OldMemberIdList); + BoldGuard := TBoldGuard.Create(XFileTimeStampedObjects, ObjectIdList, FailureList, + SingleClassList, OldMemberIdList); OldMemberIdList := TBoldMemberIdList.Create; - SingleObjectList := TBoldObjectIdList.Create; - TimeStampedObjects := TBoldObjectIdList.Create; + SingleClassList := TBoldObjectIdList.Create; + XFileTimeStampedObjects := TBoldObjectIdList.Create; ObjectIdList := TBoldObjectIdList.Create; FailureList := TBoldObjectIdList.Create; + FetchBlockSize := SQLDataBaseConfig.FetchBlockSize; Precondition.valueSpace.AllObjectIds(ObjectidList, true); - for i := 0 to ObjectIdList.Count - 1 do + + for i := ObjectIdList.Count - 1 downto 0 do begin ObjectContents := Precondition.ValueSpace.ObjectContentsByObjectId[ObjectIdList[i]]; - if assigned(ObjectContents) then - begin - OldMemberIdList.Clear; - - if ObjectContents.TimeStamp <> -1 then - TimeStampedObjects.Add(ObjectIdList[i]); + // remove objects with no ObjectContents + if not assigned(ObjectContents) then + ObjectIdList.RemoveByIndex(i); + end; - for MemberIx := 0 to ObjectContents.MemberCount - 1 do + while ObjectIdList.count > 0 do + begin + TopSortedIndex := ObjectIdList[ObjectIdList.count-1].TopSortedIndex; + SingleClassList.Clear; + SingleClassList.Add(ObjectIdList[ObjectIdList.count-1]); + ObjectIdList.RemoveByIndex(ObjectIdList.count-1); + for I := ObjectIdList.Count - 1 downto 0 do + begin + // collect objects of same class in SingleClassList + if TopSortedIndex = ObjectIdList[i].TopSortedIndex then begin - Value := ObjectContents.ValueByIndex[MemberIx]; - if assigned(Value) then - OldMemberIdList.Add(TBoldmemberId.Create(MemberIx)); + SingleClassList.Add(ObjectIdList[i]); + ObjectIdList.RemoveByIndex(i); + if SingleClassList.count = FetchBlockSize then + break; end; + end; + OldMemberIdList.Clear; + + // process one object + ObjectContents := Precondition.ValueSpace.ObjectContentsByObjectId[SingleClassList[SingleClassList.count-1]]; + if ObjectContents.TimeStamp <> -1 then + if UseXFiles then + XFileTimeStampedObjects.AddIfNotInList(SingleClassList[SingleClassList.count-1]) + else + OldMemberIdList.Add(TBoldMemberId.Create(TIMESTAMPMEMBERINDEX)); - // we must compare the object even if it has no dirty members - // since it might be a delete and the object in the db might - // be deleted already. if it is timestamped however, we will - // detect it more cheap that way - if (OldMemberIdList.Count > 0) or (ObjectContents.TimeStamp = -1) then + for MemberIx := 0 to ObjectContents.MemberCount - 1 do + begin + Value := ObjectContents.ValueByIndex[MemberIx]; + if assigned(Value) then begin - SingleObjectList.Clear; - SingleObjectList.Add(ObjectIdList[i]); - failureList.Clear; - ObjectMapper := ObjectPersistenceMappers[ObjectIdList[i].TopSortedIndex] as TBoldObjectDefaultMapper; - Objectmapper.PMCompareExactIDList(SingleObjectList, Precondition.ValueSpace, OldMemberIdList, translationList, FailureList); - MergeFailures(precondition.FailureList, FailureList); + OldMemberIdList.Add(TBoldMemberId.Create(MemberIx)); end; end; + // loop and compare other objects, if they need exact same members as first object + // then keep them in SingleClassList and fetch them together + // otherwise return the object to ObjectIdList to be processed in the next pass + for i := SingleClassList.count - 2 downto 0 do // -2 is on purpose to skip the object we processed above + begin + ObjectContents := Precondition.ValueSpace.ObjectContentsByObjectId[SingleClassList[i]]; + MemberCount := 0; + begin + if ObjectContents.TimeStamp <> -1 then + begin + if UseXFiles then + XFileTimeStampedObjects.AddIfNotInList(SingleClassList[i]) + else + begin + if not ContainsMemberId(OldMemberIdList, TIMESTAMPMEMBERINDEX) then + begin // put the object back in the ObjectIdList + ObjectIdList.Add(SingleClassList[i]); + SingleClassList.RemoveByIndex(i); + continue; + end + else + Inc(MemberCount); + end; + end; + for MemberIx := 0 to ObjectContents.MemberCount - 1 do + begin + Value := ObjectContents.ValueByIndex[MemberIx]; + if assigned(Value) then + begin + if not ContainsMemberId(OldMemberIdList, MemberIx) then + begin // set MemberCount to number we're sure won't match so it will be removed + MemberCount := MaxInt; + break; + end + else + Inc(MemberCount); + end; + end; + // now also make sure the OldMemberIdList doesn't contain more members + if MemberCount <> OldMemberIdList.Count then + begin // put the object back in the ObjectIdList + ObjectIdList.Add(SingleClassList[i]); + SingleClassList.RemoveByIndex(i); + end + end + end; + + // we must compare the object even if it has no dirty members + // since it might be a delete and the object in the db might + // be deleted already. if it is timestamped however, we will + // detect it more cheap that way + if (OldMemberIdList.Count > 0) or (ObjectContents.TimeStamp = -1) then + begin + failureList.Clear; + ObjectMapper := ObjectPersistenceMappers[TopSortedIndex] as TBoldObjectDefaultMapper; + Objectmapper.PMCompareExactIDList(SingleClassList, Precondition.ValueSpace, OldMemberIdList, translationList, FailureList); + MergeFailures(precondition.FailureList, FailureList); + end; end; - if TimeStampedObjects.Count > 0 then + if XFileTimeStampedObjects.Count > 0 then begin OldMemberIdList.clear; FailureList.Clear; OldMemberIdList.Add(TBoldMemberId.Create(TIMESTAMPMEMBERINDEX)); - RootClassObjectPersistenceMapper.PMCompareExactIDList(TimeStampedObjects, Precondition.ValueSpace, OldMemberIdList, translationlist, FailureList); + RootClassObjectPersistenceMapper.PMCompareExactIDList(XFileTimeStampedObjects, Precondition.ValueSpace, OldMemberIdList, translationlist, FailureList); if FailureList.Count > 0 then begin - BoldLog.Log(sOptimisticLockingFailedOnTimeStamp); + BoldLog.Log('Optimistic Locking failed on timestamp for the following Objects'); for i := 0 to FailureList.Count - 1 do - BoldLog.LogFmt(sOptimisticLockFailedLog, + BoldLog.LogFmt('%s: Id %s', [ ObjectPersistenceMappers[FailureList[i].TopSortedIndex].ExpressionName, FailureList[i].AsString @@ -611,31 +971,9 @@ procedure TBoldObjectDefaultMapper.GenerateMappingInfo(ExpressionName: String; M end; constructor TBoldObjectDefaultMapper.CreateFromMold(moldClass: TMoldClass; Owner: TBoldSystemPersistenceMapper; TypeNameDictionary: TBoldTypeNameDictionary); -var - i: integer; begin inherited; fOptimisticLockingMode := MoldClass.EffectiveOptimisticLocking; - if SystemPersistenceMapper.UseModelVersion then - begin - fModelVersionMember := TBoldModelVersionMember.CreateFromMold(nil, MoldClass, self, -1, TypeNameDictionary); - MemberPersistenceMappers.Add(fModelVersionMember); - end; - if SystemPersistenceMapper.UseReadOnly then - MemberPersistenceMappers.Add(TBoldReadOnlynessMember.CreateFromMold(nil, MoldClass, self, -1, TypeNameDictionary)); - - - if SystemPersistenceMapper.UseXFiles then - begin - if SystemPersistenceMapper.UseTimestamp then - MemberPersistenceMappers.Add(TBoldTimeStampMember.CreateFromMold(nil, MoldClass, self, -1, TypeNameDictionary)); - if SystemPersistenceMapper.UseGlobalId then - MemberPersistenceMappers.Add(TBoldGlobalIdMember.CreateFromMold(nil, MoldClass, self, -1, TypeNameDictionary)); - end; - - fObjectIdClass := BOLDDEFAULTIDNAME; - for i := 0 to MoldClass.AllPossibleNames.Count - 1 do - GenerateMappingInfo(MoldClass.AllPossibleNames[i], MoldClass); end; type @@ -644,44 +982,41 @@ TLittleClass = class dbType: TBoldDbType; end; - - -procedure TBoldObjectDefaultMapper.InternalMakeIDsExact(ObjectIDList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); +procedure TBoldObjectDefaultMapper.InternalMakeIDsExact(ObjectIDList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; EnsureAll: Boolean; HandleNonExisting: Boolean); var i: integer; ObjectMapper: TBoldObjectDefaultMapper; begin if assigned(MainTable) then - MakeIDsExactUsingTable(ObjectIDList, TranslationList, MainTable) + MakeIDsExactUsingTable(ObjectIDList, TranslationList, MainTable, not SystemPersistenceMapper.UseXFiles, HandleNonExisting) else begin for i := 0 to SystemPersistenceMapper.ObjectPersistenceMappers.Count-1 do begin ObjectMapper := SystemPersistenceMapper.ObjectPersistenceMappers[i] as TBoldObjectDefaultMapper; if assigned(ObjectMapper) and (ObjectMapper.SuperClass = self) then - ObjectMapper.InternalMakeIDsExact(objectidlist, TranslationList); + ObjectMapper.InternalMakeIDsExact(objectidlist, TranslationList, not SystemPersistenceMapper.UseXFiles, HandleNonExisting); end; end; end; - -procedure TBoldObjectDefaultMapper.MakeIDsExact(ObjectIDList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); +procedure TBoldObjectDefaultMapper.MakeIDsExact(ObjectIDList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; HandleNonExisting: Boolean); var i: Integer; MissingIds: TBoldObjectIdList; begin if ObjectIDList.Count = 0 then exit; - InternalMakeIDsExact(ObjectIDList, TranslationList); MissingIds := TBoldObjectIdList.Create; try + MakeIDsExactUsingTable(ObjectIDList, TranslationList, MainTable, not SystemPersistenceMapper.UseXFiles, HandleNonExisting); if SystemPersistenceMapper.UseXFiles then begin for i := 0 to ObjectIDList.Count-1 do if TranslationList.TranslateToNewId[ObjectIdList[i]] = ObjectIdList[i] then MissingIds.Add(ObjectIdList[i]); if MissingIds.Count > 0 then - MakeIDsExactUsingTable(MissingIds, TranslationList, SystemPersistenceMapper.PSSystemDescription.XFilestable); + MakeIDsExactUsingTable(MissingIds, TranslationList, SystemPersistenceMapper.PSSystemDescription.XFilestable, true, HandleNonExisting); end; finally MissingIds.Free; @@ -690,34 +1025,64 @@ procedure TBoldObjectDefaultMapper.MakeIDsExact(ObjectIDList: TBoldObjectIdList; procedure TBoldObjectDefaultMapper.SQLForID(Table: TBoldSQLTableDescription; SQL: TStrings; useAlias: Boolean); begin - SQL.Append(Format('%s.%s', [Tablealias(Table, useAlias), IDCOLUMN_NAME])); // do not localize + SQL.Append(Format('%s.%s', [Tablealias(Table, useAlias), IDCOLUMN_NAME])) end; procedure TBoldObjectDefaultMapper.SQLForKey(Table: TBoldSQLTableDescription; SQL: TStrings; const SQLStyle: TBoldSQLStyle; useAlias: Boolean); var - tableQualifier, ColumnString: string; + tableQualifier, + ColumnString: string; begin tableQualifier := ''; if (Table = MainTable) and useAlias then tableQualifier := TableAlias(Table, useALias) + '.'; case SQLStyle of - ssColumns: ColumnString := tableQualifier + '%s'; - ssParameters: ColumnString := ':' + tableQualifier + '%s'; + ssColumns : ColumnString := tableQualifier; + ssParameters: ColumnString := ':' + tableQualifier; end; - SQL.Append(Format(ColumnString, [Table.ColumnsList[0].SQLName])); - SQL.Append(Format(ColumnString, [Table.ColumnsList[1].SQLName])); + SQL.Append(ColumnString+Table.ColumnsList[0].SQLName); + SQL.Append(ColumnString+Table.ColumnsList[1].SQLName); end; procedure TBoldObjectDefaultMapper.JoinSQLTableByKey(SQL: TStringList; MainTable, JoinTable: TBoldSQLTableDescription); -const - SQLEQUALITY = '%s.%s = %s.%s'; +{$IFDEF RIL} +var + SB: TStringBuilder; +begin + SB := TStringBuilder.Create(); + //SQL.Append(Format('%s.%s = %s.%s', [TableAlias(JoinTable, True), IDCOLUMN_NAME, TableAlias(MainTable, True), IDCOLUMN_NAME])); + SB.Append(TableAlias(JoinTable, True)); + SB.Append('.'); + SB.Append(IDCOLUMN_NAME); + SB.Append(' = '); + SB.Append(TableAlias(MainTable, True)); + SB.Append('.'); + SB.Append(IDCOLUMN_NAME); + SQL.Append(SB.Tostring); + if Versioned then + begin + // SQL.Append(Format('%s.%s = %s.%s', [TableAlias(JoinTable, True), TIMESTAMPSTARTCOLUMNNAME, TableAlias(MainTable, True), TIMESTAMPSTARTCOLUMNNAME])); + SB.Clear; + SB.Append(TableAlias(JoinTable, True)); + SB.Append('.'); + SB.Append(TIMESTAMPSTARTCOLUMNNAME); + SB.Append(' = '); + SB.Append(TableAlias(MainTable, True)); + SB.Append('.'); + SB.Append(TIMESTAMPSTARTCOLUMNNAME); + SQL.Append(SB.Tostring); + end; + FreeAndNil(SB); +end; +{$ELSE} begin - SQL.Append(Format(SQLEQUALITY, [TableAlias(JoinTable, True), IDCOLUMN_NAME, TableAlias(MainTable, True), IDCOLUMN_NAME])); + SQL.Append(Format('%s.%s = %s.%s', [TableAlias(JoinTable, True), IDCOLUMN_NAME, TableAlias(MainTable, True), IDCOLUMN_NAME])); if Versioned then - SQL.Append(Format(SQLEQUALITY, [TableAlias(JoinTable, True), TIMESTAMPSTARTCOLUMNNAME, TableAlias(MainTable, True), TIMESTAMPSTARTCOLUMNNAME])); + SQL.Append(Format('%s.%s = %s.%s', [TableAlias(JoinTable, True), TIMESTAMPSTARTCOLUMNNAME, TableAlias(MainTable, True), TIMESTAMPSTARTCOLUMNNAME])); end; +{$ENDIF} procedure TBoldObjectDefaultMapper.PMUpdateStopTime(ObjectIDList: TBoldObjectIdList); var @@ -731,7 +1096,7 @@ procedure TBoldObjectDefaultMapper.PMUpdateStopTime(ObjectIDList: TBoldObjectIdL for i := 0 to ObjectIdList.Count - 1 do IdStringList.Add(ObjectIdList[i].AsString); - UpdateQuery.AssignSQLText(format('UPDATE %s SET %s = %d WHERE %s in (%s) AND (%s = %d)', // do not localize + UpdateQuery.AssignSQLText(format('UPDATE %s SET %s = %d WHERE %s in (%s) AND (%s = %d)', [SystemPersistenceMapper.RootClassObjectPersistenceMapper.MainTable.SQLName, TIMESTAMPSTOPCOLUMNNAME, SystemPersistenceMapper.CurrentTimeStamp - 1, @@ -748,27 +1113,55 @@ procedure TBoldObjectDefaultMapper.PMUpdateStopTime(ObjectIDList: TBoldObjectIdL end; end; -procedure TBoldObjectDefaultMapper.PMCreate(ObjectIDList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); +procedure TBoldObjectDefaultMapper.PMCreate(ObjectIDList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList); + var - I, T, A: Integer; - TickCounter: integer; aQuery: IBoldExecQuery; - sql, TempList: TStringList; + Row: Integer; + SQL: TStringList; + procedure ExecuteQuery; + var + i: integer; + begin + aQuery.Params.EndUpdate; + aQuery.SQLStrings.EndUpdate; +// aQuery.ParamCheck := true; + aQuery.ExecSQL; + aQuery.Params.BeginUpdate; + aQuery.SQLStrings.BeginUpdate; +// aQuery.ParamCheck := false; + aQuery.Params.Clear; + aQuery.AssignSQL(SQL); + Row := 0; + end; +var +{$IFDEF RIL} + SB: TStringBuilder; +{$ENDIF} + I, T, A: Integer; + TickCounter: integer; + TempList: TStringList; MemberPMList: TBoldMemberPersistenceMapperList; MemberPMapper: TBoldMemberDefaultMapper; NewID: TBoldObjectId; DuplicateList: TBoldObjectIdList; + IdColumnParam: IBoldParameter; + TypeColumnParam: IBoldParameter; BoldGuard: IBoldGuard; + FoundInCache: boolean; + StoreInCache: boolean; + UseParams: boolean; + Limit: integer; + ObjectCount: Integer; begin - BoldGuard := TBoldGuard.Create(MemberPMList); - MemberPMList := TBoldMemberPersistenceMapperList.Create; - MemberPMList.OwnsEntries := False; + BoldGuard := TBoldGuard.Create({MemberPMList}{$IFDEF RIL}SB{$ENDIF},TempList); + {$IFDEF RIL} + SB := TStringBuilder.Create; + {$ENDIF} Tickcounter := 0; if IsLinkClass and (not Versioned) then begin - // this will update link-objects rather than create new if they are already in the database - // this happens only if two applications link the same two objects at the same time DuplicateList := TBoldObjectidList.Create; try DetectLinkClassDuplicates(ObjectIdList, ValueSpace, TranslationList, DuplicateList); @@ -784,95 +1177,173 @@ procedure TBoldObjectDefaultMapper.PMCreate(ObjectIDList: TBoldObjectIdList; Val if ObjectIdList.Count = 0 then exit; end; - + Limit := SystemPersistenceMapper.SQLDataBaseConfig.MultiRowInsertLimit; + UseParams := SystemPersistenceMapper.SQLDataBaseConfig.UseParamsForInteger; aQuery := SystemPersistenceMapper.GetExecQuery; - sql := TStringList.Create; + aQuery.ParamCheck := true; + TempList := TStringList.Create; + aQuery.SQLStrings.BeginUpdate; + aQuery.Params.BeginUpdate; + aQuery.Params.clear; + FoundInCache := useParams and (Limit = 1) and (Length(fPMCreateCache) > 0); try for T := 0 to AllTables.Count - 1 do begin - // Clear the memberlist, as we reuse it. - while MemberPMList.Count > 0 do - MemberPMList.RemoveByIndex(0); - // Fill it with members to use. - // FIXME: This will probably not work for members with several tables... /JoHo - for A := 0 to MemberPersistenceMappers.Count - 1 do + StoreInCache := false; + if not FoundInCache then begin - MemberPMapper := MemberPersistenceMappers[A] as TBoldMemberDefaultMapper; - if assigned(MemberPMapper) and - MemberPMapper.IsStoredInObject and not MemberPMapper.CustomCreateUpDate and - ((MemberPMapper.ColumnDescriptions[0] as TBoldSQLColumnDescription).TableDescription = AllTables[T]) then - MemberPMList.Add(MemberPMapper); - end; - - // Create insert query. - sql.Clear; - aQuery.ClearParams; - TempList := TStringList.Create; - SQLForMembers(AllTables[T], TempLIst, MemberPMList, ssColumns, True, False, False); + MemberPMList := TBoldMemberPersistenceMapperList.Create; + MemberPMList.OwnsEntries := False; + aQuery.ClearParams; + for A := 0 to MemberPersistenceMappers.Count - 1 do + begin + MemberPMapper := MemberPersistenceMappers[A] as TBoldMemberDefaultMapper; + if assigned(MemberPMapper) and + MemberPMapper.IsStoredInObject and not MemberPMapper.CustomCreateUpDate and + ((MemberPMapper.ColumnDescriptions[0] as TBoldSQLColumnDescription).TableDescription = AllTables[T]) then + MemberPMList.Add(MemberPMapper); + end; + SQL := TStringList.Create; + TempList.clear; + SQLForMembers(AllTables[T], TempList, MemberPMList, ssColumns, True, False, False); - if Alltables[T].Versioned then - begin - TempList.Add(TIMESTAMPSTARTCOLUMNNAME); - if allTables[T].ContainsStopTimeStamp then - TempList.Add(TIMESTAMPSTOPCOLUMNNAME); - end; + if Alltables[T].Versioned then + begin + TempList.Add(TIMESTAMPSTARTCOLUMNNAME); + if allTables[T].ContainsStopTimeStamp then + TempList.Add(TIMESTAMPSTOPCOLUMNNAME); + end; - BoldAppendToStrings(SQL, Format('INSERT INTO %s (%s) ', [AllTables[T].SQLName, // do not localize - BoldSeparateStringList(TempLIst, ', ', '', '')]), True); + {$IFDEF RIL} + //BoldAppendToStrings(SQL, Format('INSERT INTO %s (%s) ', [AllTables[T].SQLName, BoldSeparateStringList(TempLIst, ', ', '', '')]), True); + SB.Clear; + SB.Append('INSERT INTO '); + SB.Append(AllTables[T].SQLName); + SB.Append(' ('); + SB.Append(BoldSeparateStringList(TempLIst, ', ', '', '')); + SB.Append(') '); + BoldAppendToStrings(SQL, SB.ToString, True); + {$ELSE} + BoldAppendToStrings(SQL, Format('INSERT INTO %s (%s) ', [AllTables[T].SQLName, + BoldSeparateStringList(TempList, ', ', '', '')]), True); + {$ENDIF} + + if UseParams then + begin + TempList.Clear; + SQLForMembers(AllTables[T], TempList, MemberPMList, ssParameters, True, False, False); + end; - TempList.Clear; - SQLForMembers(AllTables[T], TempList, MemberPMList, ssParameters, True, False, False); + if Alltables[T].Versioned then + begin + TempList.Add(':' + TIMESTAMPSTARTCOLUMNNAME); + if allTables[T].ContainsStopTimeStamp then + TempList.Add(':' + TIMESTAMPSTOPCOLUMNNAME); + end; - if Alltables[T].Versioned then + {$IFDEF RIL} + SB.Clear; + SB.Append('VALUES '); + if UseParams then + begin + SB.Append('('); + SB.Append(BoldSeparateStringList(TempLIst, ', ', '', '')); + SB.Append(') '); + end; + BoldAppendToStrings(SQL, SB.ToString, True); + + {$ELSE} + BoldAppendToStrings(SQL, Format('VALUES (%s) ', [BoldSeparateStringList(TempLIst, ', ', '', '')]), True); + {$ENDIF} + // store in cache + StoreInCache := UseParams and (Limit = 1); + if StoreInCache then + begin + i := Length(fPMCreateCache); + SetLength(fPMCreateCache, i+1); + fPMCreateCache[i].SqlStrings := Sql; + fPMCreateCache[i].MemberPMList := MemberPMList; + end; + end + else begin - TempList.Add(':' + TIMESTAMPSTARTCOLUMNNAME); - if allTables[T].ContainsStopTimeStamp then - TempList.Add(':' + TIMESTAMPSTOPCOLUMNNAME); + SQL := fPMCreateCache[T].SqlStrings; + MemberPMList := fPMCreateCache[T].MemberPMList; end; - - BoldAppendToStrings(SQL, Format('VALUES (%s) ', [BoldSeparateStringList(TempLIst, ', ', '', '')]), True); // do not localize - TempLIst.Free; - + aQuery.ClearParams; aQuery.AssignSQL(SQL); - aQuery.StartSQLBatch; - try - for I := 0 to ObjectIDList.Count - 1 do + Row := 0; + SB.Clear; + for I := 0 to ObjectIDList.Count-1 do + begin + NewID := TranslationList.TranslateToNewID[ObjectIDList[I]]; + if UseParams then begin - // All tables have id and type as column 0 and 1 respectively - NewID := TranslationList.TranslateToNewID[ObjectIDList[I]]; - aQuery.ParamByName(IDCOLUMN_NAME).AsInteger := (NewId as TBoldDefaultId).AsInteger; - aQuery.ParamByName(TYPECOLUMN_NAME).AsSmallInt := SystemPersistenceMapper.BoldDbTypeForTopSortedIndex(NewId.topSortedIndex); - - ValuesToParamsByMemberList(ObjectIDList[I], ValueSpace, aQuery, MemberPMList, TranslationList, dsmCreate); - - if Alltables[T].Versioned then + IdColumnParam := aQuery.CreateParam(ftInteger, IDCOLUMN_NAME); + TypeColumnParam := aQuery.CreateParam(ftSmallInt, TYPECOLUMN_NAME); + IdColumnParam.AsInteger := (NewId as TBoldDefaultId).AsInteger; + TypeColumnParam.AsSmallInt := SystemPersistenceMapper.BoldDbTypeForTopSortedIndex(NewId.topSortedIndex) + end + else + begin + SB.Append( Format('(%s,%d', [NewId.AsString, SystemPersistenceMapper.BoldDbTypeForTopSortedIndex(NewId.topSortedIndex)]) ); + end; + TempList.Clear; + ValuesToQueryByMemberList(ObjectIDList[I], ValueSpace, aQuery, TempList, MemberPMList, TranslationList, dsmCreate); + SB.Append(TempList.text); + SB.Replace(#13#10, ''); + if Alltables[T].Versioned then + begin + if versioned then begin - if versioned then - aQuery.ParamByName(TIMESTAMPSTARTCOLUMNNAME).AsInteger := SystemPersistenceMapper.CurrentTimeStamp - else - aQuery.ParamByName(TIMESTAMPSTARTCOLUMNNAME).AsInteger := 0; - - if allTables[T].ContainsStopTimeStamp then - aQuery.ParamByName(TIMESTAMPSTOPCOLUMNNAME).AsInteger := BOLDMAXTIMESTAMP; + aQuery.EnsureParamByName(TIMESTAMPSTARTCOLUMNNAME).AsInteger := SystemPersistenceMapper.CurrentTimeStamp; + SB.Append(',:'+TIMESTAMPSTARTCOLUMNNAME); + end + else + begin + aQuery.EnsureParamByName(TIMESTAMPSTARTCOLUMNNAME).AsInteger := 0; + SB.Append(',:'+TIMESTAMPSTARTCOLUMNNAME); end; - Inc(TickCounter); - if (TickCounter MOD AllTables.Count) = 0 then + if allTables[T].ContainsStopTimeStamp then begin - SystemPersistenceMapper.SendExtendedEvent(bpeCreateObject, [ObjectIdList[i], ValueSpace]); - TickCounter := 0; + aQuery.EnsureParamByName(TIMESTAMPSTOPCOLUMNNAME).AsInteger := BOLDMAXTIMESTAMP; + SB.Append(',:'+TIMESTAMPSTOPCOLUMNNAME); end; - aQuery.ExecSQL; end; - aQuery.EndSQLBatch; - except - aQuery.FailSQLBatch; - raise; + Inc(TickCounter); + if (TickCounter MOD AllTables.Count) = 0 then + begin + SystemPersistenceMapper.SendExtendedEvent(bpeCreateObject, [ObjectIdList[i], ValueSpace]); + TickCounter := 0; + end; + inc(Row); + if UseParams or (i = ObjectIDList.Count-1) or (Row = Limit) or (aQuery.ParamCount + aQuery.BatchQueryParamCount >= SystemPersistenceMapper.SQLDataBaseConfig.MaxBatchQueryParams) then + begin + if not UseParams then + SB.Append(')'); + aQuery.SQLStrings.Add(SB.ToString); + SB.Clear; + ExecuteQuery; + end + else + if not UseParams then + begin + SB.Append('),'); + end; + end; + if not StoreInCache then + begin + MemberPMList.free; + SQl.free; end; end; finally + aQuery.SQLStrings.Clear; + aQuery.SQLStrings.EndUpdate; + aQuery.Params.Clear; + aQuery.Params.EndUpdate; SystemPersistenceMapper.ReleaseExecQuery(aQuery); - sql.Free; end; for A := 0 to MemberPersistenceMappers.Count - 1 do begin @@ -884,7 +1355,7 @@ procedure TBoldObjectDefaultMapper.PMCreate(ObjectIDList: TBoldObjectIdList; Val end; end; -procedure TBoldObjectDefaultMapper.PMTemporalUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldvalueSpace; TranslationList: TBoldIdTranslationList); +procedure TBoldObjectDefaultMapper.PMTemporalUpdate(ObjectIdList: TBoldObjectIdList; const ValueSpace: IBoldvalueSpace; TranslationList: TBoldIdTranslationList); var aQuery: IBoldExecQuery; OldDataQuery: IBoldQuery; @@ -909,10 +1380,8 @@ procedure TBoldObjectDefaultMapper.PMTemporalUpdate(ObjectIdList: TBoldObjectIdL begin if Alltables[T] <> SystemPersistenceMapper.PSSystemDescription.XFilestable then begin - // Clear the memberlist, as we reuse it. MemberPMList.Clear; - // Fill it with members to use. - // FIXME: This will probably not work for members with several tables... /JoHo + for A := 0 to MemberPersistenceMappers.Count - 1 do begin MemberPMapper := MemberPersistenceMappers[A] as TBoldMemberDefaultMapper; @@ -922,8 +1391,6 @@ procedure TBoldObjectDefaultMapper.PMTemporalUpdate(ObjectIdList: TBoldObjectIdL MemberPMList.Add(MemberPMapper); end; - // Create insert query. - SQL.Clear; TempList.Clear; @@ -931,18 +1398,18 @@ procedure TBoldObjectDefaultMapper.PMTemporalUpdate(ObjectIdList: TBoldObjectIdL TempList.Add(ObjectIdLIst[i].AsString); if AllTables[T].ContainsStopTimeStamp then - OldDataQuery.AssignSQLText(format('SELECT * FROM %s WHERE (%s in %s) AND (%s = %d)', [ // do not localize + OldDataQuery.AssignSQLText(format('SELECT * FROM %s WHERE (%s in %s) AND (%s = %d)', [ Alltables[T].SQlname, IDCOLUMN_NAME, BoldSeparateStringlist(TempList, ', ', '(', ')'), TIMESTAMPSTOPCOLUMNNAME, SystemPersistenceMapper.CurrentTimeStamp - 1])) else OldDataQuery.AssignSQLText(format( - 'SELECT DataTable.* FROM %0:s DataTable, %1:s RootTable ' + // do not localize - 'WHERE (DataTable.%2:s in %3:s) AND ' + // do not localize - '(DataTable.%2:s = RootTable.%2:s) AND ' + // do not localize - '(DataTable.%4:s = RootTable.%4:s) AND ' + // do not localize - '(RootTable.%5:s = %6:d)', [ // do not localize + 'SELECT DataTable.* FROM %0:s DataTable, %1:s RootTable '+ + 'WHERE (DataTable.%2:s in %3:s) AND '+ + '(DataTable.%2:s = RootTable.%2:s) AND '+ + '(DataTable.%4:s = RootTable.%4:s) AND '+ + '(RootTable.%5:s = %6:d)', [ Alltables[T].SQlname, SystemPersistenceMapper.RootClassObjectPersistenceMapper.MainTable.SQLName, IDCOLUMN_NAME, @@ -957,7 +1424,7 @@ procedure TBoldObjectDefaultMapper.PMTemporalUpdate(ObjectIdList: TBoldObjectIdL for i := 0 to OldDataQuery.FieldCount - 1 do TempList.Add(OldDataQuery.Fields[i].FieldName); - BoldAppendToStrings(SQL, Format('INSERT INTO %s (%s) ', [AllTables[T].SQLName, // do not localize + BoldAppendToStrings(SQL, Format('INSERT INTO %s (%s) ', [AllTables[T].SQLName, BoldSeparateStringList(TempLIst, ', ', '', '')]), True); TempList.Clear; @@ -972,25 +1439,20 @@ procedure TBoldObjectDefaultMapper.PMTemporalUpdate(ObjectIdList: TBoldObjectIdL TypeColumnIndex := i; end; - BoldAppendToStrings(SQL, Format('VALUES (%s) ', [BoldSeparateStringList(TempLIst, ', ', '', '')]), True); // do not localize + BoldAppendToStrings(SQL, Format('VALUES (%s) ', [BoldSeparateStringList(TempLIst, ', ', '', '')]), True); if (IdColumnIndex = -1) or (TypeColumnIndex = -1) then - raise EBoldInternal.CreateFmt(sTypeAndIDColumnMissing, [classname, aQuery.SQLText]); + raise EBoldInternal.CreateFmt('%s.PMTemporalUpdate: Unable to find either type or ID column in SQL-statement (%s)', [classname, aQuery.SQLText]); aQuery.AssignSQL(SQL); while not OldDataQuery.Eof do begin - NewId := SystemPersistenceMapper.NewIdFromQuery(OldDataQuery, TypeColumnIndex, IdColumnIndex, BOLDMAXTIMESTAMP); + NewId := SystemPersistenceMapper.NewIdFromQuery(OldDataQuery, NO_CLASS, TypeColumnIndex, IdColumnIndex, BOLDMAXTIMESTAMP); try - // copy all old data for i := 0 to OldDataQuery.FieldCount - 1 do aQuery.ParamByName(OldDataQuery.Fields[i].FieldName).AssignFieldValue(OldDataQuery.Fields[i]); - - // fill with known new data. ValuesToParamsByMemberList(NewId, ValueSpace, aQuery, MemberPMList, TranslationList, dsmUpdate); - - // set the timestamps aQuery.ParamByName(TIMESTAMPSTARTCOLUMNNAME).AsInteger := SystemPersistenceMapper.CurrentTimeStamp; if allTables[T].ContainsStopTimeStamp then aQuery.ParamByName(TIMESTAMPSTOPCOLUMNNAME).AsInteger := BOLDMAXTIMESTAMP; @@ -1028,7 +1490,7 @@ procedure TBoldObjectDefaultMapper.PMTemporalUpdate(ObjectIdList: TBoldObjectIdL end; end; -procedure TBoldObjectDefaultMapper.PMUpdate(ObjectIDList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; TranslationList: TBoldIdTranslationList); +procedure TBoldObjectDefaultMapper.PMUpdate(ObjectIDList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; const Old_Values: IBoldValueSpace; TranslationList: TBoldIdTranslationList); var aQuery: IBoldExecQuery; I, T, A: Integer; @@ -1037,9 +1499,10 @@ procedure TBoldObjectDefaultMapper.PMUpdate(ObjectIDList: TBoldObjectIdList; Val MemberPMapper: TBoldMemberDefaultMapper; ObjectContents: IBoldObjectContents; sql: TStringList; + UseParams: boolean; BoldGuard: IBoldGuard; begin - BoldGuard := TBoldGuard.Create(MemberPMList, SQL); + BoldGuard := TBoldGuard.Create(MemberPMList, SQL, TempList); if Versioned then begin PMTemporalUpdate(ObjectIdList, ValueSpace, TranslationList); @@ -1051,63 +1514,69 @@ procedure TBoldObjectDefaultMapper.PMUpdate(ObjectIDList: TBoldObjectIdList; Val if Assigned(Old_Values) then FetchPreviousSingleLinkValues(ObjectIdList, Old_Values); + UseParams := SystemPersistenceMapper.SQLDataBaseConfig.UseParamsForInteger; aQuery := SystemPersistenceMapper.GetExecQuery; + aQuery.ParamCheck := false; + aQuery.SQLStrings.BeginUpdate; sql := TStringList.Create; + TempList := TStringList.Create; try - aQuery.StartSQLBatch; - try - for T := 0 to AllTables.Count - 1 do + for T := 0 to AllTables.Count - 1 do + begin + if UpdatesMembersInTable(AllTables[T]) then begin - if UpdatesMembersInTable(AllTables[T]) then + for I := 0 to ObjectIDList.Count - 1 do begin - for I := 0 to ObjectIDList.Count - 1 do + ObjectContents := ValueSpace.ObjectContentsByObjectId[ObjectIDList[I]]; + MemberPMList.Clear; + for A := 0 to MemberPersistenceMappers.Count - 1 do begin - ObjectContents := ValueSpace.ObjectContentsByObjectId[ObjectIDList[I]]; - - // Clear the memberlist, as we reuse it. - while MemberPMList.Count > 0 do - MemberPMList.RemoveByIndex(0); + MemberPMapper := MemberPersistenceMappers[A] as TBoldMemberDefaultMapper; + if assigned(MemberPMapper) and + MemberPMapper.IsStoredInObject and not MemberPMapper.CustomCreateUpDate and + MemberPMapper.IsDirty(ObjectContents) and + ((MemberPMapper.ColumnDescriptions[0] as TBoldSQLColumnDescription).TableDescription = AllTables[T]) then + MemberPMList.Add(MemberPMapper); + end; - // Fill it with members to use. - for A := 0 to MemberPersistenceMappers.Count - 1 do + if MemberPMLIst.Count > 0 then + begin + SQL.Clear; + BoldAppendToStrings(SQL, Format('UPDATE %s SET ', [AllTables[T].SQLName]), True); + if UseParams then begin - MemberPMapper := MemberPersistenceMappers[A] as TBoldMemberDefaultMapper; - if assigned(MemberPMapper) and - MemberPMapper.IsStoredInObject and not MemberPMapper.CustomCreateUpDate and - MemberPMapper.IsDirty(ObjectContents) and - ((MemberPMapper.ColumnDescriptions[0] as TBoldSQLColumnDescription).TableDescription = AllTables[T]) then - MemberPMList.Add(MemberPMapper); + TempList.Clear; + SQLForMembers(AllTables[T], TempList, MemberPMList, ssValues, False, False, False); + BoldAppendToStrings(SQL, BoldSeparateStringList(TempLIst, ', ', '', ''), True); end; + aQuery.ClearParams; + aQuery.AssignSQL(sql); - if MemberPMLIst.Count > 0 then + TempList.Clear; + ValuesToQueryByMemberList(ObjectIDList[I], ValueSpace, aQuery, TempList, MemberPMList, TranslationList, dsmUpdate); + aQuery.SQLStrings.Add(TempList.Text); + if UseParams then begin - TempList := TStringList.Create; - SQLForMembers(AllTables[T], TempList, MemberPMList, ssValues, False, False, False); - - SQL.Clear; - BoldAppendToStrings(SQL, Format('UPDATE %s', [AllTables[T].SQLName]), True); // do not localize - BoldAppendToStrings(SQL, Format('SET %s', [BoldSeparateStringList(TempLIst, ', ', '', '')]), True); // do not localize - BoldAppendToStrings(SQL, Format('WHERE %s = :%0:s', [IDCOLUMN_NAME]), True); // do not localize - - TempList.Free; - - aQuery.ClearParams; - aQuery.AssignSQL(sql); + aQuery.CreateParam(ftInteger, IDCOLUMN_NAME).AsInteger := (TranslationList.TranslateToNewID[ObjectIDList[I]] as TBoldDefaultId).asInteger; + BoldAppendToStrings(aQuery.SQLStrings, Format(' WHERE %s = :%0:s', [IDCOLUMN_NAME]), True); + end + else + BoldAppendToStrings(aQuery.SQLStrings, Format(' WHERE %s = %s', [IDCOLUMN_NAME, ObjectIDList[I].AsString]), True); - aQuery.ParamByName(IDCOLUMN_NAME).AsInteger := (TranslationList.TranslateToNewID[ObjectIDList[I]] as TBoldDefaultId).asInteger; - ValuesToParamsByMemberList(ObjectIDList[I], ValueSpace, aQuery, MemberPMList, TranslationList, dsmUpdate); - SystemPersistenceMapper.SendExtendedEvent(bpeUpdateObject, [ObjectIDList[I], ValueSpace, aQuery]); - aQuery.ExecSQL; - end; + SystemPersistenceMapper.SendExtendedEvent(bpeUpdateObject, [ObjectIDList[I], ValueSpace, aQuery]); + aQuery.SQLStrings.EndUpdate; + aQuery.ParamCheck := true; + aQuery.ExecSQL; + aQuery.ParamCheck := false; + aQuery.SQLStrings.BeginUpdate; end; end; end; - aQuery.EndSQLBatch; - except - aQuery.FailSQLBatch; - raise; end; finally + aQuery.SQLStrings.Clear; + aQuery.ClearParams; + aQuery.SQLStrings.EndUpdate; SystemPersistenceMapper.ReleaseExecQuery(aQuery); end; @@ -1121,8 +1590,8 @@ procedure TBoldObjectDefaultMapper.PMUpdate(ObjectIDList: TBoldObjectIdList; Val end; end; -procedure TBoldObjectDefaultMapper.PMDelete(ObjectIDList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; - Old_Values: IBoldValueSpace; TranslationList: TBoldIdTranslationList); +procedure TBoldObjectDefaultMapper.PMDelete(ObjectIDList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; + const Old_Values: IBoldValueSpace; TranslationList: TBoldIdTranslationList); var I, T: Integer; aQuery: IBoldExecQuery; @@ -1155,6 +1624,8 @@ procedure TBoldObjectDefaultMapper.PMDelete(ObjectIDList: TBoldObjectIdList; Val lst := TStringList.Create; FetchBlockSize := SystemPersistenceMapper.SQLDataBaseConfig.FetchBlockSize; aQuery := SystemPersistenceMapper.GetExecQuery; + aQuery.ParamCheck := false; + aQuery.ClearParams; try ObjectCount := ObjectIDList.Count - 1; for Block := 0 to (ObjectCount div FetchBlockSize) do @@ -1165,14 +1636,10 @@ procedure TBoldObjectDefaultMapper.PMDelete(ObjectIDList: TBoldObjectIdList; Val for i := start to stop do SystemPersistenceMapper.SendExtendedEvent(bpeDeleteObject, [ObjectIDList[I], ValueSpace]); + BoldAppendToStrings(lst, 'DELETE FROM %s ', false); + IdListString := IdListSegmentToWhereFragment(ObjectIdList, start, stop, false, aQuery); - // Construct the delete statement with a placeholder for table-name - BoldAppendToStrings(lst, 'DELETE FROM %s', True); // do not localize - IdListString := IdListSegmentToWhereFragment(ObjectIdList, start, stop, aQuery); - - BoldAppendToStrings(lst, Format('WHERE %%s %s', [IdListString]), True); // do not localize - - //Execute SQLStatement on all tables except the xfiles table + BoldAppendToStrings(lst, Format(' WHERE %%s %s', [IdListString]), false); for T := 0 to AllTables.Count - 1 do begin if AllTables[t] <> SystemPersistenceMapper.PSSystemDescription.XFilestable then @@ -1183,14 +1650,13 @@ procedure TBoldObjectDefaultMapper.PMDelete(ObjectIDList: TBoldObjectIdList; Val begin if AllTables[t].ColumnsList.IndexOf(SystemPersistenceMapper.XFilesTimeStampColumn)<> -1 then begin - aQuery.AssignSQLText(Format('UPDATE %s SET %s = %d WHERE %s %s', // do not localize + aQuery.AssignSQLText(Format('UPDATE %s SET %s = %d WHERE %s %s', [AllTables[T].SQLName, SystemPersistenceMapper.XFilesTimeStampColumn.SQLName, SystemPersistenceMapper.CurrentTimeStamp, IDCOLUMN_NAME, IdListString])); aQuery.ExecSQL; end; end; end; - end; for I := 0 to ObjectIDList.Count - 1 do @@ -1203,13 +1669,47 @@ procedure TBoldObjectDefaultMapper.PMDelete(ObjectIDList: TBoldObjectIdList; Val end; end; -procedure TBoldObjectDefaultMapper.PMMultiPurposeRetrieveExactIdList(ObjectsToFetch: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; TranslationList: TBoldIdTranslationList; MissingList: TBoldObjectIdList; FailureList: TBoldObjectIdList; TimeStamp: TBoldTimeStampType); +procedure LogLateFetch(SQLHits: integer; ExpressionName: String); +begin + BoldPMLogFmt('Fetched %d objects of class %s', [SQLHits, ExpressionName]); + (* + if SQLHits = 1 then + try + raise Exception.CreateFmt('Fetched %d objects of class %s', [SQLHits, ExpressionName]); + except + on E: Exception do + TATErrorManager.LogLastException(E,'Fetch trace', 20); + end; + *) +end; + +function TBoldObjectDefaultMapper.FindInCache(MemberIdList: TBoldMemberIdList; + FetchMode: integer; var MemberPMList, CustomMembers: TBoldMemberPersistenceMapperList; + var ASql: TStringList): boolean; +var + i: integer; +begin + result := false; + for I := Length(fQueryCache) - 1 downto 0 do + if (fQueryCache[i].fetchMode = FetchMode) and + ((not Assigned(MemberIdList) and not Assigned(fQueryCache[i].MemberList)) + or (Assigned(MemberIdList) and (MemberIdList.IsEqual(fQueryCache[i].MemberList)))) then + begin + result := true; + MemberPMList := fQueryCache[i].MemberPMList; + CustomMembers := fQueryCache[i].CustomMembers; + ASQL := fQueryCache[i].SqlStrings; + exit; + end; +end; + +procedure TBoldObjectDefaultMapper.PMMultiPurposeRetrieveExactIdList(ObjectsToFetch: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; TranslationList: TBoldIdTranslationList; MissingList: TBoldObjectIdList; FailureList: TBoldObjectIdList; TimeStamp: TBoldTimeStampType); var Start, Stop: integer; CustomMembers, MemberPMList: TBoldMemberPersistenceMapperList; aQuery: IBoldQuery; - TempLIst: TStringList; + TempList: TStringList; Block, ObjectCount: Longint; i: Integer; @@ -1219,76 +1719,85 @@ procedure TBoldObjectDefaultMapper.PMMultiPurposeRetrieveExactIdList(ObjectsToFe sql: TStringList; FetchBlockSize: integer; RefetchIdList: TBoldObjectIdList; + Guard: IBoldGuard; + FoundInCache: boolean; begin - MemberPMList := TBoldMemberPersistenceMapperList.Create; - MemberPMList.OwnsEntries := False; - CustomMembers := TBoldMemberPersistenceMapperList.Create; - CustomMembers.OwnsEntries := False; - aQuery := SystemPersistenceMapper.GetQuery; - TempLIst := TStringList.Create; - sql := TStringList.Create; + Guard := TBoldGuard.Create(TempList, RefetchIdList); + FoundInCache := FindInCache(MemberIdList, FetchMode, MemberPMList, CustomMembers, sql); + if not FoundInCache then + begin + sql := TStringList.Create; + MemberPMList := TBoldMemberPersistenceMapperList.Create; + MemberPMList.OwnsEntries := False; + CustomMembers := TBoldMemberPersistenceMapperList.Create; + CustomMembers.OwnsEntries := False; + BuildMemberFetchLists(MemberIdList, MemberPMLIst, CustomMembers, FetchMode); + end; + TempList := TStringList.Create; RefetchIdList := TBoldObjectIdList.Create; FetchBlockSize := SystemPersistenceMapper.SQLDataBaseConfig.FetchBlockSize; - + aQuery := SystemPersistenceMapper.GetQuery; try - BuildMemberFetchLists(MemberIdList, MemberPMLIst, CustomMembers, FetchMode); - try if SystemPersistenceMapper.SupportsObjectUpgrading then SystemPersistenceMapper.ObjectUpgrader.StartTransaction; - // if the memberidlist is empty, then we must fetch the objects to make sure they still exist in the database - // this ensures optimistic locking on deleted objects. - // The below test will skip fetching the object if we are fetching only "custom members" + if (MemberPMList.Count > 0) or not assigned(MemberIdList) or (MemberIdList.Count = 0) then begin +{ if assigned(MissingList) then MissingList.AddList(ObjectsToFetch); - - // We do not want to retrieve more than FetchBlockSize objects at a time - +} ObjectCount := ObjectsToFetch.Count - 1; - for Block := 0 to (ObjectCount div FetchBlockSize) do + if assigned(MissingList) then begin - sql.clear; - RetrieveSelectStatement(SQL, MemberPMList, FetchMode, Versioned); + MissingList.Capacity := ObjectCount+1; + for I := ObjectsToFetch.Count - 1 downto 0 do + MissingList.Add(ObjectsToFetch[i]); + end; + if not FoundInCache then + RetrieveSelectStatement(SQL, MemberPMList, FetchMode, Versioned); + for Block := 0 to (ObjectCount div FetchBlockSize) do + begin Start := Block * FetchBlockSize; Stop := MinIntValue([Pred(Succ(Block) * FetchBlockSize), ObjectCount]); if Stop >= Start then begin aQuery.ClearParams; - BoldAppendToStrings(SQL, IdListSegmentToWhereFragment(ObjectsToFetch, Start, Stop, aQuery), False); + TempList.Assign(SQL); + BoldAppendToStrings(TempList, IdListSegmentToWhereFragment(ObjectsToFetch, Start, Stop, true, aQuery), False); if versioned then - RetrieveTimeStampCondition(SQL, TimeStamp, true, 'AND', false); // do not localize + RetrieveTimeStampCondition(TempList, TimeStamp, true, 'AND', false); + aQuery.SQLText := TempList.Text; SQLHits := 0; - aQuery.AssignSQL(SQL); aQuery.Open; while not aQuery.EOF do begin Inc(SQLHits); - tempId := (SystemPersistenceMapper as TBoldSystemDefaultMapper).NewIdFromQuery(aQuery, 1, 0, timeStamp); + tempId := (SystemPersistenceMapper as TBoldSystemDefaultMapper).NewIdFromQuery(aQuery, NO_CLASS, 1, 0, timeStamp); NewId := ObjectsToFetch.IDByID[TempId]; TempId.Free; if not assigned(NewId) then - raise EBoldInternal.CreateFmt(sUninvitedObjectReturnedFromDB, [classname, aQuery.Fields[0].AsInteger]); + raise EBoldInternal.CreateFmt('%s.PMMultiPurposeRetrieveExactIdList: Database returned object we didn''t ask for (ID: %d)', [classname, aQuery.Fields[0].AsInteger]); if assigned(MissingList) then begin i := MissingList.IndexByID[NewId]; if i <> -1 then - MissingList.RemoveByIndex(i) + MissingList.RemoveByIndex(i); end; if not NewId.TopSortedIndexExact then NewId := TranslationList.TranslateToNewID[NewId]; if not NewId.TopSortedIndexExact then - raise EBoldInternal.CreateFmt(sIDExactnessFailure, [classname]); + raise EBoldInternal.CreateFmt('%s.PMMultiPurposeRetrieveExactIdList: Got an Id with no or only approx class!', [classname]); if (TimeStamp = BOLDMAXTIMESTAMP) and not assigned(MemberIdList) and SystemPersistenceMapper.SupportsObjectUpgrading and IsOldVersion(aQuery) then begin @@ -1312,21 +1821,29 @@ procedure TBoldObjectDefaultMapper.PMMultiPurposeRetrieveExactIdList(ObjectsToFe aQuery.Next; end; + aQuery.ClearParams; aQuery.Close; - BoldPMLogFmt(sLogFetchedXobjectsOfY, [SQLHits, ExpressionName]); + if BoldPMLogHandler<>nil then + LogLateFetch(SQLHits, ExpressionName); end; end; if assigned(MissingList) and (FetchMode <> fmDistributable) and (MissingList.Count > 0) then begin - BoldPMLogFmt(sLogXObjectsOfYMissing, [MissingList.Count, ExpressionName]); - - for i := 0 to MissingList.Count - 1 do - begin - ObjectContents := ValueSpace.EnsuredObjectContentsByObjectId[MissingList[i]]; - ObjectContents.BoldExistenceState := besDeleted; - ObjectContents.IsReadOnly := true; - end; + if BoldPMLogHandler<>nil then + BoldPMLogFmt('%d objects of type %s were missing', [MissingList.Count, ExpressionName]); +// if not SystemPersistenceMapper.SQLDataBaseConfig.IgnoreMissingObjects then + for i := 0 to MissingList.Count-1 do + begin + if SystemPersistenceMapper.SQLDataBaseConfig.IgnoreMissingObjects then + TranslationList.AddTranslationAdoptNew(MissingList[i], TBoldNonExistingObjectId.CreateWithClassID(MissingList[i].TopSortedIndex, MissingList[i].TopSortedIndexExact)) + else + begin + ObjectContents := ValueSpace.EnsuredObjectContentsByObjectId[MissingList[i]]; + ObjectContents.BoldExistenceState := besDeleted; + ObjectContents.IsReadOnly := true; + end; + end; end; end; @@ -1345,16 +1862,23 @@ procedure TBoldObjectDefaultMapper.PMMultiPurposeRetrieveExactIdList(ObjectsToFe for i := 0 to CustomMembers.Count - 1 do CustomMembers[i].PMFetch(ObjectsToFetch, ValueSpace, FetchMode, TranslationList, failureList); finally - sql.Free; - MemberPMList.Free; - CustomMembers.Free; SystemPersistenceMapper.ReleaseQuery(aQuery); - TempLIst.Free; - RefetchIdList.Free; + if not FoundInCache then + begin + // store in cache + i := Length(fQueryCache); + SetLength(fQueryCache, i+1); + if Assigned(MemberIdList) then + fQueryCache[i].MemberList := MemberIdList.Clone; + fQueryCache[i].SqlStrings := Sql; + fQueryCache[i].FetchMode := FetchMode; + fQueryCache[i].MemberPMList := MemberPMList; + fQueryCache[i].CustomMembers := CustomMembers; + end; end; end; -function TBoldObjectDefaultMapper.CompareFieldsToMembers(ObjectID: TBoldObjectId; ValueSpace: IBoldValueSpace; DataSet: IBoldDataSet; memberList: TBoldMemberPersistenceMapperList; TranslationList: TBoldIdTranslationList): Boolean; +function TBoldObjectDefaultMapper.CompareFieldsToMembers(ObjectID: TBoldObjectId; const ValueSpace: IBoldValueSpace; const DataSet: IBoldDataSet; memberList: TBoldMemberPersistenceMapperList; TranslationList: TBoldIdTranslationList): Boolean; var i: integer; ObjectContents: IBoldObjectContents; @@ -1366,14 +1890,14 @@ function TBoldObjectDefaultMapper.CompareFieldsToMembers(ObjectID: TBoldObjectId result := result and TBoldMemberDefaultMapper(Memberlist[i]).CompareFields(ObjectContents, DataSet, ValueSpace, Translationlist); end; -procedure TBoldObjectDefaultMapper.HandleCompareData(FetchedId: TBoldObjectId; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Query: IBoldQuery; MemberPMList: TBoldMemberPersistenceMapperList; FetchMode: integer; FailureList: TBoldObjectIdList); +procedure TBoldObjectDefaultMapper.HandleCompareData(FetchedId: TBoldObjectId; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Query: IBoldQuery; MemberPMList: TBoldMemberPersistenceMapperList; FetchMode: integer; FailureList: TBoldObjectIdList); begin if not CompareFieldsToMembers(FetchedId, ValueSpace, Query, MemberPMList, TranslationList) and not FailureList.IdInList[FetchedId] then FailureList.Add(FetchedId); end; -procedure TBoldObjectDefaultMapper.PMCompareExactIDList(ObjectIDList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; TranslationList: TBoldIdTranslationList; FailureList: TBoldObjectIdList); +procedure TBoldObjectDefaultMapper.PMCompareExactIDList(ObjectIDList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; TranslationList: TBoldIdTranslationList; FailureList: TBoldObjectIdList); var MissingList: TBoldObjectIdList; i: integer; @@ -1385,28 +1909,26 @@ procedure TBoldObjectDefaultMapper.PMCompareExactIDList(ObjectIDList: TBoldObjec PMMultiPurposeRetrieveExactIdList(ObjectIdList, ValueSpace, MemberIdList, fmCompare, translationList, MissingList, FailureList, BoldMaxTimeStamp); if MissingList.Count > 0 then begin - BoldLog.LogFmt(sOptimisticLockingFailedForNonExisting, [expressionName]); + BoldLog.LogFmt('Optimistic Locking failed for the following objects of type %s because they did not exist in the database:', [expressionName]); for i := 0 to MissingList.Count - 1 do - BoldLog.LogFmt(sLogIdAsString, [MissingList[i].AsString]); + BoldLog.Log('Id: ' + MissingList[i].AsString); FailureList.AddList(MissingList); end; end; -procedure TBoldObjectDefaultMapper.HandleFetchData(FetchedId: TBoldObjectId; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Query: IBoldQuery; MemberPMList: TBoldMemberPersistenceMapperList; FetchMode: integer; FailureList: TBoldObjectIdList); +procedure TBoldObjectDefaultMapper.HandleFetchData(FetchedId: TBoldObjectId; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Query: IBoldQuery; MemberPMList: TBoldMemberPersistenceMapperList; FetchMode: integer; FailureList: TBoldObjectIdList); begin ValuesFromFieldsByMemberList(FetchedId, ValueSpace, TranslationList, Query, MemberPMList); if FetchMode = fmDistributable then DistributableInfoFromQuery(FetchedId, ValueSpace, TranslationList, Query); end; -procedure TBoldObjectDefaultMapper.PMFetchExactIDList(ObjectIDList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; TranslationList: TBoldIdTranslationList; MissingList: TBoldObjectIdList); +procedure TBoldObjectDefaultMapper.PMFetchExactIDList(ObjectIDList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; TranslationList: TBoldIdTranslationList; MissingList: TBoldObjectIdList); var i: integer; TimeStamp: TBoldTimeStampType; ListOfOtherTimeStamps, ObjectsToFetch: TBoldObjectIdList; begin - // Note, when the list gets here it contains only object of one class, from one - // Bold, that are not previously present in the Bold (or possibly a forced fetch) if objectIdList.Count = 0 then exit; @@ -1445,23 +1967,78 @@ procedure TBoldObjectDefaultMapper.PMFetchExactIDList(ObjectIDList: TBoldObjectI end; end; -procedure TBoldObjectDefaultMapper.PMFetchWithCondition(ObjectIDList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; BoldCondition: TBoldCondition; FetchMode: Integer; TranslationList: TBoldIdTranslationList); +procedure TBoldObjectDefaultMapper.FetchRawSqlCondition(ObjectIDList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; RawCondition: TBoldRawSqlCondition; FetchMode: Integer; TranslationList: TBoldIdTranslationList); +var + aQuery: IBoldQuery; +begin + aQuery := SystemPersistenceMapper.GetQuery; + try + aQuery.AssignSQLText(RawCondition.SQL); + aQuery.AssignParams(RawCondition.Params); + RawCondition.AvailableAnswers := (SystemPersistenceMapper as TBoldSystemDefaultMapper).GetListUsingQuery(ObjectIDList, ValueSpace, aQuery, RawCondition.TopSortedIndex, -1, 0, FetchMode, TranslationList, RawCondition.Time, RawCondition.MaxAnswers, RawCondition.Offset); + finally + SystemPersistenceMapper.ReleaseQuery(aQuery); + end; +end; + +procedure TBoldObjectDefaultMapper.FillInMembers(MyMoldClass, + CurrentMoldClass: TMoldClass; TypeNameDictionary: TBoldTypeNameDictionary); +var + i: integer; +begin + fOptimisticLockingMode := MyMoldClass.EffectiveOptimisticLocking; + if SystemPersistenceMapper.UseModelVersion then + begin + fModelVersionMember := TBoldModelVersionMember.CreateFromMold(nil, MyMoldClass, self, -1, TypeNameDictionary); + MemberPersistenceMappers.Add(fModelVersionMember); + end; + if SystemPersistenceMapper.UseReadOnly then + MemberPersistenceMappers.Add(TBoldReadOnlynessMember.CreateFromMold(nil, MyMoldClass, self, -1, TypeNameDictionary)); + + + if SystemPersistenceMapper.UseXFiles then + begin + if SystemPersistenceMapper.UseTimestamp then + MemberPersistenceMappers.Add(TBoldTimeStampMember.CreateFromMold(nil, MyMoldClass, self, -1, TypeNameDictionary)); + if SystemPersistenceMapper.UseGlobalId then + MemberPersistenceMappers.Add(TBoldGlobalIdMember.CreateFromMold(nil, MyMoldClass, self, -1, TypeNameDictionary)); + end + else + begin + if SystemPersistenceMapper.UseTimestamp and (not MyMoldClass.IsRootClass )then + MemberPersistenceMappers.Add(TBoldNonXFileTimeStampMember.CreateFromMold(nil, MyMoldClass, self, -1, TypeNameDictionary)); + end; + + fObjectIdClass := BOLDDEFAULTIDNAME; + for i := 0 to MyMoldClass.AllPossibleNames.Count - 1 do + GenerateMappingInfo(MyMoldClass.AllPossibleNames[i], MyMoldClass); + inherited; +end; + +procedure TBoldObjectDefaultMapper.PMFetchWithCondition(ObjectIDList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; BoldCondition: TBoldCondition; FetchMode: Integer; TranslationList: TBoldIdTranslationList); var aQuery: IBoldQuery; - WhereToken: string; - fromLine: String; - JoinLine: String; - RootTableName: string; - JoinCondition: string; + WhereToken, + fromLine, JoinLine, + RootTableName, JoinCondition, + sCurrentMappingInfo: string; i, j: Integer; timeStamp: TBoldTimeStampType; MappingInfo: TBoldAllInstancesMappingArray; SQL: TStringList; SQLCondition: TBoldSQLCondition; +{$IFDEF RIL} + SB: TStringBuilder; +{$ENDIF} begin if not assigned(BoldCondition) or (BoldCondition is TBoldConditionWithClass) then begin - if BoldCondition is TBoldSQLCondition then + if BoldCondition is TBoldRawSqlCondition then + begin + FetchRawSqlCondition(ObjectIDList, ValueSpace, TBoldRawSqlCondition(BoldCondition), FetchMode, TranslationList); + Exit; + end + else if BoldCondition is TBoldSQLCondition then SQLCondition := BoldCondition as TBoldSQLCondition else SQLCondition := nil; @@ -1469,11 +2046,16 @@ procedure TBoldObjectDefaultMapper.PMFetchWithCondition(ObjectIDList: TBoldObjec MappingInfo := SystemPersistenceMapper.MappingInfo.GetAllInstancesMapping(ExpressionName); aQuery := SystemPersistenceMapper.GetQuery; sql := TStringList.Create; + {$IFDEF RIL} + SB := TStringBuilder.Create; + {$ENDIF} try for i := 0 to length(MappingInfo) - 1 do begin + sCurrentMappingInfo := MappingInfo[i].TableName; + sql.Clear; - WhereToken := 'WHERE'; // Do not localize + WhereToken := 'WHERE'; if assigned(BoldCondition) then timeStamp := (BoldCondition as TBoldConditionWithClass).Time @@ -1482,19 +2064,33 @@ procedure TBoldObjectDefaultMapper.PMFetchWithCondition(ObjectIDList: TBoldObjec if (BoldCondition is TBoldTimestampCondition) then begin - SQL.Add(format('SELECT %s, %s', [IDCOLUMN_NAME, TYPECOLUMN_NAME])); // Do not localize - SQL.Add(format('FROM %s', [(SystemPersistenceMapper.PSSystemDescription as TBoldDefaultSystemDescription).XFilestable.SQLName])); // Do not localize - SQL.Add(format('WHERE %s > %d', [SystemPersistenceMapper.XFilesTimeStampColumn.SQLname, (BoldCondition as TBoldTimestampCondition).Timestamp])); // Do not localize + SQL.Add(format('SELECT %s, %s', [IDCOLUMN_NAME, TYPECOLUMN_NAME])); + SQL.Add(format('FROM %s', [(SystemPersistenceMapper.PSSystemDescription as TBoldDefaultSystemDescription).XFilestable.SQLName])); + SQL.Add(format('WHERE %s > %d', [SystemPersistenceMapper.XFilesTimeStampColumn.SQLname, (BoldCondition as TBoldTimestampCondition).Timestamp])); aQuery.AssignSQL(SQL); end else begin - SQL.Append(Format('SELECT %s.%s, %s.%s', [MappingInfo[i].TableName, IDCOLUMN_NAME, MappingInfo[i].TableName, TYPECOLUMN_NAME])); // do not localize - FromLine := Format('FROM %s', [MappingInfo[i].TableName]); // do not localize + {$IFDEF RIL} + SB.Clear; + SB.Append('SELECT '); + SB.Append(sCurrentMappingInfo); + SB.Append('.'); + SB.Append(IDCOLUMN_NAME); + SB.Append(', '); + SB.Append(sCurrentMappingInfo); + SB.Append('.'); + SB.Append(TYPECOLUMN_NAME); + SQL.Append(SB.ToString); + + FromLine := 'FROM '+sCurrentMappingInfo; + {$ELSE} + SQL.Append(Format('SELECT %s.%s, %s.%s', [MappingInfo[i].TableName, IDCOLUMN_NAME, MappingInfo[i].TableName, TYPECOLUMN_NAME])); + FromLine := Format('FROM %s', [MappingInfo[i].TableName]); + {$ENDIF} + JoinLine := ''; RootTableName := SystemPersistenceMapper.RootClassObjectPersistenceMapper.MainTable.SQLName; - - // add the rest of the tables if assigned(SQLCondition) and SQLCondition.JoinInheritedTables and ((SQLCondition.whereFragment <> '') or @@ -1502,35 +2098,35 @@ procedure TBoldObjectDefaultMapper.PMFetchWithCondition(ObjectIDList: TBoldObjec begin for j := 0 to AllTables.count - 1 do - if not SameText(Alltables[j].SQLName, MappingInfo[i].TableName) and + if not SameText(Alltables[j].SQLName, sCurrentMappingInfo) and (AllTables[j] <> SystemPersistenceMapper.PSSystemDescription.XFilestable) then begin - JoinCondition := format('(%s.%s = %s.%s)', // do not localize - [MappingInfo[i].TableName, IDCOLUMN_NAME, AllTables[j].SQLName, IDCOLUMN_NAME]); + JoinCondition := format('(%s.%s = %s.%s)', + [sCurrentMappingInfo, IDCOLUMN_NAME, AllTables[j].SQLName, IDCOLUMN_NAME]); if SystemPersistenceMapper.SQLDataBaseConfig.UseSQL92Joins then - fromLine := fromLine + format(' left join %s on %s ', [AllTables[j].SQLName, JoinCondition]) // do not localize + fromLine := fromLine + format(' left join %s on %s ', [AllTables[j].SQLName, JoinCondition]) else begin - fromLine := fromLine + format(', %s', [AllTables[j].SQLName]); // do not localize - JoinLine := JoinLine + format('%s %s ', [WhereToken, joinCondition]); // do not localize - WhereToken := 'AND'; // do not localize + fromLine := fromLine + format(', %s', [AllTables[j].SQLName]); + JoinLine := JoinLine + format('%s %s ', [WhereToken, joinCondition]); + WhereToken := 'AND'; end end; end else if Versioned and - not SameText(MappingInfo[i].TableName, RootTableName) then + not SameText(sCurrentMappingInfo, RootTableName) then begin - joinCondition := format('(%s.%s = %s.%s) ', // do not localize - [MappingInfo[i].TableName, IDCOLUMN_NAME, RootTableName, IDCOLUMN_NAME]); + joinCondition := format('(%s.%s = %s.%s) ', + [sCurrentMappingInfo, IDCOLUMN_NAME, RootTableName, IDCOLUMN_NAME]); if SystemPersistenceMapper.SQLDataBaseConfig.UseSQL92Joins then - fromLine := fromLine + format(' left join %s on %s ', [RootTableName, JoinCondition]) // do not localize + fromLine := fromLine + format(' left join %s on %s ', [RootTableName, JoinCondition]) else begin - fromLine := FromLine + ', ' + RootTableName; // do not localize - JoinLine := JoinLine + format(' %s %s ', [WhereToken, joincondition]); // do not localize - WhereToken := 'AND'; // do not localize + fromLine := FromLine + ', ' + RootTableName; + JoinLine := JoinLine + format(' %s %s ', [WhereToken, joincondition]); + WhereToken := 'AND'; end; end; SQL.Add(fromLine); @@ -1540,21 +2136,21 @@ procedure TBoldObjectDefaultMapper.PMFetchWithCondition(ObjectIDList: TBoldObjec if Versioned then begin RetrieveTimeStampCondition(sql, TimeStamp, false, WhereToken, false); - WhereToken := 'AND'; // do not localize + WhereToken := 'AND'; end; if MappingInfo[i].ClassIdRequired then begin - SQL.Add(Format('%s %s.%s in (%s)', [WhereToken, MappingInfo[i].TableName, TYPECOLUMN_NAME, SubClassesID])); // do not localize - WhereToken := 'AND'; // do not localize + SQL.Add(Format('%s %s.%s in (%s)', [WhereToken, sCurrentMappingInfo, TYPECOLUMN_NAME, SubClassesID])); + WhereToken := 'AND'; end; if assigned(SQLCondition) then begin - if SQLCondition.whereFragment <> '' then // do not localize - SQL.Append(Format('%s (%s)', [WhereToken, SQLCondition.whereFragment])); // do not localize - if SQLCondition.orderBy <> '' then // do not localize - SQL.Append(Format('ORDER BY %s', [SQLCondition.orderBy])); // do not localize + if SQLCondition.whereFragment <> '' then + SQL.Append(Format('%s (%s)', [WhereToken, SQLCondition.whereFragment])); + if SQLCondition.orderBy <> '' then + SQL.Append(Format('ORDER BY %s', [SQLCondition.orderBy])); end; aQuery.AssignSQL(SQL); @@ -1562,88 +2158,244 @@ procedure TBoldObjectDefaultMapper.PMFetchWithCondition(ObjectIDList: TBoldObjec if assigned(SQLCondition) then aQuery.AssignParams(SQLCondition.Params); + if assigned(SQLCondition) and Assigned(SystemPersistenceMapper.OnPsEvaluate) then + SystemPersistenceMapper.OnPsEvaluate(aQuery); end; - BoldCondition.AvailableAnswers := (SystemPersistenceMapper as TBoldSystemDefaultMapper).GetListUsingQuery(ObjectIDList, ValueSpace, aQuery, FetchMode, TranslationList, TimeStamp, BoldCondition.MaxAnswers, BoldCondition.Offset); - BoldPMLogFmt(sLogFetchedXObjectsOfYFromTableZ, [ObjectIdList.Count, ExpressionName, MappingInfo[i].tableName]); + BoldCondition.AvailableAnswers := (SystemPersistenceMapper as TBoldSystemDefaultMapper).GetListUsingQuery(ObjectIDList, ValueSpace, aQuery, NO_CLASS ,1, 0, FetchMode, TranslationList, TimeStamp, BoldCondition.MaxAnswers, BoldCondition.Offset); + {$IFDEF RIL} + //BoldPMLogFmt('Fetched %d IDs in class %s from table %s', [ObjectIdList.Count, ExpressionName, MappingInfo[i].tableName]); + if BoldPMLogHandler<>nil then { skip formating if the string is not used anyway... //ril } + begin + SB.Clear; + SB.Append('Fetched '); + SB.Append(IntToStr(ObjectIdList.Count)); + SB.Append(' IDs in class '); + SB.Append(ExpressionName); + SB.Append(' from table '); + SB.Append(sCurrentMappingInfo); + BoldPMLogFmt(SB.ToSTring, []); + end; + {$ELSE} + BoldPMLogFmt('Fetched %d IDs in class %s from table %s', [ObjectIdList.Count, ExpressionName, MappingInfo[i].tableName]); + {$ENDIF} end; finally SystemPersistenceMapper.ReleaseQuery(aQuery); sql.Free; + {$IFDEF RIL} + FreeAndNil(SB); + {$ENDIF} end; end else - raise EBold.CreateFmt(sUnknownConditionType, [BoldCondition.ClassName]); + raise EBold.CreateFmt('Unknown type of condition (%s)', [BoldCondition.ClassName]); end; -function TBoldObjectDefaultMapper.NextExternalObjectId(ValueSpace: IBoldValueSpace; ObjectId: TBoldObjectId): TBoldObjectId; +function TBoldObjectDefaultMapper.NextExternalObjectId(const ValueSpace: IBoldValueSpace; ObjectId: TBoldObjectId): TBoldObjectId; var aQuery: IBoldQuery; aExecQuery: IBoldExecQuery; NewID: Longint; SystemDefaultMapper: TBoldSystemDefaultMapper; begin + NewId := -1; SystemDefaultMapper := SystemPersistenceMapper as TBoldSystemDefaultMapper; if SystemDefaultMapper.NextDBID > SystemDefaultMapper.LastReservedDBID then begin - SystemDefaultMapper.StartTransaction(ValueSpace); - aQuery := SystemDefaultMapper.GetQuery; - aExecQuery := SystemDefaultMapper.GetExecQuery; - try + // plugin ID increment here + if Assigned(IDIncrementEvent) then + begin + NewID := IDIncrementEvent(SystemDefaultMapper.ReservedCount); + if CompatibilityMode then + begin + aExecQuery := SystemDefaultMapper.GetExecQuery; + try + try + aExecQuery.AssignSQLText(Format('UPDATE %s SET %s = %s + %d', [// do not localize + SystemDefaultMapper.PSSystemDescription.IdTable.SQLName, + IDCOLUMN_NAME, + IDCOLUMN_NAME, + SystemDefaultMapper.ReservedCount])); + aExecQuery.ExecSQL; + except + on E: EDatabaseError do + begin + raise EBoldCantGetID.CreateFmt('Can''t get ID (%s: %s)!', [e.ClassName, e.message]); + end; + end; + finally + SystemDefaultMapper.ReleaseExecQuery(aExecQuery); + end; + end; + end + else + begin + SystemDefaultMapper.StartTransaction(ValueSpace); + aQuery := SystemDefaultMapper.GetQuery; + aExecQuery := SystemDefaultMapper.GetExecQuery; try - aExecQuery.AssignSQLText(Format('UPDATE %s SET %s = %s + %d', [ // do not localize - SystemDefaultMapper.PSSystemDescription.IdTable.SQLName, - IDCOLUMN_NAME, - IDCOLUMN_NAME, - SystemDefaultMapper.ReservedCount])); - aExecQuery.ExecSQL; - aQuery.AssignSQLText(Format('SELECT %s FROM %s', [ // do not localize - IDCOLUMN_NAME, - SystemDefaultMapper.PSSystemDescription.IdTable.SQLName])); - aQuery.Open; - NewID := aQuery.Fields[0].AsInteger; - aQuery.Close; - SystemDefaultMapper.Commit(ValueSpace); - SystemDefaultMapper.NextDBID := NewID - SystemDefaultMapper.ReservedCount; - SystemDefaultMapper.LastReservedDBID := SystemDefaultMapper.NextDBID + SystemDefaultMapper.ReservedCount - 1; - except - on e: EDatabaseError do + try + aExecQuery.AssignSQLText(Format('UPDATE %s SET %s = %s + %d', [ + SystemDefaultMapper.PSSystemDescription.IdTable.SQLName, + IDCOLUMN_NAME, + IDCOLUMN_NAME, + SystemDefaultMapper.ReservedCount])); + aExecQuery.ExecSQL; + aQuery.AssignSQLText(Format('SELECT %s FROM %s', [ + IDCOLUMN_NAME, + SystemDefaultMapper.PSSystemDescription.IdTable.SQLName])); + aQuery.Open; + NewID := aQuery.Fields[0].AsInteger; + aQuery.Close; + SystemDefaultMapper.Commit(ValueSpace); + except + on e: EDatabaseError do + begin + SystemDefaultMapper.RollBack(ValueSpace); + raise EBoldCantGetID.CreateFmt('Can''t get ID (%s: %s)!', [e.ClassName, e.message]); + end; + end; + finally + SystemDefaultMapper.ReleaseQuery(aQuery); + SystemDefaultMapper.ReleaseExecQuery(aExecQuery); + end; + end; + SystemDefaultMapper.NextDBID := NewID - SystemDefaultMapper.ReservedCount; + SystemDefaultMapper.LastReservedDBID := SystemDefaultMapper.NextDBID + SystemDefaultMapper.ReservedCount - 1; + end; + SystemDefaultMapper.ReservedCount := 0; + + Result := TBoldDefaultId.CreateWithClassID(ObjectId.TopSortedIndex, true); + (result as TBoldDefaultId).AsInteger := SystemDefaultMapper.NextDBID; + + SystemDefaultMapper.NextDBID := SystemDefaultMapper.NextDBID + 1; +end; + +procedure TBoldObjectDefaultMapper.FetchPreviousSingleLinkValues(ObjectIdList: TBoldObjectIdLIst; const Old_Values: IBoldvalueSpace); +var + i: integer; +begin + if not Assigned(fSingleLinkList) then + begin + fSingleLinkList := TBoldMemberIdList.Create; + for i := 0 to MemberPersistenceMappers.Count - 1 do + if MemberPersistenceMappers[i] is TBoldEmbeddedSingleLinkDefaultMapper then + fSingleLinkList.Add(TBoldmemberId.Create(MemberPersistenceMappers[i].MemberIndex)); + end; + if fSingleLinkList.Count > 0 then + PMFetchExactIDList(ObjectIdList, Old_Values, fSingleLInkList, fmNormal, nil, nil); +end; + +procedure TBoldObjectDefaultMapper.MakeIDsExactUsingTable( + ObjectIDList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; + Table: TBoldSQLTableDescription; EnsureAll: Boolean; + HandleNonExisting: Boolean); +{$IFDEF RIL} +var + Block, + ObjectCount: Longint; + topSortedIndex, I, j: Integer; + tempId: TBoldObjectId; + aQuery: IBoldQuery; + lst: TStringList; + Start, Stop: integer; + WhereFragment: string; + LittleObject: TLittleClass; + Ids: TList; + FetchBlockSize: integer; + sTestCompare: string; + Found: boolean; + SB: TStringBuilder; +begin + if ObjectIDList.Count = 0 then + exit; + lst := TStringList.Create; + SB := TStringBuilder.Create; + Ids := TList.Create; + aQuery := SystemPersistenceMapper.GetQuery; + FetchBlockSize := SystemPersistenceMapper.SQLDataBaseConfig.FetchBlockSize; + try + ObjectCount := ObjectIDList.Count - 1; + for Block := 0 to (ObjectCount div FetchBlockSize) do + begin + lst.Clear; + aQuery.ClearParams; + Table.RetrieveSelectIdAndTypeStatement(lst); + Start := Block * FetchBlockSize; + Stop := MinIntValue([Pred(Succ(Block) * FetchBlockSize), ObjectCount]); + + WhereFragment := IdListSegmentToWhereFragment(ObjectIDList, start, stop, true, aquery); + {<*>} + //BoldAppendToStrings(lst, Format(' WHERE %s %s', [IDCOLUMN_NAME, WhereFragment]), True); + { + sTestCompare := Format(' WHERE %s %s', [IDCOLUMN_NAME, WhereFragment]); + } + SB.Clear; + SB.Append(' WHERE '); + SB.Append(IDCOLUMN_NAME); + SB.Append(' '); + SB.Append(WhereFragment); + { + if S<>sTestCompare then + raise Exception.CreateFmt('Optimize error in TBoldObjectDefaultMapper.MakeIDsExactUsingTable %s<>%s', [S, sTestCompare]); + } + BoldAppendToStrings(lst, SB.ToString, True); + {} + + aQuery.AssignSQL(lst); + aQuery.Open; + Ids.Count := 0; + // commented out as Query.RecordCount can be slow +// if aQuery.RecordCount > Ids.Capacity then +// Ids.Capacity := aQuery.RecordCount; + TranslationList.Capacity := aQuery.RecordCount; + try + while not aQuery.EOF do + begin + LittleObject := TLittleClass.Create; + LittleObject.Id := aQuery.Fields[0].AsInteger; + LittleObject.DbType := aQuery.Fields[1].AsInteger; + Ids.Add(LittleObject); + aQuery.next; + end; + for i := Start to Stop do begin - SystemDefaultMapper.RollBack(ValueSpace); - raise EBoldCantGetID.CreateFmt(sCannotGetID, [e.ClassName, e.message]); + Found := false; + for j := 0 to Ids.Count - 1 do + begin + if TBoldDefaultId(ObjectIdList[i]).AsInteger = TLittleClass(Ids[j]).Id then + begin + Found := true; + TopSortedIndex := SystemPersistenceMapper.topSortedIndexForBoldDbType(TLittleClass(Ids[j]).dbType); + tempId := ObjectIdList[i].CloneWithClassId(TopSortedIndex, true); + TranslationList.AddTranslationAdoptNew(ObjectIdList[i], tempId); + Break; + end; + end; + if not Found and not SystemPersistenceMapper.SQLDataBaseConfig.IgnoreMissingObjects then + begin + if HandleNonExisting then + begin + tempId := TBoldNonExistingObjectId.Create; + TranslationList.AddTranslationAdoptNew(ObjectIdList[i], tempId); + end + else if EnsureAll then + Raise EBoldObjectNotInPs.CreateFmt('Id %d not found in table %s', [TBoldDefaultId(ObjectIdList[i]).AsInteger, Table.SQLName]); + end; end; + finally + aQuery.close; + for j := 0 to Ids.Count - 1 do + tObject(Ids[j]).Free; end; - finally - SystemDefaultMapper.ReleaseQuery(aQuery); - SystemDefaultMapper.ReleaseExecQuery(aExecQuery); end; + finally + SystemPersistenceMapper.ReleaseQuery(aQuery); + lst.Free; + FreeAndNil(SB); + Ids.free; end; - SystemDefaultMapper.ReservedCount := 0; - - Result := TBoldDefaultId.CreateWithClassID(ObjectId.TopSortedIndex, true); - (result as TBoldDefaultId).AsInteger := SystemDefaultMapper.NextDBID; - - SystemDefaultMapper.NextDBID := SystemDefaultMapper.NextDBID + 1; -end; - -procedure TBoldObjectDefaultMapper.FetchPreviousSingleLinkValues(ObjectIdList: TBoldObjectIdLIst; Old_Values: IBoldvalueSpace); -var - i: integer; - SingleLinkList: TBoldMemberIdList; - BoldGuard: IBoldGuard; -begin - BoldGuard := TBoldGuard.Create(SingleLinkList); - SingleLinkList := TBoldMemberIdList.Create; - - for i := 0 to MemberPersistenceMappers.Count - 1 do - if MemberPersistenceMappers[i] is TBoldEmbeddedSingleLinkDefaultMapper then - SingleLinkList.Add(TBoldmemberId.Create(MemberPersistenceMappers[i].MemberIndex)); - if SingleLinkList.Count > 0 then - PMFetchExactIDList(ObjectIdList, Old_Values, SingleLInkList, fmNormal, nil, nil); -end; - -procedure TBoldObjectDefaultMapper.MakeIDsExactUsingTable( - ObjectIDList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; - Table: TBoldSQLTableDescription); +{$ELSE} var Block, ObjectCount: Longint; @@ -1659,11 +2411,11 @@ procedure TBoldObjectDefaultMapper.MakeIDsExactUsingTable( begin if ObjectIDList.Count = 0 then exit; - lst := TStringList.Create; aQuery := SystemPersistenceMapper.GetQuery; FetchBlockSize := SystemPersistenceMapper.SQLDataBaseConfig.FetchBlockSize; + Ids := TList.Create; + lst := TStringList.Create; try - // We do not want to retrieve more than BLOCKSIZE objects at a time ObjectCount := ObjectIDList.Count - 1; for Block := 0 to (ObjectCount div FetchBlockSize) do begin @@ -1672,11 +2424,13 @@ procedure TBoldObjectDefaultMapper.MakeIDsExactUsingTable( Start := Block * FetchBlockSize; Stop := MinIntValue([Pred(Succ(Block) * FetchBlockSize), ObjectCount]); - WhereFragment := IdListSegmentToWhereFragment(ObjectIDList, start, stop, aquery); - BoldAppendToStrings(lst, Format(' WHERE %s %s', [IDCOLUMN_NAME, WhereFragment]), True); // do not localize + WhereFragment := IdListSegmentToWhereFragment(ObjectIDList, start, stop, true, aquery); + BoldAppendToStrings(lst, Format(' WHERE %s %s', [IDCOLUMN_NAME, WhereFragment]), True); aQuery.AssignSQL(lst); aQuery.Open; - Ids := TList.Create; + Ids.Count := 0; + if Stop - Start >= Ids.Capacity then + Ids.Capacity := Stop - Start +1; try while not aQuery.EOF do begin @@ -1688,7 +2442,6 @@ procedure TBoldObjectDefaultMapper.MakeIDsExactUsingTable( end; for i := 0 to ObjectIdList.Count - 1 do begin - // fixme: Square for j := 0 to Ids.Count - 1 do begin if TBoldDefaultId(ObjectIdList[i]).AsInteger = TLittleClass(Ids[j]).Id then @@ -1704,29 +2457,69 @@ procedure TBoldObjectDefaultMapper.MakeIDsExactUsingTable( aQuery.close; for j := 0 to Ids.Count - 1 do tObject(Ids[j]).Free; - Ids.Free; end; end; finally SystemPersistenceMapper.ReleaseQuery(aQuery); lst.Free; + Ids.Free; end; +{$ENDIF} end; function TBoldObjectDefaultMapper.InternalIdListSegmentToWhereFragment( - IdList: TBoldObjectIdList; Start, Stop: integer; - Parameterized: IBoldParameterized): String; + IdList: TBoldObjectIdList; Start, Stop: Integer; AllowParms: Boolean; + const Parameterized: IBoldParameterized): String; function GetParamStr(IdIndex, ParamIndex: integer; UseParams: Boolean): String; begin if UseParams then begin - result := ':ID' + IntToStr(ParamIndex); // do not localize - Parameterized.CreateParam(ftInteger, 'ID' + IntToStr(ParamIndex), ptInput, SizeOf(Integer)).AsInteger := (IdList[IdIndex] as TBoldDefaultId).AsInteger; // do not localize + result := ':ID'+IntToStr(ParamIndex); + Assert(IdList[IdIndex] is TBoldDefaultId, IdList[IdIndex].ClassName); + Parameterized.CreateParam(ftInteger, 'ID'+IntToStr(ParamIndex)).AsInteger := (IdList[IdIndex] as TBoldDefaultId).AsInteger; end else result := IdList[Idindex].asString end; +{$IFDEF RIL} +var + i,j: integer; + TempList: TStringList; + ParamCount: integer; + UseParams: Boolean; + SB: TStringBuilder; +begin + + ParamCount := stop-start + 1; + UseParams := AllowParms and (ParamCount <= SystemPersistenceMapper.SQLDataBaseConfig.MaxParamsInIdList); + if ParamCount = 1 then + begin + Result := ' = ' + GetParamStr(start, 1, UseParams); + end + else + try + if UseParams then + i := ParamCount * 12 + else + i := ParamCount * 8; + SB := TStringBuilder.Create(i+5); + j := i+5; + SB.Append('in ('); + for i := start to stop do + begin + if i > start then + SB.Append(', '); + SB.Append(GetParamStr(i, i-start+1, Useparams)); + end; + SB.Append(')'); + {} + Result := SB.ToString; + finally + i := sb.Length; + FreeAndNil(SB); + end; +{$ELSE} var TempList: TStringList; i: integer; @@ -1744,25 +2537,27 @@ function TBoldObjectDefaultMapper.InternalIdListSegmentToWhereFragment( TempList := TStringList.Create; for i := start to stop do TempList.Add(GetParamStr(i, i-start+1, Useparams)); - result := BoldSeparateStringList(TempLIst, ', ', 'in (', ')'); // do not localize + result := BoldSeparateStringList(TempLIst, ', ', 'in (', ')'); end; +{$ENDIF} end; function TBoldObjectDefaultMapper.IdListSegmentToWhereFragment( - IdList: TBoldObjectIdList; Start, Stop: integer; - Query: IBoldExecQuery): String; + IdList: TBoldObjectIdList; Start, Stop: Integer; AllowParms: Boolean; + const Query: IBoldExecQuery): String; begin - result := InternalIdListSegmentToWhereFragment(IdList, Start, Stop, Query as IBoldParameterized); + result := InternalIdListSegmentToWhereFragment(IdList, Start, Stop, AllowParms, Query as IBoldParameterized); end; function TBoldObjectDefaultMapper.IdListSegmentToWhereFragment( - IdList: TBoldObjectIdList; Start, Stop: integer; - Query: IBoldQuery): String; + IdList: TBoldObjectIdList; Start, Stop: Integer; AllowParms: Boolean; + const Query: IBoldQuery): String; begin - result := InternalIdListSegmentToWhereFragment(IdList, Start, Stop, Query as IBoldParameterized); + result := InternalIdListSegmentToWhereFragment(IdList, Start, Stop, AllowParms, Query as IBoldParameterized); end; { TBoldMemberDefaultMapper } + function TBoldMemberDefaultMapper.GetAllowNullAsSQL: string; begin if AllowNull then @@ -1772,6 +2567,68 @@ function TBoldMemberDefaultMapper.GetAllowNullAsSQL: string; end; procedure TBoldMemberDefaultMapper.GenerateMappingInfo(MoldClass: TMoldClass; MoldMember: TMoldMember); +{$IFDEF RIL} + procedure GenerateLocal(const ClassExpressionName, MemberExpressionName: String; var ColumnNames: String; const LocalMoldClass: TMoldClass); + var + i: integer; + SubClass: TMoldClass; + begin + if LocalMoldClass.TableMapping in [tmOwn, tmParent] then + begin + TBoldSystemDefaultMapper(SystemPersistenceMapper).MappingInfo.AddMemberMapping( + ClassExpressionName, MemberExpressionName, + FindDefiningTable(LocalMoldClass, MoldMember), + ColumnNames, ClassName, FColumnIndex); + end; + if LocalMoldClass.TableMapping = tmChildren then + begin + for i := 0 to LocalMoldClass.SubClasses.Count-1 do + begin + SubClass := LocalMoldClass.SubClasses[i]; + if SubClass.EffectivePersistent then + GenerateLocal(ClassExpressionName, MemberExpressionName, ColumnNames, SubClass); + end; + end; + end; + + procedure GenerateForClassName(const ClassExpressionName: String; var ColumnNames: String); + var + i: integer; + s: TStringList; + BoldGuard: IBoldGuard; + begin + GenerateLocal(ClassExpressionName, ExpressionName, ColumnNames, moldclass); + if assigned(MoldMember) then + begin + BoldGuard := TBoldGuard.Create(s); + s := TStringlist.Create; + s.CommaText := MoldMember.FormerNames; + for i := 0 to s.count - 1 do + GenerateLocal(ClassExpressionName, s[i], ColumnNames, moldclass); + end; + end; + +var + i: integer; + ColumnNames: String; + SB: TStringBuilder; +begin + if requiresMemberMapping then + begin + SB := TStringBuilder.Create; + ColumnNames := ''; + for i := 0 to ColumnCount - 1 do + begin + if SB.Length > 0 then + SB.Append(', '); + SB.Append(BoldExpandName(InitialColumnName[i], '', xtSQL, SystemPersistenceMapper.SQLDataBaseConfig.MaxDBIdentifierLength, SystemPersistenceMapper.NationalCharConversion)); + end; + ColumnNames := SB.ToString; + for i := 0 to MoldClass.AllPossibleNames.count - 1 do + GenerateForClassName(MoldClass.AllPossibleNames[i], ColumnNames); + FreeAndNil(SB); + end; +{$ELSE} var ColumnNames: String; @@ -1785,7 +2642,8 @@ procedure TBoldMemberDefaultMapper.GenerateMappingInfo(MoldClass: TMoldClass; Mo MemberExpressionName, FindDefiningTable(LocalMoldClass, MoldMember), ColumnNames, - ClassName); + ClassName, + FColumnIndex); if LocalMoldClass.TableMapping = tmChildren then for i := 0 to LocalMoldClass.SubClasses.Count - 1 do if LocalMoldClass.SubClasses[i].EffectivePersistent then @@ -1819,14 +2677,12 @@ procedure TBoldMemberDefaultMapper.GenerateMappingInfo(MoldClass: TMoldClass; Mo begin if ColumnNames <> '' then ColumnNames := ColumnNames + ', '; - // expansion below is to truncate the names to the right length again... ColumnNames := ColumnNames + BoldExpandName(InitialColumnName[i], '', xtSQL, SystemPersistenceMapper.SQLDataBaseConfig.MaxDBIdentifierLength, SystemPersistenceMapper.NationalCharConversion); end; - - // this will loop over the name, all former names, and the names of the association for i := 0 to MoldClass.AllPossibleNames.count - 1 do GenerateForClassName(MoldClass.AllPossibleNames[i]); end; +{$ENDIF} end; constructor TBoldMemberDefaultMapper.CreateFromMold(moldMember: TMoldMember; moldClass: TMoldClass; Owner: TBoldObjectPersistenceMapper; const MemberIndex: Integer; TypeNameDictionary: TBoldTypeNameDictionary); @@ -1842,66 +2698,121 @@ procedure TBoldSystemDefaultMapper.GetNewTimeStamp; aExecQuery: IBoldExecQuery; LastClockTimestamp: TBoldTimestampType; LastClock: TDateTime; - TheNowValue: TDateTime; begin - aQuery := GetQuery; - aExecQuery := GetExecQuery; - try - aExecQuery.AssignSQLText( - Format('UPDATE %s SET %s = %s + 1', [ // do not localize - PSSystemDescription.TimeStampTable.SQLName, - TimeStampTableTimeStampColumn.SQLname, - TimeStampTableTimeStampColumn.SQLname])); - aExecQuery.ExecSQL; + if Assigned(NewTimeStampEvent) then + begin + NewTimeStampEvent(FCurrentTimeStamp, LastClockTimestamp, LastClock, fTimeOfTimeStamp, ClockLogGranularity); + if CompatibilityMode or UseClockLog then + begin + aExecQuery := GetExecQuery; + try + if CompatibilityMode then + begin + aExecQuery.AssignSQLText( + Format('UPDATE %s SET %s = %d', [// do not localize + PSSystemDescription.TimeStampTable.SQLName, + TimeStampTableTimeStampColumn.SQLName, + FCurrentTimeStamp])); + aExecQuery.ExecSQL; + end; + if UseClockLog then + begin + if LastClockTimeStamp <> -1 then + begin + aExecQuery.ParamCheck := true; + if CompatibilityMode then + begin + aExecQuery.AssignSQLText( + Format('UPDATE %s SET %s = :newTimestamp, %s = :newClock', [// do not localize + PSSystemDescription.LastClockTable.SQLName, + LastClockTableLastTimeStampColumn.SQLName, + LastClockTableLastClockColumn.SQLName])); + aExecQuery.ParamByName('newTimestamp').AsInteger := FCurrentTimeStamp; // do not localize + aExecQuery.ParamByName('newClock').AsDateTime := fTimeOfTimeStamp; // do not localize + aExecQuery.ExecSQL; + end; - aQuery.AssignSQLText( - Format('SELECT %s FROM %s', [ // do not localize - TimeStampTableTimeStampColumn.SQLname, - PSSystemDescription.TimeStampTable.SQLName])); - aQuery.Open; - FCurrentTimeStamp := aQuery.Fields[0].AsInteger; - aQuery.Close; + aExecQuery.AssignSQLText(Format('INSERT INTO %s (%s, %s, %s, %s) VALUES (:lastTimeStamp, :thisTimeStamp, :lastClock, :thisClock)', // do not localize + [PSSystemDescription.ClockLogTable.SQLName, + ClockLogTableLastTimeStampColumn.SQLName, + ClockLogTableThisTimeStampColumn.SQLName, + ClockLogTableLastClockColumn.SQLName, + ClockLogTableThisClockColumn.SQLName])); + aExecQuery.ParamByName('lastTimeStamp').AsInteger := LastClockTimestamp; // do not localize + aExecQuery.ParamByName('thisTimeStamp').AsInteger := FCurrentTimeStamp; // do not localize + aExecQuery.ParamByName('lastClock').AsDateTime := LastClock; // do not localize + aExecQuery.ParamByName('thisClock').AsDateTime := fTimeOfTimeStamp; // do not localize + aExecQuery.ExecSQL; + end; + end; + finally + ReleaseExecQuery(aExecQuery); + end; + end; + end + else + begin + aQuery := GetQuery; + aExecQuery := GetExecQuery; + aExecQuery.ParamCheck := false; + try + aExecQuery.AssignSQLText( + Format('UPDATE %s SET %s = %s + 1', [ + PSSystemDescription.TimeStampTable.SQLName, + TimeStampTableTimeStampColumn.SQLname, + TimeStampTableTimeStampColumn.SQLname])); + aExecQuery.ExecSQL; - if UseClockLog then - begin aQuery.AssignSQLText( - Format('SELECT %s, %s FROM %s', [ // do not localize - LastClockTableLastTimeStampColumn.SqlName, - LastClockTableLastClockColumn.SQLName, - PSSystemDescription.LastClockTable.SQLName])); + Format('SELECT %s FROM %s', [ + TimeStampTableTimeStampColumn.SQLname, + PSSystemDescription.TimeStampTable.SQLName])); aQuery.Open; - LastClockTimestamp := aQuery.Fields[0].AsInteger; - LastClock := aQuery.Fields[1].AsDateTime; + FCurrentTimeStamp := aQuery.Fields[0].AsInteger; aQuery.Close; - TheNowValue := GetCorrectTime; - if (TheNowValue - LastClock) > ClockLogGranularity then + if UseClockLog then begin - aExecQuery.AssignSQLText( - Format('UPDATE %s SET %s = :newTimestamp, %s = :newClock', [ // do not localize - PSSystemDescription.LastClockTable.SQLName, - LastClockTableLastTimeStampColumn.SQLName, - LastClockTableLastClockColumn.SQLName])); - aExecQuery.ParamByName('newTimestamp').AsInteger := FCurrentTimeStamp; // do not localize - aExecQuery.ParamByName('newClock').AsDateTime := TheNowValue; // do not localize - aExecQuery.ExecSQL; - - aExecQuery.AssignSQLText(Format('INSERT INTO %s (%s, %s, %s, %s) VALUES (:lastTimeStamp, :thisTimeStamp, :lastClock, :thisClock)', // do not localize - [PSSystemDescription.ClockLogTable.SQLName, - ClockLogTableLastTimeStampColumn.SQLName, - ClockLogTableThisTimeStampColumn.SQLName, - ClockLogTableLastClockColumn.SQLName, - ClockLogTableThisClockColumn.SQLName])); - aExecQuery.ParamByName('lastTimeStamp').AsInteger := LastClockTimestamp; // do not localize - aExecQuery.ParamByName('thisTimeStamp').AsInteger := FCurrentTimeStamp; // do not localize - aExecQuery.ParamByName('lastClock').AsDateTime := LastClock; // do not localize - aExecQuery.ParamByName('thisClock').AsDateTime := TheNowValue; // do not localize - aExecQuery.ExecSQL; + aQuery.AssignSQLText( + Format('SELECT %s, %s FROM %s', [ + LastClockTableLastTimeStampColumn.SqlName, + LastClockTableLastClockColumn.SQLName, + PSSystemDescription.LastClockTable.SQLName])); + aQuery.Open; + LastClockTimestamp := aQuery.Fields[0].AsInteger; + LastClock := aQuery.Fields[1].AsDateTime; + aQuery.Close; + +// fTimeOfTimeStamp := GetCorrectTime; // TimeOfTimeStamp is already set in NewTimeStampEvent + if (fTimeOfTimeStamp - LastClock) > ClockLogGranularity then + begin + aExecQuery.ParamCheck := true; + aExecQuery.AssignSQLText( + Format('UPDATE %s SET %s = %d, %s = :newClock', [ + PSSystemDescription.LastClockTable.SQLName, + LastClockTableLastTimeStampColumn.SQLName, + Integer(FCurrentTimeStamp), + LastClockTableLastClockColumn.SQLName])); + aExecQuery.ParamByName('newClock').AsDateTime := fTimeOfTimeStamp; // do not localize + aExecQuery.ExecSQL; + + aExecQuery.AssignSQLText(Format('INSERT INTO %s (%s, %s, %s, %s) VALUES (%d, %d, :lastClock, :thisClock)', + [PSSystemDescription.ClockLogTable.SQLName, + ClockLogTableLastTimeStampColumn.SQLName, + ClockLogTableThisTimeStampColumn.SQLName, + ClockLogTableLastClockColumn.SQLName, + ClockLogTableThisClockColumn.SQLName, + Integer(LastClockTimestamp), + Integer(FCurrentTimeStamp)])); + aExecQuery.ParamByName('lastClock').AsDateTime := LastClock; // do not localize + aExecQuery.ParamByName('thisClock').AsDateTime := fTimeOfTimeStamp; // do not localize + aExecQuery.ExecSQL; + end; end; + finally + ReleaseQuery(aQuery); + ReleaseExecQuery(aExecQuery); end; - finally - ReleaseQuery(aQuery); - ReleaseExecQuery(aExecQuery); end; end; @@ -1915,7 +2826,7 @@ function TBoldObjectDefaultMapper.UpdatesMembersInTable( if atable.Versioned then begin Inc(limit); - if atable.ContainsStopTimeStamp then + if aTable.ContainsStopTimeStamp then Inc(limit); end; result := (aTable.ColumnsList.Count > limit); @@ -1948,13 +2859,13 @@ procedure TBoldObjectDefaultMapper.SQLForDistributed(SQL: TStrings; end; procedure TBoldObjectDefaultMapper.DistributableInfoFromQuery( - ObjectID: TBoldObjectId; ValueSpace: IBoldValueSpace; - TranslationList: TBoldIdTranslationList; DataSet: IBoldDataSet); + ObjectID: TBoldObjectId; const ValueSpace: IBoldValueSpace; + TranslationList: TBoldIdTranslationList; const DataSet: IBoldDataSet); begin if SystemPersistenceMapper.UseTimestamp then - ValueSpace.EnsuredObjectContentsByObjectId[ObjectID].TimeStamp := DataSet.FieldByName(SystemPersistenceMapper.XFilesTimeStampColumn.SQLname).AsInteger; + ValueSpace.EnsuredObjectContentsByObjectId[ObjectID].TimeStamp := DataSet.FieldByUpperCaseName(SystemPersistenceMapper.XFilesTimeStampColumn.SQLNameUpper).AsInteger; if SystemPersistenceMapper.UseGlobalId then - ValueSpace.EnsuredObjectContentsByObjectId[ObjectID].GlobalId := DataSet.FieldByName(SystemPersistenceMapper.XFilesGlobalIdColumn.SQLName).AsString; + ValueSpace.EnsuredObjectContentsByObjectId[ObjectID].GlobalId := DataSet.FieldByUpperCaseName(SystemPersistenceMapper.XFilesGlobalIdColumn.SQLNameUpper).AsString; end; procedure TBoldSystemDefaultMapper.PMTranslateToGlobalIds( @@ -1984,7 +2895,7 @@ procedure TBoldSystemDefaultMapper.PMTranslateToGlobalIds( IdList.Add(ObjectIdList[I].AsString); aQuery.AssignSQLText( - Format('SELECT %s, %s, %s FROM %s WHERE %0:s IN (%4:s)', [ // do not localize + Format('SELECT %s, %s, %s FROM %s WHERE %0:s IN (%4:s)', [ IDCOLUMN_NAME, TYPECOLUMN_NAME, XFilesGlobalIdColumn.SQLName, @@ -1993,16 +2904,13 @@ procedure TBoldSystemDefaultMapper.PMTranslateToGlobalIds( aQuery.Open; + TranslationList.Capacity := TranslationList.Count + aQuery.RecordCount; while not aQuery.EOF do begin - anObjectId := NewIdFromQuery(aQuery, 1, 0, BOLDMAXTIMESTAMP); + anObjectId := NewIdFromQuery(aQuery, NO_CLASS, 1, 0, BOLDMAXTIMESTAMP); aGlobalId := NewGlobalIdFromQuery(aQuery, 1); - TranslationList.AddTranslation(anObjectId, aGlobalId); - - anObjectId.Free; - - aGlobalId.Free; + TranslationList.AddTranslationAdoptBoth(anObjectId, aGlobalId); aQuery.Next; end; @@ -2042,7 +2950,7 @@ procedure TBoldSystemDefaultMapper.PMTranslateToLocalIds( IdList.Add(GlobalIdList[I].AsString); aQuery.AssignSQLText( - Format('SELECT %s, %s, %s FROM %s WHERE %0:s IN (%4:s)', [ // do not localize + Format('SELECT %s, %s, %s FROM %s WHERE %0:s IN (%4:s)', [ XFilesGlobalIdColumn.SQLName, IDCOLUMN_NAME, TYPECOLUMN_NAME, @@ -2051,15 +2959,13 @@ procedure TBoldSystemDefaultMapper.PMTranslateToLocalIds( aQuery.Open; + TranslationList.Capacity := TranslationList.Count + aQuery.RecordCount; while not aQuery.EOF do begin aGlobalId := NewGlobalIdFromQuery(aQuery, 2); - anObjectId := NewIdFromQuery(aQuery, 2, 1, BoldMaxTimeStamp); - - TranslationList.AddTranslation(aGlobalId, anObjectId); + anObjectId := NewIdFromQuery(aQuery,NO_CLASS, 2, 1, BoldMaxTimeStamp); - freeandnil(anObjectId); - freeAndNil(aGlobalId); + TranslationList.AddTranslationAdoptBoth(aGlobalId, anObjectId); aQuery.Next; end; @@ -2074,7 +2980,7 @@ procedure TBoldSystemDefaultMapper.PMTranslateToLocalIds( end; procedure TBoldSystemDefaultMapper.FetchDeletedObjects( - ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace); + ObjectIdList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace); var aQuery: IBoldQuery; IdList: TStringList; @@ -2100,7 +3006,7 @@ procedure TBoldSystemDefaultMapper.FetchDeletedObjects( IdList.Add(ObjectIdList[I].AsString); aQuery.AssignSQLText( - Format('SELECT %s, %s, %s FROM %s WHERE %0:s IN (%4:s)', [ // do not localize + Format('SELECT %s, %s, %s FROM %s WHERE %0:s IN (%4:s)', [ IDCOLUMN_NAME, TYPECOLUMN_NAME, XFilesTimeStampColumn.SQLname, @@ -2148,7 +3054,7 @@ procedure TBoldSystemDefaultMapper.InitializeBoldDbType; begin BoldDbType := MappingInfo.GetDbTypeMapping(ObjectPersistenceMapper.ExpressionName); if BoldDbType = NO_CLASS then - MissingIds.Add(format(sUnableToFindDBIDForX, [ObjectPersistenceMapper.ExpressionName])) + MissingIds.Add(format('Unable to find databaseId for %s', [ObjectPersistenceMapper.ExpressionName])) else ObjectPersistenceMapper.BoldDbType := BoldDbType; @@ -2160,8 +3066,8 @@ procedure TBoldSystemDefaultMapper.InitializeBoldDbType; end; end; end; - if MissingIds.COunt > 0 then - raise EBold.Create(MissingIds.Text); + if MissingIds.Count > 0 then + raise EBoldMissingID.Create(MissingIds.Text); end; procedure TBoldSystemDefaultMapper.PMSetReadonlyness(ReadOnlyList, WriteableList: TBoldObjectIdList); @@ -2195,7 +3101,7 @@ procedure TBoldSystemDefaultMapper.PMSetReadonlyness(ReadOnlyList, WriteableList IdList.Add(ObjectIDList[I].AsString); aQuery.AssignSQLText( - Format('UPDATE %s SET %s = %d WHERE %s IN (%s)', [ // do not localize + Format('UPDATE %s SET %s = %d WHERE %s IN (%s)', [ RootClassObjectPersistenceMapper.MainTable.SQLName, READONLYCOLUMN_NAME, ReadOnlyValue, @@ -2221,14 +3127,14 @@ function TBoldSystemDefaultMapper.NewGlobalIdFromQuery(aQuery: IBoldQuery; BoldD begin TopSortedIndex := topSortedIndexForBoldDbType(aQuery.Fields[BoldDbTypeColumn].AsInteger); Result := TBoldGlobalId.CreateWithInfo( - aQuery.FieldByName(XFilesGlobalIdColumn.SQLName).AsString, + aQuery.FieldByUpperCaseName(XFilesGlobalIdColumn.SQLNameUpper).AsString, TopSortedIndex, true, ObjectPersistenceMappers[TopSortedIndex].ExpressionName); end; procedure TBoldMemberDefaultMapper.PMFetch(ObjectIdList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; FetchMode: Integer; + const ValueSpace: IBoldValueSpace; FetchMode: Integer; TranslationList: TBoldIdTranslationList; FailureList: TBoldObjectIdList); var Block, @@ -2241,10 +3147,8 @@ procedure TBoldMemberDefaultMapper.PMFetch(ObjectIdList: TBoldObjectIdList; MemberPMList: TBoldMemberPersistenceMapperList; Table: TBoldSQLTableDescription; begin - // Note, when the list gets here it contains only object of one class, from one - // Bold, that are not previously present in the Bold (or possibly a forced fetch) - // all objectids are the same timestamp, this has been taken care of by PMFetchExactId + if (ObjectIdList.Count > 1) and RequiresLiveQuery then BlockSize := 1 else @@ -2268,30 +3172,30 @@ procedure TBoldMemberDefaultMapper.PMFetch(ObjectIdList: TBoldObjectIdList; Table := (ColumnDescriptions[0] as TBoldSQLColumnDescription).TableDescription; TempLIst.Clear; TBoldObjectDefaultMapper(ObjectPersistenceMapper).SQLForMembers(Table, TempList, MemberPMList, ssColumns, true, true, False); - SQL.Text := format('SELECT %s FROM %s WHERE %s ', [BoldSeparateStringList(TempLIst, ', ', '', ''), Table.SQLName, IDCOLUMN_NAME]); // do not localize + SQL.Text := format('SELECT %s FROM %s WHERE %s ', [BoldSeparateStringList(TempLIst, ', ', '', ''), Table.SQLName, IDCOLUMN_NAME]); Start := Block * BlockSize; Stop := MinIntValue([Pred(Succ(Block) * BlockSize), ObjectCount]); if Start <= stop then begin - BoldAppendToStrings(SQL, ObjectPersistenceMapper.IdListSegmentToWhereFragment(ObjectIdList, start, stop, aQuery), False); + BoldAppendToStrings(SQL, ObjectPersistenceMapper.IdListSegmentToWhereFragment(ObjectIdList, start, stop, true, aQuery), False); aQuery.AssignSQL(sql); aQuery.Open; while not aQuery.EOF do begin - tempId := SystemPersistenceMapper.NewIdFromQuery(aQuery, 1, 0, ObjectIDList[0].TimeStamp); + tempId := SystemPersistenceMapper.NewIdFromQuery(aQuery, NO_CLASS, 1, 0, ObjectIDList[0].TimeStamp); NewId := ObjectIDList.IDByID[TempId]; TempId.Free; if not assigned(NewId) then - raise EBoldInternal.CreateFmt('%s.PMFetch: Database returned object we didn''t ask for (ID: %d)', [ClassName, aQuery.Fields[0].AsInteger]); // do not localize + raise EBoldInternal.CreateFmt('%s.PMFetch: Database returned object we didn''t ask for (ID: %d)', [ClassName, aQuery.Fields[0].AsInteger]); if not NewId.TopSortedIndexExact then NewId := TranslationList.TranslateToNewID[NewId]; if not NewId.TopSortedIndexExact then - raise EBoldInternal.CreateFmt('%s.PMFetch: Got an Id with no or only approx class!', [Classname]); // do not localize + raise EBoldInternal.CreateFmt('%s.PMFetch: Got an Id with no or only approx class!', [Classname]); ObjectPersistenceMapper.ValuesFromFieldsByMemberList(NewId, ValueSpace, TranslationList, aQuery, MemberPMList); @@ -2309,23 +3213,8 @@ procedure TBoldMemberDefaultMapper.PMFetch(ObjectIdList: TBoldObjectIdList; end; end; -function TBoldSystemDefaultMapper.GetPSSystemDescription: TBoldDefaultSystemDescription; -begin - result := (inherited PSSystemDescription) as TBoldDefaultSystemDescription; -end; - -function TBoldObjectDefaultMapper.GetSystemPersistenceMapper: TBoldSystemDefaultMapper; -begin - result := (inherited SystemPersistenceMapper) as TBoldSystemDefaultMapper; -end; - -function TBoldSystemDefaultMapper.GetRootClassObjectPersistenceMapper: TBoldObjectDefaultMapper; -begin - result := (inherited RootClassObjectPersistenceMapper) as TBoldObjectDefaultMapper; -end; - procedure TBoldSystemDefaultMapper.PMFetchClassWithCondition( - ObjectIDList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; + ObjectIDList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; BoldCondition: TBoldCondition; FetchMode: Integer; TranslationList: TBoldIdTranslationList); var @@ -2338,19 +3227,33 @@ procedure TBoldSystemDefaultMapper.PMFetchClassWithCondition( SQlGenerator: TBoldSQLQueryGenerator; aCPCond: TBoldChangePointCondition; GlobalNameSpace: TBoldSqlNameSpace; + aVariableIDLists: TBoldObjectArray; + vBoldParameterized: IBoldParameterized; procedure FixQueriesForEnv(VarBinding: TBoldSQLVariableBinding; Context: TBoldObjectIdList; NameSpace: TBoldSqlNameSpace); var MainTableRef: TBoldSqlTableReference; + BoldID: TBoldDefaultID; begin - if VarBinding.VariableName = 'SELF' then // do not localize + if CompareText(VarBinding.VariableName, 'SELF') = 0 then // do not localize begin VarBinding.NewQuery(NameSpace); MainTableRef := VarBinding.TableReferenceForTable(VarBinding.ObjectMapper.MainTable, VarBinding.Query, true); VarBinding.Context := OclCondition.Context; VarBinding.Query.AddWCF(TBoldSQLWCFBinaryInfix.CreateWCFForIdList(MainTableRef.GetColumnReference(IDCOLUMN_NAME), OclCondition.Context)); - end; + end else if VarBinding.IsExternal and (VarBinding.TopSortedIndex > -1) then + begin + VarBinding.NewQuery(NameSpace); + + MainTableRef := VarBinding.TableReferenceForTable(VarBinding.ObjectMapper.MainTable, VarBinding.Query, true); + VarBinding.Context := TBoldObjectIdList.Create; + aVariableIDLists.Add(VarBinding.Context); + BoldID := TBoldDefaultID.CreateWithClassID(VarBinding.ObjectMapper.TopSortedIndex, True); + BoldID.AsInteger := VarBinding.ExternalVarvalue; + VarBinding.Context.AddAndAdopt(BoldID); + VarBinding.Query.AddWCF(TBoldSQLWCFBinaryInfix.CreateWCFForIdList(MainTableRef.GetColumnReference(IDCOLUMN_NAME), VarBinding.Context)); + end; end; begin @@ -2361,8 +3264,14 @@ procedure TBoldSystemDefaultMapper.PMFetchClassWithCondition( GlobalNameSpace := nil; SQLNodeMaker := nil; q2 := GetQuery; + if q2.QueryInterface(IBoldParameterized, vBoldParameterized) = S_OK then + begin + vBoldParameterized.ParamCheck := false; + vBoldParameterized := nil; + end; sql := TStringList.Create; OclCondition := BoldCondition as TBoldOclCondition; + aVariableIDLists := TBoldObjectArray.Create(0, [bcoDataOwner]); try SQLNodeMaker := TBoldSQlNodeMaker.Create(OclCondition); SQLNodeMaker.Execute; @@ -2385,7 +3294,10 @@ procedure TBoldSystemDefaultMapper.PMFetchClassWithCondition( Q2.AssignSQL(sql); Q2.AssignParams(SQLNodeMaker.RootNode.Query.Params); - BoldCondition.AvailableAnswers := GetListUsingQuery(ObjectIdList, ValueSpace, Q2, FetchMode, TranslationList, BOLDMAXTIMESTAMP, BoldCondition.MaxAnswers, BoldCondition.Offset); + if Assigned(OnPsEvaluate) then + OnPsEvaluate(Q2); + + BoldCondition.AvailableAnswers := GetListUsingQuery(ObjectIdList, ValueSpace, Q2, NO_CLASS, 1, 0, FetchMode, TranslationList, BOLDMAXTIMESTAMP, BoldCondition.MaxAnswers, BoldCondition.Offset); finally ReleaseQuery(q2); sql.Free; @@ -2393,6 +3305,7 @@ procedure TBoldSystemDefaultMapper.PMFetchClassWithCondition( SQlNodeResolver.free; GlobalNameSpace.Free; SQLNodeMaker.Free; + aVariableIDLists.Free; end; end else if BoldCondition is TBoldChangePointCondition then @@ -2409,7 +3322,7 @@ procedure TBoldSystemDefaultMapper.PMFetchClassWithCondition( q2 := GetQuery; try GetChangePointsQuery(q2, aCPCond.IdList, aCPCond.StartTime, aCPCond.EndTime, GlobalNameSpace); - BoldCondition.AvailableAnswers := GetListUsingQuery(ObjectIdList, ValueSpace, Q2, FetchMode, TranslationList, BOLDINVALIDTIMESTAMP, BoldCondition.MaxAnswers, BoldCondition.Offset); + BoldCondition.AvailableAnswers := GetListUsingQuery(ObjectIdList, ValueSpace, Q2, NO_CLASS, 1, 0, FetchMode, TranslationList, BOLDINVALIDTIMESTAMP, BoldCondition.MaxAnswers, BoldCondition.Offset); (CommonSuperClassObjectMapper(aCPCond.IdList) as TBoldObjectDefaultMapper).GetChangePoints(ObjectIdList, aCPCond, GlobalNameSpace); finally ReleaseQuery(q2); @@ -2466,7 +3379,7 @@ procedure TBoldObjectDefaultMapper.GetChangePoints( (MemberPersistenceMappers[MemberMapperIndexByMemberIndex[Condition.MemberIdList[i].MemberIndex]] as TBoldMemberDefaultMapper).GetChangePoints(ObjectIdList, Condition, NameSpace); end; -function TBoldMemberDefaultMapper.CompareFields(ObjectContent: IBoldObjectContents; DataSet: IBoldDataSet; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; +function TBoldMemberDefaultMapper.CompareFields(const ObjectContent: IBoldObjectContents; const DataSet: IBoldDataSet; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; var aField : IBoldField; ColumnIndex: Integer; @@ -2476,22 +3389,25 @@ function TBoldMemberDefaultMapper.CompareFields(ObjectContent: IBoldObjectConten begin for ColumnIndex := 0 to ColumnCount - 1 do begin - aField := DataSet.FieldByName(ColumnDescriptions[ColumnIndex].SQLName); + aField := DataSet.FieldByUpperCaseName(ColumnDescriptions[ColumnIndex].SQLNameUpper); if Assigned(aField) then begin if not CompareField(ObjectContent, aField, ColumnIndex, ValueSpace, TranslationList) then begin - BoldLog.LogFmt(sOptimisticLockingFailed, + BoldLog.LogFmt('Optimistic Locking Failed for %s.%s (ID: %s) Column %d [%s] ValueInDb:%s InMemTimestamp: %d', [ObjectPersistenceMapper.ExpressionName, ExpressionName, ObjectContent.ObjectId.AsString, ColumnIndex, - ColumnDescriptions[ColumnIndex].SQLName]); + ColumnDescriptions[ColumnIndex].SQLName, + aField.AsString, + ObjectContent.Timestamp] + ); result := false; end; end else - raise EBoldInternal.CreateFmt(sSomeColumnsNotInTable, [classname, 'CompareFields', ColumnIndex, ColumnDescriptions[ColumnIndex].SQLName]); // do not localize + raise EBoldInternal.CreateFmt('%s.CompareFields: Some columns not found in table (%d:%s)', [classname, ColumnIndex, ColumnDescriptions[ColumnIndex].SQLName]); end; end; end; @@ -2499,7 +3415,7 @@ function TBoldMemberDefaultMapper.CompareFields(ObjectContent: IBoldObjectConten procedure TBoldMemberDefaultMapper.GetChangePoints( ObjectIDList: TBoldObjectIdList; Condition: TBoldChangePointCondition; NameSpace: TBoldSqlnameSpace); begin - raise EBold.CreateFmt(sNotSupportedOnMember, [classname]); + raise EBold.CreateFmt('%s.GetChangePoints: not supported on this member', [classname]); end; procedure TBoldSystemDefaultMapper.PMTimeForTimestamp( @@ -2510,13 +3426,13 @@ procedure TBoldSystemDefaultMapper.PMTimeForTimestamp( aQuery := GetQuery; try aQuery.AssignSQLText( - format('SELECT %s FROM %s WHERE :time1 >= %s and :time2 < %s', [ // do not localize + format('SELECT %s FROM %s WHERE :time1 >= %s and :time2 < %s', [ ClockLogTableLastClockColumn.SQLname, PSSystemDescription.ClockLogTable.SQLName, ClockLogTableLastTimeStampColumn.SQLName, ClockLogTableThisTimeStampColumn.SQLName])); - aQuery.ParamByName('time1').AsInteger := Timestamp; // do not localize - aQuery.ParamByName('time2').AsInteger := Timestamp; // do not localize + aQuery.ParamByName('time1').AsInteger := Timestamp; + aQuery.ParamByName('time2').AsInteger := Timestamp; aQuery.Open; if not aQuery.EOF then ClockTime := aQuery.Fields[0].AsDateTime @@ -2536,13 +3452,13 @@ procedure TBoldSystemDefaultMapper.PMTimestampForTime(ClockTime: TDateTime; aQuery := GetQuery; try aQuery.AssignSQLText( - Format('SELECT %s FROM %s WHERE :time1 > %s and :time2 <= %s', [ // do not localize + Format('SELECT %s FROM %s WHERE :time1 > %s and :time2 <= %s', [ ClockLogTableThisTimeStampColumn.SQLName, PSSystemDescription.ClockLogTable.SQLName, ClockLogTableLastClockColumn.SQLname, ClockLogTableThisClockColumn.SQLname])); - aQuery.ParamByName('time1').AsDateTime := ClockTime; // do not localize - aQuery.ParamByName('time2').AsDateTime := ClockTime; // do not localize + aQuery.ParamByName('time1').AsDateTime := ClockTime; + aQuery.ParamByName('time2').AsDateTime := ClockTime; aQuery.Open; if not aQuery.EOF then Timestamp := aQuery.Fields[0].AsInteger @@ -2559,11 +3475,6 @@ function TBoldMemberDefaultMapper.SupportsComparingWithoutValue: Boolean; result := false; end; -function TBoldMemberDefaultMapper.GetObjectPersistenceMapper: TBoldObjectDefaultMapper; -begin - result := (inherited ObjectPersistenceMapper) as TBoldObjectDefaultMapper; -end; - { EBoldOptimisticLockingFailed } constructor EBoldOptimisticLockingFailed.Create(msg: string; args: array of const; FailedObjects: TBoldObjectIdList); @@ -2571,8 +3482,28 @@ constructor EBoldOptimisticLockingFailed.Create(msg: string; args: array of cons inherited Create(Msg, Args, FailedObjects); end; +destructor TBoldObjectDefaultMapper.Destroy; +var + i: integer; +begin + for I := 0 to Length(fQueryCache) - 1 do + begin + fQueryCache[i].SqlStrings.Free; + fQueryCache[i].MemberList.Free; + fQueryCache[i].MemberPMList.Free; + fQueryCache[i].CustomMembers.Free; + end; + for I := 0 to Length(fPMCreateCache) - 1 do + begin + fPMCreateCache[i].SqlStrings.Free; + fPMCreateCache[i].MemberPMList.Free; + end; + fSingleLinkList.free; + inherited; +end; + procedure TBoldObjectDefaultMapper.DetectLinkClassDuplicates( - ObjectIdList: TBoldObjectidList; ValueSpace: IBoldvalueSpace; + ObjectIdList: TBoldObjectidList; const ValueSpace: IBoldvalueSpace; TranslationList: TBoldIdTranslationList; DuplicateList: TBoldObjectIdList); var @@ -2598,10 +3529,8 @@ procedure TBoldObjectDefaultMapper.DetectLinkClassDuplicates( LinkMapper1 := (LinkClassRole1 as TBoldEmbeddedSingleLinkDefaultMapper); LinkMapper2 := (LinkClassRole2 as TBoldEmbeddedSingleLinkDefaultMapper); - // if we find a linkobject that links the same two objects as one of the new, - // translate the new object to the old object. - QueryText := format('SELECT %s, %s FROM %s WHERE (%s = %%s) AND (%s = %%s)', [ // do not localize + QueryText := format('SELECT %s, %s FROM %s WHERE (%s = %%s) AND (%s = %%s)', [ IDCOLUMN_NAME, TYPECOLUMN_NAME, MainTable.SQLName, LinkMapper1.MainColumnName, LinkMapper2.MainColumnName]); @@ -2612,8 +3541,6 @@ procedure TBoldObjectDefaultMapper.DetectLinkClassDuplicates( LinkObject := ValueSpace.EnsuredObjectContentsByObjectId[ObjectIdList[i]]; Id1 := (LinkMapper1.GetValue(LinkObject) as IBoldObjectIdRef).Id; Id2 := (LinkMapper2.GetValue(LinkObject) as IBoldObjectIdRef).Id; - - // if either object is new, then this can not be a dupe if not (ObjectisNew(Id1) or ObjectIsNew(Id2)) then begin if assigned(Id1) then @@ -2621,8 +3548,6 @@ procedure TBoldObjectDefaultMapper.DetectLinkClassDuplicates( if assigned(Id2) then Id2 := TranslationList.TranslateToNewId[Id2]; - // if the linkobject is broken (doesn't have 2 IDs) or is pointing to objects that are deleted, - // then we will get an inconsistent database later, but lets not get an AV here... if assigned(Id1) and assigned(Id2) then begin @@ -2630,15 +3555,9 @@ procedure TBoldObjectDefaultMapper.DetectLinkClassDuplicates( Query.open; if not query.Eof then begin - OldLinkObjectId := SystemPersistenceMapper.NewIdFromQuery(Query, 1, 0, BOLDMAXTIMESTAMP); - try - // the new linkobject has already received a translation to its persistent ID - // we need to add a translation from that ID to the existing link objectid - TranslationList.addTranslation(TranslationList.TranslateToNewId[ObjectIdList[i]], OldLinkObjectId); - DuplicateList.Add(ObjectIdList[i]); - finally - OldLinkObjectId.Free; - end; + OldLinkObjectId := SystemPersistenceMapper.NewIdFromQuery(Query, NO_CLASS, 1, 0, BOLDMAXTIMESTAMP); + TranslationList.addTranslationAdoptNew(TranslationList.TranslateToNewId[ObjectIdList[i]], OldLinkObjectId); + DuplicateList.Add(ObjectIdList[i]); end; Query.Close; end; @@ -2650,8 +3569,8 @@ procedure TBoldObjectDefaultMapper.DetectLinkClassDuplicates( end; end; -function TBoldMemberDefaultMapper.CheckEitherNull(field: IBoldField; - Value: IBoldValue; var Equal: Boolean): Boolean; +function TBoldMemberDefaultMapper.CheckEitherNull(const field: IBoldField; + const Value: IBoldValue; var Equal: Boolean): Boolean; begin Equal := false; result := false; @@ -2686,7 +3605,8 @@ procedure TBoldMemberDefaultMapper.InitializePSDescriptions; Columns := TStringList.Create; Columns.CommaText := MemberMappings[0].Columns; if Columns.Count <> ColumnCount then - raise EBold.CreateFmt(sUnsupportedMappingChange, [ObjectPersistenceMapper.ExpressionName, ExpressionName]); + raise EBold.CreateFmt('Database Mapping has changed in an unsupported way for %s.%s. Number of columns has changed', [ObjectPersistenceMapper.ExpressionName, ExpressionName]); + ColumnDescriptions.Capacity := ObjectPersistenceMapper.MemberPersistenceMappers.Count; for i := 0 to Columns.Count - 1 do ColumnDescriptions.Add( SystemPersistenceMapper.EnsureColumn(MemberMappings[0].TableName, @@ -2696,17 +3616,23 @@ procedure TBoldMemberDefaultMapper.InitializePSDescriptions; ColumnBDEFieldType[i], ColumnSize[i], AllowNull, - ObjectPersistenceMapper.Versioned, // ??? is this really right? is it not supposed to be the mapper of the class that defines the attribute? - Yes, in theory. In practice it makes no difference. + ObjectPersistenceMapper.Versioned, DefaultDbValue)); +{$IFDEF IndexColumn} + if MemberMappings[0].ColumnIndex then begin + for i := 0 to Columns.Count - 1 do + SystemPersistenceMapper.EnsureIndex(MemberMappings[0].TableName, + Columns[i], False, False, True, False); + end; +{$ENDIF} end else if (length(memberMappings) = 0) and RequiresMemberMapping then - raise EBold.CreateFmt(sUnableToFindMappingForX, [ObjectPersistenceMapper.ExpressionName, ExpressionName]); + raise EBoldMissingID.CreateFmt('Unable to find database mapping for %s.%s', [ObjectPersistenceMapper.ExpressionName, ExpressionName]); end; procedure TBoldObjectDefaultMapper.InitializePSDescriptions; begin - // it is important that the x-files table come before the other tables - // (and in general that the tables for a superclass comes before the tables of a subclass) + if SystemPersistenceMapper.UseXFiles then AllTables.Add(SystemPersistenceMapper.PSSystemDescription.XFilestable); @@ -2715,13 +3641,10 @@ procedure TBoldObjectDefaultMapper.InitializePSDescriptions; if not assigned(SuperClass) then SystemPersistenceMapper.PSSystemDescription.RootTable := MainTable; - // the starttimestamp column is added in EnsureTable - // root class needs to have a stopcolumn as well... if Versioned and (self = SystemPersistenceMapper.RootClassObjectPersistenceMapper) then begin SystemPersistenceMapper.EnsureColumn(MainTable.SQLName, TIMESTAMPSTOPCOLUMNNAME, SystemPersistenceMapper.SQLDataBaseConfig.ColumnTypeForInteger, SystemPersistenceMapper.SQLDataBaseConfig.EffectiveSQLforNotNull, BOLDTIMESTAMPFIELDTYPE, 0, true, true, SystemPersistenceMapper.SQLDataBaseConfig.CorrectlyQuotedDefaultValue(intTostr(BOLDMAXTIMESTAMP))); - // the following index improves performance alot in Interbase, and seems to have no negative impact in SQLServer. - MainTable.EnsureIndex(TIMESTAMPSTOPCOLUMNNAME, false, false); + MainTable.EnsureIndex(TIMESTAMPSTOPCOLUMNNAME, false, false, false); MainTable.ContainsStopTimeStamp := true; end; end; @@ -2733,26 +3656,21 @@ procedure TBoldSystemDefaultMapper.InitializePSDescriptions; DefaultStringLength: integer; begin DefaultStringLength := SQLDataBaseConfig.DefaultStringLength; - // inherited is called at the end to ensure that systemtables are available to other parts of initialization - - // Create BOLD_ID + PSSystemDescription.SQLTablesList.Capacity := ObjectPersistenceMappers.Count + 10; PSSystemDescription.IdTable := TBoldSQLTableDescription.Create(PSSystemDescription, false); PSSystemDescription.IdTable.SQLName := IDTABLE_NAME; PSSystemDescription.IdTable.AddColumn(IDCOLUMN_NAME, SQLDataBaseConfig.ColumnTypeForInteger, SQLDataBaseConfig.EffectiveSQLforNotNull, IDCOLUMN_TYPE, 0, False, ''); - - // Create BOLD_TYPES PSSystemDescription.TypeTable := TBoldSQLTableDescription.Create(PSSystemDescription, false); PSSystemDescription.TypeTable.SQLName := TYPETABLE_NAME; PSSystemDescription.TypeTable.AddColumn(TYPECOLUMN_NAME, SQLDataBaseConfig.ColumnTypeForSmallInt, SQLDataBaseConfig.EffectiveSQLforNotNull, TYPECOLUMN_TYPE, 0, False, ''); PSSystemDescription.TypeTable.AddColumn(CLASSNAMECOLUMN_NAME, format(SQLDataBaseConfig.ColumnTypeForString, [DefaultStringLength]), SQLDataBaseConfig.EffectiveSQLforNotNull, ftString, DefaultStringLength, False, ''); - if UseXFiles then begin PSSystemDescription.XFilesTable := TBoldSQLTableDescription.Create(PSSystemDescription, false); - PSSystemDescription.XFilesTable.SQLName := TABLEPREFIXTAG + '_XFILES'; // do not localize + PSSystemDescription.XFilesTable.SQLName := TABLEPREFIXTAG + '_XFILES'; PSSystemDescription.XFilesTable.AddColumn(IDCOLUMN_NAME, SQLDataBaseConfig.ColumnTypeForInteger, SQLDataBaseConfig.EffectiveSQLforNotNull, IDCOLUMN_TYPE, 0, False, ''); PSSystemDescription.XFilesTable.AddColumn(TYPECOLUMN_NAME, SQLDataBaseConfig.ColumnTypeForSmallInt, SQLDataBaseConfig.EffectiveSQLforNotNull, TYPECOLUMN_TYPE, 0, False, ''); - PSSystemDescription.XFilesTable.EnsureIndex(IDCOLUMN_NAME, true, true); + PSSystemDescription.XFilesTable.EnsureIndex(IDCOLUMN_NAME, true, true, false); if UseGlobalId then fXFilesGlobalIdColumn := PSSystemDescription.XFilesTable.AddColumn(GLOBALIDCOLUMN_NAME, format(SQLDataBaseConfig.ColumnTypeForString, [DefaultStringLength]), SQLDataBaseConfig.EffectiveSQLforNotNull, ftString, DefaultStringLength, False, ''); if UseTimestamp then @@ -2792,7 +3710,9 @@ procedure TBoldSystemDefaultMapper.InitializePSDescriptions; PSSystemDescription.MemberMappingTable.AddColumn(MMT_TABLENAME_COLUMN, format(SQLDataBaseConfig.ColumnTypeForString, [MappingStringLength]), SQLDataBaseConfig.EffectiveSQLforNotNull, ftString, MappingStringLength, False, ''); PSSystemDescription.MemberMappingTable.AddColumn(MMT_COLUMNS_COLUMN, format(SQLDataBaseConfig.ColumnTypeForString, [MappingStringLength]), SQLDataBaseConfig.EffectiveSQLforNotNull, ftString, MappingStringLength, False, ''); PSSystemDescription.MemberMappingTable.AddColumn(MMT_MAPPERNAME_COLUMN, format(SQLDataBaseConfig.ColumnTypeForString, [MappingStringLength]), SQLDataBaseConfig.EffectiveSQLforNotNull, ftString, MappingStringLength, False, ''); - +{$IFDEF IndexColumn} + PSSystemDescription.MemberMappingTable.AddColumn(MMT_INDEX_COLUMN, SQLDataBaseConfig.ColumnTypeForInteger, SQLDataBaseConfig.EffectiveSQLforNotNull, ftBoolean, 0, False, ''); +{$ENDIF} PSSystemDescription.AllInstancesMappingTable := TBoldSQLTableDescription.Create(PSSystemDescription, false); PSSystemDescription.AllInstancesMappingTable.SQLName := AllInstancesMappingTable_NAME; PSSystemDescription.AllInstancesMappingTable.AddColumn(AID_CLASSNAME_COLUMN, format(SQLDataBaseConfig.ColumnTypeForString, [MappingStringLength]), SQLDataBaseConfig.EffectiveSQLforNotNull, ftString, MappingStringLength, False, ''); @@ -2806,11 +3726,6 @@ procedure TBoldSystemDefaultMapper.InitializePSDescriptions; inherited; end; -function TBoldMemberDefaultMapper.GetSystemPersistenceMapper: TBoldSystemDefaultMapper; -begin - result := inherited SystemPersistenceMapper as TBoldSystemDefaultMapper; -end; - function TBoldMemberDefaultMapper.RequiresMemberMapping: Boolean; begin result := ColumnCount > 0; @@ -2842,17 +3757,16 @@ function TBoldSingleColumnMember.GetColumnSize(ColumnIndex: Integer): Integer; class procedure TBoldSingleColumnMember.EnsureFirstColumn(ColumnIndex: Integer); begin if ColumnIndex <> 0 then - raise EBoldBadColumnIndex.CreateFmt(sIllegalColumnIndex, [ClassName, 'EnsureFirstColumn', ColumnIndex]); // do not localize + raise EBoldBadColumnIndex.CreateFmt('%s: Illegal Column Index (%d)', [ClassName, ColumnIndex]); end; { TBoldModelVersionMember } function TBoldModelVersionMember.CompareField( - ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; - ValueSpace: IBoldValueSpace; + const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; + const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; begin -// actually this method is irrelevant result := true; end; @@ -2892,50 +3806,55 @@ function TBoldModelVersionMember.GetColumnTypeAsSQL(ColumnIndex: Integer): strin end; function TBoldModelVersionMember.IsDirty( - ObjectContents: IBoldObjectContents): Boolean; + const ObjectContents: IBoldObjectContents): Boolean; begin result := true; end; function TBoldModelVersionMember.ShouldFetch( - ObjectContents: IBoldObjectContents): Boolean; + const ObjectContents: IBoldObjectContents): Boolean; begin - // in an environment that uses ModelVersion, - // it must always be fetched so that an automatic update can be performed + result := true; end; +function TBoldModelVersionMember.ValueAsVariant( + const ObjectContent: IBoldObjectContents; ColumnIndex: Integer; + TranslationList: TBoldIdTranslationList): variant; +begin + result := VersionNumber; +end; + procedure TBoldModelVersionMember.ValueFromField( - OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; - ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; - Field: IBoldField; ColumnIndex: Integer); + OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; + const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; + const Field: IBoldField; ColumnIndex: Integer); begin -// do nothing end; procedure TBoldModelVersionMember.ValueToParam( - ObjectContent: IBoldObjectContents; Param: IBoldParameter; + const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); begin Param.AsInteger := VersionNumber; end; -function TBoldModelVersionMember.VersionFromQuery(Query: IBoldQuery): Integer; +function TBoldModelVersionMember.VersionFromQuery(const Query: IBoldQuery): Integer; var aField: IBoldField; begin - aField := Query.FieldByName(ColumnDescriptions[0].SQLName); + aField := Query.FieldByUpperCaseName(ColumnDescriptions[0].SQLNameUpper); if assigned(aField) then result := aField.AsInteger else - raise EBoldInternal.CreateFmt(sColumnNotFoundInTable, [classname, ColumnDescriptions[0].SQLName]); + raise EBoldInternal.CreateFmt('%s.VersionFromQuery: Column not found in table (%s)', [classname, ColumnDescriptions[0].SQLName]); end; { TBoldReadOnlynessMember } function TBoldReadOnlynessMember.CompareField( - ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; - ValueSpace: IBoldValueSpace; + const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; + const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; begin result := true; @@ -2977,35 +3896,40 @@ function TBoldReadOnlynessMember.GetColumnTypeAsSQL( end; function TBoldReadOnlynessMember.IsDirty( - ObjectContents: IBoldObjectContents): Boolean; + const ObjectContents: IBoldObjectContents): Boolean; begin result := false; end; function TBoldReadOnlynessMember.ShouldFetch( - ObjectContents: IBoldObjectContents): Boolean; + const ObjectContents: IBoldObjectContents): Boolean; begin result := true; end; +function TBoldReadOnlynessMember.ValueAsVariant( + const ObjectContent: IBoldObjectContents; ColumnIndex: Integer; + TranslationList: TBoldIdTranslationList): variant; +begin + result := 0; +end; + procedure TBoldReadOnlynessMember.ValueFromField( - OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; - ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; - Field: IBoldField; ColumnIndex: Integer); + OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; + const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; + const Field: IBoldField; ColumnIndex: Integer); begin ObjectContent.SetIsReadOnly(field.AsInteger = 1); end; procedure TBoldReadOnlynessMember.ValueToParam( - ObjectContent: IBoldObjectContents; Param: IBoldParameter; + const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); begin - // since IsDirty is false, this will only happen on Create or - // when using UpdateWholeObjects (which is a bad thing...) Param.AsInteger := 0; end; -function TBoldObjectDefaultMapper.IsOldVersion(Query: IBoldQuery): Boolean; +function TBoldObjectDefaultMapper.IsOldVersion(const Query: IBoldQuery): Boolean; var CurrentObjectVersion: integer; begin @@ -3014,7 +3938,7 @@ function TBoldObjectDefaultMapper.IsOldVersion(Query: IBoldQuery): Boolean; SystemPersistenceMapper.ObjectUpgrader.NeedsManualUpdate(ExpressionName, CurrentObjectVersion); end; -procedure TBoldObjectDefaultMapper.PortObject(ObjectId: TBoldObjectId; Query: IBoldQuery); +procedure TBoldObjectDefaultMapper.PortObject(ObjectId: TBoldObjectId; const Query: IBoldQuery); begin if assigned(SystemPersistenceMapper.ObjectUpgrader) then SystemPersistenceMapper.ObjectUpgrader.UpgradeObjectById(ObjectId, Query); @@ -3024,14 +3948,14 @@ procedure TBoldObjectDefaultMapper.PortObject(ObjectId: TBoldObjectId; Query: IB { TBoldTimeStampMember } function TBoldTimeStampMember.CompareField( - ObjectContent: IBoldObjectContents; Field: IBoldField; - ColumnIndex: integer; ValueSpace: IBoldValueSpace; + const ObjectContent: IBoldObjectContents; const Field: IBoldField; + ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; begin if ColumnIndex = 0 then result := Field.AsInteger = ObjectContent.TimeStamp else - raise EBold.CreateFmt(sIllegalColumnIndex, [classname, 'CompareField', ColumnIndex]); // do not localize + raise EBold.CreateFmt('%s.CompareField: invalid columnIndex (%d)', [classname, ColumnIndex]); end; constructor TBoldTimeStampMember.CreateFromMold(moldMember: TMoldMember; @@ -3050,10 +3974,9 @@ constructor TBoldTimeStampMember.CreateFromMold(moldMember: TMoldMember; function TBoldTimeStampMember.FindDefiningTable(LocalMoldClass: TMoldClass; MoldMember: TMoldMember): string; begin - // unfortunately, it is too early to call the - // SystemPersistenceMapper.XFilesTable.SQLName since it would create the - // PSDescriptions before all the Mappers are in place. - result := BoldExpandPrefix(TABLEPREFIXTAG + '_XFILES', '', SystemPersistenceMapper.SQLDatabaseConfig.SystemTablePrefix, SystemPersistenceMapper.SQLDataBaseConfig.MaxDBIdentifierLength, SystemPersistenceMapper.NationalCharConversion); // do not localize + + + result := BoldExpandPrefix(TABLEPREFIXTAG + '_XFILES', '', SystemPersistenceMapper.SQLDatabaseConfig.SystemTablePrefix, SystemPersistenceMapper.SQLDataBaseConfig.MaxDBIdentifierLength, SystemPersistenceMapper.NationalCharConversion); end; function TBoldTimeStampMember.GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; @@ -3067,14 +3990,13 @@ function TBoldTimeStampMember.GetColumnTypeAsSQL(ColumnIndex: Integer): string; end; -function TBoldTimeStampMember.IsDirty(ObjectContents: IBoldObjectContents): Boolean; +function TBoldTimeStampMember.IsDirty(const ObjectContents: IBoldObjectContents): Boolean; begin result := true; end; -function TBoldTimeStampMember.ShouldFetch(ObjectContents: IBoldObjectContents): Boolean; +function TBoldTimeStampMember.ShouldFetch(const ObjectContents: IBoldObjectContents): Boolean; begin - // the timestamp should only be loaded if the object uses timestamp-mode for optimistic locking result := ObjectPersistenceMapper.fOptimisticLockingMode = bolmTimeStamp; end; @@ -3083,16 +4005,22 @@ function TBoldTimeStampMember.SupportsComparingWithoutValue: Boolean; result := true; end; +function TBoldTimeStampMember.ValueAsVariant(const ObjectContent: IBoldObjectContents; + ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; +begin + result := SystemPersistenceMapper.CurrentTimeStamp;; +end; + procedure TBoldTimeStampMember.ValueFromField( - OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; - ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; - Field: IBoldField; ColumnIndex: Integer); + OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; + const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; + const Field: IBoldField; ColumnIndex: Integer); begin ObjectContent.TimeStamp := Field.AsInteger; end; procedure TBoldTimeStampMember.ValueToParam( - ObjectContent: IBoldObjectContents; Param: IBoldParameter; + const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); begin Param.AsInteger := SystemPersistenceMapper.CurrentTimeStamp; @@ -3101,8 +4029,8 @@ procedure TBoldTimeStampMember.ValueToParam( { TBoldGlobalIdMember } function TBoldGlobalIdMember.CompareField( - ObjectContent: IBoldObjectContents; Field: IBoldField; - ColumnIndex: integer; ValueSpace: IBoldValueSpace; + const ObjectContent: IBoldObjectContents; const Field: IBoldField; + ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; begin result := true; @@ -3117,7 +4045,7 @@ constructor TBoldGlobalIdMember.CreateFromMold(moldMember: TMoldMember; fDefaultDbValue := ''; fAllowNull := false; fDelayedFetch := true; - fContentName := 'String'; // do not localize + fContentName := 'String'; fIsStoredInObject := true; fInitialColumnRootName := GLOBALIDCOLUMN_NAME; inherited; @@ -3125,10 +4053,9 @@ constructor TBoldGlobalIdMember.CreateFromMold(moldMember: TMoldMember; function TBoldGlobalIdMember.FindDefiningTable(LocalMoldClass: TMoldClass; MoldMember: TMoldMember): string; begin - // unfortunately, it is too early to call the - // SystemPersistenceMapper.XFilesTable.SQLName since it would create the - // PSDescriptions before all the Mappers are in place. - result := BoldExpandPrefix(TABLEPREFIXTAG + '_XFILES', '', SystemPersistenceMapper.SQLDatabaseConfig.SystemTablePrefix, SystemPersistenceMapper.SQLDataBaseConfig.MaxDBIdentifierLength, SystemPersistenceMapper.NationalCharConversion); // do not localize + + + result := BoldExpandPrefix(TABLEPREFIXTAG + '_XFILES', '', SystemPersistenceMapper.SQLDatabaseConfig.SystemTablePrefix, SystemPersistenceMapper.SQLDataBaseConfig.MaxDBIdentifierLength, SystemPersistenceMapper.NationalCharConversion); end; function TBoldGlobalIdMember.GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; @@ -3138,32 +4065,39 @@ function TBoldGlobalIdMember.GetColumnBDEFieldType(ColumnIndex: Integer): TField function TBoldGlobalIdMember.GetColumnTypeAsSQL(ColumnIndex: Integer): string; begin - // {F4252AB4-8FFA-460F-BDBD-1BB57D588D14} result := format(SystemPersistenceMapper.SQLDataBaseConfig.ColumnTypeForString, [39]); end; function TBoldGlobalIdMember.IsDirty( - ObjectContents: IBoldObjectContents): Boolean; + const ObjectContents: IBoldObjectContents): Boolean; begin result := false; end; -function TBoldGlobalIdMember.ShouldFetch(ObjectContents: IBoldObjectContents): Boolean; +function TBoldGlobalIdMember.ShouldFetch(const ObjectContents: IBoldObjectContents): Boolean; begin result := false; end; +function TBoldGlobalIdMember.ValueAsVariant(const ObjectContent: IBoldObjectContents; + ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; +begin + result := ObjectContent.GlobalId; + if result = '' then + result := ExternalIdGenerator; +end; + procedure TBoldGlobalIdMember.ValueFromField(OwningObjectId: TBoldObjectId; - ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; - TranslationList: TBoldIdTranslationList; Field: IBoldField; + const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; + TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); begin ObjectContent.GlobalId := Field.AsString; end; procedure TBoldGlobalIdMember.ValueToParam( - ObjectContent: IBoldObjectContents; Param: IBoldParameter; + const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); var GlobalId: String; @@ -3182,7 +4116,6 @@ procedure TBoldXFilesMembers.InitializePSDescriptions; i: integer; begin inherited; - // since these members do not require membermappings... they have to build their PSDesc manually if ColumnDescriptions.Count = 0 then begin for i := 0 to ColumnCount - 1 do @@ -3199,6 +4132,105 @@ function TBoldXFilesMembers.RequiresMemberMapping: Boolean; result := false; end; +{ TBoldNonXFileTimeStampMember } + +function TBoldNonXFileTimeStampMember.CompareField( + const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; + const ValueSpace: IBoldValueSpace; + TranslationList: TBoldIdTranslationList): Boolean; +begin + if ColumnIndex = 0 then + result := Field.AsInteger = ObjectContent.TimeStamp + else + raise EBold.CreateFmt('%s.CompareField: invalid columnIndex (%d)', [classname, ColumnIndex]); + +end; + +constructor TBoldNonXFileTimeStampMember.CreateFromMold(moldMember: TMoldMember; + moldClass: TMoldClass; Owner: TBoldObjectPersistenceMapper; + const MemberIndex: Integer; TypeNameDictionary: TBoldTypeNameDictionary); +begin + fExpressionname := '_' + TIMESTAMPCOLUMN_NAME; + fDefaultDbValue := ''; + fAllowNull := false; + fDelayedFetch := MoldClass.EffectiveOptimisticLocking <> bolmTimeStamp; + fContentName := ''; + fIsStoredInObject := true; + fInitialColumnRootName := TIMESTAMPCOLUMN_NAME; + inherited CreateFromMold(MoldMember, MoldClass, Owner, TIMESTAMPMEMBERINDEX, TypeNameDictionary); +end; + +function TBoldNonXFileTimeStampMember.FindDefiningTable( + LocalMoldClass: TMoldClass; MoldMember: TMoldMember): string; +var + TopClassWithOwnTable, RootClass, C: TMoldClass; +begin + TopClassWithOwnTable := nil; + RootClass := LocalMoldClass.Model.RootClass; + C := LocalMoldClass; + while C <> RootClass do + begin + if C.TableMapping = tmOwn then + TopClassWithOwnTable := C; + Assert(Assigned(C.SuperClass), C.name); + C := C.SuperClass; + end; + if not Assigned(TopClassWithOwnTable) then + raise Exception.Create('No table found for timestamp for class: ' + LocalMoldClass.name); + result := BoldExpandPrefix(TopClassWithOwnTable.TableName, TopClassWithOwnTable.Name, SystemPersistenceMapper.SQLDatabaseConfig.SystemTablePrefix, SystemPersistenceMapper.SQLDataBaseConfig.MaxDbIdentifierLength, RootClass.Model.NationalCharConversion); +end; + +function TBoldNonXFileTimeStampMember.GetColumnBDEFieldType( + ColumnIndex: Integer): TFieldType; +begin + result := BOLDTIMESTAMPFIELDTYPE; +end; + +function TBoldNonXFileTimeStampMember.GetColumnTypeAsSQL( + ColumnIndex: Integer): string; +begin + result := SystemPersistenceMapper.SQLDataBaseConfig.ColumnTypeForInteger; +end; + +function TBoldNonXFileTimeStampMember.IsDirty( + const ObjectContents: IBoldObjectContents): Boolean; +begin + result := true; +end; + +function TBoldNonXFileTimeStampMember.ShouldFetch( + const ObjectContents: IBoldObjectContents): Boolean; +begin + result := ObjectPersistenceMapper.fOptimisticLockingMode = bolmTimeStamp; +end; + +function TBoldNonXFileTimeStampMember.SupportsComparingWithoutValue: Boolean; +begin + result := true; +end; + +function TBoldNonXFileTimeStampMember.ValueAsVariant( + const ObjectContent: IBoldObjectContents; ColumnIndex: Integer; + TranslationList: TBoldIdTranslationList): variant; +begin + result := SystemPersistenceMapper.CurrentTimeStamp; +end; + +procedure TBoldNonXFileTimeStampMember.ValueFromField( + OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; + const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; + const Field: IBoldField; ColumnIndex: Integer); +begin + ObjectContent.TimeStamp := Field.AsInteger; +end; + +procedure TBoldNonXFileTimeStampMember.ValueToParam( + const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; + ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); +begin + Param.AsInteger := SystemPersistenceMapper.CurrentTimeStamp; +end; + initialization ExternalIDGenerator := BoldCreateGUIDWithBracketsAsString; @@ -3216,5 +4248,3 @@ finalization BoldObjectPersistenceMappers.RemoveDescriptorByName(DEFAULTNAME); end. - - diff --git a/Source/PMapper/Default/BoldPMappersLinkDefault.pas b/Source/PMapper/Default/BoldPMappersLinkDefault.pas index e7a7022b..77402c50 100644 --- a/Source/PMapper/Default/BoldPMappersLinkDefault.pas +++ b/Source/PMapper/Default/BoldPMappersLinkDefault.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPMappersLinkDefault; interface @@ -59,14 +62,15 @@ TBoldEmbeddedSingleLinkDefaultMapper = class(TBoldLinkDefaultMapper) function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; override; function GetColumnSize(ColumnIndex: Integer): Integer; override; function GetInitialColumnName(ColumnIndex: Integer): string; override; - function CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; procedure InitializePSDescriptions; override; function GetOtherEndObjectMapper: TBoldObjectDefaultMapper; override; function DefaultDefaultDbValue: String; override; public class function CanStore(const ContentName: string): Boolean; override; - procedure ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; - procedure ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); override; + function ValueAsVariant(const ObjectContent: IBoldObjectContents; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; override; constructor CreateFromMold(moldMember: TMoldMember; moldClass: TMoldClass; Owner: TBoldObjectPersistenceMapper; const MemberIndex: Integer; TypeNameDictionary: TBoldTypeNameDictionary); override; property OtherEndObjectPMIndex: Integer read fOtherEndObjectPMIndex; property OtherEndMemberPMIndex: Integer read GetOtherEndMemberPMIndex; @@ -86,8 +90,8 @@ TBoldNonEmbeddedLinkDefaultMapper = class (TBoldLinkDefaultMapper) fRemoteInnerLinkMemberIndex: integer; fIsIndirect: Boolean; fRemoteOtherEndObjectMapperIndex: Integer; - procedure ProcessSQL(Query: IBoldQuery; WhereFragment: String; resultList: TList; TimeStamp: TBoldTimeStampType); - procedure ProcessResult(ResultList: TList; ValueSpace: IBoldValueSpace; ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; timeStamp: TBoldTimeStampType; FetchMode: integer; FailureList: TBoldObjectIdList); + procedure ProcessSQL(const Query: IBoldQuery; WhereFragment: String; resultList: TList; TimeStamp: TBoldTimeStampType); + procedure ProcessResult(ResultList: TList; const ValueSpace: IBoldValueSpace; ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; timeStamp: TBoldTimeStampType; FetchMode: integer; FailureList: TBoldObjectIdList); function GetLinkClassTableName: string; function GetLinkClassObjectMapper: TBoldObjectDefaultMapper; virtual; abstract; function GetClosestColumnName: string; @@ -100,9 +104,9 @@ TBoldNonEmbeddedLinkDefaultMapper = class (TBoldLinkDefaultMapper) function GetIsOrdered: Boolean; virtual; abstract; procedure GetChangePoints(ObjectIDList: TBoldObjectIdList; Condition: TBoldChangePointCondition; NameSpace: TBoldSqlnameSpace); override; function GetColumnCount: Integer; override; - procedure CompareValuesToLists(OwningId: TBoldObjectId; MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist; FailureList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); virtual; abstract; - procedure StuffValuesFromLists(MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist); virtual; abstract; - function CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + procedure CompareValuesToLists(OwningId: TBoldObjectId; const MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist; FailureList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); virtual; abstract; + procedure StuffValuesFromLists(const MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist); virtual; abstract; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; function EmbeddingMapper: TBoldEmbeddedSingleLinkDefaultMapper; function GetOtherEndObjectMapper: TBoldObjectDefaultMapper; override; function GetSupportsPolymorphicFetch: Boolean; override; @@ -114,7 +118,7 @@ TBoldNonEmbeddedLinkDefaultMapper = class (TBoldLinkDefaultMapper) property LinkClassTablename: string read GetLinkClassTableName; property LinkClassObjectMapper: TBoldObjectDefaultMapper read GetLinkClassObjectMapper; property Ordered: Boolean read GetIsOrdered; - procedure PMFetch(ObjectIDList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; FetchMode: Integer; TranslationList: TBoldIdTranslationList; FailureList: TBoldObjectIdList); override; + procedure PMFetch(ObjectIDList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; FetchMode: Integer; TranslationList: TBoldIdTranslationList; FailureList: TBoldObjectIdList); override; constructor CreateFromMold(moldMember: TMoldMember; moldClass: TMoldClass; Owner: TBoldObjectPersistenceMapper; const MemberIndex: Integer; TypeNameDictionary: TBoldTypeNameDictionary); override; end; @@ -128,8 +132,8 @@ TBoldSingleLinkDefaultMapper = class(TBoldNonEmbeddedLinkDefaultMapper) { TBoldDirectSingleLinkDefaultmapper } TBoldDirectSingleLinkDefaultmapper = class(TBoldSingleLinkDefaultMapper) protected - procedure StuffValuesFromLists(MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist); override; - procedure CompareValuesToLists(OwningId: TBoldObjectId; MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist; FailureList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; + procedure StuffValuesFromLists(const MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist); override; + procedure CompareValuesToLists(OwningId: TBoldObjectId; const MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist; FailureList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; function GetLinkClassObjectMapper: TBoldObjectDefaultMapper; override; public constructor CreateFromMold(moldMember: TMoldMember; moldClass: TMoldClass; Owner: TBoldObjectPersistenceMapper; const MemberIndex: Integer; TypeNameDictionary: TBoldTypeNameDictionary); override; @@ -139,8 +143,8 @@ TBoldDirectSingleLinkDefaultmapper = class(TBoldSingleLinkDefaultMapper) { TBoldIndirectSingleLinkDefaultmapper } TBoldIndirectSingleLinkDefaultmapper = class(TBoldSingleLinkDefaultMapper) protected - procedure StuffValuesFromLists(MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist); override; - procedure CompareValuesToLists(OwningId: TBoldObjectId; MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist; FailureList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; + procedure StuffValuesFromLists(const MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist); override; + procedure CompareValuesToLists(OwningId: TBoldObjectId; const MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist; FailureList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; function GetLinkClassObjectMapper: TBoldObjectDefaultMapper; override; public constructor CreateFromMold(moldMember: TMoldMember; moldClass: TMoldClass; Owner: TBoldObjectPersistenceMapper; const MemberIndex: Integer; TypeNameDictionary: TBoldTypeNameDictionary); override; @@ -160,8 +164,8 @@ TBoldMultiLinkDefaultMapper = class(TBoldNonEmbeddedLinkDefaultMapper) { TBoldDirectMultiLinkDefaultmapper } TBoldDirectMultiLinkDefaultmapper = class(TBoldMultiLinkDefaultMapper) protected - procedure StuffValuesFromLists(MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist); override; - procedure CompareValuesToLists(OwningId: TBoldObjectId; MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist; FailureList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; + procedure StuffValuesFromLists(const MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist); override; + procedure CompareValuesToLists(OwningId: TBoldObjectId; const MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist; FailureList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; function GetLinkClassObjectMapper: TBoldObjectDefaultMapper; override; public constructor CreateFromMold(moldMember: TMoldMember; moldClass: TMoldClass; Owner: TBoldObjectPersistenceMapper; const MemberIndex: Integer; TypeNameDictionary: TBoldTypeNameDictionary); override; @@ -171,14 +175,17 @@ TBoldDirectMultiLinkDefaultmapper = class(TBoldMultiLinkDefaultMapper) { TBoldIndirectMultiLinkDefaultmapper } TBoldIndirectMultiLinkDefaultmapper = class(TBoldMultiLinkDefaultMapper) protected - procedure StuffValuesFromLists(MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist); override; - procedure CompareValuesToLists(OwningId: TBoldObjectId; MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist; FailureList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; + procedure StuffValuesFromLists(const MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist); override; + procedure CompareValuesToLists(OwningId: TBoldObjectId; const MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist; FailureList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; function GetLinkClassObjectMapper: TBoldObjectDefaultMapper; override; public constructor CreateFromMold(moldMember: TMoldMember; moldClass: TMoldClass; Owner: TBoldObjectPersistenceMapper; const MemberIndex: Integer; TypeNameDictionary: TBoldTypeNameDictionary); override; class function CanStore(const ContentName: string): Boolean; override; end; + const + MaxUnion = 30; + implementation uses @@ -194,13 +201,17 @@ implementation BoldTaggedValueSupport, BoldPMapperLists, BoldGuard, - BoldDefaultStreamNames, - BoldPMConsts; + {$IFDEF RIL} + {$IFNDEF BOLD_UNICODE} + StringBuilder, + {$ENDIF} + {$ENDIF} + BoldDefaultStreamNames; { Supporting functions/procedures } {Returns new ObjectId with owned ClassId, both must be freed} -function CreateAndEnsureId(ObjectId: Integer; ClassId: Integer; Exact: Boolean; TransLationlist: TBoldIdTranslationList; ValueSpace: IBoldValueSpace; TimeStamp: TBoldTimeStampType): TBoldDefaultId; +function CreateAndEnsureId(ObjectId: Integer; ClassId: Integer; Exact: Boolean; TransLationlist: TBoldIdTranslationList; const ValueSpace: IBoldValueSpace; TimeStamp: TBoldTimeStampType): TBoldDefaultId; begin Assert (ClassID <> -1); if TimeStamp = BOLDMAXTIMESTAMP then @@ -210,7 +221,7 @@ function CreateAndEnsureId(ObjectId: Integer; ClassId: Integer; Exact: Boolean; Result.AsInteger := ObjectId; if assigned(TranslationList) then - TranslationList.AddTranslation(nil, Result); // needed? + TranslationList.AddTranslation(nil, Result); ValueSpace.EnsureObjectId(Result); end; @@ -242,14 +253,18 @@ TTempLinkValues = class(TObject) end; function SortLinkValues(Item1, Item2: Pointer): integer; +var + Tl1, Tl2: TTempLinkValues; begin - result := TTempLinkValues(Item1).Objectid - TTempLinkValues(Item2).Objectid; + Tl1 := TTempLinkValues(Item1); + Tl2 := TTempLinkValues(Item2); + result := Tl1.Objectid - Tl2.Objectid; if result = 0 then - result := TTempLinkValues(Item1).OrderValue - TTempLinkValues(Item2).OrderValue; + result := Tl1.OrderValue - Tl2.OrderValue; if result = 0 then - result := TTempLinkValues(Item1).RemoteId - TTempLinkValues(Item2).RemoteId; + result := Tl1.RemoteId - Tl2.RemoteId; if result = 0 then - result := TTempLinkValues(Item1).ClosestId - TTempLinkValues(Item2).ClosestId; + result := Tl1.ClosestId - Tl2.ClosestId; end; constructor TBoldNonEmbeddedLinkDefaultMapper.CreateFromMold( @@ -262,9 +277,9 @@ constructor TBoldNonEmbeddedLinkDefaultMapper.CreateFromMold( fIsStoredInObject := IsStoredInObject and ((MoldMember as TMoldRole).RoleType in [rtRole, rtInnerLinkRole]); end; -function TBoldNonEmbeddedLinkDefaultMapper.CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; +function TBoldNonEmbeddedLinkDefaultMapper.CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; begin - raise EBold.CreateFmt(sCannotCallOnTransientClass, [classname]); + raise EBold.CreateFmt('%s.CompareField: Can not be called for this class, it is not stored', [classname]); end; function TBoldNonEmbeddedLinkDefaultMapper.GetColumnCount: Integer; @@ -272,7 +287,268 @@ function TBoldNonEmbeddedLinkDefaultMapper.GetColumnCount: Integer; Result := 0; end; -procedure TBoldNonEmbeddedLinkDefaultMapper.ProcessSQL(Query: IBoldQuery; WhereFragment: String; resultList: TList; TimeStamp: TBoldTimeStampType); +procedure TBoldNonEmbeddedLinkDefaultMapper.ProcessSQL(const Query: IBoldQuery; WhereFragment: String; resultList: TList; TimeStamp: TBoldTimeStampType); +{$IFDEF RIL} +var + Cnt: integer; + + i, j: integer; + ClassIdRequired: Boolean; + NextColumnIndex: integer; + LinkData: TTempLinkValues; + MappingInfo: TBoldMemberMappingArray; + AIMappingInfo: TBoldAllInstancesMappingArray; // of TBoldAllInstancesMappingInfo + EmbeddingColumnName, + EmbeddingOrderColumnName: String; + WhereClause, + SelectClause: String; + Selectlist: TStringList; + SQL: TStringList; + OperatingOnRootTable: Boolean; + RootTableJoin, + sMappingInfoTableName: string; + First: Boolean; +const + LinkTableAlias: String = 'LinkTable_Alias'; + LinkTableAlias_Dot: String = 'LinkTable_Alias.'; + RootTableAlias: String = 'RootTable_Alias'; + procedure ExecQuery; + var + tmpQuery: IBoldQuery; + begin + tmpQuery := Query; + tmpQuery.AssignSQL(SQL); + SQL.Clear; + tmpQuery.Open; + if tmpQuery.RecordCount > resultList.Capacity then + resultList.Capacity := tmpQuery.RecordCount; + while not tmpQuery.Eof do + begin + LinkData := TTempLinkValues.Create; + LinkData.ClosestId := tmpQuery.Fields[0].AsInteger; + LinkData.ClosestClassid := tmpQuery.Fields[1].AsInteger; + LinkData.ObjectId := tmpQuery.Fields[2].AsInteger; + NextColumnIndex := 3; + if ordered then + begin + LinkData.Ordervalue := tmpQuery.Fields[NextColumnIndex].AsInteger; + INC(NextColumnIndex); + end + else + LinkData.OrderValue := 0; + + if isIndirect then + LinkData.RemoteId := tmpQuery.Fields[NextColumnIndex].AsInteger; + ResultList.Add(LinkData); + tmpQuery.Next; + end; + tmpQuery.Close; + end; +var + SB: TStringBuilder; + + +begin + AIMappingInfo := nil; + SelectList := TStringList.Create; + sql := TStringList.Create; + SB := TStringBuilder.Create; + first := true; + MappingInfo := SystemPersistenceMapper.MappingInfo.GetMemberMappings(ClosestOtherEndObjectMapper.ExpressionName, EmbeddingMapper.ExpressionName); + try + if length(MappingInfo)>1 then + BoldPMLogFmt('Fetching accross %4d tables for %s', [length(MappingInfo), EmbeddingMapper.ExpressionName]); + for i := 0 to length(MappingInfo) - 1 do + begin + if not first then + SQL.Append(' UNION '); + sMappingInfoTableName := MappingInfo[i].TableName; + + EmbeddingColumnName := MappingInfo[i].ColumnByIndex[0]; + if Ordered then + begin + if ORDERCOLUMN_INDEX >= MappingInfo[i].ColumnCount then + raise EBoldBadColumnIndex.CreateFmt('%s.: Order column not found for association %s', [ClassName, EmbeddingColumnName]); + EmbeddingOrderColumnName := MappingInfo[i].ColumnByIndex[ORDERCOLUMN_INDEX]; + end + else + EmbeddingOrderColumnName := ''; + + SelectList.Clear; + {ID, TYPE, ClosstId, [OderColumn], [RemoteColumn]} + + //SelectList.Add(LinkTableAlias + '.' + IDCOLUMN_NAME); + SB.Clear; + SB.Append(LinkTableAlias_Dot); + SB.Append(IDCOLUMN_NAME); + SelectList.Append(SB.ToString); + //SelectList.Add(LinkTableAlias + '.' + TYPECOLUMN_NAME); + SB.Clear; + SB.Append(LinkTableAlias_Dot); + SB.Append(TYPECOLUMN_NAME); + SelectList.Append(SB.ToString); + //SelectList.Append(LinkTableAlias + '.' + EmbeddingColumnName); + SB.Clear; + SB.Append(LinkTableAlias_Dot); + SB.Append(EmbeddingColumnName); + SelectList.Append(SB.ToString); + + if ordered then + SelectList.Append(EmbeddingOrderColumnName); + if IsIndirect then + SelectList.Append(RemoteInnerLinkMapper.MainColumnName); + + //SelectClause := Format('SELECT %s', [BoldSeparateStringList(SelectList, ', ', '', '')]); + SelectClause := 'SELECT ' + BoldSeparateStringList(SelectList,', ','',''); + + //WhereClause := Format('WHERE (%s.%s) %s', [LinkTableAlias, EmbeddingColumnName, WhereFragment]); + SB.Clear; + SB.Append('WHERE ('); + SB.Append(LinkTableAlias_Dot); + SB.Append(EmbeddingColumnName); + SB.Append(') '); + SB.Append(WhereFragment); + WhereClause := SB.ToString; + + SQL.Append(SelectClause); + //SQL.Add('FROM '+ MappingInfo[i].TableName + ' ' + LinkTableAlias); + SB.Clear; + SB.Append('FROM '); + SB.Append(sMappingInfoTableName); + SB.Append(' '); + SB.Append(LinkTableAlias); + SQL.Append(SB.ToString); + + RootTableJoin := ''; { build this string conditionally, only if needed !! //ril } + { + RootTableJoin := format('((%s.%s = %s.%s) and (%s.%s = %s.%s))', [ + LinkTableAlias, TIMESTAMPSTARTCOLUMNNAME, + RootTableAlias, TIMESTAMPSTARTCOLUMNNAME, + LinkTableAlias, IDCOLUMN_NAME, + RootTableAlias, IDCOLUMN_NAME]); + } + + if ClosestOtherEndObjectMapper.Versioned and + not SameText(sMappingInfoTableName, SystemPersistenceMapper.RootClassObjectPersistenceMapper.Maintable.SQLName) {=OperatingOnRootTable} then + begin + if SystemPersistenceMapper.SQLDataBaseConfig.UseSQL92Joins then + begin + SB.Clear; + SB.Append('(('); + SB.Append(LinkTableAlias_Dot); + SB.Append(TIMESTAMPSTARTCOLUMNNAME); + SB.Append(' = '); + SB.Append(RootTableAlias); + SB.Append('.'); + SB.Append(TIMESTAMPSTARTCOLUMNNAME); + SB.Append(') and ('); + SB.Append(LinkTableAlias_Dot); + SB.Append(IDCOLUMN_NAME); + SB.Append(' = '); + SB.Append(RootTableAlias); + SB.Append('.'); + SB.Append(IDCOLUMN_NAME); + SB.Append('))'); + RootTableJoin := SB.ToString; + { + SQL.append(format(' left join %s %s on %s', [ + SystemPersistenceMapper.RootClassObjectPersistenceMapper.MainTable.SQLName, RootTableAlias, RootTableJoin] )) + } + + SB.Clear; + SB.Append(' left join '); + SB.Append(SystemPersistenceMapper.RootClassObjectPersistenceMapper.MainTable.SQLName); + SB.Append(' '); + SB.Append(RootTableAlias); + SB.Append(' on '); + SB.Append(RootTableJoin); + SQL.Append(SB.ToString); + end + else + begin + {SQL.Append(format(', %s %s', [SystemPersistenceMapper.RootClassObjectPersistenceMapper.MainTable.SQLName, RootTableAlias] )); } + SQL.Append(', '+SystemPersistenceMapper.RootClassObjectPersistenceMapper.MainTable.SQLName+' '+RootTableAlias); + end; + end; + + SQL.Append(WhereClause); + + ClassIDRequired := true; + AIMappingInfo := SystemPersistenceMapper.MappingInfo.GetAllInstancesMapping(ClosestOtherEndObjectMapper.ExpressionName); + { 1. Cheapest check first. + 2. Break when false as this won't change anymore... } + Cnt := Length(AIMappingInfo); + for j := 0 to Cnt-1 do + begin + if not AIMappingInfo[j].ClassIdRequired and + SameText(AIMappingInfo[j].TableName, sMappingInfoTableName) then + begin + ClassIdRequired := False; + Break; + end; + end; + + if ClassIdRequired then + begin + {ril}//SQL.Add(format('AND (%s in (%s))', [TYPECOLUMN_NAME, ClosestOtherEndObjectMapper.SubClassesID])); + //SQL.Append('AND ('+TYPECOLUMN_NAME+' in ('+ClosestOtherEndObjectMapper.SubClassesID+'))'); + SB.Clear; + SB.Append('AND ('); + SB.Append(TYPECOLUMN_NAME); + SB.Append(' in ('); + SB.Append(ClosestOtherEndObjectMapper.SubClassesID); + SB.Append('))'); + SQL.Append(SB.ToString); + end; + + if ClosestOtherEndObjectMapper.Versioned then + begin + OperatingOnRootTable := SameText(sMappingInfoTableName, SystemPersistenceMapper.RootClassObjectPersistenceMapper.Maintable.SQLName); + if OperatingOnRootTable then + ClosestOtherEndObjectMapper.RetrieveTimeStampCondition(SQL, TimeStamp, false, 'AND', True, LinkTableAlias, LinkTableAlias) + else + ClosestOtherEndObjectMapper.RetrieveTimeStampCondition(SQL, TimeStamp, false, 'AND', True, LinkTableAlias, RootTableAlias); + if not OperatingOnRootTable and not SystemPersistenceMapper.SQLDataBaseConfig.UseSQL92Joins then + begin + if RootTableJoin='' then { not prepared yet } + begin + SB.Clear; + SB.Append('(('); + SB.Append(LinkTableAlias_Dot); + SB.Append(TIMESTAMPSTARTCOLUMNNAME); + SB.Append(' = '); + SB.Append(RootTableAlias); + SB.Append('.'); + SB.Append(TIMESTAMPSTARTCOLUMNNAME); + SB.Append(') and ('); + SB.Append(LinkTableAlias_Dot); + SB.Append(IDCOLUMN_NAME); + SB.Append(' = '); + SB.Append(RootTableAlias); + SB.Append('.'); + SB.Append(IDCOLUMN_NAME); + SB.Append('))'); + RootTableJoin := SB.ToString; + end; + SQL.Append('and '+RootTableJoin); + end; + end; + if ((i+1) mod MaxUnion) = 0 then + begin + ExecQuery; + first := true; + end + else + first := false; + end; + if Sql.Count > 0 then + ExecQuery; + finally + SelectList.Free; + SQL.free; + SB.Free; + end; +{$ELSE} var i, j: integer; ClassIdRequired: Boolean; @@ -299,47 +575,44 @@ procedure TBoldNonEmbeddedLinkDefaultMapper.ProcessSQL(Query: IBoldQuery; WhereF begin EmbeddingColumnName := MappingInfo[i].ColumnByIndex[0]; if Ordered then - EmbeddingOrderColumnName := MappingInfo[i].ColumnByIndex[1] + EmbeddingOrderColumnName := MappingInfo[i].ColumnByIndex[ORDERCOLUMN_INDEX] else EmbeddingOrderColumnName := ''; SelectList.Clear; {ID, TYPE, ClosstId, [OderColumn], [RemoteColumn]} SelectList.Add(LinkTableAlias + '.' + IDCOLUMN_NAME); - SelectList.Add(LinkTableAlias + '.' + TYPECOLUMN_NAME); // FIXME hardwired + SelectList.Add(LinkTableAlias + '.' + TYPECOLUMN_NAME); SelectList.Append(LinkTableAlias + '.' + EmbeddingColumnName); - // there is no need to add an OrderBy clause since the list will be ordered in memory prior to processing if ordered then SelectList.Append(EmbeddingOrderColumnName); if IsIndirect then SelectList.Append(Format('%s', [RemoteInnerLinkMapper.MainColumnName])); - SelectClause := Format('SELECT %s', [BoldSeparateStringList(SelectList, ', ', '', '')]); // do not localize + SelectClause := Format('SELECT %s', [BoldSeparateStringList(SelectList, ', ', '', '')]); - WhereClause := Format('WHERE (%s.%s) %s', [LinkTableAlias, EmbeddingColumnName, WhereFragment]); // do not localize + WhereClause := Format('WHERE (%s.%s) %s', [LinkTableAlias, EmbeddingColumnName, WhereFragment]); SQL.Clear; SQL.Add(SelectClause); - SQL.Add('FROM '+ MappingInfo[i].TableName + ' ' + LinkTableAlias); // do not localize + SQL.Add('FROM '+ MappingInfo[i].TableName + ' ' + LinkTableAlias); OperatingOnRootTable := SameText(MappingInfo[i].TableName, SystemPersistenceMapper.RootClassObjectPersistenceMapper.Maintable.SQLName); - RootTableJoin := format('((%s.%s = %s.%s) and (%s.%s = %s.%s))', [ // do not localize + RootTableJoin := format('((%s.%s = %s.%s) and (%s.%s = %s.%s))', [ LinkTableAlias, TIMESTAMPSTARTCOLUMNNAME, RootTableAlias, TIMESTAMPSTARTCOLUMNNAME, LinkTableAlias, IDCOLUMN_NAME, RootTableAlias, IDCOLUMN_NAME]); - // Add the root table if it is needed and not already there - if ClosestOtherEndObjectMapper.Versioned and not OperatingOnRootTable then begin if SystemPersistenceMapper.SQLDataBaseConfig.UseSQL92Joins then - SQL.append(format(' left join %s %s on %s', [ // do not localize + SQL.append(format(' left join %s %s on %s', [ SystemPersistenceMapper.RootClassObjectPersistenceMapper.MainTable.SQLName, RootTableAlias, RootTableJoin] )) else - SQL.Append(format(', %s %s', [ // do not localize + SQL.Append(format(', %s %s', [ SystemPersistenceMapper.RootClassObjectPersistenceMapper.MainTable.SQLName, RootTableAlias] )); end; @@ -354,17 +627,15 @@ procedure TBoldNonEmbeddedLinkDefaultMapper.ProcessSQL(Query: IBoldQuery; WhereF ClassIdRequired := false; if ClassIdRequired then - SQL.Add(format('AND (%s in (%s))', [TYPECOLUMN_NAME, ClosestOtherEndObjectMapper.SubClassesID])); // do not localize - - // add timestamp conditions and nessesary joins + SQL.Add(format('AND (%s in (%s))', [TYPECOLUMN_NAME, ClosestOtherEndObjectMapper.SubClassesID])); if ClosestOtherEndObjectMapper.Versioned then begin if OperatingOnRootTable then - ClosestOtherEndObjectMapper.RetrieveTimeStampCondition(SQL, TimeStamp, false, 'AND', True, LinkTableAlias, LinkTableAlias) // do not localize + ClosestOtherEndObjectMapper.RetrieveTimeStampCondition(SQL, TimeStamp, false, 'AND', True, LinkTableAlias, LinkTableAlias) else - ClosestOtherEndObjectMapper.RetrieveTimeStampCondition(SQL, TimeStamp, false, 'AND', True, LinkTableAlias, RootTableAlias); // do not localize + ClosestOtherEndObjectMapper.RetrieveTimeStampCondition(SQL, TimeStamp, false, 'AND', True, LinkTableAlias, RootTableAlias); if not OperatingOnRootTable and not SystemPersistenceMapper.SQLDataBaseConfig.UseSQL92Joins then - SQL.Append(format('and %s', [RootTableJoin])); // do not localize + SQL.Append(format('and %s', [RootTableJoin])); end; Query.AssignSQL(SQL); @@ -394,9 +665,11 @@ procedure TBoldNonEmbeddedLinkDefaultMapper.ProcessSQL(Query: IBoldQuery; WhereF SelectList.Free; sql.free; end; -end; +{$ENDIF} +end; { TBoldNonEmbeddedLinkDefaultMapper.ProcessSQL } -procedure TBoldNonEmbeddedLinkDefaultMapper.ProcessResult(ResultList: TList; ValueSpace: IBoldValueSpace; ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; TimeStamp: TBoldTimeStampType; FetchMode: integer; FailureList: TBoldObjectIdList); + +procedure TBoldNonEmbeddedLinkDefaultMapper.ProcessResult(ResultList: TList; const ValueSpace: IBoldValueSpace; ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; TimeStamp: TBoldTimeStampType; FetchMode: integer; FailureList: TBoldObjectIdList); var UnprocessedObjects: TBoldObjectidList; ListOfClosestEnd: TBoldObjectIdlist; @@ -410,19 +683,18 @@ procedure TBoldNonEmbeddedLinkDefaultMapper.ProcessResult(ResultList: TList; Val i, OldfailureCount: integer; begin ObjectContents := ValueSpace.EnsuredObjectContentsByObjectId[CurrentobjectId]; - ObjectContents.EnsureMember(MemberId, ContentName); - MemberInterface := ObjectContents.ValueByMemberId[MemberID]; + MemberInterface := ObjectContents.EnsureMemberAndGetValueByIndex(MemberId.MemberIndex, ContentName); if FetchMode = fmCompare then begin OldFailureCount := failureLIst.Count; CompareValuestoLists(CurrentObjectId, MemberInterface, ListOfClosestEnd, ListOfRemoteEnd, FailureList, TranslationList); if FailureList.Count > OldFailureCount then begin - BoldLog.LogFmt(sOptimisticLockingFailedForTheFollowing, [ + BoldLog.LogFmt('Optimistic Locking failed for %s.%s for the following objects', [ ObjectPersistenceMapper.ExpressionName, ExpressionName]); for i := OldFailureCount to FailureList.Count - 1 do - BoldLog.LogFmt(sLogIdAsString, [FailureList[i].AsString]); + BoldLog.Log('Id: '+ FailureList[i].AsString); end; end else if MemberInterface.BoldPersistenceState = bvpsInvalid then @@ -435,16 +707,14 @@ procedure TBoldNonEmbeddedLinkDefaultMapper.ProcessResult(ResultList: TList; Val procedure EnsureAndAddToList(List: TBoldObjectIdList; ClassId: integer; Exact: Boolean; IdAsInteger: integer); var BoldId: TBoldDefaultId; - BoldGuard: IBoldGuard; begin - BoldGuard := TBoldGuard.Create(BoldID); BoldId := CreateAndEnsureId(IdAsInteger, ClassId, Exact, TranslationList, ValueSpace, TimeStamp); - List.Add(BoldId); + List.AddAndAdopt(BoldId); end; function FindInListByIdAsInteger(List: TBoldObjectIdList; IdAsInteger: integer): TBoldObjectId; @@ -465,6 +735,7 @@ procedure TBoldNonEmbeddedLinkDefaultMapper.ProcessResult(ResultList: TList; Val Currentresult: TTempLinkValues; RemoteOtherEndExact: Boolean; TranslatedClassId: integer; + BoldObjectId: TBoldObjectId; BoldGuard: IBoldGuard; begin BoldGuard := TBoldGuard.Create(ListOfRemoteEnd, ListOfClosestEnd, UnprocessedObjects, MemberID); @@ -472,12 +743,13 @@ procedure TBoldNonEmbeddedLinkDefaultMapper.ProcessResult(ResultList: TList; Val (not ObjectPersistenceMappers[RemoteOtherEndObjectMapperIndex].HasSubClasses); UnprocessedObjects := ObjectIDList.Clone; + MemberID := TBoldMemberId.Create(MemberIndex); ListOfClosestEnd := TBoldObjectIdlist.Create; ListOfRemoteEnd := TBoldObjectIdlist.Create; - MemberID := TBoldMemberId.Create(MemberIndex); - + CurrentId := -1; if resultList.Count > 0 then - begin + try + ListOfClosestEnd.Capacity := resultList.Count; CurrentId := TTempLinkValues(ResultList[0]).ObjectId; for i := 0 to ResultList.Count - 1 do begin @@ -496,10 +768,18 @@ procedure TBoldNonEmbeddedLinkDefaultMapper.ProcessResult(ResultList: TList; Val CurrentResult.RemoteId); end; - ProcessResultForOneObject(FindInListByIdAsInteger(UnprocessedObjects, CurrentId)); - end; + BoldObjectId := FindInListByIdAsInteger(UnprocessedObjects, CurrentId); + ProcessResultForOneObject(BoldObjectId); + except + on e:EBoldDuplicateSingleLinkValueInDb do + begin + e.Message := 'BoldId: ' + IntToStr(CurrentId) + ' ' + e.Message; - // clear links for objects that had no related objects in the database + raise; + end + else + raise; + end; while UnprocessedObjects.Count > 0 do ProcessResultForOneObject(UnprocessedObjects[0] as TBoldDefaultId); {Lists empty at this point} @@ -527,12 +807,12 @@ function TBoldNonEmbeddedLinkDefaultMapper.CreateSelectClause: string; end; *) -procedure TBoldNonEmbeddedLinkDefaultMapper.PMFetch(ObjectIDList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; FetchMode: Integer; TranslationList: TBoldIdTranslationList; FailureList: TBoldObjectIdList); +procedure TBoldNonEmbeddedLinkDefaultMapper.PMFetch(ObjectIDList: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; FetchMode: Integer; TranslationList: TBoldIdTranslationList; FailureList: TBoldObjectIdList); var TimeStamp: TBoldTimeStampType; ResultList: TList; start, stop: integer; - Block, ObjectCount, I: Integer; + Block, ObjectCount, I, FetchBlockSize, unions: Integer; WhereFragment: String; TopSortedIndex: Integer; aQuery: IBoldQuery; @@ -542,8 +822,6 @@ procedure TBoldNonEmbeddedLinkDefaultMapper.PMFetch(ObjectIDList: TBoldObjectIdL TopSortedIndex := ObjectPersistenceMapper.TopSortedIndex; - // splitting on timestamps is performed by the objectpersistencemapper already - TimeStamp := ObjectIdList[0].TimeStamp; for I := 0 to ObjectIDList.Count - 1 do @@ -567,19 +845,24 @@ procedure TBoldNonEmbeddedLinkDefaultMapper.PMFetch(ObjectIDList: TBoldObjectIdL try ObjectCount := ObjectIDList.Count - 1; - // only do the fetching in blocks, the actual processing must be done in one go - // since ProcessResult will clear all objects with empty links - // besides, the point of blockfetching is mainly to reduce the size of the SQL-statement - for Block := 0 to (ObjectCount div SystemPersistenceMapper.SQLDataBaseConfig.FetchBlockSize) do + Unions := MinIntValue([MaxUnion, length(SystemPersistenceMapper.MappingInfo.GetMemberMappings(ClosestOtherEndObjectMapper.ExpressionName, EmbeddingMapper.ExpressionName))]); + FetchBlockSize := 1; + if Unions > 0 then + FetchBlockSize := SystemPersistenceMapper.SQLDataBaseConfig.FetchBlockSize div Unions; + if FetchBlockSize = 0 then + FetchBlockSize := 1; + for Block := 0 to (ObjectCount div FetchBlockSize) do begin aQuery.ClearParams; - Start := Block * SystemPersistenceMapper.SQLDataBaseConfig.FetchBlockSize; - Stop := MinIntValue([Pred(Succ(Block) * SystemPersistenceMapper.SQLDataBaseConfig.FetchBlockSize), ObjectCount]); - WhereFragment := ObjectPersistenceMapper.IdListSegmentToWhereFragment(ObjectIdList, Start, Stop, aQuery); + Start := Block * FetchBlockSize; + Stop := MinIntValue([Pred(Succ(Block) * FetchBlockSize), ObjectCount]); + WhereFragment := ObjectPersistenceMapper.IdListSegmentToWhereFragment(ObjectIdList, Start, Stop, false, aQuery); ProcessSQL(aQuery, WhereFragment, resultList, TimeStamp); end; - ResultList.Sort(SortLinkValues); - BoldPMLogFmt(sLogFetchIDs, [ResultLIst.Count, ObjectIdList.Count, ObjectPersistenceMapper.ExpressionName, ExpressionName]); + if ResultList.Count > 1 then + ResultList.Sort(SortLinkValues); + if BoldPMLogHandler<>nil then + BoldPMLogFmt('Fetched %4d ids for %4d nonembedded links %s.%s', [ResultLIst.Count, ObjectIdList.Count, ObjectPersistenceMapper.ExpressionName, ExpressionName]); ProcessResult(ResultList, ValueSpace, ObjectIdList, TranslationList, timeStamp, FetchMode, FailureList); finally @@ -602,7 +885,7 @@ function TBoldEmbeddedSingleLinkDefaultMapper.GetColumnTypeAsSQL(ColumnIndex: In case ColumnIndex of 0, 1: Result := SystemPersistenceMapper.SQLDataBaseConfig.ColumnTypeForInteger; else - raise EBoldBadColumnIndex.CreateFmt(sIllegalColumnIndex, [ClassName, 'GetColumnTypeAsSQL', ColumnIndex]); // do not localize + raise EBoldBadColumnIndex.CreateFmt('%s.GetColumnTypeAsSQL: Bad column index', [ClassName]); end; end; @@ -616,7 +899,7 @@ function TBoldEmbeddedSingleLinkDefaultMapper.GetColumnBDEFieldType(ColumnIndex: case ColumnIndex of 0, 1: Result := ftInteger; else - raise EBoldBadColumnIndex.CreateFmt(sIllegalColumnIndex, [ClassName, 'GetColumnBDEFieldType', ColumnIndex]); // do not localize + raise EBoldBadColumnIndex.CreateFmt('%s.GetColumnBDEFieldType: Bad column index', [ClassName]); end; end; @@ -625,7 +908,7 @@ function TBoldEmbeddedSingleLinkDefaultMapper.GetColumnSize(ColumnIndex: Integer Result := 0; end; -function TBoldEmbeddedSingleLinkDefaultMapper.CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; +function TBoldEmbeddedSingleLinkDefaultMapper.CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; var anIdRef: IBoldObjectIdRef; begin @@ -650,37 +933,72 @@ function TBoldEmbeddedSingleLinkDefaultMapper.CompareField(ObjectContent: IBoldO result := Field.AsInteger = anIdRef.OrderNo; end; end; + end; function TBoldEmbeddedSingleLinkDefaultMapper.GetInitialColumnName(ColumnIndex: Integer): string; begin case ColumnIndex of 0: Result := InitialColumnRootName; - 1: Result := InitialColumnRootName + '_O'; + 1: Result := InitialColumnRootName + ORDERCOLUMN_SUFFIX; else - raise EBoldBadColumnIndex.CreateFmt(sIllegalColumnIndex, [classname, 'GetInitialColumnName', ColumnIndex]); // do not localize + raise EBoldBadColumnIndex.CreateFmt('%s.GetInitialColumnName: Bad column index', [classname]); end; end; -procedure TBoldEmbeddedSingleLinkDefaultMapper.ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); +procedure TBoldEmbeddedSingleLinkDefaultMapper.ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); var SingleLink: IBoldObjectIdRef; + aBoldObjectID: TBoldObjectID; begin SingleLink := GetEnsuredValue(ObjectContent) as IBoldObjectIdRef; case ColumnIndex of 0: if assigned(SingleLink.Id) then - Param.AsInteger := (TranslationList.TranslateToNewID[SingleLink.Id] as TBoldDefaultId).asInteger + begin + aBoldObjectID := TranslationList.TranslateToNewID[SingleLink.Id]; + if aBoldObjectID is TBoldDefaultId then + Param.AsInteger := TBoldDefaultId(aBoldObjectID).asInteger + else + Param.AsInteger := INTERNALNULLKEY; + end else Param.AsInteger := INTERNALNULLKEY; 1: Param.AsInteger := SingleLink.OrderNo; else - raise EBoldBadColumnIndex.CreateFmt(sIllegalColumnIndex, [ClassName, 'ValueToParam', ColumnIndex]); // do not localize + raise EBoldBadColumnIndex.CreateFmt('%s.ValueToParam: Bad column index (%d)', [ClassName, ColumnIndex]); end; end; -procedure TBoldEmbeddedSingleLinkDefaultMapper.ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); +function TBoldEmbeddedSingleLinkDefaultMapper.ValueAsVariant( + const ObjectContent: IBoldObjectContents; ColumnIndex: Integer; + TranslationList: TBoldIdTranslationList): variant; +var + SingleLink: IBoldObjectIdRef; + aBoldObjectID: TBoldObjectID; +begin + SingleLink := GetEnsuredValue(ObjectContent) as IBoldObjectIdRef; + case ColumnIndex of + 0: + if assigned(SingleLink.Id) then + begin + aBoldObjectID := TranslationList.TranslateToNewID[SingleLink.Id]; + if aBoldObjectID is TBoldDefaultId then + result := TBoldDefaultId(aBoldObjectID).asInteger + else + result := INTERNALNULLKEY; + end + else + result := INTERNALNULLKEY; + 1: + result := SingleLink.OrderNo; + else + raise EBoldBadColumnIndex.CreateFmt('%s.ValueAsVariant: Bad column index (%d)', [ClassName, ColumnIndex]); + end; +end; + +procedure TBoldEmbeddedSingleLinkDefaultMapper.ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); var ObjectId: TBoldObjectId; anIdRef: IBoldObjectIdRef; @@ -691,15 +1009,14 @@ procedure TBoldEmbeddedSingleLinkDefaultMapper.ValueFromField(OwningObjectId: TB if not Field.IsNull and (Field.AsInteger <> INTERNALNULLKEY) then begin ObjectId := CreateAndEnsureId(Field.AsInteger, OtherEndObjectPMIndex, OtherEndExact, TranslationList, ValueSpace, OwningObjectId.TimeStamp); - anIdRef.SetFromId(ObjectId); - ObjectID.Free; + anIdRef.SetFromId(ObjectId, true); end else - anIdRef.SetFromId(nil); + anIdRef.SetFromId(nil, false); 1: anIdRef.Orderno := Field.AsInteger; else - raise EBoldBadColumnIndex.CreateFmt(sIllegalColumnIndex, [ClassName, 'ValueFromField', ColumnIndex]); // do not localize + raise EBoldBadColumnIndex.CreateFmt('%s.ValueFromField: Bad column index', [ClassName]); end; end; @@ -794,7 +1111,7 @@ function TBoldDirectSingleLinkDefaultmapper.GetLinkClassObjectMapper: TBoldObjec result := nil; end; -procedure TBoldDirectSingleLinkDefaultmapper.CompareValuesToLists(OwningId: TBoldObjectId; MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist; FailureList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); +procedure TBoldDirectSingleLinkDefaultmapper.CompareValuesToLists(OwningId: TBoldObjectId; const MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist; FailureList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); var IdRef: IBoldObjectIdRef; begin @@ -812,10 +1129,10 @@ procedure TBoldDirectSingleLinkDefaultmapper.CompareValuesToLists(OwningId: TBol end; procedure TBoldDirectSingleLinkDefaultmapper.StuffValuesFromLists( - MemberInterface: IBoldValue; ListOfClosestEnd, + const MemberInterface: IBoldValue; ListOfClosestEnd, ListOfRemoteEnd: TBoldObjectIdlist); begin - (MemberInterface as IBoldObjectIdRef).SetFromId(FirstIdInList(ListOfClosestEnd)); + (MemberInterface as IBoldObjectIdRef).SetFromId(FirstIdInList(ListOfClosestEnd), false); end; { TBoldIndirectSingleLinkDefaultmapper } @@ -838,7 +1155,7 @@ constructor TBoldIndirectSingleLinkDefaultmapper.CreateFromMold( fRemoteInnerLinkMemberIndex := LinkClass.AllBoldMembers.IndexOf(Role.OtherEnd.LinkRole.OtherEnd); if (LinkClass.TableMapping = tmChildren) then - raise EBoldFeatureNotImplementedYet.CreateFmt(sChildMappedLinkClassesNotSupported, + raise EBoldFeatureNotImplementedYet.CreateFmt('%s.%s: ChildMapped LinkObjects (%s) are not supported!', [MoldClass.name, Role.Name, LinkClass.Name]); end; @@ -847,7 +1164,7 @@ function TBoldIndirectSingleLinkDefaultmapper.GetLinkClassObjectMapper: TBoldObj result := ObjectPersistenceMappers[ClosestOtherEndObjectMapperIndex]; end; -procedure TBoldIndirectSingleLinkDefaultmapper.CompareValuesToLists(OwningId: TBoldObjectId; MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist; FailureList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); +procedure TBoldIndirectSingleLinkDefaultmapper.CompareValuesToLists(OwningId: TBoldObjectId; const MemberInterface: IBoldValue; ListOfClosestEnd: TBoldObjectIdlist; ListOfRemoteEnd: TBoldObjectIdlist; FailureList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); var IdRefPair: IBoldObjectIdRefPair; begin @@ -867,7 +1184,7 @@ procedure TBoldIndirectSingleLinkDefaultmapper.CompareValuesToLists(OwningId: TB end; procedure TBoldIndirectSingleLinkDefaultmapper.StuffValuesFromLists( - MemberInterface: IBoldValue; ListOfClosestEnd, + const MemberInterface: IBoldValue; ListOfClosestEnd, ListOfRemoteEnd: TBoldObjectIdlist); begin (MemberInterface as IBoldObjectIdRefPair).SetFromIds(FirstIdInList(ListOfClosestEnd), FirstIdInList(ListOfRemoteEnd)); @@ -876,7 +1193,7 @@ procedure TBoldIndirectSingleLinkDefaultmapper.StuffValuesFromLists( { TBoldDirectMultiLinkDefaultmapper } procedure TBoldDirectMultiLinkDefaultmapper.CompareValuesToLists( - OwningId: TBoldObjectId; MemberInterface: IBoldValue; ListOfClosestEnd, + OwningId: TBoldObjectId; const MemberInterface: IBoldValue; ListOfClosestEnd, ListOfRemoteEnd, FailureList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); var IdList: IBoldObjectIdListRef; @@ -921,7 +1238,7 @@ function TBoldDirectMultiLinkDefaultmapper.GetLinkClassObjectMapper: TBoldObject end; procedure TBoldDirectMultiLinkDefaultmapper.StuffValuesFromLists( - MemberInterface: IBoldValue; ListOfClosestEnd, + const MemberInterface: IBoldValue; ListOfClosestEnd, ListOfRemoteEnd: TBoldObjectIdlist); begin (MemberInterface as IBoldObjectIdListRef).SetFromIdList(ListOfClosestEnd); @@ -930,7 +1247,7 @@ procedure TBoldDirectMultiLinkDefaultmapper.StuffValuesFromLists( { TBoldIndirectMultiLinkDefaultmapper } procedure TBoldIndirectMultiLinkDefaultmapper.CompareValuesToLists( - OwningId: TBoldObjectId; MemberInterface: IBoldValue; ListOfClosestEnd, + OwningId: TBoldObjectId; const MemberInterface: IBoldValue; ListOfClosestEnd, ListOfRemoteEnd, FailureList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); var IdLists: IBoldObjectIdListRefPair; @@ -973,7 +1290,7 @@ constructor TBoldIndirectMultiLinkDefaultmapper.CreateFromMold( fRemoteInnerLinkMemberIndex := LinkClass.AllBoldMembers.IndexOf(Role.OtherEnd.LinkRole.OtherEnd); if (LinkClass.TableMapping = tmChildren) then - raise EBoldFeatureNotImplementedYet.CreateFmt(sChildMappedLinkClassesNotSupported, + raise EBoldFeatureNotImplementedYet.CreateFmt('%s.%s: ChildMapped LinkObjects (%s) are not supported!', [MoldClass.name, Role.Name, LinkClass.Name]); end; @@ -983,7 +1300,7 @@ function TBoldIndirectMultiLinkDefaultmapper.GetLinkClassObjectMapper: TBoldObje end; procedure TBoldIndirectMultiLinkDefaultmapper.StuffValuesFromLists( - MemberInterface: IBoldValue; ListOfClosestEnd, + const MemberInterface: IBoldValue; ListOfClosestEnd, ListOfRemoteEnd: TBoldObjectIdlist); begin (MemberInterface as IBoldObjectIdListRefPair).SetFromIdLists(ListOfClosestEnd, ListOfRemoteEnd); @@ -993,7 +1310,8 @@ procedure TBoldIndirectMultiLinkDefaultmapper.StuffValuesFromLists( function TBoldSingleLinkDefaultMapper.FirstIdInList(List: TBoldObjectIdList): TBoldObjectId; begin - Assert(List.Count <= 1); + if List.Count > 1 then + raise EBoldDuplicateSingleLinkValueInDb.Create(ObjectPersistenceMapper.ExpressionName + '.' + ExpressionName + ';List count is ' + IntToStr(List.Count) + ', expected <= 1, possible reason: duplicate values in DB for a single link'); if List.Count = 0 then Result := nil else @@ -1064,7 +1382,7 @@ procedure TBoldEmbeddedSingleLinkDefaultMapper.GetNonEmbeddedChangePoints( result.AddJoin(NewTableRef.GetColumnReference(MemberMapping.ColumnByIndex[0]), JoinTableRef.GetColumnReference(MemberMapping.ColumnByIndex[0])); result.AddJoin(NewTableRef.GetColumnReference(IDCOLUMN_NAME), JoinTableRef.GetColumnReference(IDCOLUMN_NAME)); Query.AddWCF(TBoldSQLWCFUnaryPrefix.Create(TBoldSQLWCFExists.Create(result, NewTableRef), - 'not')); // do not localize + 'not')); end; function JoinRootTableInto(Query: TBoldSQLQuery; TableRef: TBoldSQLTableReference): TBoldSQLTableReference; @@ -1141,6 +1459,7 @@ procedure TBoldEmbeddedSingleLinkDefaultMapper.InitializePSDescriptions; i, j: Integer; MemberMappings: TBoldMemberMappingArray; Columns: TStringList; + CatenatedColumns: string; BoldGuard: IBoldGuard; begin inherited; @@ -1150,14 +1469,29 @@ procedure TBoldEmbeddedSingleLinkDefaultMapper.InitializePSDescriptions; if not IsInherited then begin - Columns := TStringList.create; MemberMappings := SystemPersistenceMapper.MappingInfo.GetMemberMappings(ObjectPersistenceMapper.ExpressionName, ExpressionName); - for i := 0 to length(MemberMappings) - 1 do + Columns := TStringList.create; + if SystemPersistenceMapper.SQLDataBaseConfig.SingleIndexOrderedLinks then begin - Columns.CommaText := MemberMappings[i].Columns; - for j := 0 to Columns.Count - 1 do + for i := 0 to length(MemberMappings) - 1 do + begin + Columns.CommaText := MemberMappings[i].Columns; + CatenatedColumns := Columns[0]; + for j := 1 to Columns.Count - 1 do + CatenatedColumns := CatenatedColumns + ';' + Columns[j]; SystemPersistenceMapper.EnsureIndex(MemberMappings[i].TableName, - Columns[j], False, False, ObjectPersistenceMapper.Versioned); + CatenatedColumns, False, False, False, ObjectPersistenceMapper.Versioned); + end; + end + else + begin + for i := 0 to length(MemberMappings) - 1 do + begin + Columns.CommaText := MemberMappings[i].Columns; + for j := 0 to Columns.Count - 1 do + SystemPersistenceMapper.EnsureIndex(MemberMappings[i].TableName, + Columns[j], False, False, False, ObjectPersistenceMapper.Versioned); + end; end; end; end; @@ -1182,7 +1516,7 @@ function TBoldEmbeddedSingleLinkDefaultMapper.GetMainColumnName: String; function TBoldEmbeddedSingleLinkDefaultMapper.GetOrderColumnName: String; begin - result := ColumnDescriptions[1].SQLName; + result := ColumnDescriptions[ORDERCOLUMN_INDEX].SQLName; end; function TBoldNonEmbeddedLinkDefaultMapper.GetLinkClassTableName: string; @@ -1252,6 +1586,7 @@ function TBoldNonEmbeddedLinkDefaultMapper.GetSupportsPolymorphicFetch: Boolean; end; initialization + with BoldMemberPersistenceMappers do begin AddDescriptor(TBoldNonEmbeddedLinkDefaultMapper, alAbstract); @@ -1280,4 +1615,3 @@ finalization end. - diff --git a/Source/PMapper/Default/BoldPSDescriptionsDefault.pas b/Source/PMapper/Default/BoldPSDescriptionsDefault.pas index aafb9fdd..2f47336e 100644 --- a/Source/PMapper/Default/BoldPSDescriptionsDefault.pas +++ b/Source/PMapper/Default/BoldPSDescriptionsDefault.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPSDescriptionsDefault; interface @@ -7,12 +10,14 @@ interface BoldPSDescriptionsSQL, BoldPSParams, BoldPSParamsSQL, - BoldPSParamsDefault; + BoldPSParamsDefault, + BoldDBInterfaces; type {---TBoldDefaultSystemDescription---} TBoldDefaultSystemDescription = class(TBoldSQLSystemDescription) private + Query: IBoldExecQuery; FIdTable: TBoldSQLTableDescription; FTimeStamptable: TBoldSQLTableDescription; FTypeTable: TBoldSQLTableDescription; @@ -36,16 +41,15 @@ TBoldDefaultSystemDescription = class(TBoldSQLSystemDescription) procedure AddFirstClock(PSParams: TBoldPSDefaultParams); procedure AddTableNames(PSParams: TBoldPSDefaultParams); - procedure GenerateScriptForFirstID(Script: TStrings; Separator: String); - procedure GenerateScriptForFirstTimeStamp(Script: TStrings; Separator: String); - procedure GenerateScriptForFirstClock(Script: TStrings; Separator: String); - procedure GenerateScriptForTableNames(Script: TStrings; Separator: String); + procedure GenerateScriptForFirstID(Script: TStrings); + procedure GenerateScriptForFirstTimeStamp(Script: TStrings); + procedure GenerateScriptForFirstClock(Script: TStrings); + procedure GenerateScriptForTableNames(Script: TStrings); protected - procedure InitializeKnownSystemtables(KnownTables: TStrings; PSParams: TBoldPSSQLParams); override; public procedure CreatePersistentStorage(PSParams: TBoldPSParams); override; - procedure GenerateDatabaseScript(Script: TStrings; Separator: string); override; + procedure GenerateDatabaseScript(Script: TStrings); override; property IdTable: TBoldSQLTableDescription read FIdTable write SetIdTable; property RootTable: TBoldSQLTableDescription read fRootTable write SetRootTable; property TypeTable: TBoldSQLTableDescription read FTypeTable write SetTypeTable; @@ -63,11 +67,15 @@ implementation uses SysUtils, - BoldDBInterfaces, + {$IFNDEF BOLD_UNICODE} + StringBuilder, + {$ENDIF} + DB, BoldDefs, BoldLogHandler, BoldNameExpander, - BoldPMConsts; + BoldMath, + BoldRev; {---TBoldDefaultSystemDescription---} @@ -93,27 +101,27 @@ procedure TBoldDefaultSystemDescription.AddFirstClock(PSParams: TBoldPSDefaultPa procedure AddFirstClockUsingQuery; var - Q: IBoldExecQuery; + vParam: IBoldParameter; begin - q := PSParams.DataBase.GetExecQuery; - try - q.AssignSQLText(format( - 'INSERT INTO %s (%s, %s) VALUES (0, :FirstClock)', // do not localize - [LastClockTable.SQLName, LASTTIMESTAMPCOLUMN_NAME, LASTCLOCKCOLUMN_NAME] )); - q.ParamByName('FirstClock').AsDateTime := 0; // do not localize - q.ExecSQL; - finally - PSParams.DataBase.ReleaseExecQuery(q); - end; + Query.AssignSQLText(format( + 'INSERT INTO %s (%s, %s) VALUES (0, :FirstClock)', + [LastClockTable.SQLName, LASTTIMESTAMPCOLUMN_NAME, LASTCLOCKCOLUMN_NAME] )); + vParam := Query.FindParam('FirstClock'); + if not Assigned(vParam) then + vParam := Query.CreateParam(ftDateTime, 'FirstClock'); + vParam.AsDateTime := 0; + Query.ParamCheck := true; + Query.ExecSQL; + Query.ParamCheck := false; end; - + begin - BoldLog.Log(sLogWritingFirstClock); + BoldLog.Log('Writing First Clock'); case EffectiveGenerationMode(PSParams) of dbgTable: AddFirstClockUsingTable; dbgQuery: AddFirstClockUsingQuery; - else raise EBold.CreateFmt(sUnknownGenerationMode, [ClassName, 'AddFirstClock']); // do not localize + else raise EBold.CreateFmt('%s.AddFirstClock: unknown database generation mode', [ClassName]); end; end; @@ -138,26 +146,19 @@ procedure TBoldDefaultSystemDescription.AddFirstID(PSParams: TBoldPSDefaultParam end; procedure AddFirstIdUsingQuery; - var - Q: IBoldExecQuery; begin - q := PSParams.DataBase.GetExecQuery; - try - q.AssignSQLText(format( - 'INSERT INTO %s (%s) VALUES (1)', // do not localize + Query.AssignSQLText(format( + 'INSERT INTO %s (%s) VALUES (1)', [IDTable.SQLName, IDCOLUMN_NAME] )); - q.ExecSQL; - finally - PSParams.DataBase.ReleaseExecQuery(q); - end; + Query.ExecSQL; end; begin - BoldLog.Log(sLogWritingFirstID); + BoldLog.Log('Writing First ID'); case EffectiveGenerationMode(PSParams) of dbgTable: AddFirstIDUsingTable; dbgQuery: AddFirstIDUsingQuery; - else raise EBold.CreateFmt(sUnknownGenerationMode, [ClassName, 'AddFirstID']); // do not localize + else raise EBold.CreateFmt('%s.AddFirstID: unknown database generation mode', [ClassName]); end; end; @@ -166,7 +167,7 @@ procedure TBoldDefaultSystemDescription.AddFirstTimeStamp(PSParams: TBoldPSDefau var Table: IBoldTable; begin - BoldLog.Log(sLogWritingFirstTimeStamp); + BoldLog.Log('Writing First TimeStamp'); Table := PSParams.DataBase.GetTable; with Table do try @@ -181,26 +182,19 @@ procedure TBoldDefaultSystemDescription.AddFirstTimeStamp(PSParams: TBoldPSDefau end; end; procedure AddFirstTimeStampUsingQuery; - var - Q: IBoldExecQuery; begin - q := PSParams.DataBase.GetExecQuery; - try - q.AssignSQLText(format( - 'INSERT INTO %s (%s) VALUES (0)', // do not localize - [TimeStampTable.SQLName, BoldExpandName(TIMESTAMPCOLUMN_NAME, '', xtSQL, SQLDatabaseConfig.MaxDbIdentifierLength, NationalCharConversion)] )); - q.ExecSQL; - finally - PSParams.DataBase.ReleaseExecQuery(q); - end; + Query.AssignSQLText(format( + 'INSERT INTO %s (%s) VALUES (0)', + [TimeStampTable.SQLName, BoldExpandName(TIMESTAMPCOLUMN_NAME, '', xtSQL, SQLDatabaseConfig.MaxDbIdentifierLength, NationalCharConversion)] )); + Query.ExecSQL; end; begin - BoldLog.Log(sLogWritingFirstTimeStamp); + BoldLog.Log('Writing First TimeStamp'); case EffectiveGenerationMode(PSParams) of dbgTable: AddFirstTimeStampUsingTable; dbgQuery: AddFirstTimeStampUsingQuery; - else raise EBold.CreateFmt(sUnknownGenerationMode, [ClassName, 'AddFirstTimeStamp']); // do not localize + else raise EBold.CreateFmt('%s.AddFirstTimeStamp: unknown database generation mode', [ClassName]); end; end; @@ -220,7 +214,7 @@ procedure TBoldDefaultSystemDescription.AddTableNames(PSParams: TBoldPSDefaultPa for i := 0 to SQLTablesList.Count - 1 do begin Append; - FieldValues['TABLENAME'] := SQLTablesList[i].SQLName; // do not localize + FieldValues['TABLENAME'] := SQLTablesList[i].SQLName; Post; end; Close; @@ -231,45 +225,58 @@ procedure TBoldDefaultSystemDescription.AddTableNames(PSParams: TBoldPSDefaultPa procedure AddTableNamesUsingQuery; var - Q: IBoldExecQuery; i: integer; + row, limit: integer; + sb: TStringBuilder; + TableCount: integer; + sInsert: string; begin - q := PSParams.DataBase.GetExecQuery; + sb := TStringBuilder.Create; try - q.AssignSQLText(format( - 'INSERT INTO %s (TABLENAME) VALUES (:TABLENAME)', // do not localize - [TableTable.SQLName] )); - for i := 0 to SQLTablesList.Count - 1 do + sInsert := format('INSERT INTO %s (TABLENAME) VALUES ', [TableTable.SQLName]); + limit := SQLDatabaseConfig.MultiRowInsertLimit; + row := 0; + for i := 0 to SQLTablesList.Count-1 do begin - q.ParamByName('TABLENAME').AsString := SQLTablesList[i].SQLName; // do not localize - q.ExecSQL; + if row = 0 then + sb.append(sInsert); + sb.Append(Format('(''%s'')', [SQLTablesList[i].SQLName])); + inc(row); + if (row = limit) or (i = SQLTablesList.Count - 1) then + begin + Query.AssignSQLText(sb.ToString); + Query.ExecSQL; + row := 0; + sb.clear; + end + else + sb.Append(','); end; finally - PSParams.DataBase.ReleaseExecQuery(q); + sb.free; end; end; begin - BoldLog.Log(sLogWritingTableNames); + BoldLog.Log('Writing TableNames'); case EffectiveGenerationMode(PSParams) of dbgTable: AddTableNamesUsingTable; dbgQuery: AddTableNamesUsingQuery; - else raise EBold.CreateFmt(sUnknownGenerationMode, [ClassName, 'AddTableNames']); // do not localize + else raise EBold.CreateFmt('%s.AddTableNames: unknown database generation mode', [ClassName]); end; end; procedure TBoldDefaultSystemDescription.CreatePersistentStorage(PSParams: TBoldPSParams); var PSParamsDefault: TBoldPSDefaultParams; -begin - inherited; - if BoldLog.ProcessInterruption then - exit; - BoldLog.LogHeader := sLogInitializingDefaultPS; - PSParamsDefault := PSParams as TBoldPSDefaultParams; - if EffectiveUseTransactions(PSParamsDefault) then - PSParamsDefault.Database.StartTransaction; - try + + procedure InternalExecute; + begin + Query := PSParamsDefault.Database.GetExecQuery; + Query.ParamCheck := false; + Query.StartSQLBatch; + if EffectiveUseTransactions(PSParamsDefault) then + PSParamsDefault.Database.StartTransaction; AddFirstID(PSParamsDefault); if assigned(TimeStampTable) then AddFirstTimeStamp(PSParamsDefault); @@ -277,60 +284,78 @@ procedure TBoldDefaultSystemDescription.CreatePersistentStorage(PSParams: TBoldP AddFirstClock(PSParamsDefault); AddTableNames(PSParamsDefault); BoldLog.Separator; + Query.EndSQLBatch; + end; + +begin + inherited; + if BoldLog.ProcessInterruption then + exit; + BoldLog.LogHeader := 'Initializing Default Persistent Storage'; + PSParamsDefault := PSParams as TBoldPSDefaultParams; + try + InternalExecute; finally + PSParamsDefault.Database.ReleaseExecQuery(Query); if EffectiveUseTransactions(PSParamsDefault) then begin BoldLog.Separator; - BoldLog.Log(sCommittingInitialData); + BoldLog.Log('Committing changes to initial data'); PSParamsDefault.Database.Commit; end; end; end; -procedure TBoldDefaultSystemDescription.GenerateDatabaseScript( - Script: TStrings; Separator: string); +procedure TBoldDefaultSystemDescription.GenerateDatabaseScript(Script: TStrings); begin inherited; - GenerateScriptForFirstID(Script, Separator); + GenerateScriptForFirstID(Script); if assigned(TimeStampTable) then - GenerateScriptForFirstTimeStamp(Script, Separator); + GenerateScriptForFirstTimeStamp(Script); if assigned(LastClockTable) then - GenerateScriptForFirstClock(Script, Separator); - GenerateScriptForTableNames(Script, Separator); + GenerateScriptForFirstClock(Script); + GenerateScriptForTableNames(Script); end; -procedure TBoldDefaultSystemDescription.GenerateScriptForFirstClock(Script: TStrings; Separator: String); +procedure TBoldDefaultSystemDescription.GenerateScriptForFirstClock(Script: TStrings); begin - Script.Add(Separator); Script.Add(format( - 'INSERT INTO %s (%s, %s) VALUES (0, %s)', // do not localize - [LastClockTable.SQLName, LASTTIMESTAMPCOLUMN_NAME, LASTCLOCKCOLUMN_NAME, DateToStr(0)] )); + 'INSERT INTO %s (%s, %s) VALUES (0, %s)%s', + [LastClockTable.SQLName, LASTTIMESTAMPCOLUMN_NAME, LASTCLOCKCOLUMN_NAME, QuotedStr(DateToStr(0)), + SQLDatabaseConfig.SqlScriptTerminator] )); + if SQLDatabaseConfig.SqlScriptSeparator<>'' then + Script.Add(SQLDatabaseConfig.SqlScriptSeparator); end; -procedure TBoldDefaultSystemDescription.GenerateScriptForFirstID(Script: TStrings; Separator: String); +procedure TBoldDefaultSystemDescription.GenerateScriptForFirstID(Script: TStrings); begin - Script.Add(Separator); - Script.Add(format('INSERT INTO %s (%s) VALUES (1)', [IDTable.SQLName, IDCOLUMN_NAME] )); // do not localize + Script.Add(format('INSERT INTO %s (%s) VALUES (1)%s', [IDTable.SQLName, IDCOLUMN_NAME, SQLDatabaseConfig.SqlScriptTerminator] )); + if SQLDatabaseConfig.SqlScriptSeparator<>'' then + Script.Add(SQLDatabaseConfig.SqlScriptSeparator); end; -procedure TBoldDefaultSystemDescription.GenerateScriptForFirstTimeStamp(Script: TStrings; Separator: String); +procedure TBoldDefaultSystemDescription.GenerateScriptForFirstTimeStamp(Script: TStrings); begin - Script.Add(Separator); Script.Add(format( - 'INSERT INTO %s (%s) VALUES (0)', // do not localize - [TimeStampTable.SQLName, BoldExpandName(TIMESTAMPCOLUMN_NAME, '', xtSQL, SQLDatabaseConfig.MaxDbIdentifierLength, NationalCharConversion)] )); + 'INSERT INTO %s (%s) VALUES (0)%s', + [TimeStampTable.SQLName, + BoldExpandName(TIMESTAMPCOLUMN_NAME, '', xtSQL, SQLDatabaseConfig.MaxDbIdentifierLength, NationalCharConversion), + SQLDatabaseConfig.SqlScriptTerminator] )); + if SQLDatabaseConfig.SqlScriptSeparator<>'' then + Script.Add(SQLDatabaseConfig.SqlScriptSeparator); end; -procedure TBoldDefaultSystemDescription.GenerateScriptForTableNames(Script: TStrings; Separator: String); +procedure TBoldDefaultSystemDescription.GenerateScriptForTableNames(Script: TStrings); var i: integer; begin for i := 0 to SQLTablesList.Count - 1 do begin - Script.Add(Separator); Script.Add(format( - 'INSERT INTO %s (TABLENAME) VALUES (''%s'')', // do not localize - [TableTable.SQLName, SQLTablesList[i].SQLName])); + 'INSERT INTO %s (TABLENAME) VALUES (''%s'')%s', + [TableTable.SQLName, SQLTablesList[i].SQLName, SQLDatabaseConfig.SqlScriptTerminator])); + if SQLDatabaseConfig.SqlScriptSeparator<>'' then + Script.Add(SQLDatabaseConfig.SqlScriptSeparator); end; end; @@ -339,15 +364,12 @@ procedure TBoldDefaultSystemDescription.InitializeKnownSystemtables( var Query: IBoldQuery; begin - // Reset The Query-pointer to avoid AVs at the end of method Query := nil; - // try to determine if the TablesTable exists... if PSParams.DataBase.TableExists(TableTable.SQLName) then begin - // Load the data from the table Query := PSParams.DataBase.GetQuery; try - Query.AssignSQLText(format('SELECT %s FROM %s', [TABLENAMECOLUMN_NAME, TableTable.SQLName])); // do not localize // do not localize + Query.AssignSQLText(format('SELECT %s FROM %s', [TABLENAMECOLUMN_NAME, TableTable.SQLName])); try Query.Open; while not Query.Eof do @@ -357,8 +379,7 @@ procedure TBoldDefaultSystemDescription.InitializeKnownSystemtables( end; Query.Close; except - // silence any exceptions (this happens if the table does not exist in the database, - // and the databaseinterfaces does not support IBoldTable + end; finally PSParams.DataBase.ReleaseQuery(Query); @@ -366,34 +387,42 @@ procedure TBoldDefaultSystemDescription.InitializeKnownSystemtables( end; end; -procedure TBoldDefaultSystemDescription.SetIdTable(const Value: TBoldSQLTableDescription); +procedure TBoldDefaultSystemDescription.SetIdTable( + const Value: TBoldSQLTableDescription); begin FIdTable := Value; end; -procedure TBoldDefaultSystemDescription.SetRootTable(const Value: TBoldSQLTableDescription); +procedure TBoldDefaultSystemDescription.SetRootTable( + const Value: TBoldSQLTableDescription); begin fRootTable := Value; end; -procedure TBoldDefaultSystemDescription.SetTabletable(const Value: TBoldSQLTableDescription); +procedure TBoldDefaultSystemDescription.SetTabletable( + const Value: TBoldSQLTableDescription); begin FTabletable := Value; end; -procedure TBoldDefaultSystemDescription.SetTimeStamptable(const Value: TBoldSQLTableDescription); +procedure TBoldDefaultSystemDescription.SetTimeStamptable( + const Value: TBoldSQLTableDescription); begin FTimeStamptable := Value; end; -procedure TBoldDefaultSystemDescription.SetTypeTable(const Value: TBoldSQLTableDescription); +procedure TBoldDefaultSystemDescription.SetTypeTable( + const Value: TBoldSQLTableDescription); begin FTypeTable := Value; end; -procedure TBoldDefaultSystemDescription.SetXFilestable(const Value: TBoldSQLTableDescription); +procedure TBoldDefaultSystemDescription.SetXFilestable( + const Value: TBoldSQLTableDescription); begin FXFilestable := Value; end; +initialization + end. diff --git a/Source/PMapper/Default/BoldPSParamsDefault.pas b/Source/PMapper/Default/BoldPSParamsDefault.pas index bc820df0..8be8ee3f 100644 --- a/Source/PMapper/Default/BoldPSParamsDefault.pas +++ b/Source/PMapper/Default/BoldPSParamsDefault.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPSParamsDefault; interface @@ -12,4 +15,8 @@ TBoldPSDefaultParams = class(TBoldPSSQLParams) implementation + + +initialization + end. diff --git a/Source/PMapper/SQL/BoldPMappersSQL.pas b/Source/PMapper/SQL/BoldPMappersSQL.pas index b0548586..00043dff 100644 --- a/Source/PMapper/SQL/BoldPMappersSQL.pas +++ b/Source/PMapper/SQL/BoldPMappersSQL.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPMappersSQL; interface @@ -13,10 +16,12 @@ interface BoldId, BoldSQLMappingInfo, BoldSQLDatabaseConfig, + BoldIndexCollection, BoldValueSpaceInterfaces, BoldTypeNameDictionary, BoldPSDescriptionsSQL, - BoldTaggedValueSupport; + BoldTaggedValueSupport, + BoldElements; type { forward declarations } @@ -24,12 +29,15 @@ TBoldSystemSQLMapper = class; TBoldObjectSQLMapper = class; TBoldMemberSQLMapper = class; TBoldPreInitializeBoldDbType = procedure(SystemSQLMapper: TBoldSystemSQLMapper) of Object; + TBoldOnPsEvaluate = procedure(const ABoldQuery: IBoldQuery) of Object; EBoldDbTypeMissing = class(EBold); {---Enumerations---} TBoldDBStorageMode = (dsmUpdate, dsmCreate); + + {---TBoldSystemSQLMapper---} TBoldSystemSQLMapper = class(TBoldSystemPersistenceMapper) private @@ -38,42 +46,59 @@ TBoldSystemSQLMapper = class(TBoldSystemPersistenceMapper) fMappingInfo: TBoldSQLMappingInfo; fNationalCharConversion: TBoldNationalCharConversion; fSQLDataBaseConfig: TBoldSQLDataBaseConfig; + fCustomIndexes: TBoldIndexCollection; fOnGetDatabase: TBoldGetDatabaseEvent; + fMaxDbType: integer; + fExecQuery: IBoldExecQuery; + fOnPsEvaluate: TBoldOnPsEvaluate; + fTopSortedIndexForBoldDbType: array of integer; // JNo, optimization function GetIBoldDataBase: IBoldDataBase; function GetAllTables: TBoldSQLTableDescriptionList; function GetPSSystemDescription: TBoldSQLSystemDescription; - function GetRootClassObjectPersistenceMapper: TBoldObjectSQLMapper; - function GetMappingInfo: TBoldSQLMappingInfo; + function GetRootClassObjectPersistenceMapper: TBoldObjectSQLMapper; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetMappingInfo: TBoldSQLMappingInfo; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure InitializeTopSortedIndexForBoldDbType; protected procedure InitializeBoldDbType; virtual; abstract; procedure FillPSParams(PSParams: TBoldPSParams); override; function CreatePSParams: TBoldPSParams; override; - procedure StartTransaction(ValueSpace: IBoldValueSpace); override; - procedure Commit(ValueSpace: IBoldValueSpace); override; - procedure RollBack(ValueSpace: IBoldValueSpace); override; + procedure StartTransaction(const ValueSpace: IBoldValueSpace); override; + procedure Commit(const ValueSpace: IBoldValueSpace); override; + procedure RollBack(const ValueSpace: IBoldValueSpace); override; function CreateMappingInfo: TBoldSQLMappingInfo; virtual; abstract; + procedure AddCustomIndexes; public - constructor CreateFromMold(MoldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; SQLDatabaseConfig: TBoldSQLDatabaseConfig; GetDatabaseFunc: TBoldGetDatabaseEvent); + constructor CreateFromMold(MoldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; + CustomIndexes: TBoldIndexCollection; SQLDatabaseConfig: TBoldSQLDatabaseConfig; GetDatabaseFunc: TBoldGetDatabaseEvent); destructor Destroy; override; procedure PMFetch(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; + const ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; TranslationList: TBoldIdTranslationList); override; function BoldDbTypeForTopSortedIndex(TopSortedIndex: Integer): TBoldDbType; procedure CloseDataBase; procedure CreatePersistentStorage; override; - procedure GenerateDatabaseScript(Script: TStrings; Separator: string); virtual; + procedure GenerateDatabaseScript(Script: TStrings); virtual; function EnsureTable(const TableName: string; TableVersioned: Boolean): TBoldSQLTableDescription; virtual; abstract; + function EnsureColumn(const TableName, ColumnName, SQLType, + SQLAllowNull: string; const BDEType: TFieldType; Length: Integer; + const AllowNull, InVersionedTable: Boolean; + const DefaultDBValue: String): TBoldSQLColumnDescription; + procedure EnsureIndex(const TableName, Fields: string; const PrimaryIndex, + Unique, InVersionedTable: Boolean); function GetQuery: IBoldQuery; function GetExecQuery: IBoldExecQuery; + procedure StartSQLBatch; override; + procedure EndSQLBatch; override; + procedure FailSQLBatch; override; procedure InvokeMemberMappersInitializeSystem; virtual; procedure OpenDatabase(ReadDbTypeFromDB: Boolean; ReadMappingFromDB: Boolean); procedure ReleaseQuery(var aQuery: IBoldQuery); procedure ReleaseExecQuery(var aQuery: IBoldExecQuery); function TopSortedIndexForBoldDbType(BoldDbType: TBoldDbType): Integer; + function CanEvaluateInPS(sOCL: string; aSystem: TBoldElement; aContext: TBoldElementTypeInfo = nil; const aVariableList: TBoldExternalVariableList = nil): Boolean; virtual; abstract; property AllTables: TBoldSQLTableDescriptionList read GetAllTables; -// property Connected: Boolean read GetConnected; property Database: IBoldDataBase read GetIBoldDataBase; property OnPreInitializeBoldDbType: TBoldPreInitializeBoldDbType read fOnPreInitializeBoldDbType write fOnPreInitializeBoldDbType; property PSSystemDescription: TBoldSQLSystemDescription read GetPSSystemDescription; @@ -81,12 +106,13 @@ TBoldSystemSQLMapper = class(TBoldSystemPersistenceMapper) property MappingInfo: TBoldSQLMappingInfo read GetMappingInfo; property NationalCharConversion: TBoldNationalCharConversion read fNationalCharConversion; property SQLDataBaseConfig: TBoldSQLDataBaseConfig read fSQLDataBaseConfig; + property OnPsEvaluate: TBoldOnPsEvaluate read fOnPsEvaluate write fOnPsEvaluate; end; {---TBoldObjectSQLMapper---} TBoldObjectSQLMapper = class(TBoldObjectPersistenceMapper) private - fBoldDbType: TBoldDbType; // FIXME move down + fBoldDbType: TBoldDbType; fAllTables: TBoldSQLTableDescriptionList; fMainTable: TBoldSQLTableDescription; function GetSystemPersistenceMapper: TBoldSystemSQLMapper; @@ -104,15 +130,16 @@ TBoldObjectSQLMapper = class(TBoldObjectPersistenceMapper) public constructor CreateFromMold(MoldClass: TMoldClass; Owner: TBoldSystemPersistenceMapper; TypeNameDictionary: TBoldTypeNameDictionary); override; destructor Destroy; override; - procedure GenerateDatabaseScript(Script: TStrings; Separator: string); virtual; + procedure GenerateDatabaseScript(Script: TStrings); virtual; function UpdatesMembersInTable(aTable: TBoldSQLTableDescription): Boolean; virtual; abstract; property AllTables: TBoldSQLtableDescriptionList read GetAllTables; property MainTable: TBoldSQLTableDescription read fmainTable; procedure RetrieveSelectStatement(s: TStrings; MemberMapperList: TBoldMemberPersistenceMapperList; FetchMode: Integer; ForceRootTable: Boolean); virtual; procedure RetrieveTimeStampCondition(SQL: TStrings; TimeStamp: TBoldTimeStampType; UseAlias: Boolean; WhereToken: string; UseOwnTableForStartTime: Boolean; SuggestedStartTimeAlias: string = ''; SuggestedEndTimeAlias: string = ''); property BoldDbType: TBoldDbType read fBoldDbType write fBoldDbType; - procedure ValuesFromFieldsByMemberList(ObjectId: TBoldObjectId; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; DataSet: IBoldDataSet; MemberList: TBoldMemberPersistenceMapperList); - procedure ValuesToParamsByMemberList(ObjectId: TBoldObjectId; ValueSpace: IBoldValueSpace; Query: IBoldExecQuery; memberList: TBoldMemberPersistenceMapperList; TranslationList: TBoldIdTranslationList; DBStorageMode: TBoldDBStorageMode); + procedure ValuesFromFieldsByMemberList(ObjectId: TBoldObjectId; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const DataSet: IBoldDataSet; MemberList: TBoldMemberPersistenceMapperList); + procedure ValuesToParamsByMemberList(ObjectId: TBoldObjectId; const ValueSpace: IBoldValueSpace; const Query: IBoldExecQuery; memberList: TBoldMemberPersistenceMapperList; TranslationList: TBoldIdTranslationList; DBStorageMode: TBoldDBStorageMode); + procedure ValuesToQueryByMemberList(ObjectId: TBoldObjectId; const ValueSpace: IBoldValueSpace; const Query: IBoldExecQuery; SQL: TStrings; memberList: TBoldMemberPersistenceMapperList; TranslationList: TBoldIdTranslationList; DBStorageMode: TBoldDBStorageMode); property SystemPersistenceMapper: TBoldSystemSQLMapper read GetSystemPersistenceMapper; end; @@ -135,25 +162,25 @@ TBoldMemberSQLMapper = class(TBoldMemberPersistenceMapper) function DefaultDefaultDbValue: String; virtual; property InitialColumnRootName: string read fInitialColumnRootName; function GetRequiresLiveQuery: Boolean; virtual; - procedure SetParamToNullWithDataType(aParam: IBoldParameter; FieldType: TFieldType); + procedure SetParamToNullWithDataType(const aParam: IBoldParameter; FieldType: TFieldType); function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; virtual; property InitialColumnName[Columnindex: integer]: string read GetInitialColumnName; public constructor CreateFromMold(Moldmember: TMoldMember; MoldClass: TMoldClass; Owner: TBoldObjectPersistenceMapper; const MemberIndex: Integer; TypeNameDictionary: TBoldTypeNameDictionary); override; destructor Destroy; override; - procedure GenerateDatabaseScript(Script: TStrings; Separator: string); virtual; + procedure GenerateDatabaseScript(Script: TStrings); virtual; property ColumnDescriptions: TBoldSQLDescriptionList read GetColumnDescriptions; property AllowNullAsSQL: string read GetAllowNullAsSQL; property ColumnCount: integer read GetColumnCount; property ColumnTypeAsSQL[Columnindex: integer]: string read GetColumnTypeAsSQL; property ColumnSize[Columnindex: integer]: integer read GetColumnSize; property AllowNull: Boolean read fAllowNull; -// procedure ValueToParam(Value: IBoldValue; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); virtual; - procedure ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); virtual; - procedure ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); virtual; - procedure ValueToQuery(ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; Query: IBoldExecQuery; TranslationList: TBoldIdtranslationlist; DBStorageMode: TBoldDBStorageMode); - procedure ValueFromQuery(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; DataSet: IBoldDataSet); virtual; - procedure InitializeSystem(theDatabase: IBoldDataBase); virtual; + function ValueAsVariant(const ObjectContent: IBoldObjectContents; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; virtual; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); virtual; + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); virtual; + procedure ValueToQuery(const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; const Query: IBoldExecQuery; TranslationList: TBoldIdtranslationlist; DBStorageMode: TBoldDBStorageMode); + procedure ValueFromQuery(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const DataSet: IBoldDataSet); + procedure InitializeSystem(const theDatabase: IBoldDataBase); virtual; property ColumnBDEFieldType[Columnindex: integer]: TFieldType read GetColumnBDEFieldType; property RequiresLiveQuery: Boolean read GetRequiresLiveQuery; property SystemPersistenceMapper: TBoldSystemSQLMapper read GetSystemPersistenceMapper; @@ -167,9 +194,17 @@ implementation BoldUtils, BoldPSParamsSQL, BoldNameExpander, + BoldValueInterfaces, + BoldDefaultStreamNames, + Variants, SysUtils, - BoldPMConsts; - + {$IFDEF RIL} + {$IFNDEF BOLD_UNICODE} + StringBuilder, + {$ENDIF} + {$ENDIF} + BoldRev; + {---TBoldSystemSQLMapper---} function TBoldSystemSQLMapper.GetAllTables: TBoldSQLTableDescriptionList; begin @@ -181,13 +216,18 @@ function TBoldSystemSQLMapper.GetPSSystemDescription: TBoldSQLSystemDescription; result := (inherited PSSystemDescription) as TBoldSQLSystemDescription; end; -constructor TBoldSystemSQLMapper.CreateFromMold(MoldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; SQlDatabaseConfig: TBoldSQLDatabaseConfig; GetDatabaseFunc: TBoldGetDatabaseEvent); +constructor TBoldSystemSQLMapper.CreateFromMold(MoldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; + CustomIndexes: TBoldIndexCollection; SQlDatabaseConfig: TBoldSQLDatabaseConfig; GetDatabaseFunc: TBoldGetDatabaseEvent); begin fNationalCharConversion := MoldModel.NationalCharConversion; - fSQLDataBaseConfig := TBoldSQLDataBaseConfig.Create; - fSQLDataBaseConfig.AssignConfig(SQLDatabaseConfig); + fSQLDataBaseConfig := SQlDatabaseConfig; + fCustomIndexes := TBoldIndexCollection.Create(nil); + if Assigned(CustomIndexes) then + fCustomIndexes.Assign(CustomIndexes); fOnGetDatabase := GetDatabaseFunc; - inherited createFromMold(MoldModel, TypeNameDictionary); + fMaxDbType := -1; + inherited CreateFromMold(MoldModel, TypeNameDictionary, SQlDatabaseConfig.DefaultObjectMapper); + AddCustomIndexes; end; procedure TBoldSystemSQLMapper.FillPSParams(PSParams: TBoldPSParams); @@ -211,17 +251,51 @@ procedure TBoldSystemSQLMapper.ReleaseQuery(var aQuery: IBoldQuery); Database.ReleaseQuery(aQuery); end; +function TBoldSystemSQLMapper.GetExecQuery: IBoldExecQuery; +begin + if not Assigned(fExecQuery) then + begin + fExecQuery := Database.GetExecQuery; + end; + result := fExecQuery; +end; + +procedure TBoldSystemSQLMapper.ReleaseExecQuery(var aQuery: IBoldExecQuery); +begin + if fExecQuery <> aQuery then + Database.ReleaseExecQuery(aQuery); +end; + function TBoldSystemSQLMapper.GetIBoldDataBase: IBoldDataBase; begin if not assigned(fOnGetDatabase) then raise EBoldInternal.CreateFmt('%s: No event that provides an IBoldDatabase', [classname]); result := fOnGetDatabase; if not assigned(result) then - raise EBold.CreateFmt(sNoDatabase, [classname]); + raise EBold.CreateFmt('%s: No database', [classname]); end; -procedure TBoldSystemSQLMapper.StartTransaction(ValueSpace: IBoldValueSpace); +procedure TBoldSystemSQLMapper.StartSQLBatch; begin + GetExecQuery.StartSQLBatch; +end; + +procedure TBoldSystemSQLMapper.EndSQLBatch; +begin + GetExecQuery.EndSQLBatch; +end; + +procedure TBoldSystemSQLMapper.FailSQLBatch; +begin + GetExecQuery.FailSQLBatch; +end; + +procedure TBoldSystemSQLMapper.StartTransaction(const ValueSpace: IBoldValueSpace); +begin +{$IFDEF BOLD_LITE} + if Database.InTransaction then + raise EBold.Create('Transactions not supported in Bold Lite'); +{$ELSE} with Database do if IsSqlBased and (not InTransaction) then begin @@ -230,36 +304,83 @@ procedure TBoldSystemSQLMapper.StartTransaction(ValueSpace: IBoldValueSpace); end else fTransactionStartedByMe := false; +{$ENDIF} end; -procedure TBoldSystemSQLMapper.Commit(ValueSpace: IBoldValueSpace); +procedure TBoldSystemSQLMapper.Commit(const ValueSpace: IBoldValueSpace); begin +{$IFDEF BOLD_LITE} + if Database.InTransaction then + raise EBold.Create('Transactions not supported in Bold Lite'); +{$ELSE} if fTransactionStartedByMe then with Database do if IsSqlBased and InTransaction then Commit; fTransactionStartedByMe := false; +{$ENDIF} end; -procedure TBoldSystemSQLMapper.RollBack(ValueSpace: IBoldValueSpace); +procedure TBoldSystemSQLMapper.RollBack(const ValueSpace: IBoldValueSpace); begin +{$IFDEF BOLD_LITE} + if Database.InTransaction then + raise EBold.Create('Transactions not supported in Bold Lite'); +{$ELSE} if fTransactionStartedByMe then with Database do if IsSqlBased and InTransaction then RollBack; fTransactionStartedByMe := false; +{$ENDIF} +end; + +function TBoldSystemSQLMapper.EnsureColumn(const TableName, ColumnName, SQLType, SQLAllowNull: string; + const BDEType: TFieldType; Length: Integer; + const AllowNull, InVersionedTable: Boolean; + const DefaultDBValue: String): TBoldSQLColumnDescription; +var + Table: TBoldSQLTableDescription; +begin + EnsureTable(TableName, InversionedTable); + Table := PSSystemDescription.SQLTablesList.ItemsBySQLName[TableName]; + Result := Table.ColumnsList.ItemsBySQLName[ColumnName] as TBoldSQLColumnDescription; + if not assigned(Result) then + Result := Table.AddColumn(ColumnName, SQLType, SQLAllowNull, BDEType, Length, AllowNull, DefaultDbValue) + else + begin + Result.Size := Length; + Result.Mandatory := not AllowNull; + Result.SQLType := SQLType; + Result.FieldType := BDEType; + Result.SQLAllowNull := SQLAllowNull; + result.DefaultDBValue := DefaultDBValue; + end; +end; + +procedure TBoldSystemSQLMapper.EnsureIndex(const TableName, Fields: string; const PrimaryIndex, Unique, InVersionedTable: Boolean); +var + Table: TBoldSQLTableDescription; +begin + EnsureTable(TableName, InVersionedTable); + Table := PSSystemDescription.SQLTablesList.ItemsBySQLName[TableName]; + Table.EnsureIndex(Fields, PrimaryIndex, Unique, false); end; procedure TBoldSystemSQLMapper.OpenDatabase(ReadDbTypeFromDB: Boolean; ReadMappingFromDB: Boolean); begin try Database.OPEN; + if not Database.Connected then + raise EBold.CreateFmt('%s.OpenDatabase: Failed to connect to database', [classname]); + MappingInfo.ReadDataFromDB(DataBase, ReadDbTypeFromDB, ReadMappingFromDB); if assigned(OnPreInitializeBoldDbType) then OnPreInitializeBoldDbType(self); // used for DBStructureValidator InitializeBoldDbType; + InitializeTopSortedIndexForBoldDbType; EnsurePSDescription; except DataBase.Close; @@ -333,7 +454,7 @@ function TBoldObjectSQLMapper.TableAlias(Table: TBoldSQLTableDescription; useAli if useAlias then begin if Table = DistributableTable then - result := 'X_FILES' // do not localize + result := 'X_FILES' else begin i := AllTables.Indexof(Table) + 1; @@ -349,6 +470,85 @@ function TBoldObjectSQLMapper.TableAlias(Table: TBoldSQLTableDescription; useAli end; procedure TBoldObjectSQLMapper.SQLForMembers(Table: TBoldSQLTableDescription; SQL: TStrings; const MemberList: TBoldMemberPersistenceMapperList; const SQLStyle: TBoldSQLStyle; const IncludeKey: Boolean; const StoredInObjectOnly, UseAlias: Boolean); +{$IFDEF RIL} +var + SB: TStringBuilder; + c, m: integer; + Column: TBoldSQLColumnDescription; + MemberMapper: TBoldMemberSQLMapper; +begin + if IncludeKey and (SQLStyle in [ssColumns, ssParameters]) then + begin + if assigned(Table) then + SQLForKey(Table, SQL, SQLStyle, UseAlias) + else + SQLForKey(MainTable, SQL, SQLStyle, UseAlias) + end; + +{ + if ScanRF(sMembersSQL,#13#10,0)= SLen-1 then //has ctrlf at end of str + SLen := SLen-2; //=removes ctrlf +} + if MemberList.Count = 0 then + exit; + SB := TStringBuilder.Create(SQL.Text); + try + for m := 0 to MemberList.Count - 1 do + begin + MemberMapper := MemberList[m] as TBoldMemberSQLMapper; + if Assigned(MemberMapper) and + (not StoredInObjectOnly or MemberMapper.IsStoredInObject) then + begin + for c := 0 to MemberMapper.ColumnDescriptions.Count - 1 do + begin + Column := MemberMapper.ColumnDescriptions[c] as TBoldSQLColumnDescription; + if not Assigned(Table) or (Column.TableDescription = table) then + begin + if Assigned(Table) then + begin + if SB.Length>0 then + SB.Append(#13#10); {= "append"} + case SQLStyle of + ssColumns : begin + SB.Append(Column.SQLName); + end; + ssParameters: begin + SB.Append(':'); + SB.Append(Column.SQLName); + end; + ssValues : begin + SB.Append(Format('%s = :%0:s', [Column.SQLName])); + end; + else + raise EBold.Create('unimplememnted'); + end + end + else + begin + if SB.Length>0 then + SB.Append(#13#10); {= "append"} + case SQLStyle of + ssColumns: begin + // SQL.Append(Format('%s.%s', [TableAlias(Column.TableDescription, useAlias), Column.SQLName])) + SB.Append(TableAlias(Column.TableDescription, useAlias)); + SB.Append('.'); + SB.Append(Column.SQLName); + end; + else + raise EBold.Create('unimplememnted'); + end; + end; + end; + end; + end; + end; + finally + SB.Replace(#13#10#13#10, #13#10); + SQL.Text := SB.ToString; + FreeAndNil(SB); + end; +end; +{$ELSE} var c, m: integer; @@ -373,22 +573,24 @@ procedure TBoldObjectSQLMapper.SQLForMembers(Table: TBoldSQLTableDescription; SQ if assigned(Table) then case SQLStyle of ssColumns: SQL.Append(Column.SQLName); - ssParameters: SQL.Append(Format(':%s', [Column.SQLName])); // do not localize - ssValues: SQL.Append(Format('%s = :%0:s', [Column.SQLName])); // do not localize + ssParameters: SQL.Append(Format(':%s', [Column.SQLName])); + ssValues: SQL.Append(Format('%s = :%0:s', [Column.SQLName])); else - raise EBold.Create(sUnimplemented); + raise EBold.Create('unimplememnted'); end else case SQLStyle of - ssColumns: SQL.Append(Format('%s.%s', [TableAlias(Column.TableDescription, useAlias), Column.SQLName])) // do not localize + ssColumns: SQL.Append(Format('%s.%s', [TableAlias(Column.TableDescription, useAlias), Column.SQLName])) else - raise EBold.Create(sUnimplemented); + raise EBold.Create('unimplememnted'); end; end; end; end; +{$ENDIF} procedure TBoldObjectSQLMapper.RetrieveSelectStatement(s: TStrings; MemberMapperList: TBoldMemberPersistenceMapperList; FetchMode: Integer; ForceRootTable: Boolean); +{$IFDEF RIL} var T: Integer; SelectList: TStringList; @@ -400,15 +602,136 @@ procedure TBoldObjectSQLMapper.RetrieveSelectStatement(s: TStrings; MemberMapper TableList: TBoldSQLtableDescriptionList; Table: TBoldSQLtableDescription; Mapper: TBoldMemberSQLMapper; + SB: TStringBuilder; begin SelectList := TStringList.Create; FromList := TStringList.Create; WhereList := TStringList.Create; - JoinLIst := TStringList.Create; + JoinList := TStringList.Create; TableList := TBoldSQLtableDescriptionList.Create(SystemPersistenceMapper.PSSystemDescription); tableList.OwnsEntries := false; + SB := TStringBuilder.Create; + try + + if ForceRootTable then + TableList.Add(SystemPersistenceMapper.RootClassObjectPersistenceMapper.MainTable); + + for MapperIx := 0 to MemberMapperList.count - 1 do + begin + Mapper := MemberMapperList[MapperIx] as TBoldMemberSQLMapper; + for ColumnIx := 0 to Mapper.ColumnDescriptions.Count - 1 do + begin + Table := (Mapper.ColumnDescriptions[ColumnIx] as TBoldSQLColumnDescription).TableDescription; + if TableList.IndexOf(Table) = -1 then + TableList.Add(Table); + end; + end; + + SQLForMembers(nil, SelectList, MemberMapperList, ssColumns, true, false, true); + //FromList.Append(Format('%s %s', [MainTable.SQLName, TableAlias(MainTable, true)])); + SB.Clear; + SB.Append(MainTable.SQLName); + SB.Append(' '); + SB.Append(TableAlias(MainTable, true)); + FromList.Append(SB.ToString); + + if (FetchMode = fmNormal) and SystemPersistenceMapper.SQLDataBaseConfig.UseSQL92Joins then + begin + { cheapest check first } + for T := 0 to TableList.COunt-1 do + if (TableList[T]<>MainTable) and (TableList[T].ColumnsList.Count>2) then + begin + //Join := format('left join %s %s on ', [TableList[T].SQLName, TableAlias(TableList[T], true)]); + SB.Clear; + SB.Append('left join '); + SB.Append(TableList[T].SQLName); + SB.Append(' '); + SB.Append(TableAlias(TableList[T], true)); + SB.Append(' on '); + + JoinList.Clear; + JoinSQLTableByKey(JoinList, MainTable, TableList[T]); + + //Join := Join + BoldSeparateStringList(JoinList, ' and ', '(', ')'); + SB.Append(BoldSeparateStringList(JoinList, ' and ', '(', ')')); + Join := SB.ToString; + FromList.Append(Join); + end; + end + else + begin + for T := 0 to TableList.Count - 1 do + if (TableList[T] <> MainTable) and (TableList[T].ColumnsList.Count > 2) then + begin + //FromList.Append(Format('%s %s',[TableList[T].SQLName, TableAlias(TableList[t], true)])); + SB.Clear; + SB.Append(TableList[T].SQLName); + SB.Append(' '); + SB.Append(TableAlias(TableList[t], true)); + FromList.Append(SB.ToString); + end; + + for T := 0 to TableList.Count-1 do + begin + {ril} // cheapest check first + if (TableList[T]<>MainTable) and (TableList[T].ColumnsList.Count > 2) then + JoinSQLTableByKey(WhereList, MainTable, TableList[T]); + end; + +{ if FetchMode = fmDistributable then + begin + SQLForDistributed(SelectList, ssColumns); + FromList.Append(Format('%s %s', [DistributableTable.SQLName, + TableAlias(DistributableTable, true)])); + JoinSQLTableByKey(WhereList, MainTable, DistributableTable); + end;} + end; + + SQLForID(Maintable, WhereList, True); + + {ril} {'SELECT %s ':} + BoldAppendToStrings(S, 'SELECT '+BoldSeparateStringList(SelectList, ', ', '', '')+' ', true); + if SystemPersistenceMapper.SQLDataBaseConfig.UseSQL92Joins and (FetchMode = fmNormal) then + {ril} {'FROM %s ':} + BoldAppendToStrings(S, 'FROM '+BoldSeparateStringList(FromList, ' ', '', '')+' ', true) + else + {ril} {'FROM %s ':} + BoldAppendToStrings(S, 'FROM '+BoldSeparateStringList(FromList, ', ', '', '')+' ', true); + + {ril} {'WHERE %s ':} + BoldAppendToStrings(S, 'WHERE '+BoldSeparateStringList(WhereList, ' AND ', '', '')+' ', true); + finally + SelectList.Free; + FromList.Free; + WhereList.Free; + JoinList.Free; + TableList.Free; + FreeAndNil(SB); + end; +end; +{$ELSE} +var + T: Integer; + SelectList: TStringList; + FromList: TStringList; + WhereList: TStringList; + JoinList: TStringList; + Join: String; + MapperIx, ColumnIx: integer; + TableList: TBoldSQLtableDescriptionList; + Table: TBoldSQLtableDescription; + Mapper: TBoldMemberSQLMapper; + +begin + SelectList := TStringList.Create; + FromList := TStringList.Create; + WhereList := TStringList.Create; + JoinLIst := TStringList.Create; + TableList := TBoldSQLtableDescriptionList.Create(SystemPersistenceMapper.PSSystemDescription); + tableList.OwnsEntries := false; try + if ForceRootTable then TableList.Add(SystemPersistenceMapper.RootClassObjectPersistenceMapper.MainTable); @@ -425,17 +748,16 @@ procedure TBoldObjectSQLMapper.RetrieveSelectStatement(s: TStrings; MemberMapper SQLForMembers(nil, SelectList, MemberMapperList, ssColumns, true, false, true); - FromList.Append(Format('%s %s', [MainTable.SQLName, TableAlias(MainTable, true)])); // do not localize + FromList.Append(Format('%s %s', [MainTable.SQLName, TableAlias(MainTable, true)])); if SystemPersistenceMapper.SQLDataBaseConfig.UseSQL92Joins and (FetchMode = fmNormal) then begin - // left join rateable x on Song.Bold_ID=rateable.Bold_id for T := 0 to TableList.COunt - 1 do if (TableList[T].ColumnsList.Count > 2) and (TableList[T] <> MainTable) then begin - Join := format('left join %s %s on ', [TableList[T].SQLName, TableAlias(TableList[T], true)]); // do not localize + Join := format('left join %s %s on ', [TableList[T].SQLName, TableAlias(TableList[T], true)]); JoinList.Clear; JoinSQLTableByKey(JoinList, MainTable, TableList[T]); - Join := Join + BoldSeparateStringList(JoinList, ' and ', '(', ')'); // do not localize + Join := Join + BoldSeparateStringList(JoinList, ' and ', '(', ')'); FromList.Add(Join); end; end @@ -443,7 +765,7 @@ procedure TBoldObjectSQLMapper.RetrieveSelectStatement(s: TStrings; MemberMapper begin for T := 0 to TableList.Count - 1 do if (TableList[T].ColumnsList.Count > 2) and (TableList[T] <> MainTable) then - FromList.Append(Format('%s %s',[TableList[T].SQLName, TableAlias(TableList[t], true)])); // do not localize + FromList.Append(Format('%s %s',[TableList[T].SQLName, TableAlias(TableList[t], true)])); for T := 0 to TableList.Count - 1 do begin @@ -462,14 +784,14 @@ procedure TBoldObjectSQLMapper.RetrieveSelectStatement(s: TStrings; MemberMapper SQLForID(Maintable, WhereList, True); - BoldAppendToStrings(S, Format('SELECT %s ', [BoldSeparateStringList(SelectList, ', ', '', '')]), true); // do not localize + BoldAppendToStrings(S, Format('SELECT %s ', [BoldSeparateStringList(SelectList, ', ', '', '')]), true); if SystemPersistenceMapper.SQLDataBaseConfig.UseSQL92Joins and (FetchMode = fmNormal) then - BoldAppendToStrings(S, Format('FROM %s ', [BoldSeparateStringList(FromList, ' ', '', '')]), true) // do not localize + BoldAppendToStrings(S, Format('FROM %s ', [BoldSeparateStringList(FromList, ' ', '', '')]), true) else - BoldAppendToStrings(S, Format('FROM %s ', [BoldSeparateStringList(FromList, ', ', '', '')]), true); // do not localize + BoldAppendToStrings(S, Format('FROM %s ', [BoldSeparateStringList(FromList, ', ', '', '')]), true); - BoldAppendToStrings(S, Format('WHERE %s ', [BoldSeparateStringList(WhereList, ' AND ', '', '')]), true); // do not localize + BoldAppendToStrings(S, Format('WHERE %s ', [BoldSeparateStringList(WhereList, ' AND ', '', '')]), true); finally SelectList.Free; FromList.Free; @@ -478,23 +800,110 @@ procedure TBoldObjectSQLMapper.RetrieveSelectStatement(s: TStrings; MemberMapper TableList.Free; end; end; +{$ENDIF} + -procedure TBoldObjectSQLMapper.ValuesFromFieldsByMemberList(ObjectID: TBoldObjectId; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; DataSet: IBoldDataSet; memberList: TBoldMemberPersistenceMapperList); +procedure TBoldObjectSQLMapper.ValuesFromFieldsByMemberList(ObjectID: TBoldObjectId; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const DataSet: IBoldDataSet; memberList: TBoldMemberPersistenceMapperList); var - i: integer; + i,FieldIndex: integer; + aField : IBoldField; ObjectContents: IBoldObjectContents; + MemberMapper: TBoldMemberSQLMapper; + ColumnIndex: Integer; begin ObjectContents := ValueSpace.EnsuredObjectContentsByObjectId[ObjectID]; + FieldIndex := 2; // skip id and type for i:= 0 to memberlist.count - 1 do - TBoldMemberSQLMapper(Memberlist[i]).ValueFromQuery(ObjectId, ObjectContents, ValueSpace, TranslationList, DataSet); + begin + MemberMapper := TBoldMemberSQLMapper(Memberlist[i]); + if MemberMapper.ShouldFetch(ObjectContents) then + for ColumnIndex := 0 to MemberMapper.ColumnCount - 1 do + begin + aField := nil; + if FieldIndex < DataSet.FieldCount then + begin + aField := DataSet.Fields[FieldIndex]; + if not SameText(aField.FieldName, MemberMapper.ColumnDescriptions[ColumnIndex].SQLName) then + aField := nil; + end; + if not Assigned(aField) then + begin + aField := DataSet.FieldByUpperCaseName(MemberMapper.ColumnDescriptions[ColumnIndex].SQLNameUpper); + FieldIndex := aField.Field.Index; + end; + MemberMapper.ValueFromField(ObjectId, ObjectContents, ValueSpace, TranslationList, aField, ColumnIndex); + inc(FieldIndex); + end; + end; end; -procedure TBoldObjectSQLMapper.ValuesToParamsByMemberList(ObjectID: TBoldObjectId; ValueSpace: IBoldValueSpace; Query: IBoldExecQuery; memberList: TBoldMemberPersistenceMapperList; TranslationList: TBoldIdTranslationList; DBStorageMode: TBoldDBStorageMode); +procedure TBoldObjectSQLMapper.ValuesToParamsByMemberList(ObjectId: TBoldObjectId; const ValueSpace: IBoldValueSpace; const Query: IBoldExecQuery; memberList: TBoldMemberPersistenceMapperList; TranslationList: TBoldIdTranslationList; DBStorageMode: TBoldDBStorageMode); var i: integer; + ObjectContents: IBoldObjectContents; begin + ObjectContents := ValueSpace.EnsuredObjectContentsByObjectId[ObjectID]; for i := 0 to memberlist.count - 1 do - TBoldMemberSQLMapper(Memberlist[i]).ValueToQuery(ValueSpace.ObjectContentsByObjectId[ObjectID], ValueSpace, Query, translationList, DBStorageMode); + TBoldMemberSQLMapper(Memberlist[i]).ValueToQuery(ObjectContents, ValueSpace, Query, translationList, DBStorageMode); +end; + +procedure TBoldObjectSQLMapper.ValuesToQueryByMemberList( + ObjectId: TBoldObjectId; const ValueSpace: IBoldValueSpace; const Query: IBoldExecQuery; + SQL: TStrings; memberList: TBoldMemberPersistenceMapperList; + TranslationList: TBoldIdTranslationList; DBStorageMode: TBoldDBStorageMode); +var + i: integer; + ColumnIndex: Integer; + MemberMapper: TBoldMemberSQLMapper; + ObjectContents: IBoldObjectContents; + Members: TStringList; + Value: Variant; + Param: IBoldParameter; + ParamName: string; +begin + if SystemPersistenceMapper.SQLDataBaseConfig.UseParamsForInteger then + ValuesToParamsByMemberList(ObjectID,ValueSpace,Query,MemberList,TranslationList,DbStorageMode) + else + begin + ObjectContents := ValueSpace.EnsuredObjectContentsByObjectId[ObjectID]; + Members := TStringList.Create; + for i := 0 to MemberList.count - 1 do + begin + MemberMapper := Memberlist[i] as TBoldMemberSQLMapper; + if (DBStorageMode = dsmCreate) or MemberMapper.IsDirty(ObjectContents) then + begin + for ColumnIndex := 0 to MemberMapper.ColumnCount - 1 do + begin + Value := MemberMapper.ValueAsVariant(ObjectContents, ColumnIndex, TranslationList); + if not SystemPersistenceMapper.SQLDataBaseConfig.UseParamsForEmptyString and SameText(MemberMapper.ContentName, BoldContentName_String) and (Value = '') then + Members.Add(QuotedStr('')) // handle blank strings + else // handle nulls + if VarIsNull(Value) then + Members.Add(SystemPersistenceMapper.SQLDataBaseConfig.SQLforNull) + else // handle integers + if (MemberMapper.ColumnTypeAsSQL[ColumnIndex] = SystemPersistenceMapper.SQLDataBaseConfig.ColumnTypeForInteger) then + Members.Add(Value) + else + begin + ParamName := 'p'+IntToStr(Query.ParamCount); + Param := Query.CreateParam(ftUnknown, ParamName); + MemberMapper.ValueToParam(ObjectContents, Param, ColumnIndex, translationList); + Members.Add(':'+ParamName); + end; + if DBStorageMode = dsmUpdate then + Members[Members.Count-1] := Format('%s=%s', [MemberMapper.ColumnDescriptions[ColumnIndex].SQLName, Members[Members.Count-1]]); + end; + end; + end; + if (Members.Count > 0) then + begin + if (DBStorageMode = dsmCreate) then + SQL.Add(','+Members.CommaText) + else + SQL.Add(Members.CommaText); + end; + Members.free; + end; end; {---TBoldMemberSQLMapper---} @@ -506,16 +915,16 @@ constructor TBoldMemberSQLMapper.CreateFromMold(Moldmember: TMoldMember; MoldCla fInitialColumnRootName := BoldExpandName(MoldMember.ColumnName, MoldMember.name, xtSQL, SystemPersistenceMapper.SQLDataBaseConfig.MaxDBIdentifierLength, MoldClass.Model.NationalCharConversion); - if MoldMember is TMoldAttribute then - fDefaultDbValue := (MoldMember as TMoldAttribute).DefaultDBValue; - - if fDefaultDbValue = '' then - fDefaultDbValue := DefaultDefaultDbValue; - if MoldMember is TMoldAttribute then fAllowNull := (MoldMember as TMoldAttribute).AllowNull else fAllowNull := true; + + if MoldMember is TMoldAttribute then + fDefaultDbValue := (MoldMember as TMoldAttribute).DefaultDBValue; + + if fDefaultDbValue = '' then + fDefaultDbValue := DefaultDefaultDbValue; end; destructor TBoldMemberSQLMapper.destroy; @@ -527,14 +936,47 @@ destructor TBoldMemberSQLMapper.destroy; function TBoldMemberSQLMapper.GetColumnSize(ColumnIndex: Integer): Integer; begin - raise EBold.CreateFmt(sIllegalColumnIndex, [ClassName, 'GetColumnSize', ColumnIndex]); // do not localize + raise EBold.CreateFmt('%s.GetColumnSize: illegal index', [ClassName]); end; function TBoldMemberSQLMapper.GetInitialColumnName(ColumnIndex: Integer): string; begin Result := InitialColumnRootName; if ColumnIndex > 0 then - Result := Format('%s_%d', [Result, ColumnIndex]); // do not localize + Result := Format('%s_%d', [Result, ColumnIndex]); +end; + + +procedure TBoldSystemSQLMapper.AddCustomIndexes; +var + I: Integer; + Table: TBoldSQLTableDescription; + CustomIndex: TBoldIndexDefintion; + AnIndex: TBoldSQLIndexDescription; +begin + for I := 0 to fCustomIndexes.Count - 1 do + begin + CustomIndex := fCustomIndexes.IndexDefinition[I]; + Table := PSSystemDescription.SQLTablesList.ItemsBySQLName[CustomIndex.TableName]; + if CustomIndex.Remove then + begin + AnIndex := nil; + if Assigned(Table) then + AnIndex := Table.IndexList.ItemsByIndexFields[CustomIndex.Columns]; + if Assigned(AnIndex) then + begin + Table.IndexList.Remove(AnIndex); + end + else + raise EBold.Create('Can''t Remove nonexistent index: ' + CustomIndex.TableName + ': [' + CustomIndex.Columns+ ']'); + end + else + begin + if (Table = nil) then + raise EBold.Create('Can''t create index on nonexistant table ' + CustomIndex.TableName); + Table.EnsureIndex(CustomIndex.Columns, False, CustomIndex.Unique, false); + end; + end; end; function TBoldSystemSQLMapper.BoldDbTypeForTopSortedIndex( @@ -543,22 +985,17 @@ function TBoldSystemSQLMapper.BoldDbTypeForTopSortedIndex( result := (ObjectPersistenceMappers[TopSortedIndex] as TBoldObjectSQLMapper).BoldDbType; end; -function TBoldSystemSQLMapper.TopSortedIndexForBoldDbType( - BoldDbType: TBoldDbType): Integer; -var - i: integer; +function TBoldSystemSQLMapper.TopSortedIndexForBoldDbType(BoldDbType: TBoldDbType): Integer; begin - result := -1; - for i := 0 to ObjectPersistenceMappers.Count - 1 do - if (ObjectPersistenceMappers[i] is TBoldObjectSQLMapper) and // tests for nil - ((ObjectPersistenceMappers[i] as TBoldObjectSQLMapper).BoldDbType = BoldDbType) then - begin - result := i; - break; - end; + if fMaxDbType = -1 then + raise Exception.Create('fTopSortedIndexForBoldDbType not initialized'); + if BoldDbType > fMaxDbType then + Result := -1 + else + Result := fTopSortedIndexForBoldDbType[BoldDbType]; end; -procedure TBoldMemberSQLMapper.SetParamToNullWithDataType(aParam: IBoldParameter; FieldType: TFieldType); +procedure TBoldMemberSQLMapper.SetParamToNullWithDataType(const aParam: IBoldParameter; FieldType: TFieldType); begin with aParam do begin @@ -568,17 +1005,23 @@ procedure TBoldMemberSQLMapper.SetParamToNullWithDataType(aParam: IBoldParameter end; end; -procedure TBoldMemberSQLMapper.ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); +procedure TBoldMemberSQLMapper.ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); +begin + raise EBold.CreateFmt('%s.ValueToParam: illegal call', [classname]); +end; + +function TBoldMemberSQLMapper.ValueAsVariant(const ObjectContent: IBoldObjectContents; + ColumnIndex: Integer; TranslationList: TBoldIdTranslationList): variant; begin - raise EBold.CreateFmt(sIllegalCall, [classname, 'ValueToParam']); // do not localize + raise EBold.CreateFmt('%s.ValueAsVariant: Illegal call', [classname]); end; -procedure TBoldMemberSQLMapper.ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); +procedure TBoldMemberSQLMapper.ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); begin - raise EBold.CreateFmt(sIllegalCall, [classname, 'ValueFromField']); // do not localize + raise EBold.CreateFmt('%s.ValueFromField: Illegal call', [classname]); end; -procedure TBoldMemberSQLMapper.ValueToQuery(ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; Query: IBoldExecQuery; TranslationList: TBoldIdTranslationList; DBStorageMode: TBoldDBStorageMode); +procedure TBoldMemberSQLMapper.ValueToQuery(const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; const Query: IBoldExecQuery; TranslationList: TBoldIdTranslationList; DBStorageMode: TBoldDBStorageMode); var aParam : IBoldParameter; ColumnIndex: Integer; @@ -587,44 +1030,52 @@ procedure TBoldMemberSQLMapper.ValueToQuery(ObjectContent: IBoldObjectContents; begin for ColumnIndex := 0 to ColumnCount - 1 do begin - aParam := Query.ParamByName(ColumnDescriptions[ColumnIndex].SQLName); + if Query.ParamCheck then + aParam := Query.EnsureParamByName(ColumnDescriptions[ColumnIndex].SQLName) + else + aParam := Query.CreateParam(ftUnknown, 'p'+IntToStr(Query.ParamCount)); if Assigned(aParam) then ValueToParam(ObjectContent, aParam, ColumnIndex, translationList) else - raise EBoldInternal.CreateFmt(sSomeColumnsNotInTable, [classname, 'ValueToQuery', ColumnIndex, ColumnDescriptions[ColumnIndex].SQLName]); // do not localize + raise EBoldInternal.CreateFmt('%s.ValueToQuery: Some columns not found in table (%d:%s)', [classname, ColumnIndex, ColumnDescriptions[ColumnIndex].SQLName]); end; end; end; -procedure TBoldMemberSQLMapper.ValueFromQuery(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; DataSet: IBoldDataSet); +procedure TBoldMemberSQLMapper.ValueFromQuery(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const DataSet: IBoldDataSet); var aField : IBoldField; ColumnIndex: Integer; + ErrorMsg : String; begin if ShouldFetch(ObjectContent) then begin for ColumnIndex := 0 to ColumnCount - 1 do begin - aField := DataSet.FieldByName(ColumnDescriptions[ColumnIndex].SQLName); + aField := DataSet.FieldByUpperCaseName(ColumnDescriptions[ColumnIndex].SQLNameUpper); + if not Assigned(aField) and (Length(ColumnDescriptions[ColumnIndex].SQLName) = 31) then // Could be DBX problem + aField := DataSet.FieldByUpperCaseName(Copy(ColumnDescriptions[ColumnIndex].SQLNameUpper,1,30)); if Assigned(aField) then ValueFromField(OwningObjectId, ObjectContent, ValueSpace, TranslationList, aField, ColumnIndex) else - raise EBoldInternal.CreateFmt(sSomeColumnsNotInTable, [classname, 'ValueFromQuery', ColumnIndex, ColumnDescriptions[ColumnIndex].SQLName]); // do not localize + raise EBoldInternal.CreateFmt('%s.ValueFromQuery: Some columns not found in table (%d:%s).' + ErrorMsg, [classname, ColumnIndex, ColumnDescriptions[ColumnIndex].SQLName]); end; end; end; -procedure TBoldMemberSQLMapper.InitializeSystem(theDatabase: IBoldDataBase); +procedure TBoldMemberSQLMapper.InitializeSystem(const theDatabase: IBoldDataBase); begin end; function TBoldMemberSQLMapper.GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; begin - raise EBold.CreateFmt(sIllegalColumnIndex, [ClassName, 'GetColumnBDEFieldType', ColumnIndex]); // do not localize + raise EBold.CreateFmt('%s.GetColumnBDEFieldType: illegal index', [ClassName]); end; procedure TBoldSystemSQLMapper.CloseDataBase; begin + if assigned(fExecQuery) then + Database.ReleaseExecQuery(fExecQuery); Database.Close; end; @@ -684,10 +1135,10 @@ procedure TBoldObjectSQLMapper.RetrieveTimeStampCondition(SQL: TStrings; TimeSta end; if TimeStamp = BOLDMAXTIMESTAMP then - SQL.Append(Format('%s (%s.%s = %d)', [WhereToken, // do not localize + SQL.Append(Format('%s (%s.%s = %d)', [WhereToken, EndTimeTableAlias, TIMESTAMPSTOPCOLUMNNAME, TimeStamp])) else - SQL.Append(Format('%s ((%s.%s <= %d) and (%s.%s >= %d))', [WhereToken, // do not localize + SQL.Append(Format('%s ((%s.%s <= %d) and (%s.%s >= %d))', [WhereToken, StartTimeTableAlias, TIMESTAMPSTARTCOLUMNNAME, TimeStamp, EndTimeTableAlias, TIMESTAMPSTOPCOLUMNNAME, TimeStamp])); end; @@ -707,7 +1158,7 @@ function TBoldSystemSQLMapper.GetMappingInfo: TBoldSQLMappingInfo; destructor TBoldSystemSQLMapper.Destroy; begin FreeAndNil(fMappingInfo); - FreeAndNil(fSQLDataBaseConfig); + FreeAndNil(fCustomIndexes); inherited; end; @@ -751,27 +1202,27 @@ function TBoldMemberSQLMapper.DefaultDefaultDbValue: String; result := ''; end; -procedure TBoldSystemSQLMapper.GenerateDatabaseScript(Script: TStrings; Separator: string); +procedure TBoldSystemSQLMapper.GenerateDatabaseScript(Script: TStrings); var i: integer; begin - PSSystemDescription.GenerateDatabaseScript(Script, Separator); + PSSystemDescription.GenerateDatabaseScript(Script); for i := 0 to ObjectPersistenceMappers.Count - 1 do if assigned(ObjectPersistenceMappers[i]) then - (ObjectPersistenceMappers[i] as TBoldObjectSQLMapper).GenerateDatabaseScript(script, separator); - MappingInfo.ScriptForWriteData(Script, Separator, false); + (ObjectPersistenceMappers[i] as TBoldObjectSQLMapper).GenerateDatabaseScript(script); + MappingInfo.ScriptForWriteData(Database, Script, False, SQLDatabaseConfig.SqlScriptSeparator, SQLDatabaseConfig.SqlScriptTerminator); end; -procedure TBoldObjectSQLMapper.GenerateDatabaseScript(Script: TStrings; Separator: string); +procedure TBoldObjectSQLMapper.GenerateDatabaseScript(Script: TStrings); var i: integer; begin for i := 0 to MemberPersistenceMappers.Count - 1 do if assigned(MemberPersistenceMappers[i]) then - (MemberPersistenceMappers[i] as TBoldMemberSQLMapper).GenerateDatabaseScript(script, separator); + (MemberPersistenceMappers[i] as TBoldMemberSQLMapper).GenerateDatabaseScript(script); end; -procedure TBoldMemberSQLMapper.GenerateDatabaseScript(Script: TStrings; Separator: string); +procedure TBoldMemberSQLMapper.GenerateDatabaseScript(Script: TStrings); begin // intentionally left blank end; @@ -796,18 +1247,8 @@ function TBoldMemberSQLMapper.GetColumnDescriptions: TBoldSQLDescriptionList; result := fColumnDescriptions; end; -function TBoldSystemSQLMapper.GetExecQuery: IBoldExecQuery; -begin - result := Database.GetExecQuery; -end; - -procedure TBoldSystemSQLMapper.ReleaseExecQuery(var aQuery: IBoldExecQuery); -begin - Database.ReleaseExecQuery(aQuery); -end; - procedure TBoldSystemSQLMapper.PMFetch(ObjectIDList: TBoldObjectIdList; - ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; + const ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; TranslationList: TBoldIdTranslationList); var WasInTransaction: Boolean; @@ -821,4 +1262,34 @@ procedure TBoldSystemSQLMapper.PMFetch(ObjectIDList: TBoldObjectIdList; end; end; +procedure TBoldSystemSQLMapper.InitializeTopSortedIndexForBoldDbType; +var + i: integer; + DbType: integer; +begin + fMaxDbType := -1; + for i := 0 to ObjectPersistenceMappers.Count - 1 do + if ObjectPersistenceMappers[i] is TBoldObjectSQLMapper then + begin + DbType := TBoldObjectSQLMapper(ObjectPersistenceMappers[i]).BoldDbType; + if DbType > fMaxDbType then + fMaxDbType := DbType; + end; + if fMaxDbType > 50000 then + raise Exception.Create(Format('DbType: %d, too big', [fMaxDbType])); + SetLength(fTopSortedIndexForBoldDbType, fMaxDbType+1); + for i := 0 to fMaxDbType do + fTopSortedIndexForBoldDbType[i] := -1; + for i := 0 to ObjectPersistenceMappers.Count - 1 do + if (ObjectPersistenceMappers[i] is TBoldObjectSQLMapper) then + begin + DbType := TBoldObjectSQLMapper(ObjectPersistenceMappers[i]).BoldDbType; + if fTopSortedIndexForBoldDbType[DbType] <> -1 then + raise Exception.Create(Format('Duplicate DbType: %d', [i])); + fTopSortedIndexForBoldDbType[DbType] := i; + end; +end; + +initialization + end. diff --git a/Source/PMapper/SQL/BoldPSDescriptionsSQL.pas b/Source/PMapper/SQL/BoldPSDescriptionsSQL.pas index e977acba..04c778d5 100644 --- a/Source/PMapper/SQL/BoldPSDescriptionsSQL.pas +++ b/Source/PMapper/SQL/BoldPSDescriptionsSQL.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPSDescriptionsSQL; interface @@ -19,6 +22,11 @@ interface TYPECOLUMN_TYPE = ftSmallint; type + //Copied from Data.DB + TIndexOptionExt = (ixPrimary, ixUnique, ixDescending, ixCaseInsensitive, + ixExpression, ixNonMaintained, ixNonClustered {ext}); + TIndexOptionsExt = set of TIndexOptionExt; + TBoldSQLSystemDescription = class; TBoldSQLDescriptionElement = class; TBoldSQLTableDescription = class; @@ -32,6 +40,7 @@ TBoldSQLIndexDescriptionList = class; {---TBoldSQLSystemDescription---} TBoldSQLSystemDescription = class(TBoldPSSystemDescription) private + fExecQuery: IBoldExecQuery; fTables: TBoldSQLTableDescriptionList; fSQLDatabaseConfig: TBoldSQLDatabaseConfig; fNationalCharConversion: TBoldNationalCharConversion; @@ -48,7 +57,7 @@ TBoldSQLSystemDescription = class(TBoldPSSystemDescription) destructor Destroy; override; procedure CleanPersistentStorage(PSParams: TBoldPSSQLParams); procedure CreatePersistentStorage(PSParams: TBoldPSParams); override; - procedure GenerateDatabaseScript(Script: TStrings; Separator: string); virtual; + procedure GenerateDatabaseScript(Script: TStrings); virtual; property SQLDatabaseConfig: TBoldSQLDatabaseConfig read fSQLDatabaseConfig; property SQLTablesList: TBoldSQLTableDescriptionList read fTables; property NationalCharConversion: TBoldNationalCharConversion read fNationalCharConversion; @@ -58,12 +67,15 @@ TBoldSQLSystemDescription = class(TBoldPSSystemDescription) TBoldSQLDescriptionElement = class(TBoldPSDescriptionElement) private fSQLName: string; + fSQLNameUpper: string; protected - procedure SetSQLName(v: string); virtual; - function MappedSQLName(value: String): String; + function GetDebugInfo: string; override; + procedure SetSQLName(const v: string); virtual; function OwningSystem: TBoldSQLSystemdescription; public property SQLName: string read fSQLName write SetSQLName; + property SQLNameUpper: string read fSQLNameUpper; + function MappedSQLName(const value: String): String; end; {---TBoldSQLTableDescription---} @@ -76,20 +88,20 @@ TBoldSQLTableDescription = class(TBoldSQLDescriptionElement) fContainsStopTimeStamp: Boolean; function GetSystemDescription: TBoldSQLSystemDescription; protected - procedure SetSQLName(v: string); override; + procedure SetSQLName(const v: string); override; function TableExists(PSParams: TBoldPSSQLParams): boolean; procedure CreateTableBDE(PSParams: TBoldPSSQLParams); procedure CreateTableSQL(PSParams: TBoldPSSQLParams); public constructor Create(aOwner: TBoldPSDescriptionElement; Versioned: Boolean); destructor Destroy; override; - function AddColumn(const ColName: string; SQLColType, AllowNullAsSQL: String; ColType: TFieldType; ColSize: Integer; AllowNull: Boolean; DefaultDBValue: string): TBoldSQLColumnDescription; - procedure EnsureIndex(const Fields: string; Primary, Unique: boolean); + function AddColumn(const ColName: string; SQLColType, AllowNullAsSQL: String; ColType: TFieldType; ColSize: Integer; AllowNull: Boolean; const DefaultDBValue: string): TBoldSQLColumnDescription; + procedure EnsureIndex(const Fields: string; Primary, Unique, NonClustered: boolean); procedure CreateTable(PSParams: TBoldPSSQLParams); procedure DeleteTable(PSParams: TBoldPSSQLParams); procedure RetrieveSelectIdAndTypeStatement(S: TStrings); - procedure GenerateDatabaseScript(Script: TStrings; Separator: string); - function SQLForCreateTable(DataBase: IBoldDatabase): string; + procedure GenerateDatabaseScript(Script: TStrings); + function SQLForCreateTable(const DataBase: IBoldDatabase): string; function SQLForDropTable: string; property ColumnsList: TBoldSQLDescriptionList read fColumns; property IndexList: TBoldSQLIndexDescriptionList read fIndexes; @@ -108,13 +120,14 @@ TBoldSQLColumnDescription = class(TBoldSQLDescriptionElement) fSQLAllowNull: string; fFieldType: TFieldType; fDefaultDBValue: String; - function GetTableDescription: TBoldSQLTableDescription; + function GetTableDescription: TBoldSQLTableDescription; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected - procedure SetSQLName(v: string); override; + function GetDebugInfo: string; override; + procedure SetSQLName(const v: string); override; public procedure CreateBDEColumn(FieldDefs: TFieldDefs); constructor Create(aOwner: TBoldPSDescriptionElement); - function GetSQLForColumn(DataBase: IBoldDatabase): string; + function GetSQLForColumn(const DataBase: IBoldDatabase): string; property TableDescription: TBoldSQLTableDescription read GetTableDescription; property Size: integer read fSize write fSize; property Mandatory: Boolean read fMandatory write fMandatory; @@ -127,56 +140,58 @@ TBoldSQLColumnDescription = class(TBoldSQLDescriptionElement) {---TBoldSQLIndexDescription---} TBoldSQLIndexDescription = class(TBoldPSDescriptionElement) private - fIndexOptions: TIndexOptions; + fIndexOptions: TIndexOptionsExt; fIndexedFields: string; function GetTableDescription: TBoldSQLTableDescription; function GetIndexedFieldsForSQL: String; - protected - property TableDescription: TBoldSQLTableDescription read GetTableDescription; - function GeneratedName: String; public + property TableDescription: TBoldSQLTableDescription read GetTableDescription; constructor Create(aOwner: TBoldPSDescriptionElement; const Fields: String); + class function NormalizeFields(const IndexedFields: string): string; function SQLForPrimaryKey: string; function SQLForSecondaryKey: string; + function GeneratedName: String; property IndexedFields: string read fIndexedFields write fIndexedFields; property IndexedFieldsForSQL: String read GetIndexedFieldsForSQL; procedure CreateBDEIndex(PSParams: TBoldPSSQLParams; IndexDefs: TIndexDefs); - property IndexOptions: TIndexOptions read fIndexOptions write fIndexOptions; + property IndexOptions: TIndexOptionsExt read fIndexOptions write fIndexOptions; end; {---TBoldSQLDescriptionList---} TBoldSQLDescriptionList = class(TBoldIndexableList) private fSystemDescription: TBoldSQLSystemDescription; - function GetItem(index: Integer): TBoldSQLDescriptionElement; - function GetItemBySQLName(SQLName: string): TBoldSQLDescriptionElement; + function GetItem(index: Integer): TBoldSQLDescriptionElement; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemBySQLName(const SQLName: string): TBoldSQLDescriptionElement; public constructor Create(SystemDescription: TBoldSQLSystemDescription); - procedure ToStrings(S: TStrings); //Does not feel necessary.. + procedure ToStrings(S: TStrings); property Items[index: Integer]: TBoldSQLDescriptionElement read GetItem; default; - property ItemsBySQLName[SQLName: string]: TBoldSQLDescriptionElement read GetItemBySQLName; + property ItemsBySQLName[const SQLName: string]: TBoldSQLDescriptionElement read GetItemBySQLName; end; {---TBoldSQLTableDescriptionList---} TBoldSQLTableDescriptionList = class(TBoldSQLDescriptionList) private - function GetItem(index: Integer): TBoldSQLTableDescription; - function GetItemBySQLName(SQLName: string): TBoldSQLTableDescription; + function GetItem(index: Integer): TBoldSQLTableDescription; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemBySQLName(const SQLName: string): TBoldSQLTableDescription; public property Items[index: Integer]: TBoldSQLTableDescription read GetItem; default; - property ItemsBySQLName[SQLName: string]: TBoldSQLtableDescription read GetItemBySQLName; + property ItemsBySQLName[const SQLName: string]: TBoldSQLtableDescription read GetItemBySQLName; end; TBoldSQLIndexDescriptionList = class(TBoldIndexableList) private - function GetItem(index: integer): TBoldSQLIndexDescription; - function GetItemsByIndexFields(const IndexFields: string): TBoldSQLIndexDescription; + class var IX_SQLIndexFields: integer; + function GetItem(index: integer): TBoldSQLIndexDescription; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetItemsByIndexFields(const IndexFields: string): TBoldSQLIndexDescription; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public constructor Create; property items[index: integer]: TBoldSQLIndexDescription read GetItem; default; property ItemsByIndexFields[const IndexFields: string]: TBoldSQLIndexDescription read GetItemsByIndexFields; end; + var BoldCleanDatabaseForced: Boolean = false; @@ -188,15 +203,19 @@ implementation BoldLogHandler, BoldQueryUserDlg, SysUtils, - BoldPMConsts, TypInfo, + {$IFDEF MSWINDOWS} Controls, Dialogs, + {$ENDIF} + {$IFDEF LINUX} + QControls, + QDialogs, + {$ENDIF} BoldHashIndexes; var IX_SQLDescriptionSQLName: integer = -1; - IX_SQLIndexFields: integer = -1; type {---TSQLDescriptorSQLNameIndex---} @@ -216,60 +235,80 @@ function TSQLDescriptorSQLNameIndex.ItemAsKeyString(Item: TObject): string; Result := TBoldSQLDescriptionElement(Item).SQLName; end; +function TBoldSQLIndexDescriptionList.GetItem(index: integer): TBoldSQLIndexDescription; +begin + result := (inherited items[index]) as TBoldSQLIndexDescription; +end; + +function TBoldSQLIndexDescriptionList.GetItemsByIndexFields(const IndexFields: string): TBoldSQLIndexDescription; +begin + Result := TBoldSQLIndexDescription(TBoldStringHashIndex(Indexes[IX_SQLIndexFields]).FindByString(TBoldSQLIndexDescription.NormalizeFields(IndexFields))); +end; + {---TBoldSQLSystemDescription---} constructor TBoldSQLSystemDescription.Create(aOwner: TBoldPSDescriptionElement; SQLDatabaseConfig: TBoldSQLDataBaseConfig; NationalCharConversion: TBoldNationalCharConversion); begin - inherited create(aOwner); + inherited Create(aOwner); fTables := TBoldSQLTableDescriptionList.Create(self); - fSQLDatabaseConfig := TBoldSQLDataBaseConfig.Create; - fSQLDatabaseConfig.AssignConfig(SQLDatabaseConfig); + fSQLDatabaseConfig := SQLDatabaseConfig; fNationalCharConversion := NationalCharConversion; end; destructor TBoldSQLSystemDescription.Destroy; begin FreeAndNil(fTables); - FreeAndNil(fSQLDatabaseConfig); inherited; end; procedure TBoldSQLSystemDescription.InitializeKnownSystemtables( KnownTables: TStrings; PSParams: TBoldPSSQLParams); begin - // do nothing; end; procedure TBoldSQLSystemDescription.CreatePersistentStorage(PSParams: TBoldPSParams); var - i: integer; PsParamsSQL: TBoldPSSQLParams; + + procedure CreateTables; + var + i: integer; + begin + fExecQuery := PSParamsSQL.Database.GetExecQuery; + fExecQuery.ParamCheck := false; + fExecQuery.StartSQLBatch; + try + if BoldLog.ProcessInterruption then + exit; + BoldLog.LogHeader := 'Creating tables'; + BoldLog.ProgressMax := SQLTablesList.Count-1; + for i := 0 to SQLTablesList.Count - 1 do + begin + BoldLog.Progress := i; + SQLTablesList[i].CreateTable(PsParamsSQL); + BoldLog.Sync; + if BoldLog.ProcessInterruption then + exit; + end; + fExecQuery.EndSQLBatch; + CommitMetaDataTransaction(PSParamsSQL); + except + RollBackMetaDataTransaction(PSParamsSQL); + fExecQuery.FailSQLBatch; + raise; + end; + end; + begin if not (PSParams is TBoldPSSQLParams) then - raise EBold.CreateFmt(sUnknownPSParamsType, [classname, PSParams.Classname]); + raise EBold.CreateFmt('%s.CreatePersistentStorage: Unknown type of PSParams: %s', [classname, PSParams.Classname]); PSParamsSQL := PSParams as TBoldPSSQLParams; - CleanPersistentStorage(PSParamsSQL); - StartMetaDataTransaction(PSParamsSQL); try - if BoldLog.ProcessInterruption then - exit; - - BoldLog.LogHeader := sCreatingTables; - BoldLog.ProgressMax := SQLTablesList.Count-1; - for i := 0 to SQLTablesList.Count - 1 do - begin - BoldLog.Progress := i; - SQLTablesList[i].CreateTable(PsParamsSQL); - BoldLog.Sync; - if BoldLog.ProcessInterruption then - exit; - end; - CommitMetaDataTransaction(PSParamsSQL); - except - RollBackMetaDataTransaction(PSParamsSQL); - raise; + CreateTables; + finally + PSParamsSQL.Database.ReleaseExecQuery(fExecQuery); end; end; @@ -279,7 +318,9 @@ function TBoldSQLSystemDescription.ContinueClearPS(TableNameList: TStrings): boo if TableNameList.IndexOf(BoldExpandPrefix(IDTABLE_NAME, '', SQLDatabaseConfig.SystemTablePrefix, SQLDatabaseConfig.MaxDBIdentifierLength, NationalCharConversion)) > -1 then Result := BoldCleanDatabaseForced or - (MessageDlg(sContinueDeleteBoldTables, mtWarning, [mbYes, mbNo], 0) = mrYes); + (MessageDlg('Persistent Storage Seems to Contain a Bold Database. ' + + 'Continuing Will Permanently Destroy Data. Continue?', + mtWarning, [mbYes, mbNo], 0) = mrYes); end; procedure TBoldSQLSystemDescription.CleanPersistentStorage(PSParams: TBoldPSSQLParams); @@ -312,16 +353,17 @@ function DeleteTableBDE: boolean; function DeleteTableSQL: boolean; var + PsParamsSQL: TBoldPSSQLParams; Query: IBoldExecQuery; begin result := true; - - Query := PSParams.DataBase.GetExecQuery; + PSParamsSQL := PSParams as TBoldPSSQLParams; + Query := PSParamsSQL.Database.GetExecQuery; try - Query.AssignSQLText('DROP TABLE ' + Tablenamelist[i]); // do not localize + Query.AssignSQLText('DROP TABLE '+Tablenamelist[i]); Query.ExecSQL; finally - PSParams.dataBase.ReleaseExecQuery(Query); + PSParamsSQL.Database.ReleaseExecQuery(Query); end; end; @@ -331,11 +373,12 @@ function DeleteTable: Boolean; IsBoldTable: boolean; begin + Result:=False; IsBoldTable := Knowntables.IndexOf(TableNameList[i]) <> -1 ; if not IsBoldTable and (not PSParams.IgnoreUnknownTables) and not (Query in [qrYesAll, qrNoAll]) then - Query := QueryUser(sDeleteTable, Format(sDeleteNonBoldTable, [TableNameList[i]])); + Query := QueryUser('Delete Table', Format('Table %s does not seem to be a Bold table. Do you want to delete it.', [TableNameList[i]])); MayDelete := (Query in [qrYes, qrYesAll]) and (not PSParams.IgnoreUnknownTables); @@ -350,7 +393,7 @@ function DeleteTable: Boolean; begin Guard := TBoldGuard.Create(Knowntables, TableNameList); - BoldLog.LogHeader := sCleaningPS; + BoldLog.LogHeader := 'Cleaning Persistent Storage'; Query := qrYes; TableNameList := TStringList.Create; @@ -358,15 +401,13 @@ function DeleteTable: Boolean; InitializeKnownSystemtables(KnownTables, PSParams); - - // this is needed in ADO since the cached table seems to keep the BOLD_TABLEs table open even though it has been closed... PSParams.Database.ReleaseCachedObjects; StartMetaDataTransaction(PSParams); try PSParams.Database.AllTableNames('*', False, TableNameList); if not ContinueClearPS(TableNameList) then - raise EBold.Create(sCleaningPSAborted); + raise EBold.Create('Cleaning of Persistent Storage Aborted'); BoldLog.ProgressMax := TableNameList.Count-1; for i := 0 to TableNameList.Count - 1 do @@ -375,13 +416,13 @@ function DeleteTable: Boolean; try if DeleteTable then begin - BoldLog.LogFmt(sDeletingTableX, [TableNameList[i]]); + BoldLog.LogFmt('Deleting Table: %s', [TableNameList[i]]); end else - BoldLog.LogFmt(sKeepingTableX, [TableNameList[i]]); + BoldLog.LogFmt('Keeping Table: %s', [TableNameList[i]]); except on e:Exception do - BoldLog.LogFmt(sErrorDeletingTable, [TableNameList[i], E.Message], ltError); + BoldLog.LogFmt('Error Deleting Table %s: %s', [TableNameList[i], E.Message], ltError); end; BoldLog.Sync; if BoldLog.ProcessInterruption then @@ -396,7 +437,12 @@ function DeleteTable: Boolean; end; {---TBoldSQLDescriptionElement---} -function TBoldSQLDescriptionElement.MappedSQLName(value: String): String; +function TBoldSQLDescriptionElement.GetDebugInfo: string; +begin + result := ClassName + ':' + SqlName; +end; + +function TBoldSQLDescriptionElement.MappedSQLName(const value: String): String; var System: TBoldSQLSystemDescription; begin @@ -417,9 +463,10 @@ function TBoldSQLDescriptionElement.OwningSystem: TBoldSQLSystemdescription; result := nil; end; -procedure TBoldSQLDescriptionElement.SetSQLName(v: string); +procedure TBoldSQLDescriptionElement.SetSQLName(const v: string); begin fSQLName := MappedSQlName(v); + fSQLNameUpper := AnsiUpperCase(v); end; {---TBoldSQLTableDescription---} @@ -439,35 +486,35 @@ destructor TBoldSQLTableDescription.Destroy; inherited; end; -function TBoldSQLTableDescription.SQLForCreateTable(DataBase: IBoldDatabase): string; +function TBoldSQLTableDescription.SQLForCreateTable(const DataBase: IBoldDatabase): string; var i: integer; s: string; begin - Result := Format('CREATE TABLE %s (', [SQLName]); // do not localize + Result := Format('CREATE TABLE %s (', [SQLName]); for i := 0 to ColumnsList.Count - 1 do begin if i > 0 then Result := Result + ', ' + BOLDCRLF; s := (ColumnsList[i] as TBoldSQLColumnDescription).GetSQLForColumn(DataBase); Result := Result + ' ' + s; - BoldLog.Log(Format(sAddingColumn, [s]), ltDetail); + BoldLog.Log('Adding column: '+s, ltDetail); end; if SystemDescription.SQLDatabaseConfig.SupportsConstraintsInCreateTable and Assigned(PrimaryIndex) then begin Result := Result + ', ' + BOLDCRLF + ' ' + PrimaryIndex.SQLForPrimaryKey; - BoldLog.Log(Format(sAddingPrimaryIndex, [PrimaryIndex.SQLForPrimaryKey]), ltDetail); + BoldLog.Log('Adding Primary index: '+PrimaryIndex.SQLForPrimaryKey, ltDetail); end; Result := Result + ')'; end; function TBoldSQLTableDescription.SQLForDropTable: string; begin - result := format('DROP TABLE %s', [SQLName]); // do not localize + result := format('DROP TABLE %s', [SQLName]); end; -procedure TBoldSQLTableDescription.SetSQLName(v: string); +procedure TBoldSQLTableDescription.SetSQLName(const v: string); begin if SQLName <> MappedSQLName(v) then begin @@ -495,12 +542,9 @@ procedure TBoldSQLTableDescription.CreateTableBDE(PSParams: TBoldPSSQLParams); try TableName := SQLName; Exclusive := True; - - // Create columns FieldDefs.Clear; for i := 0 to ColumnsList.Count - 1 do (ColumnsList[i] as TBoldSQLColumnDescription).CreateBDEColumn(FieldDefs); - // Create Indexes if IndexList.Count > MAXIMUMINDEXCOUNT then MaxIndex := MAXIMUMINDEXCOUNT else @@ -520,26 +564,22 @@ procedure TBoldSQLTableDescription.CreateTableSQL(PSParams: TBoldPSSQLParams); i: integer; Query: IBoldExecQuery; begin - Query := PSParams.Database.GetExecQuery; - try - Query.AssignSQLText(SQLForCreateTable(PSParams.Database)); - Query.ExecSQL; - for i := 0 to IndexList.count-1 do - if (not SystemDescription.SQLDatabaseConfig.SupportsConstraintsInCreateTable) or - (IndexList[i] <> PrimaryIndex) then - begin - Query.AssignSQLText((IndexList[i] as TBoldSQLIndexDescription).SQLForSecondaryKey); - Query.ExecSQL; - end; - finally - PSParams.Database.ReleaseExecQuery(Query); - end; + Query := SystemDescription.fExecQuery; + Query.AssignSQLText(SQLForCreateTable(PSParams.Database)); + Query.ExecSQL; + for i := 0 to IndexList.count-1 do + if (not SystemDescription.SQLDatabaseConfig.SupportsConstraintsInCreateTable) or + (IndexList[i] <> PrimaryIndex) then + begin + Query.AssignSQLText((IndexList[i] as TBoldSQLIndexDescription).SQLForSecondaryKey); + Query.ExecSQL; + end; end; procedure TBoldSQLTableDescription.CreateTable(PSParams: TBoldPSSQLParams); begin - BoldLog.LogFmtIndent(sCreatingTableX, [SQLName]); + BoldLog.LogFmtIndent('Creating Table: %s', [SQLName]); case SystemDescription.EffectiveGenerationMode(PSParams) of dbgTable: CreateTableBDE(PSParams); dbgQuery: CreateTableSQL(PSParams); @@ -564,10 +604,10 @@ procedure TBoldSQLTableDescription.DeleteTable(PSParams: TBoldPSSQLParams); var Table: IBoldTable; begin - BoldLog.LogFmt(sLocatingTableX, [SQLName]); + BoldLog.LogFmt('Locating Table: %s', [SQLName]); if TableExists(PSParams) then begin - BoldLog.LogFmt(sDeletingTableX, [SQLName]); + BoldLog.LogFmt('Deleting Table: %s', [SQLName]); Table := PSParams.Database.GetTable; with table do try @@ -580,10 +620,10 @@ procedure TBoldSQLTableDescription.DeleteTable(PSParams: TBoldPSSQLParams); end; end else - BoldLog.LogFmt(sTableXNotPresent, [SQLName]); + BoldLog.LogFmt('Table %s not Present', [SQLName]); end; -function TBoldSQLTableDescription.AddColumn(const ColName: string; SQLColType, AllowNullAsSQL: String; ColType: TFieldType; ColSize: Integer; AllowNull: Boolean; DefaultDBValue: String): TBoldSQLColumnDescription; +function TBoldSQLTableDescription.AddColumn(const ColName: string; SQLColType, AllowNullAsSQL: String; ColType: TFieldType; ColSize: Integer; AllowNull: Boolean; const DefaultDBValue: String): TBoldSQLColumnDescription; begin Result := TBoldSQLColumnDescription.Create(Self); Result.SQLName := ColName; @@ -595,7 +635,7 @@ function TBoldSQLTableDescription.AddColumn(const ColName: string; SQLColType, A Result.DefaultDBValue := DefaultDBValue; end; -procedure TBoldSQLTableDescription.EnsureIndex(const Fields: string; Primary, Unique: boolean); +procedure TBoldSQLTableDescription.EnsureIndex(const Fields: string; Primary, Unique, NonClustered: boolean); var BoldSQLIndexDescription: TBoldSQLIndexDescription; begin @@ -610,14 +650,16 @@ procedure TBoldSQLTableDescription.EnsureIndex(const Fields: string; Primary, Un end; if Unique then BoldSQLIndexDescription.IndexOptions := BoldSQLIndexDescription.IndexOptions + [ixUnique]; + if NonClustered then + BoldSQLIndexDescription.IndexOptions := BoldSQLIndexDescription.IndexOptions + [ixNonClustered]; end; procedure TBoldSQLTableDescription.RetrieveSelectIdAndTypeStatement(S: TStrings); begin with S do begin - Append(Format('SELECT %s.%s, %s.%s',[SQLName, IDCOLUMN_NAME, SQLName, TYPECOLUMN_NAME])); // do not localize - Append(Format('FROM %s',[SQLName])); // do not localize + Append(Format('SELECT %s.%s, %s.%s',[SQLName, IDCOLUMN_NAME, SQLName, TYPECOLUMN_NAME])); + Append(Format('FROM %s',[SQLName])); end; end; @@ -633,7 +675,7 @@ procedure TBoldSQLColumnDescription.CreateBDEColumn(FieldDefs: TFieldDefs); var FieldDef: TFieldDef; begin - BoldLog.LogFmt(sAddingColumnInfo, + BoldLog.LogFmt('Adding column: %s [%s, %d]', [SQLName, GetEnumName(TypeInfo(TFieldType), Ord(FieldType)), Size], ltDetail); FieldDef := FieldDefs.AddFieldDef; @@ -644,8 +686,8 @@ procedure TBoldSQLColumnDescription.CreateBDEColumn(FieldDefs: TFieldDefs); if DefaultDBValue <> '' then begin BoldLog.Separator; - BoldLog.LogFmt(sColumnHasDefaultDBValue, [SQLName, DefaultDBValue], ltWarning); - BoldLog.Log(sUnsupportedInTableCreationMode); + BoldLog.LogFmt('Column %s has a default db value (%s)', [SQLName, DefaultDBValue], ltWarning); + BoldLog.Log('This is not supported when generating the database using TTable, please use TQuery-method instead if this default value is required'); BoldLog.Separator; end; end; @@ -655,7 +697,7 @@ function TBoldSQLColumnDescription.GetTableDescription: TBoldSQLTableDescription Result := Owner as TBoldSQLTableDescription; end; -procedure TBoldSQLColumnDescription.SetSQLName(v: string); +procedure TBoldSQLColumnDescription.SetSQLName(const v: string); begin if SQLName <> v then begin @@ -664,16 +706,21 @@ procedure TBoldSQLColumnDescription.SetSQLName(v: string); end; end; -function TBoldSQLColumnDescription.GetSQLForColumn(DataBase: IBoldDatabase): string; +function TBoldSQLColumnDescription.GetDebugInfo: string; +begin + result := TableDescription.SqlName + '.' + SqlName; +end; + +function TBoldSQLColumnDescription.GetSQLForColumn(const DataBase: IBoldDatabase): string; var DefaultValue: String; begin if (not assigned(DataBase) or Database.SupportsDefaultColumnValues) and (DefaultDbValue <> '') then - DefaultValue := 'DEFAULT ' + DefaultDbValue // do not localize + DefaultValue := 'DEFAULT '+DefaultDbValue else DefaultValue := ''; - Result := Format('%s %s %s %s', [SQLName, SQLType, DefaultValue, SQLAllowNull]); // do not localize + Result := Format('%s %s %s %s', [SQLName, SQLType, DefaultValue, SQLAllowNull]); end; {---TBoldSQLIndexDescription---} @@ -688,18 +735,20 @@ constructor TBoldSQLIndexDescription.Create(aOwner: TBoldPSDescriptionElement; c function TBoldSQLIndexDescription.SQLForPrimaryKey: string; begin - Result := Format('CONSTRAINT %s PRIMARY KEY (%s)', [generatedName, IndexedFieldsForSQL]); // do not localize + Result := Format('CONSTRAINT %s PRIMARY KEY (%s)', [generatedName, IndexedFieldsForSQL]); end; function TBoldSQLIndexDescription.SQLForSecondaryKey: string; var - Unique: string; + sType: string; begin if ixUnique in IndexOptions then - Unique := 'UNIQUE' // do not localize + sType := 'UNIQUE' // do not localize + else if ixNonClustered in IndexOptions then + sType := 'NONCLUSTERED' // do not localize else - Unique := ''; - Result := Format('CREATE %s INDEX %s ON %s (%s)', [Unique, GeneratedName, TableDescription.SQLName, IndexedFieldsForSQL]); // do not localize + sType := ''; + Result := Format('CREATE %s INDEX %s ON %s (%s)', [sType, GeneratedName, TableDescription.SQLName, IndexedFieldsForSQL]); // do not localize end; @@ -708,6 +757,27 @@ function TBoldSQLIndexDescription.GetTableDescription: TBoldSQLTableDescription; Result := Owner as TBoldSQLTableDescription; end; +class function TBoldSQLIndexDescription.NormalizeFields( + const IndexedFields: string): string; +var + sl: TStringList; +begin + result := StringReplace(IndexedFields, ';', ',', [rfReplaceAll]); + result := StringReplace(result, ' ', '', [rfReplaceAll]); + if pos(',', result) > 1 then + begin + sl := TStringList.Create; + try + sl.CommaText := result; + sl.Sorted := true; + Result := sl.CommaText; + finally + sl.free; + end; + end; + result := StringReplace(Result, ',', ';', [rfReplaceAll]); +end; + procedure TBoldSQLIndexDescription.CreateBDEIndex(PSParams: TBoldPSSQLParams; IndexDefs: TIndexDefs); var ActualOptions: TIndexOptions; @@ -715,16 +785,33 @@ procedure TBoldSQLIndexDescription.CreateBDEIndex(PSParams: TBoldPSSQLParams; In SQLName: string; begin SQLName := GeneratedName; - BoldLog.LogFmt(sAddingIndex, [SQLName, IndexedFields], ltDetail); - ActualOptions := IndexOptions; + BoldLog.LogFmt('Adding Index: %s on %s', [SQLName, IndexedFields], ltDetail); + //Conversion of TIndexOptionsEx to TIndexOptions + if ixPrimary in IndexOptions then begin + ActualOptions := ActualOptions + [db.ixPrimary]; + end; + if ixUnique in IndexOptions then begin + ActualOptions := ActualOptions + [db.ixUnique]; + end; + if ixDescending in IndexOptions then begin + ActualOptions := ActualOptions + [db.ixDescending]; + end; + if ixCaseInsensitive in IndexOptions then begin + ActualOptions := ActualOptions + [db.ixCaseInsensitive]; + end; + if ixExpression in IndexOptions then begin + ActualOptions := ActualOptions + [db.ixExpression]; + end; + if ixNonMaintained in IndexOptions then begin + ActualOptions := ActualOptions + [db.ixNonMaintained]; + end; ActualName := SQLName; - // Paradox complains if IndexOptions are empty. if not PSParams.Database.IsSQLBased then begin if ActualOptions = [] then - ActualOptions := [ixCaseInsensitive]; + ActualOptions := [db.ixCaseInsensitive]; - if ixPrimary in ActualOptions then + if db.ixPrimary in ActualOptions then ActualName := ''; end; IndexDefs.Add(ActualName, IndexedFields, ActualOptions); @@ -745,7 +832,7 @@ function TBoldSQLDescriptionList.GetItem(index: Integer): TBoldSQLDescriptionEle Result := TBoldSQLDescriptionElement(inherited Items[index]); end; -function TBoldSQLDescriptionList.GetItemBySQLName(SQLName: string): TBoldSQLDescriptionElement; +function TBoldSQLDescriptionList.GetItemBySQLName(const SQLName: string): TBoldSQLDescriptionElement; begin Result := TBoldSQLDescriptionElement(TSQLDescriptorSQLNameIndex(Indexes[IX_SQLDescriptionSQLName]).FindByString( BoldExpandName(SQLName, '', xtSQL, @@ -769,7 +856,7 @@ function TBoldSQLTableDescriptionList.GetItem(index: Integer): TBoldSQLTableDesc Result := TBoldSQLTableDescription(inherited Items[index]); end; -function TBoldSQLTableDescriptionList.GetItemBySQLName(SQLName: string): TBoldSQLTableDescription; +function TBoldSQLTableDescriptionList.GetItemBySQLName(const SQLName: string): TBoldSQLTableDescription; begin Result := TBoldSQLTableDescription(TSQLDescriptorSQLNameIndex(Indexes[IX_SQLDescriptionSQLName]).FindByString( BoldExpandName(SQLName, '', xtSQL, @@ -789,7 +876,7 @@ function TBoldSQLIndexDescription.GeneratedName: String; IndexNameLength := TableDescription.SystemDescription.SQLDatabaseConfig.MaxDBIdentifierLength; if IndexNameLength = -1 then IndexNameLength := TableDescription.SystemDescription.SQLDatabaseConfig.MaxIndexNameLength; - result := BoldExpandName('IX_'+TableDescription.SQLName+'_'+IndexedFields, // do not localize + result := BoldExpandName('IX_'+TableDescription.SQLName+'_'+StringReplace(IndexedFields, ';', '_', [rfReplaceAll]), '', xtSQL, IndexNameLength, @@ -803,35 +890,26 @@ constructor TBoldSQLIndexDescriptionList.Create; begin inherited Create; SetIndexCapacity(1); + IX_SQLIndexFields := -1; SetIndexVariable(IX_SQLIndexFields, AddIndex(TSQLIndexFieldsIndex.Create)); end; -function TBoldSQLIndexDescriptionList.GetItem(index: integer): TBoldSQLIndexDescription; -begin - result := (inherited items[index]) as TBoldSQLIndexDescription; -end; - -function TBoldSQLIndexDescriptionList.GetItemsByIndexFields(const IndexFields: string): TBoldSQLIndexDescription; -begin - Result := TBoldSQLIndexDescription(TSQLIndexFieldsIndex(Indexes[IX_SQLIndexFields]).FindByString(IndexFields)); -end; - { TSQLIndexFieldsIndex } function TSQLIndexFieldsIndex.ItemAsKeyString(Item: TObject): string; begin - Result := TBoldSQLIndexDescription(Item).IndexedFields; + Result := TBoldSQLIndexDescription.NormalizeFields(TBoldSQLIndexDescription(Item).IndexedFields); end; -procedure TBoldSQLSystemDescription.GenerateDatabaseScript(Script: TStrings; Separator: string); +procedure TBoldSQLSystemDescription.GenerateDatabaseScript(Script: TStrings); var i: integer; begin for i := 0 to SQLTablesList.Count - 1 do - SQLTablesList[i].GenerateDatabaseScript(Script, Separator); + SQLTablesList[i].GenerateDatabaseScript(Script); end; -procedure TBoldSQLTableDescription.GenerateDatabaseScript(Script: TStrings; Separator: string); +procedure TBoldSQLTableDescription.GenerateDatabaseScript(Script: TStrings); var SQL: TStringList; Guard: IBoldGuard; @@ -839,16 +917,18 @@ procedure TBoldSQLTableDescription.GenerateDatabaseScript(Script: TStrings; Sepa begin Guard := TBoldGuard.create(SQL); SQL := TStringList.Create; - sql.Text := SQLForCreateTable(nil); - Script.Add(Separator); + sql.Text := SQLForCreateTable(nil) + SystemDescription.SQLDatabaseConfig.SqlScriptTerminator; Script.AddStrings(Sql); + if SystemDescription.SQLDatabaseConfig.SqlScriptSeparator<>'' then + Script.Add(SystemDescription.SQLDatabaseConfig.SqlScriptSeparator); for i := 0 to IndexList.count-1 do if IndexList[i] <> PrimaryIndex then begin - sql.Text := (IndexList[i] as TBoldSQLIndexDescription).SQLForSecondaryKey; - Script.Add(Separator); + sql.Text := (IndexList[i] as TBoldSQLIndexDescription).SQLForSecondaryKey + SystemDescription.SQLDatabaseConfig.SqlScriptTerminator; Script.AddStrings(Sql); + if SystemDescription.SQLDatabaseConfig.SqlScriptSeparator<>'' then + Script.Add(SystemDescription.SQLDatabaseConfig.SqlScriptSeparator); end; end; @@ -868,7 +948,7 @@ procedure TBoldSQLSystemDescription.CommitMetaDataTransaction(PSParams: TBoldPSS begin if PsParams.Database.InTransaction then begin - BoldLog.Log(sCommittingToDB); + BoldLog.Log('Committing changes to metadata'); PsParams.Database.Commit; end; end; @@ -877,7 +957,7 @@ procedure TBoldSQLSystemDescription.RollBackMetaDataTransaction(PSParams: TBoldP begin if PsParams.Database.InTransaction then begin - BoldLog.Log(sRollingBackDB); + BoldLog.Log('Rolling back changes to metadata'); PsParams.Database.RollBack; end; end; diff --git a/Source/PMapper/SQL/BoldPSParamsSQL.pas b/Source/PMapper/SQL/BoldPSParamsSQL.pas index 3acdbe60..3203b934 100644 --- a/Source/PMapper/SQL/BoldPSParamsSQL.pas +++ b/Source/PMapper/SQL/BoldPSParamsSQL.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPSParamsSQL; interface @@ -20,4 +23,10 @@ TBoldPSSQLParams = class(TBoldPSParams) implementation + +{ TBoldPSSQLParams } + +initialization + + end. diff --git a/Source/PMapper/SQL/BoldSQLDatabaseConfig.pas b/Source/PMapper/SQL/BoldSQLDatabaseConfig.pas index 95243309..ab56073b 100644 --- a/Source/PMapper/SQL/BoldSQLDatabaseConfig.pas +++ b/Source/PMapper/SQL/BoldSQLDatabaseConfig.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSQLDatabaseConfig; interface @@ -13,32 +16,57 @@ interface dbeInterbaseSQLDialect1, dbeInterbaseSQLDialect3, dbeGenericANSISQL92, dbeSQLServer, + dbePostgres, dbeDBISAM, dbeOracle, dbeAdvantage, dbeParadox, dbeInformix); +const + cMaxBatchQueryLength = 65536 * 64; + cMaxBatchQueryParams = 1000; + +type TBoldSQLDataBaseConfig = class; TBoldSQLDataBaseConfig = class(TPersistent) private + FIfTemplate: string; + FColumnExistsTemplate: string; + FTableExistsTemplate: string; + FIndexExistsTemplate: string; + FIndexColumnExistsTemplate: string; FColumnTypeForBlob: string; FColumnTypeForDateTime: string; FColumnTypeForDate: string; FColumnTypeForTime: string; FColumnTypeForFloat: string; + fColumnTypeForInt64: string; + fDefaultValueForDateTime: string; + FDefaultSystemMapper: string; + FDefaultObjectMapper: string; fOnChange: TNotifyEvent; fUseSQL92Joins: boolean; + fSingleIndexOrderedLinks: Boolean; fFetchBlockSize: integer; + fMultiRowInsertLimit: integer; + fUseParamsForInteger: boolean; + fUseParamsForEmptyString: boolean; fDefaultStringLength: integer; FColumnTypeForString: string; + FColumnTypeForUnicodeString: string; + FColumnTypeForText: string; + FColumnTypeForUnicodeText: string; + FLongStringLimit: integer; fDropColumnTemplate: string; fDropIndexTemplate: string; fDropTableTemplate: string; + fIndexInfoTemplate: string; fSQLforNotNull: string; FColumnTypeForInteger: string; fColumnTypeForSmallInt: string; + FColumnTypeForGUID: string; fSupportsConstraintsInCreateTable: Boolean; fQuoteNonStringDefaultValues: Boolean; fSupportsStringDefaultValues: Boolean; @@ -61,24 +89,55 @@ TBoldSQLDataBaseConfig = class(TPersistent) FSqlScriptSeparator: string; FSqlScriptRollBackTransaction: string; FSqlScriptCommitTransaction: string; + FDatabaseCaseSensitiveTemplate: string; + fQuoteLeftBracketInLike: Boolean; + fIgnoreMissingObjects: boolean; + fMaxBatchQueryLength: integer; + fMaxBatchQueryParams: integer; + fBatchQueryBegin: string; + fBatchQueryEnd: string; + fBatchQuerySeparator: string; + fUseBatchQueries: boolean; + fUseMultiRowInserts: boolean; + fSQLforNull: string; + fEvolveDropsUnknownIndexes: boolean; + fCreateDatabaseTemplate: string; + fDropDatabaseTemplate: string; + fDatabaseExistsTemplate: string; + procedure SetIfTemplate(const Value: string); + procedure SetColumnExistsTemplate(const Value: string); + procedure SetTableExistsTemplate(const Value: string); + procedure SetIndexExistsTemplate(const Value: string); + procedure SetIndexColumnExistsTemplate(const Value: string); procedure SetColumnTypeForBlob(const Value: string); procedure SetColumnTypeForDate(const Value: string); procedure SetColumnTypeForDateTime(const Value: string); procedure SetColumnTypeForTime(const Value: string); + procedure SetDefaultValueForDateTime(const Value: string); + procedure SetDefaultObjectMapper(const Value: string); + procedure SetDefaultSystemMapper(const Value: string); procedure Change; procedure SetUseSQL92Joins(const Value: boolean); + procedure SetSingleIndexOrderedLinks(const Value: boolean); procedure SetColumnTypeForFloat(const Value: string); procedure SetDefaultStringLength(const Value: integer); procedure SetFetchBlockSize(const Value: integer); procedure SetColumnTypeForString(const Value: string); + procedure SetColumnTypeForUnicodeString(const Value: string); + procedure SetColumnTypeForText(const Value: string); + procedure SetColumnTypeForUnicodeText(const Value: string); + procedure SetLongStringLimit(Value: integer); procedure SetDropColumnTemplate(const Value: string); procedure SetDropIndexTemplate(const Value: string); procedure SetDropTableTemplate(const Value: string); + procedure SetIndexInfoTemplate(const Value: string); procedure SetInitialValues; procedure SetSQLforNotNull(const Value: string); procedure SetColumnTypeForInteger(const Value: string); function GetEffectiveSQLForNotNull: string; procedure SetColumnTypeForSmallInt(const Value: string); + procedure SetColumnTypeForInt64(const Value: string); + procedure SetColumnTypeForGUID(const Value: string); procedure SetSupportsConstraintsInCreateTable(const Value: Boolean); procedure SetQuoteNonStringDefaultValues(const Value: Boolean); procedure SetSupportsStringDefaultValues(const Value: Boolean); @@ -90,10 +149,12 @@ TBoldSQLDataBaseConfig = class(TPersistent) procedure SetDBGenerationMode(const Value: TBoldDatabaseGenerationMode); procedure setAllowMetadataChangesInTransaction(const Value: Boolean); procedure ReadUseTransactionsDuringDBCreate(Reader: TReader); + procedure SetDatabaseCaseSensitiveTemplate(const Value: string); procedure SetFieldTypeForBlob(const Value: TFieldType); procedure SetEmptyStringMarker(const Value: String); procedure SetStoreEmptyStringsAsNULL(const Value: Boolean); procedure SetSystemTablePrefix(const Value: String); + procedure SetQuoteLeftBracketInLike(const Value: Boolean); procedure SetSqlScriptCommentStart(const Value: string); procedure SetSqlScriptCommentStop(const Value: string); procedure SetSqlScriptSeparator(const Value: string); @@ -101,51 +162,112 @@ TBoldSQLDataBaseConfig = class(TPersistent) procedure SetSqlScriptTerminator(const Value: string); procedure SetSqlScriptCommitTransaction(const Value: string); procedure SetSqlScriptRollBackTransaction(const Value: string); + procedure SetIgnoreMissingObjects(const Value: boolean); + procedure SetMaxBatchQueryLength(const Value: integer); + procedure SetMaxBatchQueryParams(const Value: integer); + procedure SetBatchQueryBegin(const Value: string); + procedure SetBatchQueryEnd(const Value: string); + procedure SetBatchQuerySeparator(const Value: string); + procedure SetUseBatchQueries(const Value: boolean); + procedure SetMultiRowInsertLimit(const Value: integer); + procedure SetUseParamsForInteger(const Value: boolean); + procedure SetUseParamsForEmptyString(const Value: boolean); + procedure SetSQLforNull(const Value: string); + procedure SetEvolveDropsUnknownIndexes(const Value: boolean); + procedure SetCreateDatabaseTemplate(const Value: string); + procedure SetDropDatabaseTemplate(const Value: string); + procedure SetDatabaseExistsTemplate(const Value: string); protected procedure DefineProperties(Filer: TFiler); override; public - constructor create; + constructor Create; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure AssignConfig(Source: TBoldSQLDataBaseConfig); + function GetCreateDatabaseQuery(const DatabaseName: String): String; + function GetDropDatabaseQuery(const DatabaseName: String): String; + function GetDatabaseExistsQuery(const DatabaseName: String): String; function GetDropColumnQuery(const TableName, columnName: String): String; function GetDropIndexQuery(const TableName, IndexName: String): String; function GetDropTableQuery(const TableName: String): String; + function GetIndexInfoQuery(const TableName: String): String; + function GetColumnTypeForString(Size: Integer): string; + function GetColumnTypeForUnicodeString(Size: Integer): string; procedure InitializeDbEngineSettings(Engine: TBoldDatabaseEngine); function CorrectlyQuotedDefaultValue(value: string): String; + function GetColumnExistsQuery(const TableName, ColumnName: string): string; + function GetIfColumnNotExistsQuery(const TableName, ColumnName, SQLStatement: + string): string; + function GetIndexColumnExistsQuery(const TableName, IndexColumnName: string): + string; + function GetIndexExistsQuery(const TableName, IndexName: string): string; + function GetTableExistsQuery(const TableName: string): string; property EffectiveSQLForNotNull: string read GetEffectiveSQLForNotNull; property OnChange: TNotifyEvent read fOnChange write fOnChange; property Engine: TBoldDatabaseEngine read fEngine write fEngine; published + property DefaultSystemMapper: string read FDefaultSystemMapper write SetDefaultSystemMapper; + property DefaultObjectMapper: string read FDefaultObjectMapper write SetDefaultObjectMapper; + property IfTemplate: string read FIfTemplate write SetIfTemplate; + property ColumnExistsTemplate: string read FColumnExistsTemplate write SetColumnExistsTemplate; + property TableExistsTemplate: string read FTableExistsTemplate write SetTableExistsTemplate; + property IndexExistsTemplate: string read FIndexExistsTemplate write SetIndexExistsTemplate; + property IndexColumnExistsTemplate: string read FIndexColumnExistsTemplate write SetIndexColumnExistsTemplate; property ColumnTypeForDate: string read FColumnTypeForDate write SetColumnTypeForDate; property ColumnTypeForTime: string read FColumnTypeForTime write SetColumnTypeForTime; property ColumnTypeForDateTime: string read FColumnTypeForDateTime write SetColumnTypeForDateTime; + property DefaultValueForDateTime: string read FDefaultValueForDateTime write SetDefaultValueForDateTime; property ColumnTypeForBlob: string read FColumnTypeForBlob write SetColumnTypeForBlob; property ColumnTypeForFloat: string read FColumnTypeForFloat write SetColumnTypeForFloat; property ColumnTypeForCurrency: string read FColumnTypeForCurrency write SetColumnTypeForCurrency; property ColumnTypeForString: string read FColumnTypeForString write SetColumnTypeForString; + property ColumnTypeForUnicodeString: string read FColumnTypeForUnicodeString write SetColumnTypeForUnicodeString; + property ColumnTypeForText: string read FColumnTypeForText write SetColumnTypeForText; + property ColumnTypeForUnicodeText: string read FColumnTypeForUnicodeText write SetColumnTypeForUnicodeText; + property LongStringLimit: integer read FLongStringLimit write SetLongStringLimit default -1; property ColumnTypeForInteger: string read FColumnTypeForInteger write SetColumnTypeForInteger; property ColumnTypeForSmallInt: string read fColumnTypeForSmallInt write SetColumnTypeForSmallInt; + property ColumnTypeForInt64: string read fColumnTypeForInt64 write SetColumnTypeForInt64; + property ColumnTypeForGUID: string read fColumnTypeForGUID write SetColumnTypeForGUID; property FieldTypeForBlob: TFieldType read fFieldTypeForBlob write SetFieldTypeForBlob default ftBlob; property FetchBlockSize: integer read fFetchBlockSize write SetFetchBlockSize default 250; property MaxParamsInIdList: integer read fMaxParamsInIdList write SetMaxParamsInIdList default 20; property DefaultStringLength: integer read fDefaultStringLength write SetDefaultStringLength default 255; property UseSQL92Joins: boolean read fUseSQL92Joins write SetUseSQL92Joins default false; + property SingleIndexOrderedLinks: boolean read fSingleIndexOrderedLinks write SetSingleIndexOrderedLinks default false; + property IgnoreMissingObjects: boolean read fIgnoreMissingObjects write SetIgnoreMissingObjects default false; + property CreateDatabaseTemplate: string read fCreateDatabaseTemplate write SetCreateDatabaseTemplate; + property DropDatabaseTemplate: string read fDropDatabaseTemplate write SetDropDatabaseTemplate; + property DatabaseExistsTemplate: string read fDatabaseExistsTemplate write SetDatabaseExistsTemplate; property DropColumnTemplate: string read fDropColumnTemplate write SetDropColumnTemplate; property DropTableTemplate: string read fDropTableTemplate write SetDropTableTemplate; + property IndexInfoTemplate: string read fIndexInfoTemplate write SetIndexInfoTemplate; property DropIndexTemplate: string read fDropIndexTemplate write SetDropIndexTemplate; + property EvolveDropsUnknownIndexes: boolean read fEvolveDropsUnknownIndexes write SetEvolveDropsUnknownIndexes; property MaxDbIdentifierLength: integer read fMaxDbIdentifierLength write SetMaxDbIdentifierLength default -1; property MaxIndexNameLength: integer read fMaxIndexNameLength write SetMaxIndexNameLenght default 18; + property MaxBatchQueryLength: integer read fMaxBatchQueryLength write SetMaxBatchQueryLength default cMaxBatchQueryLength; + property MaxBatchQueryParams: integer read fMaxBatchQueryParams write SetMaxBatchQueryParams default cMaxBatchQueryParams; + property BatchQueryBegin: string read fBatchQueryBegin write SetBatchQueryBegin; + property BatchQueryEnd: string read fBatchQueryEnd write SetBatchQueryEnd; + property BatchQuerySeparator: string read fBatchQuerySeparator write SetBatchQuerySeparator; + property UseBatchQueries: boolean read fUseBatchQueries write SetUseBatchQueries default false; + property UseParamsForInteger: boolean read fUseParamsForInteger write SetUseParamsForInteger default false; + property UseParamsForEmptyString: boolean read fUseParamsForEmptyString write SetUseParamsForEmptyString default false; + property MultiRowInsertLimit: integer read fMultiRowInsertLimit write SetMultiRowInsertLimit default 1; + property SQLforNull: string read fSQLforNull write SetSQLforNull; property SQLforNotNull: string read fSQLforNotNull write SetSQLforNotNull; property QuoteNonStringDefaultValues: Boolean read fQuoteNonStringDefaultValues write SetQuoteNonStringDefaultValues; property SupportsConstraintsInCreateTable: Boolean read fSupportsConstraintsInCreateTable write SetSupportsConstraintsInCreateTable; property SupportsStringDefaultValues: Boolean read fSupportsStringDefaultValues write SetSupportsStringDefaultValues; property DBGenerationMode: TBoldDatabaseGenerationMode read fDBGenerationMode write SetDBGenerationMode; property AllowMetadataChangesInTransaction: Boolean read fAllowMetadataChangesInTransaction write setAllowMetadataChangesInTransaction default True; + property DatabaseCaseSensitiveTemplate: string read FDatabaseCaseSensitiveTemplate write SetDatabaseCaseSensitiveTemplate; property ReservedWords: TStringList read fReservedWords write SetReservedWords; property EmptyStringMarker: String read fEmptyStringMarker write SetEmptyStringMarker; property StoreEmptyStringsAsNULL: Boolean read fStoreEmptyStringsAsNULL write SetStoreEmptyStringsAsNULL; property SystemTablePrefix: String read fSystemTablePrefix write SetSystemTablePrefix; + property QuoteLeftBracketInLike: Boolean read fQuoteLeftBracketInLike write SetQuoteLeftBracketInLike; property SqlScriptSeparator: string read FSqlScriptSeparator write SetSqlScriptSeparator; property SqlScriptTerminator: string read FSqlScriptTerminator write SetSqlScriptTerminator; property SqlScriptCommentStart: string read FSqlScriptCommentStart write SetSqlScriptCommentStart; @@ -158,13 +280,18 @@ TBoldSQLDataBaseConfig = class(TPersistent) implementation uses - SysUtils; + SysUtils, + BoldRev; const EmptyMarker = ''; + DatabaseNameMarker = ''; TableNameMarker = ''; ColumnNameMarker = ''; IndexNameMarker = ''; + ConditionMarker = ''; + SQLStatementMarker = ''; + IndexColumnNameMarker = ''; { TBoldSQLDataBaseConfig } @@ -180,18 +307,39 @@ procedure TBoldSQLDataBaseConfig.AssignConfig(Source: TBoldSQLDataBaseConfig); begin fColumnTypeForBlob := Source.ColumnTypeForBlob; fColumnTypeForDateTime := Source.ColumnTypeForDateTime; + fDefaultValueForDateTime := Source.DefaultValueForDateTime; fColumnTypeForDate := Source.ColumnTypeForDate; fColumnTypeForTime := Source.ColumnTypeForTime; fColumnTypeForFloat := Source.ColumnTypeForFloat; FColumnTypeForCurrency := Source.ColumnTypeForCurrency; fColumnTypeForString := Source.ColumnTypeForString; + fColumnTypeForUnicodeString := Source.ColumnTypeForUnicodeString; + fColumnTypeForText := Source.ColumnTypeForText; + fColumnTypeForUnicodeText := Source.ColumnTypeForUnicodeText; + FLongStringLimit := Source.LongStringLimit; FColumnTypeForInteger := Source.ColumnTypeForInteger; fColumnTypeForSmallInt := Source.ColumnTypeForSmallInt; + fColumnTypeForInt64 := Source.ColumnTypeForInt64; + fColumnTypeForGUID := Source.ColumnTypeForGUID; + FDefaultSystemMapper := Source.FDefaultSystemMapper; + FDefaultObjectMapper := Source.FDefaultObjectMapper; fUseSQL92Joins := Source.UseSQL92Joins; + fMultiRowInsertLimit := Source.MultiRowInsertLimit; + fUseParamsForInteger := Source.UseParamsForInteger; + fUseParamsForEmptyString := Source.UseParamsForEmptyString; + fSingleIndexOrderedLinks := Source.SingleIndexOrderedLinks; fFetchBlockSize := Source.FetchBlockSize; + fIndexInfoTemplate := Source.IndexInfoTemplate; fMaxParamsInIdList := Source.MaxParamsInIdList; fMaxIndexNameLength := Source.MaxIndexNameLength; fMaxDbIdentifierLength := Source.MaxDbIdentifierLength; + fMaxIndexNameLength := Source.MaxIndexNameLength; + fMaxBatchQueryLength := Source.MaxBatchQueryLength; + fMaxBatchQueryParams := Source.MaxBatchQueryParams; + fBatchQueryBegin := Source.BatchQueryBegin; + fBatchQueryEnd := Source.BatchQueryEnd; + fBatchQuerySeparator := Source.BatchQuerySeparator; + fUseBatchQueries := Source.UseBatchQueries; fFieldTypeForBlob := Source.FieldTypeForBlob; fStoreEmptyStringsAsNULL := Source.StoreEmptyStringsAsNULL; fSystemTablePrefix := Source.SystemTablePrefix; @@ -199,9 +347,14 @@ procedure TBoldSQLDataBaseConfig.AssignConfig(Source: TBoldSQLDataBaseConfig); fAllowMetadataChangesInTransaction := Source.AllowMetadataChangesInTransaction; fDbGenerationMode := Source.DBGenerationMode; fDefaultStringLength := Source.DefaultStringLength; + fCreateDatabaseTemplate := Source.CreateDatabaseTemplate; + fDropDatabaseTemplate := Source.DropDatabaseTemplate; + fDatabaseExistsTemplate := Source.DatabaseExistsTemplate; fDropColumnTemplate := Source.DropColumnTemplate; fDropTableTemplate := Source.DropTableTemplate; fDropIndexTemplate := Source.DropIndexTemplate; + fEvolveDropsUnknownIndexes := Source.EvolveDropsUnknownIndexes; + fSQLforNull := Source.SQLforNull; fSQLforNotNull := Source.SQLforNotNull; fSupportsConstraintsInCreateTable := Source.SupportsConstraintsInCreateTable; fQuoteNonStringDefaultValues := Source.QuoteNonStringDefaultValues; @@ -214,6 +367,13 @@ procedure TBoldSQLDataBaseConfig.AssignConfig(Source: TBoldSQLDataBaseConfig); FSqlScriptStartTransaction := Source.SqlScriptStartTransaction; FSqlScriptCommitTransaction := Source.SqlScriptCommitTransaction; FSqlScriptRollBackTransaction := Source.SqlScriptRollBackTransaction; + FIfTemplate := Source.IfTemplate; + FColumnExistsTemplate := Source.ColumnExistsTemplate; + FTableExistsTemplate := Source.TableExistsTemplate; + FIndexExistsTemplate := Source.IndexExistsTemplate; + FIndexColumnExistsTemplate := Source.IndexColumnExistsTemplate; + FDatabaseCaseSensitiveTemplate := Source.DatabaseCaseSensitiveTemplate; + FIgnoreMissingObjects := Source.IgnoreMissingObjects; Change; end; @@ -227,6 +387,8 @@ constructor TBoldSQLDataBaseConfig.create; begin inherited; fReservedWords := TStringList.Create; + FDefaultSystemMapper := DEFAULTNAME; + FDefaultObjectMapper := DEFAULTNAME; // Since SetInitialValues is called when the persistencehandle sets the "dbengine" property // and the fetchblocksize has not been tested with all databases, it should not be restored when // setting the initial values, instead it is initialized once in the constructor @@ -234,6 +396,42 @@ constructor TBoldSQLDataBaseConfig.create; SetInitialValues; end; +procedure TBoldSQLDataBaseConfig.SetBatchQueryBegin(const Value: string); +begin + if fBatchQueryBegin <> Value then + begin + fBatchQueryBegin := Value; + Change; + end; +end; + +procedure TBoldSQLDataBaseConfig.SetBatchQueryEnd(const Value: string); +begin + if fBatchQueryEnd <> Value then + begin + fBatchQueryEnd := Value; + Change; + end; +end; + +procedure TBoldSQLDataBaseConfig.SetBatchQuerySeparator(const Value: string); +begin + if fBatchQuerySeparator <> Value then + begin + fBatchQuerySeparator := Value; + Change; + end; +end; + +procedure TBoldSQLDataBaseConfig.SetColumnExistsTemplate(const Value: string); +begin + if FColumnExistsTemplate <> Value then + begin + FColumnExistsTemplate := Value; + Change; + end; +end; + procedure TBoldSQLDataBaseConfig.SetColumnTypeForBlob(const Value: string); begin if fColumnTypeForBlob <> Value then @@ -271,6 +469,15 @@ procedure TBoldSQLDataBaseConfig.SetColumnTypeForFloat(const Value: string); end; end; +procedure TBoldSQLDataBaseConfig.SetColumnTypeForGUID(const Value: string); +begin + if FColumnTypeForGUID <> Value then + begin + FColumnTypeForGUID := Value; + Change; + end; +end; + procedure TBoldSQLDataBaseConfig.SetColumnTypeForString(const Value: string); begin if FColumnTypeForString <> Value then @@ -280,6 +487,42 @@ procedure TBoldSQLDataBaseConfig.SetColumnTypeForString(const Value: string); end; end; +procedure TBoldSQLDataBaseConfig.SetColumnTypeForUnicodeString(const Value: string); +begin + if FColumnTypeForUnicodeString <> Value then + begin + FColumnTypeForUnicodeString := Value; + Change; + end; +end; + +procedure TBoldSQLDataBaseConfig.SetColumnTypeForText(const Value: string); +begin + if FColumnTypeForText <> Value then + begin + FColumnTypeForText := Value; + Change; + end; +end; + +procedure TBoldSQLDataBaseConfig.SetColumnTypeForUnicodeText(const Value: string); +begin + if FColumnTypeForUnicodeText <> Value then + begin + FColumnTypeForUnicodeText := Value; + Change; + end; +end; + +procedure TBoldSQLDataBaseConfig.SetCreateDatabaseTemplate(const Value: string); +begin + if fCreateDatabaseTemplate <> Value then + begin + fCreateDatabaseTemplate := Value; + Change; + end; +end; + procedure TBoldSQLDataBaseConfig.SetColumnTypeForTime(const Value: string); begin if fColumnTypeForTime <> Value then @@ -289,6 +532,15 @@ procedure TBoldSQLDataBaseConfig.SetColumnTypeForTime(const Value: string); end; end; +procedure TBoldSQLDataBaseConfig.SetDefaultObjectMapper(const Value: string); +begin + if fDefaultObjectMapper <> Value then + begin + fDefaultObjectMapper := Value; + Change; + end; +end; + procedure TBoldSQLDataBaseConfig.SetDefaultStringLength(const Value: integer); begin if fDefaultStringLength <> Value then @@ -298,6 +550,25 @@ procedure TBoldSQLDataBaseConfig.SetDefaultStringLength(const Value: integer); end; end; +procedure TBoldSQLDataBaseConfig.SetDefaultSystemMapper(const Value: string); +begin + if fDefaultSystemMapper <> Value then + begin + fDefaultSystemMapper := Value; + Change; + end; +end; + +procedure TBoldSQLDataBaseConfig.SetDefaultValueForDateTime( + const Value: string); +begin + if fDefaultValueForDateTime <> Value then + begin + fDefaultValueForDateTime := Value; + Change; + end; +end; + procedure TBoldSQLDataBaseConfig.SetDropColumnTemplate(const Value: string); begin if fDropColumnTemplate <> Value then @@ -307,6 +578,15 @@ procedure TBoldSQLDataBaseConfig.SetDropColumnTemplate(const Value: string); end; end; +procedure TBoldSQLDataBaseConfig.SetDropDatabaseTemplate(const Value: string); +begin + if fDropDatabaseTemplate <> Value then + begin + fDropDatabaseTemplate := Value; + Change; + end; +end; + procedure TBoldSQLDataBaseConfig.SetDropIndexTemplate(const Value: string); begin if fDropIndexTemplate <> Value then @@ -334,52 +614,204 @@ procedure TBoldSQLDataBaseConfig.SetFetchBlockSize(const Value: integer); end; end; +function TBoldSQLDataBaseConfig.GetColumnTypeForString(Size: Integer): string; +begin + if ( LongStringLimit = -1) or (Size <= LongStringLimit) then + Result := Format(ColumnTypeForString, [Size]) + else + Result := Format(ColumnTypeForText, [Size]); +end; + +function TBoldSQLDataBaseConfig.GetColumnTypeForUnicodeString( + Size: Integer): string; +begin + if ( LongStringLimit = -1) or (Size <= LongStringLimit) then + Result := Format(ColumnTypeForUnicodeString, [Size]) + else + Result := Format(ColumnTypeForUnicodeText, [Size]); +end; + +function TBoldSQLDataBaseConfig.GetCreateDatabaseQuery( + const DatabaseName: String): String; +begin + Result := ''; + if CreateDatabaseTemplate <> '' then begin + Result := CreateDatabaseTemplate; + Result := StringReplace(result, DatabaseNameMarker, DatabaseName, [rfIgnoreCase, rfReplaceAll]); + end else begin + raise EBold.Create('Please set the template in the SQLDatabaseConfig ' + + 'for CreateDatabaseTemplate.'); + end; +end; + +function TBoldSQLDataBaseConfig.GetDatabaseExistsQuery( + const DatabaseName: String): String; +begin + Result := ''; + if DatabaseExistsTemplate <> '' then begin + Result := DatabaseExistsTemplate; + Result := StringReplace(result, DatabaseNameMarker, DatabaseName, [rfIgnoreCase, rfReplaceAll]); + end else begin + raise EBold.Create('Please set the template in the SQLDatabaseConfig ' + + 'for DatabaseExistsTemplate.'); + end; +end; + +function TBoldSQLDataBaseConfig.GetDropDatabaseQuery( + const DatabaseName: String): String; +begin + Result := ''; + if DropDatabaseTemplate <> '' then begin + Result := DropDatabaseTemplate; + Result := StringReplace(result, DatabaseNameMarker, DatabaseName, [rfIgnoreCase, rfReplaceAll]); + end else begin + raise EBold.Create('Please set the template in the SQLDatabaseConfig ' + + 'for DropDatabaseTemplate.'); + end; +end; + function TBoldSQLDataBaseConfig.GetDropColumnQuery(const TableName: string; const columnName: String): String; begin - result := DropColumnTemplate; - result := StringReplace(result, TableNameMarker, TableName, [rfIgnoreCase, rfReplaceAll]); - result := StringReplace(result, ColumnNameMarker, ColumnName, [rfIgnoreCase, rfReplaceAll]); + Result := ''; + if DropColumnTemplate <> '' then begin + Result := DropColumnTemplate; + Result := StringReplace(result, TableNameMarker, TableName, [rfIgnoreCase, + rfReplaceAll]); + Result := StringReplace(result, ColumnNameMarker, ColumnName, [rfIgnoreCase, + rfReplaceAll]); + end else begin + raise EBold.Create('Please set the template in the SQLDatabaseConfig ' + + 'for DropColumnTemplate.'); + end; end; function TBoldSQLDataBaseConfig.GetDropIndexQuery(const TableName: string; const IndexName: String): String; begin - result := DropIndexTemplate; - result := StringReplace(result, TableNameMarker, TableName, [rfIgnoreCase, rfReplaceAll]); - result := StringReplace(result, IndexNameMarker, IndexName, [rfIgnoreCase, rfReplaceAll]); + Result := ''; + if DropIndexTemplate <> '' then begin + Result := DropIndexTemplate; + Result := StringReplace(result, TableNameMarker, TableName, [rfIgnoreCase, + rfReplaceAll]); + Result := StringReplace(result, IndexNameMarker, IndexName, [rfIgnoreCase, + rfReplaceAll]); + end else begin + raise EBold.Create('Please set the template in the SQLDatabaseConfig ' + + 'for DropIndexTemplate.'); + end; end; function TBoldSQLDataBaseConfig.GetDropTableQuery(const TableName: String): String; begin - result := DropTableTemplate; - result := StringReplace(result, TableNameMarker, TableName, [rfIgnoreCase, rfReplaceAll]); + Result := ''; + if DropTableTemplate <> '' then begin + Result := DropTableTemplate; + Result := StringReplace(result, TableNameMarker, TableName, [rfIgnoreCase, + rfReplaceAll]); + end else begin + raise EBold.Create('Please set the template in the SQLDatabaseConfig ' + + 'for DropTableTemplate.'); + end; end; +procedure TBoldSQLDataBaseConfig.SetIndexInfoTemplate(const Value: string); +begin + if fIndexInfoTemplate <> Value then + begin + fIndexInfoTemplate := Value; + Change; + end; +end; + +procedure TBoldSQLDataBaseConfig.SetIfTemplate(const Value: string); +begin + if FIfTemplate <> Value then + begin + FIfTemplate := Value; + Change; + end; +end; + +procedure TBoldSQLDataBaseConfig.SetIgnoreMissingObjects(const Value: boolean); +begin + if fIgnoreMissingObjects <> Value then + begin + fIgnoreMissingObjects := Value; + Change; + end; +end; + +procedure TBoldSQLDataBaseConfig.SetIndexColumnExistsTemplate( + const Value: string); +begin + if FIndexColumnExistsTemplate <> Value then + begin + FIndexColumnExistsTemplate := Value; + Change; + end; +end; + +procedure TBoldSQLDataBaseConfig.SetIndexExistsTemplate(const Value: string); +begin + if FIndexExistsTemplate <> Value then + begin + FIndexExistsTemplate := Value; + Change; + end; +end; + procedure TBoldSQLDataBaseConfig.SetInitialValues; begin - FColumnTypeForBlob := 'BLOB'; // do not localize - FColumnTypeForDateTime := 'DATE'; // do not localize - FColumnTypeForDate := 'DATE'; // do not localize - FColumnTypeForTime := 'DATE'; // do not localize - FColumnTypeForFloat := 'DOUBLE PRECISION'; // do not localize - FColumnTypeForCurrency := 'DOUBLE PRECISION'; // do not localize - fColumnTypeForString := 'VARCHAR(%d)'; // do not localize - FColumnTypeForInteger := 'INTEGER'; // do not localize - fColumnTypeForSmallInt := 'SMALLINT'; // do not localize + FDatabaseCaseSensitiveTemplate := ''; // is database specific + FIfTemplate := ''; // is database specific + FColumnExistsTemplate := ''; // is database specific + FTableExistsTemplate := ''; // is database specific + FIndexExistsTemplate := ''; // is database specific + FIndexColumnExistsTemplate := ''; // is database specific + FColumnTypeForBlob := 'BLOB'; + FColumnTypeForDateTime := 'DATE'; + FColumnTypeForDate := 'DATE'; + FColumnTypeForTime := 'DATE'; + fDefaultValueForDateTime := ''; + FColumnTypeForFloat := 'DOUBLE PRECISION'; + FColumnTypeForCurrency := 'DOUBLE PRECISION'; + fColumnTypeForString := 'VARCHAR(%d)'; + fColumnTypeForUnicodeString := 'NVARCHAR(%d)'; // do not localize + fColumnTypeForText := 'VARCHAR(MAX)'; // do not localize + fColumnTypeForUnicodeText := 'NVARCHAR(MAX)'; // do not localize + fLongStringLimit := -1; + FColumnTypeForInteger := 'INTEGER'; + fColumnTypeForSmallInt := 'SMALLINT'; + fColumnTypeForInt64 := 'BIGINT'; // do not localize fDefaultStringLength := 255; fMaxParamsInIdList := 20; fMaxIndexNameLength := 18; fMaxDbIdentifierLength := -1; + fMaxBatchQueryLength := cMaxBatchQueryLength; + fMaxBatchQueryParams := cMaxBatchQueryParams; + fBatchQueryBegin := ''; + fBatchQueryEnd := ''; + fBatchQuerySeparator := ';'; + fUseBatchQueries := false; fFieldTypeForBlob := ftBlob; fStoreEmptyStringsAsNULL := false; - fSystemTablePrefix := 'BOLD'; // do not localize + fSystemTablePrefix := 'BOLD'; fEmptyStringMarker := ''; + fMultiRowInsertLimit := 1; + UseParamsForInteger := false; + UseParamsForEmptyString := false; + fIgnoreMissingObjects := false; fAllowMetadataChangesInTransaction := true; fDBGenerationMode := dbgQuery; - fDropColumnTemplate := 'ALTER TABLE DROP '; // do not localize - fDropTableTemplate := 'DROP TABLE '; // do not localize - fDropIndexTemplate := 'DROP INDEX '; // do not localize - fSQLforNotNull := 'NOT NULL'; // do not localize + fCreateDatabaseTemplate := 'CREATE DATABASE '; + fDropDatabaseTemplate := 'DROP DATABASE '; + fDatabaseExistsTemplate := ''; + fDropColumnTemplate := 'ALTER TABLE DROP '; + fDropTableTemplate := 'DROP TABLE '; + fDropIndexTemplate := 'DROP INDEX '; + fEvolveDropsUnknownIndexes := true; + fSQLforNull := 'NULL'; + fSQLforNotNull := 'NOT NULL'; fSupportsConstraintsInCreateTable := true; FQuoteNonStringDefaultValues := false; fSupportsStringDefaultValues := true; @@ -387,35 +819,90 @@ procedure TBoldSQLDataBaseConfig.SetInitialValues; FSqlScriptStartTransaction := 'START TRANSACTION'; FSqlScriptTerminator := ';'; FSqlScriptCommentStop := ' */'; - FSqlScriptSeparator := '---'; + FSqlScriptSeparator := ''; FSqlScriptRollBackTransaction := 'ROLLBACK'; FSqlScriptCommitTransaction := 'COMMIT'; - fReservedWords.Text := 'ACTIVE, ADD, ALL, AFTER, ALTER'#10'AND, ANY, AS, ASC, ASCENDING,'#10 + // do not localize - 'AT, AUTO, AUTOINC, AVG, BASE_NAME'#10'BEFORE, BEGIN, BETWEEN, BLOB, BOOLEAN,'#10 + // do not localize - 'BOTH, BY, BYTES, CACHE, CAST, CHAR'#10'CHARACTER, CHECK, CHECK_POINT_LENGTH, COLLATE,'#10 + // do not localize - 'COLUMN, COMMIT, COMMITTED, COMPUTED'#10'CONDITIONAL, CONSTRAINT, CONTAINING, COUNT, CREATE, CSTRING,'#10 + // do not localize - 'CURRENT, CURSOR, DATABASE, DATE, DAY'#10'DEBUG, DEC, DECIMAL, DECLARE, DEFAULT,'#10 + // do not localize - 'DELETE, DESC, DESCENDING, DISTINCT, DO'#10'DOMAIN, DOUBLE, DROP, ELSE, END,'#10 + // do not localize - 'ENTRY_POINT, ESCAPE, EXCEPTION, EXECUTE'#10'EXISTS, EXIT, EXTERNAL, EXTRACT, FILE, FILTER,'#10 + // do not localize - 'FLOAT, FOR, FOREIGN, FROM, FULL, FUNCTION'#10'GDSCODE, GENERATOR, GEN_ID, GRANT,'#10 + // do not localize - 'GROUP, GROUP_COMMIT_WAIT_TIME, HAVING'#10'HOUR, IF, IN, INT, INACTIVE, INDEX, INNER,'#10 + // do not localize - 'INPUT_TYPE, INSERT, INTEGER, INTO'#10'IS, ISOLATION, JOIN, KEY, LONG, LENGTH,'#10 + // do not localize - 'LOGFILE, LOWER, LEADING, LEFT, LEVEL'#10'LIKE, LOG_BUFFER_SIZE, MANUAL, MAX, MAXIMUM_SEGMENT,'#10 + // do not localize - 'MERGE, MESSAGE, MIN, MINUTE, MODULE_NAME'#10'MONEY, MONTH, NAMES, NATIONAL, NATURAL,'#10 + // do not localize - 'NCHAR, NO, NOT, NULL, NUM_LOG_BUFFERS'#10'NUMERIC, OF, ON, ONLY, OPTION,'#10 + // do not localize - 'OR, ORDER, OUTER, OUTPUT_TYPE, OVERFLOW'#10'PAGE_SIZE, PAGE, PAGES, PARAMETER, PASSWORD,'#10 + // do not localize - 'PLAN, POSITION, POST_EVENT, PRECISION'#10'PROCEDURE, PROTECTED, PRIMARY, PRIVILEGES, RAW_PARTITIONS, RDB$DB_KEY,'#10 + // do not localize - 'READ, REAL, RECORD_VERSION, REFERENCES'#10'RESERV, RESERVING, RETAIN, RETURNING_VALUES, RETURNS, REVOKE,'#10 + // do not localize - 'RIGHT, ROLE, ROLLBACK, SECOND, SEGMENT'#10'SELECT, SET, SHARED, SHADOW, SCHEMA, SINGULAR,'#10 + // do not localize - 'SIZE, SMALLINT, SNAPSHOT, SOME, SORT'#10'SQLCODE, STABILITY, STARTING, STARTS, STATISTICS,'#10 + // do not localize - 'SUB_TYPE, SUBSTRING, SUM, SUSPEND, TABLE'#10'THEN, TIME, TIMESTAMP, TIMEZONE_HOUR, TIMEZONE_MINUTE,'#10 + // do not localize - 'TO, TRAILING, TRANSACTION, TRIGGER, TRIM'#10'UNCOMMITTED, UNION, UNIQUE, UPDATE, UPPER,'#10 + // do not localize - 'USER, VALUE, VALUES, VARCHAR, VARIABLE'#10'VARYING, VIEW, WAIT, WHEN, WHERE,'#10 + // do not localize - 'WHILE, WITH, WORK, WRITE, YEAR'; // do not localize + fReservedWords.Text := 'ACTIVE, ADD, ALL, AFTER, ALTER'#10'AND, ANY, AS, ASC, ASCENDING,'#10 + + 'AT, AUTO, AUTOINC, AVG, BASE_NAME'#10'BEFORE, BEGIN, BETWEEN, BLOB, BOOLEAN,'#10 + + 'BOTH, BY, BYTES, CACHE, CAST, CHAR'#10'CHARACTER, CHECK, CHECK_POINT_LENGTH, COLLATE,'#10 + + 'COLUMN, COMMIT, COMMITTED, COMPUTED'#10'CONDITIONAL, CONSTRAINT, CONTAINING, COUNT, CREATE, CSTRING,'#10 + + 'CURRENT, CURSOR, DATABASE, DATE, DAY'#10'DEBUG, DEC, DECIMAL, DECLARE, DEFAULT,'#10 + + 'DELETE, DESC, DESCENDING, DISTINCT, DO'#10'DOMAIN, DOUBLE, DROP, ELSE, END,'#10 + + 'ENTRY_POINT, ESCAPE, EXCEPTION, EXECUTE'#10'EXISTS, EXIT, EXTERNAL, EXTRACT, FILE, FILTER,'#10 + + 'FLOAT, FOR, FOREIGN, FROM, FULL, FUNCTION'#10'GDSCODE, GENERATOR, GEN_ID, GRANT,'#10 + + 'GROUP, GROUP_COMMIT_WAIT_TIME, HAVING'#10'HOUR, IF, IN, INT, INACTIVE, INDEX, INNER,'#10 + + 'INPUT_TYPE, INSERT, INTEGER, INTO'#10'IS, ISOLATION, JOIN, KEY, LONG, LENGTH,'#10 + + 'LOGFILE, LOWER, LEADING, LEFT, LEVEL'#10'LIKE, LOG_BUFFER_SIZE, MANUAL, MAX, MAXIMUM_SEGMENT,'#10 + + 'MERGE, MESSAGE, MIN, MINUTE, MODULE_NAME'#10'MONEY, MONTH, NAMES, NATIONAL, NATURAL,'#10 + + 'NCHAR, NO, NOT, NULL, NUM_LOG_BUFFERS'#10'NUMERIC, OF, ON, ONLY, OPTION,'#10 + + 'OR, ORDER, OUTER, OUTPUT_TYPE, OVERFLOW'#10'PAGE_SIZE, PAGE, PAGES, PARAMETER, PASSWORD,'#10 + + 'PLAN, POSITION, POST_EVENT, PRECISION'#10'PROCEDURE, PROTECTED, PRIMARY, PRIVILEGES, RAW_PARTITIONS, RDB$DB_KEY,'#10 + + 'READ, REAL, RECORD_VERSION, REFERENCES'#10'RESERV, RESERVING, RETAIN, RETURNING_VALUES, RETURNS, REVOKE,'#10 + + 'RIGHT, ROLE, ROLLBACK, SECOND, SEGMENT'#10'SELECT, SET, SHARED, SHADOW, SCHEMA, SINGULAR,'#10 + + 'SIZE, SMALLINT, SNAPSHOT, SOME, SORT'#10'SQLCODE, STABILITY, STARTING, STARTS, STATISTICS,'#10 + + 'SUB_TYPE, SUBSTRING, SUM, SUSPEND, TABLE'#10'THEN, TIME, TIMESTAMP, TIMEZONE_HOUR, TIMEZONE_MINUTE,'#10 + + 'TO, TRAILING, TRANSACTION, TRIGGER, TRIM'#10'UNCOMMITTED, UNION, UNIQUE, UPDATE, UPPER,'#10 + + 'USER, VALUE, VALUES, VARCHAR, VARIABLE'#10'VARYING, VIEW, WAIT, WHEN, WHERE,'#10 + + 'WHILE, WITH, WORK, WRITE, YEAR'; Change; end; +procedure TBoldSQLDataBaseConfig.SetLongStringLimit(Value: integer); +begin + if FLongStringLimit <> Value then + begin + FLongStringLimit := Value; + Change; + end; +end; + +procedure TBoldSQLDataBaseConfig.SetSingleIndexOrderedLinks(const Value: boolean); +begin + if fSingleIndexOrderedLinks <> Value then + begin + fSingleIndexOrderedLinks := Value; + Change; + end; +end; + +procedure TBoldSQLDataBaseConfig.SetUseBatchQueries(const Value: boolean); +begin + if fUseBatchQueries <> Value then + begin + fUseBatchQueries := Value; + Change; + end; +end; + +procedure TBoldSQLDataBaseConfig.SetUseParamsForEmptyString( + const Value: boolean); +begin + if fUseParamsForEmptyString <> Value then + begin + fUseParamsForEmptyString := Value; + Change; + end; +end; + +procedure TBoldSQLDataBaseConfig.SetUseParamsForInteger(const Value: boolean); +begin + if fUseParamsForInteger <> Value then + begin + fUseParamsForInteger := Value; + Change; + end; +end; + +procedure TBoldSQLDataBaseConfig.SetMultiRowInsertLimit(const Value: integer); +begin + if fMultiRowInsertLimit <> Value then + begin + fMultiRowInsertLimit := Value; + Change; + end; +end; + procedure TBoldSQLDataBaseConfig.SetUseSQL92Joins(const Value: boolean); begin if fUseSQL92Joins <> Value then @@ -432,76 +919,228 @@ procedure TBoldSQLDataBaseConfig.InitializeDbEngineSettings(Engine: TBoldDatabas ReservedWords.Add(name) end; begin - // if the engine is unknown, we do not alter any settings. if Engine <> dbeUnknown then SetInitialValues; case Engine of + dbePostgres: + begin + fColumnTypeForBlob := 'BYTEA'; // do not localize + fColumnTypeForCurrency := 'NUMERIC'; // do not localize + fColumnTypeForDateTime := 'TIMESTAMP'; // do not localize + fColumnTypeForFloat := 'NUMERIC'; // do not localize + FColumnTypeForTime := 'TIME'; // do not localize + fColumnTypeForGuid := 'UUID'; + fMaxIndexNameLength := 63; + fMaxDbIdentifierLength := 63; + fMultiRowInsertLimit := 1000; + fIndexColumnExistsTemplate := 'select indexname from pg_indexes where upper(tablename) = upper('''')'; + FColumnExistsTemplate := 'SELECT column_name FROM information_schema.columns WHERE upper(table_name)=upper('''') and upper(column_name)=upper('''')'; // do not localize + fDatabaseExistsTemplate := 'select exists(SELECT datname FROM pg_catalog.pg_database WHERE lower(datname) = lower(''''));'; +// IndexInfoTemplate := 'select indexname from pg_indexes where tablename = '''''; // this is not complete IndexName, IsPrimary, IsUnique, ColumnName + fReservedWords.Text := 'ALL, ANALYSE, AND, ANY, ARRAY, AS, ASC, ASYMMETRIC, AUTHORIZATION,'#10 + // do not localize + 'BETWEEN, BINARY, BOOLEAN, BOTH, CASE, CAST, CHAR, CHARACTER, CHECK,'#10 + // do not localize + 'CMIN, COALESCE, COLLATE, COLUMN, CONSTRAINT, CONVERT, CREATE, CROSS,'#10 + // do not localize + 'CURRENT_DATE, CURRENT_ROLE, CURRENT_TIME, CURRENT_TIMESTAMP,'#10 + // do not localize + 'CURRENT_USER, DEC, DECIMAL, DEFAULT, DEFERRABLE, SEC, ELSE, END,'#10 + // do not localize + 'EXCEPT, EXISTS, EXTRACT, FALSE, FLOAT, FOR, FOREIGN, FREEZE, FROM,'#10 + // do not localize + 'FULL, GRANT, GREATEST, GROUP, HAVING, ILIKE, IN, INITIALLY, INNER,'#10 + // do not localize + 'INOUT, INT, INTEGER, INTERSECT, INTERVAL, INTO, IS, ISNULL, JOIN,'#10 + // do not localize + 'LEADING, LEAST, LEFT, LIKE, LIMIT, LOCALTIME, LOCALTIMESTAMP,'#10 + // do not localize + 'NATIONAL, NATURAL, NCHAR, NEW, NONE, NOT, NOTNULL, NULL, NULLIF,'#10 + // do not localize + 'NUMERIC, OFF, OFFSET, OLD, ON, ONLY, OR, ORDER, OUT, OUTER, OVERLAPS,'#10 + // do not localize + 'OVERLAY, PLI, POSITION, PRECISION, PRIMARY, REAL, REFERENCES,'#10 + // do not localize + 'RETURNING, RIGHT, ROW, SELECT, SESSION_USER, SETOF, SIMILAR,'#10 + // do not localize + 'SMALLINT, SOME, SUBSTRING, SYMMETRIC, TABLE, THEN, TIME, TIMESTAMP,'#10 + // do not localize + 'TOP_LEVEL_COUNT, TRAILING, TREAT, TRIM, TRUE, UNION, UNIQUE, USER,'#10 + // do not localize + 'USING, VALUES, VARCHAR, VERBOSE, WHEN, WHERE'; // do not localize + + + end; dbeSQLServer: begin - fColumnTypeForDate := 'DATETIME'; // do not localize - fColumnTypeForTime := 'DATETIME'; // do not localize - fColumnTypeForDateTime := 'DATETIME'; // do not localize - fColumnTypeForFloat := 'DECIMAL (28,10)'; // do not localize - fColumnTypeForCurrency := 'DECIMAL (28,10)'; // do not localize - fDropColumnTemplate := 'ALTER TABLE DROP COLUMN '; // do not localize - fDropIndexTemplate := 'DROP INDEX .'; // do not localize + FDatabaseCaseSensitiveTemplate := 'EXECUTE sp_helpsort'; // do not localize + FIfTemplate := 'IF BEGIN END'; // do not localize + FColumnExistsTemplate := 'SELECT * FROM SYS.COLUMNS WHERE UPPER(NAME) = UPPER(N'''') AND OBJECT_ID = OBJECT_ID(UPPER(N''''))'; // do not localize + FTableExistsTemplate := 'SELECT * FROM SYS.TABLES WHERE UPPER(NAME)=UPPER('''')'; // do not localize + FIndexExistsTemplate := 'SELECT NAME FROM SYS.INDEXES WHERE UPPER(NAME)=UPPER('''') AND OBJECT_ID = OBJECT_ID(UPPER(N''''))'; // do not localize + FIndexColumnExistsTemplate := + 'SELECT IND.NAME FROM SYS.INDEXES IND INNER' // do not localize + +' JOIN SYS.INDEX_COLUMNS IC ON IND.OBJECT_ID = IC.OBJECT_ID AND' // do not localize + +' IND.INDEX_ID = IC.INDEX_ID INNER JOIN SYS.COLUMNS COL ON' // do not localize + +' IC.OBJECT_ID = COL.OBJECT_ID AND IC.COLUMN_ID = COL.COLUMN_ID' // do not localize + +' WHERE IND.OBJECT_ID = OBJECT_ID(UPPER(N'''')) AND UPPER(COL.NAME) = UPPER('''')'; // do not localize + fColumnTypeForDate := 'DATETIME'; // do not localize + fColumnTypeForTime := 'DATETIME'; // do not localize + fColumnTypeForDateTime := 'DATETIME'; // do not localize + fCreateDatabaseTemplate := 'USE MASTER;GO;CREATE DATABASE '; + fDatabaseExistsTemplate := 'IF EXISTS (SELECT name FROM master.sys.databases WHERE name = N'''')'; + fColumnTypeForFloat := 'DECIMAL (28,10)'; // do not localize + fColumnTypeForCurrency := 'DECIMAL (28,10)'; // do not localize + fColumnTypeForText := 'VARCHAR(MAX)'; // do not localize + fColumnTypeForUnicodeText := 'NVARCHAR(MAX)'; // do not localize + FColumnTypeForBlob := 'VARBINARY(MAX)'; // do not localize + fColumnTypeForInt64 := 'BIGINT'; // do not localize + fColumnTypeForGuid := 'UNIQUEIDENTIFIER'; // do not localize + fLongStringLimit := 4000; + fMaxBatchQueryLength := 65536 * 1024; // Length of a string containing SQL statements (batch size) 65,536 * Network packet size Default packet size is 4096 bytes + fMaxBatchQueryParams := 2000; + fMultiRowInsertLimit := 1000; + fDropColumnTemplate := + 'DECLARE @CONSTRAINTNAME NVARCHAR(200)' // do not localize + +' SELECT @CONSTRAINTNAME=OD.NAME' // do not localize + +' FROM SYSOBJECTS OT, SYSCOLUMNS C, SYSOBJECTS OD' // do not localize + +' WHERE UPPER(OT.NAME) = UPPER('''')' // do not localize + +' AND OT.ID = C.ID' // do not localize + +' AND UPPER(C.NAME) = UPPER('''')' // do not localize + +' AND C.CDEFAULT = OD.ID' // do not localize + +' IF @CONSTRAINTNAME IS NOT NULL' // do not localize + +' EXEC(''ALTER TABLE DROP CONSTRAINT '' + @CONSTRAINTNAME)' // do not localize + +' IF EXISTS (SELECT * FROM SYSCOLUMNS WHERE ID=OBJECT_ID('''') AND UPPER(NAME)=UPPER(''''))' // do not localize + +' EXEC(''ALTER TABLE DROP COLUMN '')'; // do not localize + fDropIndexTemplate := 'DROP INDEX .'; // do not localize + fIndexInfoTemplate:= + 'SELECT IND.NAME INDEXNAME, IND.IS_PRIMARY_KEY ISPRIMARY, IND.IS_UNIQUE ISUNIQUE, COL.NAME COLUMNNAME FROM' // do not localize + +' SYS.INDEXES IND INNER JOIN SYS.INDEX_COLUMNS IC ON IND.OBJECT_ID = IC.OBJECT_ID AND IND.INDEX_ID = IC.INDEX_ID' // do not localize + +' INNER JOIN SYS.COLUMNS COL ON IC.OBJECT_ID = COL.OBJECT_ID AND IC.COLUMN_ID = COL.COLUMN_ID' // do not localize + +' WHERE UPPER(OBJECT_NAME(IND.OBJECT_ID))=UPPER('''')' // do not localize + +' ORDER BY INDEXNAME, INDEX_COLUMN_ID'; // do not localize end; dbeGenericANSISQL92: begin - fColumnTypeForDate := 'DATE'; // do not localize - fColumnTypeForTime := 'TIME'; // do not localize - fColumnTypeForDateTime := 'TIMESTAMP'; // do not localize + fColumnTypeForDate := 'DATE'; + fColumnTypeForTime := 'TIME'; + fColumnTypeForDateTime := 'TIMESTAMP'; end; dbeInterbaseSQLDialect3: begin - fColumnTypeForDate := 'TIMESTAMP'; // do not localize - fColumnTypeForTime := 'TIMESTAMP'; // do not localize - fColumnTypeForDateTime := 'TIMESTAMP'; // do not localize + fColumnTypeForDate := 'TIMESTAMP'; // do not localize + fColumnTypeForTime := 'TIMESTAMP'; // do not localize + fColumnTypeForDateTime := 'TIMESTAMP'; // do not localize fMaxIndexNameLength := 31; fMaxDbIdentifierLength := 31; fAllowMetadataChangesInTransaction := true; + fColumnTypeForInt64:='INT64'; // do not localize + fColumnTypeForText:='VARCHAR(32765)'; // do not localize + fColumnTypeForUnicodeString:='VARCHAR(%d) CHARACTER SET UNICODE'; // do not localize + fColumnTypeForUnicodeText:='VARCHAR(4000) CHARACTER SET UNICODE'; // do not localize + fIfTemplate:='EXECUTE BLOCK AS BEGIN IF () THEN EXECUTE STATEMENT ''''; END'; // do not localize + fIndexColumnExistsTemplate:= + 'SELECT IX.RDB$INDEX_NAME AS Name FROM RDB$INDICES IX, RDB$INDEX_SEGMENTS SG WHERE IX.RDB$INDEX_NAME = SG.RDB$INDEX_NAME AND ' // do not localize + +' UPPER(SG.RDB$FIELD_NAME)=UPPER('''') AND UPPER(IX.RDB$RELATION_NAME)=UPPER('''')'; // do not localize + fIndexExistsTemplate:= + 'SELECT * FROM RDB$INDICES WHERE UPPER(RDB$INDEX_NAME) = UPPER('''')'; // do not localize + fTableExistsTemplate:= + 'SELECT * FROM RDB$RELATIONS WHERE UPPER(RDB$RELATION_NAME) = UPPER('''')'; // do not localize + fColumnExistsTemplate:= + 'SELECT * FROM RDB$RELATION_FIELDS WHERE UPPER(RDB$RELATION_NAME)=' // do not localize + +'UPPER('''') AND UPPER(RDB$FIELD_NAME)=UPPER('''')'; // do not localize + fIndexInfoTemplate := 'select ix.rdb$index_name INDEXNAME, sg.rdb$field_name COLUMNNAME,' + // do not localize + 'case (ix.rdb$unique_flag) when 1 then ''T'' else ''F'' end isunique,' + + 'case(rc.rdb$constraint_type) when ''PRIMARY KEY'' then ''T'' else ''F'' end isprimary ' + + 'from rdb$indices ix ' + + 'left join rdb$relation_constraints rc on rc.rdb$index_name = ix.rdb$index_name ' + + 'left join rdb$index_segments sg on ix.rdb$index_name = sg.rdb$index_name where Upper(ix.rdb$relation_name)=Upper('''') '+ + 'order by ix.rdb$index_name, sg.rdb$field_position'; + ; + end; dbeInterbaseSQLDialect1: begin fMaxIndexNameLength := 31; fMaxDbIdentifierLength := 31; fAllowMetadataChangesInTransaction := true; + fColumnTypeForInt64:='INT64'; // do not localize + fColumnTypeForText:='VARCHAR(32765)'; // do not localize + fColumnTypeForUnicodeString:='VARCHAR(%d) CHARACTER SET UNICODE'; // do not localize + fColumnTypeForUnicodeText:='VARCHAR(4000) CHARACTER SET UNICODE'; // do not localize + fIfTemplate:='EXECUTE BLOCK AS BEGIN IF () THEN EXECUTE STATEMENT ''''; END'; // do not localize + fIndexColumnExistsTemplate:= + 'SELECT IX.RDB$INDEX_NAME AS Name FROM RDB$INDICES IX, RDB$INDEX_SEGMENTS SG WHERE IX.RDB$INDEX_NAME = SG.RDB$INDEX_NAME AND ' // do not localize + +' UPPER(SG.RDB$FIELD_NAME)=UPPER('''') AND UPPER(IX.RDB$RELATION_NAME)=UPPER('''')'; // do not localize + fIndexExistsTemplate:= + 'SELECT * FROM RDB$INDICES WHERE UPPER(RDB$INDEX_NAME) = UPPER('''')'; // do not localize + fTableExistsTemplate:= + 'SELECT * FROM RDB$RELATIONS WHERE UPPER(RDB$RELATION_NAME) = UPPER('''')'; // do not localize + fColumnExistsTemplate:= + 'SELECT * FROM RDB$RELATION_FIELDS WHERE UPPER(RDB$RELATION_NAME)=' // do not localize + +'UPPER('''') AND UPPER(RDB$FIELD_NAME)=UPPER('''')'; // do not localize + fIndexInfoTemplate := 'select ix.rdb$index_name INDEXNAME, sg.rdb$field_name COLUMNNAME,' + // do not localize + 'case (ix.rdb$unique_flag) when 1 then ''T'' else ''F'' end isunique,' + + 'case(rc.rdb$constraint_type) when ''PRIMARY KEY'' then ''T'' else ''F'' end isprimary ' + + 'from rdb$indices ix ' + + 'left join rdb$relation_constraints rc on rc.rdb$index_name = ix.rdb$index_name ' + + 'left join rdb$index_segments sg on ix.rdb$index_name = sg.rdb$index_name where Upper(ix.rdb$relation_name)=Upper('''') '+ + 'order by ix.rdb$index_name, sg.rdb$field_position'; end; dbeDBISAM: begin - fColumnTypeForDate := 'DATE'; // do not localize - fColumnTypeForTime := 'TIME'; // do not localize - fColumnTypeForDateTime := 'TIMESTAMP'; // do not localize - fColumnTypeForFloat := 'FLOAT'; // do not localize - fColumnTypeForCurrency := 'FLOAT'; // do not localize + fColumnTypeForDate := 'DATE'; + fColumnTypeForTime := 'TIME'; + fColumnTypeForDateTime := 'TIMESTAMP'; + fColumnTypeForFloat := 'FLOAT'; + fColumnTypeForCurrency := 'FLOAT'; fDefaultStringLength := 250; - AddReservedWord('Description'); // do not localize + AddReservedWord('Description'); end; dbeAdvantage: begin - fSQLforNotNull := 'CONSTRAINT NOT NULL'; // do not localize - fColumnTypeForSmallInt := 'SHORT'; // do not localize - fColumnTypeForFloat := 'NUMERIC'; // do not localize - fColumnTypeForCurrency := 'NUMERIC'; // do not localize + fSQLforNotNull := 'CONSTRAINT NOT NULL'; + fColumnTypeForSmallInt := 'SHORT'; + fColumnTypeForFloat := 'NUMERIC'; + fColumnTypeForCurrency := 'NUMERIC'; fSupportsConstraintsInCreateTable := false; fQuoteNonStringDefaultValues := true; fSupportsStringDefaultValues := false; - fColumnTypeForDate := 'DATE'; // do not localize - fColumnTypeForTime := 'TIME'; // do not localize - fColumnTypeForDateTime := 'TIMESTAMP'; // do not localize - fColumnTypeForString := 'CHAR(%d)'; // do not localize + fColumnTypeForDate := 'DATE'; + fColumnTypeForTime := 'TIME'; + fColumnTypeForDateTime := 'TIMESTAMP'; + fColumnTypeForString := 'CHAR(%d)'; fStoreEmptyStringsAsNULL := True; end; dbeOracle: begin - FColumnTypeForString := 'VARCHAR2(%d)'; // do not localize - FColumnTypeForFloat := 'NUMBER'; // do not localize - FColumnTypeForCurrency := 'NUMBER'; // do not localize - FColumnTypeForInteger := 'NUMBER(10,0)'; // do not localize - fColumnTypeForSmallInt := 'NUMBER(5,0)'; // do not localize - fDropColumnTemplate := 'ALTER TABLE DROP COLUMN '; // do not localize + FColumnTypeForString := 'VARCHAR2(%d)'; // do not localize + FColumnTypeForFloat := 'NUMBER'; // do not localize + FColumnTypeForCurrency := 'NUMBER(10,2)'; // do not localize + fColumnTypeForText:='CLOB'; // do not localize + fColumnTypeForUnicodeString:='NVARCHAR2(%d)'; // do not localize + fColumnTypeForUnicodeText:='CLOB'; // do not localize fMaxIndexNameLength := 30; fMaxDbIdentifierLength := 30; + fSupportsStringDefaultValues:=False; + fIfTemplate:= + 'DECLARE V_COUNT INTEGER; BEGIN SELECT CASE WHEN () THEN 1 ELSE 0 END CASE1 INTO V_COUNT FROM DUAL;' // do not localize + +' IF (V_COUNT=1) THEN EXECUTE IMMEDIATE ''''; END IF;END;'; // do not localize + fIndexColumnExistsTemplate:= + 'SELECT INDEX_NAME AS NAME FROM USER_IND_COLUMNS WHERE UPPER(COLUMN_NAME)=UPPER('''')' // do not localize + +' AND UPPER(TABLE_NAME)=UPPER('''')'; // do not localize + fIndexExistsTemplate:= + 'SELECT * FROM USER_INDEXES WHERE UPPER(INDEX_NAME) = UPPER('''') AND GENERATED = ''N'''; // do not localize + fTableExistsTemplate:= + 'SELECT * FROM USER_TABLES WHERE UPPER(TABLE_NAME) = UPPER('''')'; // do not localize + fColumnExistsTemplate:= + 'SELECT * FROM USER_TAB_COLUMNS WHERE UPPER(TABLE_NAME) = UPPER('''')' // do not localize + +' AND UPPER(COLUMN_NAME) = UPPER('''')'; // do not localize + fIndexInfoTemplate:= + 'SELECT AIC.INDEX_NAME AS IndexName,' // do not localize + +' CASE ALC.CONSTRAINT_TYPE' // do not localize + +' WHEN ''P'' THEN ''T''' // do not localize + +' ELSE ''F''' // do not localize + +' END AS IsPrimary,' // do not localize + +' CASE ALC.CONSTRAINT_TYPE' // do not localize + +' WHEN ''U'' THEN ''T''' // do not localize + +' WHEN ''P'' THEN ''T''' // do not localize + +' ELSE ''F''' // do not localize + +' END AS IsUnique,' // do not localize + +' AIC.COLUMN_NAME AS ColumnName' // do not localize + +' FROM USER_IND_COLUMNS AIC' // do not localize + +' LEFT JOIN USER_CONSTRAINTS ALC ON AIC.INDEX_NAME = ALC.CONSTRAINT_NAME' // do not localize + +' AND AIC.TABLE_NAME = ALC.TABLE_NAME' // do not localize + +' WHERE UPPER(AIC.TABLE_NAME) = UPPER('''')' // do not localize + +' ORDER BY IndexName, Column_Position'; // do not localize + fDropColumnTemplate := 'ALTER TABLE DROP COLUMN '; // do not localize + fBatchQueryBegin := 'BEGIN'; + fBatchQueryEnd := 'END;'; end; dbeParadox: begin @@ -511,11 +1150,11 @@ procedure TBoldSQLDataBaseConfig.InitializeDbEngineSettings(Engine: TBoldDatabas begin fMaxIndexNameLength := 18; fMaxDbIdentifierLength := 18; - fColumnTypeForCurrency := 'MONEY'; // do not localize - fColumnTypeForFloat := 'NUMERIC'; // do not localize - fColumnTypeForDate := 'DATETIME YEAR TO DAY'; // do not localize - fColumnTypeForTime := 'DATETIME HOUR TO FRACTION'; // do not localize - fColumnTypeForDateTime := 'DATETIME YEAR TO FRACTION'; // do not localize + fColumnTypeForCurrency := 'MONEY'; + fColumnTypeForFloat := 'NUMERIC'; + fColumnTypeForDate := 'DATETIME YEAR TO DAY'; + fColumnTypeForTime := 'DATETIME HOUR TO FRACTION'; + fColumnTypeForDateTime := 'DATETIME YEAR TO FRACTION'; end; end; Change; @@ -536,6 +1175,15 @@ procedure TBoldSQLDataBaseConfig.SetSQLforNotNull(const Value: string); end; end; +procedure TBoldSQLDataBaseConfig.SetSQLforNull(const Value: string); +begin + if FColumnTypeForInteger <> Value then + begin + fSQLforNull := Value; + Change; + end; +end; + procedure TBoldSQLDataBaseConfig.SetColumnTypeForInteger(const Value: string); begin if FColumnTypeForInteger <> Value then @@ -553,6 +1201,14 @@ function TBoldSQLDataBaseConfig.GetEffectiveSQLForNotNull: string; result := SQLforNotNull; end; + +function TBoldSQLDataBaseConfig.GetIndexInfoQuery( + const TableName: String): String; +begin + result := IndexInfoTemplate; + result := StringReplace(result, '', TableName, [rfIgnoreCase, rfReplaceAll]); +end; + procedure TBoldSQLDataBaseConfig.SetColumnTypeForSmallInt(const Value: string); begin if FColumnTypeForSmallInt <> Value then @@ -562,6 +1218,14 @@ procedure TBoldSQLDataBaseConfig.SetColumnTypeForSmallInt(const Value: string); end; end; +procedure TBoldSQLDataBaseConfig.SetColumnTypeForInt64(const Value: string); +begin + if fColumnTypeForInt64 <> Value then begin + fColumnTypeForInt64 := Value; + Change; + end; +end; + procedure TBoldSQLDataBaseConfig.SetSupportsConstraintsInCreateTable(const Value: Boolean); begin if fSupportsConstraintsInCreateTable <> Value then @@ -571,6 +1235,16 @@ procedure TBoldSQLDataBaseConfig.SetSupportsConstraintsInCreateTable(const Value end; end; +procedure TBoldSQLDataBaseConfig.SetQuoteLeftBracketInLike( + const Value: Boolean); +begin + if fQuoteLeftBracketInLike <> Value then + begin + fQuoteLeftBracketInLike := Value; + Change; + end; +end; + procedure TBoldSQLDataBaseConfig.SetQuoteNonStringDefaultValues(const Value: Boolean); begin if fQuoteNonStringDefaultValues <> Value then @@ -635,6 +1309,24 @@ procedure TBoldSQLDataBaseConfig.SetMaxIndexNameLenght(const Value: integer); end; end; +procedure TBoldSQLDataBaseConfig.SetMaxBatchQueryLength(const Value: integer); +begin + if fMaxBatchQueryLength <> Value then + begin + fMaxBatchQueryLength := Value; + Change; + end; +end; + +procedure TBoldSQLDataBaseConfig.SetMaxBatchQueryParams(const Value: integer); +begin + if fMaxBatchQueryParams <> Value then + begin + fMaxBatchQueryParams := Value; + Change; + end; +end; + procedure TBoldSQLDataBaseConfig.SetMaxDbIdentifierLength(const Value: integer); begin if fMaxDbIdentifierLength <> Value then @@ -665,7 +1357,89 @@ procedure TBoldSQLDataBaseConfig.setAllowMetadataChangesInTransaction(const Valu procedure TBoldSQLDataBaseConfig.DefineProperties(Filer: TFiler); begin inherited DefineProperties(Filer); - Filer.DefineProperty('UseTransactionsDuringDBCreate', ReadUseTransactionsDuringDBCreate, nil, True); // do not localize + Filer.DefineProperty('UseTransactionsDuringDBCreate', ReadUseTransactionsDuringDBCreate, nil, True); +end; + +function TBoldSQLDataBaseConfig.GetColumnExistsQuery(const TableName, + ColumnName: string): string; +begin + Result := ''; + if ColumnExistsTemplate <> '' then begin + Result := ColumnExistsTemplate; + Result := StringReplace(Result, TableNameMarker, TableName, [rfIgnoreCase, + rfReplaceAll]); + Result := StringReplace(Result, ColumnNameMarker, ColumnName, [rfIgnoreCase, + rfReplaceAll]); + end else begin + raise EBold.Create('Please set the template in the SQLDatabaseConfig ' + + 'for ColumnExistsTemplate.'); + end; +end; + +function TBoldSQLDataBaseConfig.GetIfColumnNotExistsQuery(const TableName, + ColumnName, SQLStatement: string): string; +var + sCondition: string; +begin + Result := ''; + if (ColumnExistsTemplate <> '') and (IfTemplate <> '') then begin + sCondition := GetColumnExistsQuery(TableName, ColumnName); + sCondition := Format('NOT EXISTS(%s)', [sCondition]); + Result := IfTemplate; + Result := StringReplace(Result, ConditionMarker, sCondition, [rfReplaceAll, + rfIgnoreCase]); + Result := StringReplace(Result, SQLStatementMarker, SQLStatement, + [rfReplaceAll, rfIgnoreCase]); + end else begin + raise EBold.Create('Please set the templates in the SQLDatabaseConfig ' + + 'for IfTemplate and ColumnExistsTemplate.'); + end; +end; + +function TBoldSQLDataBaseConfig.GetIndexColumnExistsQuery(const TableName, + IndexColumnName: string): string; +begin + Result := ''; + if IndexColumnExistsTemplate <> '' then begin + Result := IndexColumnExistsTemplate; + Result := StringReplace(Result, TableNameMarker, TableName, [rfIgnoreCase, + rfReplaceAll]); + Result := StringReplace(Result, IndexColumnNameMarker, IndexColumnName, + [rfIgnoreCase, rfReplaceAll]); + end else begin + raise EBold.Create('Please set the template in the SQLDatabaseConfig ' + + 'for IndexColumnExistsTemplate.'); + end; +end; + +function TBoldSQLDataBaseConfig.GetIndexExistsQuery(const TableName, IndexName: + string): string; +begin + Result := ''; + if IndexExistsTemplate <> '' then begin + Result := IndexExistsTemplate; + Result := StringReplace(Result, TableNameMarker, TableName, [rfIgnoreCase, + rfReplaceAll]); + Result := StringReplace(Result, IndexNameMarker, IndexName, [rfIgnoreCase, + rfReplaceAll]); + end else begin + raise EBold.Create('Please set the template in the SQLDatabaseConfig ' + + 'for IndexExistsTemplate.'); + end; +end; + +function TBoldSQLDataBaseConfig.GetTableExistsQuery(const TableName: string): + string; +begin + Result := ''; + if TableExistsTemplate <> '' then begin + Result := TableExistsTemplate; + Result := StringReplace(Result, TableNameMarker, TableName, [rfIgnoreCase, + rfReplaceAll]); + end else begin + raise EBold.Create('Please set the template in the SQLDatabaseConfig ' + + 'for TableExistsTemplate.'); + end; end; procedure TBoldSQLDataBaseConfig.ReadUseTransactionsDuringDBCreate(Reader: TReader); @@ -673,6 +1447,24 @@ procedure TBoldSQLDataBaseConfig.ReadUseTransactionsDuringDBCreate(Reader: TRead AllowMetadataChangesInTransaction := Reader.ReadBoolean; end; +procedure TBoldSQLDataBaseConfig.SetDatabaseCaseSensitiveTemplate(const Value: + string); +begin + if FDatabaseCaseSensitiveTemplate <> Value then begin + FDatabaseCaseSensitiveTemplate := Value; + Change; + end; +end; + +procedure TBoldSQLDataBaseConfig.SetDatabaseExistsTemplate(const Value: string); +begin + if fDatabaseExistsTemplate <> Value then + begin + fDatabaseExistsTemplate := Value; + Change; + end; +end; + procedure TBoldSQLDataBaseConfig.SetFieldTypeForBlob(const Value: TFieldType); begin if fFieldTypeForBlob <> Value then @@ -691,6 +1483,15 @@ procedure TBoldSQLDataBaseConfig.SetEmptyStringMarker(const Value: String); end; end; +procedure TBoldSQLDataBaseConfig.SetEvolveDropsUnknownIndexes(const Value: boolean); +begin + if fEvolveDropsUnknownIndexes <> Value then + begin + fEvolveDropsUnknownIndexes := Value; + Change; + end; +end; + procedure TBoldSQLDataBaseConfig.SetStoreEmptyStringsAsNULL(const Value: Boolean); begin if fStoreEmptyStringsAsNULL <> Value then @@ -700,12 +1501,13 @@ procedure TBoldSQLDataBaseConfig.SetStoreEmptyStringsAsNULL(const Value: Boolean end; end; + procedure TBoldSQLDataBaseConfig.SetSystemTablePrefix(const Value: String); var Temp: String; begin if Value = '' then - temp := 'BOLD' // do not localize + temp := 'BOLD' else temp := Value; if fSystemTablePrefix <> temp then @@ -715,6 +1517,15 @@ procedure TBoldSQLDataBaseConfig.SetSystemTablePrefix(const Value: String); end; end; +procedure TBoldSQLDataBaseConfig.SetTableExistsTemplate(const Value: string); +begin + if FTableExistsTemplate <> Value then + begin + FTableExistsTemplate := Value; + Change; + end; +end; + procedure TBoldSQLDataBaseConfig.SetSqlScriptCommentStart( const Value: string); begin diff --git a/Source/PMapper/SQL/BoldSQLMappingInfo.pas b/Source/PMapper/SQL/BoldSQLMappingInfo.pas index 0b3e230d..22724ce4 100644 --- a/Source/PMapper/SQL/BoldSQLMappingInfo.pas +++ b/Source/PMapper/SQL/BoldSQLMappingInfo.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSQLMappingInfo; interface @@ -24,19 +27,25 @@ TBoldClassMappingInfo = class(TBoldMemoryManagedObject) TBoldMemberMappingInfo = class(TBoldClassMappingInfo) private + FColumnIndex: Boolean; fMemberName: String; fTableName: string; fColumns: string; fMapperName: string; function GetColumnByIndex(Index: integer): string; + function GetColumnCount: integer; public - constructor create(const ClassExpressionName, MemberName, TableName, Columns, MapperName: string); + constructor create(const ClassExpressionName, MemberName, TableName, Columns, + MapperName: string; const ColumnIndex: Boolean); function CompareMapping(Mapping: TBoldMemberMappingInfo): Boolean; + function CompareType(Mapping: TBoldMemberMappingInfo): Boolean; property MemberName: String read fMemberName; property TableName: string read fTableName; property MapperName: string read fMapperName; property Columns: string read fColumns; property ColumnByIndex[Index: integer]: string read GetColumnByIndex; + property ColumnIndex: Boolean read FColumnIndex; + property ColumnCount: integer read GetColumnCount; end; TBoldDbTypeMappingInfo = class(TBoldClassMappingInfo) @@ -75,7 +84,7 @@ TBoldObjectStorageMappingInfo = class(TBoldClassMappingInfo) TBoldMemberMappingList = class(TBoldIndexableList) private function GetMappingsByExpressionNames(const ClassExpressionName, MemberName: string): TBoldMemberMappingArray; - function GetItems(index: integer): TBoldMemberMappingInfo; + function GetItems(index: integer): TBoldMemberMappingInfo; {$IFDEF BOLD_INLINE}inline;{$ENDIF} public constructor Create; procedure FillFromList(SourceList: TBoldMemberMappingList); @@ -88,27 +97,27 @@ TBoldClassMappingList = class(TBoldIndexableList) function GetMappingsForClassName(const ClassExpressionName: string): TBoldClassMappingArray; public constructor Create; - procedure AddMapping(Mapping: TBoldClassMappingInfo); + procedure AddMapping(Mapping: TBoldClassMappingInfo); {$IFDEF BOLD_INLINE}inline;{$ENDIF} property MappingsForClassName[const ClassExpressionName: string]: TBoldClassMappingArray read GetMappingsForClassName; end; TBoldAllInstancesMappingList = class(TBoldClassMappingList) private - function GetItems(index: integer): TBoldAllInstancesMappingInfo; + function GetItems(index: integer): TBoldAllInstancesMappingInfo; {$IFDEF BOLD_INLINE}inline;{$ENDIF} public property items[index: integer]: TBoldAllInstancesMappingInfo read GetItems; default; end; TBoldObjectStorageMappingList = class(TBoldClassMappingList) private - function GetItems(index: integer): TBoldObjectStorageMappingInfo; + function GetItems(index: integer): TBoldObjectStorageMappingInfo; {$IFDEF BOLD_INLINE}inline;{$ENDIF} public property items[index: integer]: TBoldObjectStorageMappingInfo read GetItems; default; end; TBoldDbTypeMappingList = class(TBoldClassMappingList) private - function GetItems(index: integer): TBoldDbTypeMappingInfo; + function GetItems(index: integer): TBoldDbTypeMappingInfo; {$IFDEF BOLD_INLINE}inline;{$ENDIF} public property items[index: integer]: TBoldDbTypeMappingInfo read GetItems; default; end; @@ -129,6 +138,7 @@ TBoldSQLMappingInfo = class fAllInstancesMapping: TBoldAllInstancesMappingList; fObjectStorageMapping: TBoldObjectStorageMappingList; fDbTypeMapping: TBoldDbTypeMappingList; + FCurrentDatabase: IBoldDataBase; property MemberMappingInfo[index: integer]: TBoldMemberMappingInfo read GetMemberMappingInfo; property AllInstancesMappingInfo[index: integer]: TBoldAllInstancesMappingInfo read GetAllInstancesMappingInfo; property ObjectStorageMappingInfo[index: integer]: TBoldObjectStorageMappingInfo read GetObjectStorageMappingInfo; @@ -140,9 +150,11 @@ TBoldSQLMappingInfo = class destructor Destroy; override; procedure ReadDataFromDB(DataBase: IBoldDataBase; ReadDbTypeFromDB, ReadMappingFromDB: Boolean); virtual; abstract; procedure WriteDataToDB(DataBase: IBoldDataBase); - procedure ScriptForWriteData(Script: TStrings; Separator: string = ''; ClearFirst: Boolean = true; terminator: string = ''); virtual; abstract; + procedure ScriptForWriteData(DataBase: IBoldDataBase; Script: TStrings; ClearFirst: Boolean; + Separator: String; Terminator: String); virtual; abstract; function CloneWithoutDbType: TBoldSQLMappingInfo; - procedure AddMemberMapping(const ClassExpressionName, MemberName, TableName, ColumnNames, MapperName: String); + procedure AddMemberMapping(const ClassExpressionName, MemberName, TableName, + ColumnNames, MapperName: String; const ColumnIndex: Boolean); procedure AddAllInstancesMapping(const ClassExpressionName, TableName: String; ClassIdRequired: Boolean); procedure AddObjectStorageMapping(const ClassExpressionName, TableName: String); Procedure AddTypeIdMapping(const ClassExpressionName: String; DbType: TBoldDbType); @@ -165,27 +177,52 @@ implementation uses BoldIndex, BoldLogHandler, + StrUtils, SysUtils, BoldUtils, - BoldPMConsts, - BoldHashIndexes; + BoldHashIndexes, + BoldPMapperLists, + Boldrev; type + TBoldClassMappingIndex = class(TBoldStringHashIndex) protected - function ItemAsKeyString(Item: TObject): string; override; + function ItemASKeyString(Item: TObject): string; override; end; TBoldMemberMappingIndex = class(TBoldStringHashIndex) protected - function ItemAsKeyString(Item: TObject): string; override; - function KeyStringForExpressionNames(const ClassExpressionName, MemberName: string): string; + function ItemASKeyString(Item: TObject): string; override; + function KeyStringForExpressionNames(const ClassExpressionName, MemberName: string): string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure FindAllByExpressionNames(const ClassExpressionName, MemberName: string; aList: TList); end; var IX_ClassExpressionNameIndex: integer = -1; IX_ClassAndMemberExpressionNameIndex: integer = -1; + +{ TBoldAllInstancesMappingList } + +function TBoldAllInstancesMappingList.GetItems(index: integer): TBoldAllInstancesMappingInfo; +begin + result := (inherited items[index]) as TBoldAllInstancesMappingInfo; +end; + +{ TBoldObjectStorageMappingList } + +function TBoldObjectStorageMappingList.GetItems(index: integer): TBoldObjectStorageMappingInfo; +begin + result := (inherited items[index]) as TBoldObjectStorageMappingInfo; +end; + +{ TBoldDbTypeMappingList } + +function TBoldDbTypeMappingList.GetItems(index: integer): TBoldDbTypeMappingInfo; +begin + result := (inherited items[index]) as TBoldDbTypeMappingInfo; +end; + { TBoldDBMappingInfo } procedure TBoldSQLMappingInfo.AddAllInstancesMapping(const ClassExpressionName, TableName: String; ClassIdRequired: Boolean); @@ -203,7 +240,9 @@ procedure TBoldSQLMappingInfo.AddAllInstancesMapping(const ClassExpressionName, fAllInstancesMapping.Add(TBoldAllInstancesMappingInfo.Create(ClassExpressionName, TableName, ClassIdRequired)); end; -procedure TBoldSQLMappingInfo.AddMemberMapping(const ClassExpressionName, MemberName, TableName, ColumnNames, MapperName: String); +procedure TBoldSQLMappingInfo.AddMemberMapping(const ClassExpressionName, + MemberName, TableName, ColumnNames, MapperName: String; const ColumnIndex: + Boolean); var OldMappings: TBoldMemberMappingArray; i: integer; @@ -215,7 +254,8 @@ procedure TBoldSQLMappingInfo.AddMemberMapping(const ClassExpressionName, Member begin exit; end; - fMemberMapping.Add(TBoldMemberMappingInfo.Create(ClassExpressionName, MemberName, TableName, ColumnNames, MapperName)); + fMemberMapping.Add(TBoldMemberMappingInfo.Create(ClassExpressionName, + MemberName, TableName, ColumnNames, MapperName, ColumnIndex)); end; procedure TBoldSQLMappingInfo.AddObjectStorageMapping(const ClassExpressionName, TableName: String); @@ -303,18 +343,44 @@ function TBoldSQLMappingInfo.GetObjectStorageMappingInfo( function TBoldMemberMappingInfo.CompareMapping(Mapping: TBoldMemberMappingInfo): Boolean; begin - result := - SameText(TableName, Mapping.TableName) and - SameText(Columns, Mapping.Columns); + Result := (SameText(TableName, Mapping.TableName) and SameText(Columns, Mapping.Columns)) and CompareType(Mapping); +end; + +function TBoldMemberMappingInfo.CompareType( + Mapping: TBoldMemberMappingInfo): Boolean; +const + CompatibleDateTypes: array [0..2] of string = ('TBoldPMDateTime', 'TBoldPMDate', 'TBoldPMTime'); + CompatibleStringTypes: array [0..1] of string = ('TBoldPMString', 'TBoldPMAnsiString'); +begin + Result := (MapperName = Mapping.MapperName); + if not Result then begin + // This is hardcoded case that should consider Date and DateTime as compatible. + // The generic way to do this properly would be to compare the actual ColumnTypes that are specified in TBoldSQLDataBaseConfig + // But the sql config is hard to reach from here... + Result := ((AnsiIndexText(MapperName, CompatibleDateTypes) <> -1) and + (AnsiIndexText(Mapping.MapperName, CompatibleDateTypes) <> -1)); + end; + if not Result then begin + // Same for String/AnsiString + Result := ((AnsiIndexText(MapperName, CompatibleStringTypes) <> -1) and + (AnsiIndexText(Mapping.MapperName, CompatibleStringTypes) <> -1)); + end; + if not Result then +// If new mapper inherits from old mapper we assume they are compatible + Result := BoldMemberPersistenceMappers.DescriptorByDelphiName[MapperName].MemberPersistenceMapperClass.InheritsFrom( + BoldMemberPersistenceMappers.DescriptorByDelphiName[Mapping.MapperName].MemberPersistenceMapperClass); end; -constructor TBoldMemberMappingInfo.create(const ClassExpressionName, MemberName, TableName, Columns, MapperName: string); +constructor TBoldMemberMappingInfo.create(const ClassExpressionName, + MemberName, TableName, Columns, MapperName: string; const ColumnIndex: + Boolean); begin inherited create(ClassExpressionName); fMemberName := MemberName; fTableName := TableName; fColumns := Columns; fMapperName := MapperName; + FColumnIndex := ColumnIndex; end; function TBoldMemberMappingInfo.GetColumnByIndex(Index: integer): string; @@ -330,6 +396,19 @@ function TBoldMemberMappingInfo.GetColumnByIndex(Index: integer): string; end; end; +function TBoldMemberMappingInfo.GetColumnCount: integer; +var + s: TStringList; +begin + s := TStringList.Create; + try + s.CommaText := Columns; + result := s.Count; + finally + s.free; + end; +end; + { TBoldAllInstancesMappingInfo } function TBoldAllInstancesMappingInfo.CompareMapping(Mapping: TBoldAllInstancesMappingInfo): Boolean; @@ -410,7 +489,8 @@ procedure TBoldMemberMappingList.FillFromList( SourceList[i].MemberName, SourceList[i].TableName, SourceList[i].Columns, - Sourcelist[i].MapperName)); + Sourcelist[i].MapperName, + SourceList[i].ColumnIndex)); end; function TBoldMemberMappingList.GetItems(index: integer): TBoldMemberMappingInfo; @@ -489,7 +569,7 @@ procedure TBoldSQLMappingInfo.AddTypeIdMapping(const ClassExpressionName: String raise EBoldInternal.CreateFmt('%s.AddTypeIdMapping: ClassExpressionName is empty (dbtype: %d)', [ClassName, dbType]); OldMapping := GetDbTypeMapping(ClassExpressionName); if (OldMapping <> -1) and (OldMapping <> dbtype) then - raise EBold.CreateFmt(sMultipleDBTypes, [classname, ClassExpressionName, dbtype, oldMapping]); + raise EBold.CreateFmt('%s.AddTypeIdMapping: The class %s has multiple db types (%d and %d)', [classname, ClassExpressionName, dbtype, oldMapping]); if OldMapping = -1 then begin fDbTypeMapping.AddMapping(TBoldDbTypeMappingInfo.create(ClassExpressionName, DbType)); @@ -515,27 +595,6 @@ function TBoldSQLMappingInfo.GetDbTypeMappingInfo(Index: integer): TBoldDbTypeMa end; -{ TBoldAllInstancesMappingList } - -function TBoldAllInstancesMappingList.GetItems(index: integer): TBoldAllInstancesMappingInfo; -begin - result := (inherited items[index]) as TBoldAllInstancesMappingInfo; -end; - -{ TBoldObjectStorageMappingList } - -function TBoldObjectStorageMappingList.GetItems(index: integer): TBoldObjectStorageMappingInfo; -begin - result := (inherited items[index]) as TBoldObjectStorageMappingInfo; -end; - -{ TBoldDbTypeMappingList } - -function TBoldDbTypeMappingList.GetItems(index: integer): TBoldDbTypeMappingInfo; -begin - result := (inherited items[index]) as TBoldDbTypeMappingInfo; -end; - procedure TBoldSQLMappingInfo.WriteDataToDB(DataBase: IBoldDataBase); var i: integer; @@ -544,22 +603,38 @@ procedure TBoldSQLMappingInfo.WriteDataToDB(DataBase: IBoldDataBase); begin if BoldLog.ProcessInterruption then exit; - - BoldLog.Log(sLogWritingMappingToDB); - Script := TStringList.create; - q := DataBase.GetExecQuery; + BoldLog.Log('Writing mapping information to database'); + if not Database.Connected then + Database.Open; + Database.StartTransaction; try - ScriptForWriteData(Script); - BoldLog.ProgressMax := Script.Count; - for i := 0 to Script.Count-1 do - begin - q.AssignSQLText(Script[i]); - q.ExecSQL; - BoldLog.Progress := i; + q := DataBase.GetExecQuery; + Script := TStringList.create; + try + q.ParamCheck := false; + ScriptForWriteData(DataBase, Script, True, '', ''); + BoldLog.ProgressMax := Script.Count; + q.StartSQLBatch; + try + for i := 0 to Script.Count-1 do + begin + q.AssignSQLText(Script[i]); + q.ExecSQL; + BoldLog.Progress := i; + end; + q.EndSQLBatch; + except + q.FailSQLBatch; + raise; + end; + finally + Script.Free; + DataBase.ReleaseExecQuery(q); end; finally - Script.Free; - DataBase.ReleaseExecQuery(q); + BoldLog.Separator; + BoldLog.Log('Committing changes to mapping information'); + Database.Commit; end; end; @@ -574,7 +649,8 @@ function TBoldSQLMappingInfo.CloneWithoutDbType: TBoldSQLMappingInfo; MemberMappingInfo[i].MemberName, MemberMappingInfo[i].TableName, MemberMappingInfo[i].Columns, - MemberMappingInfo[i].MapperName); + MemberMappingInfo[i].MapperName, + MemberMappingInfo[i].ColumnIndex); for i := 0 to fAllInstancesMapping.Count-1 do result.AddAllInstancesMapping(AllInstancesMappingInfo[i].ClassExpressionName, AllInstancesMappingInfo[i].TableName, AllInstancesMappingInfo[i].ClassIdRequired); diff --git a/Source/PMapper/SQL/BoldSQLQuery.pas b/Source/PMapper/SQL/BoldSQLQuery.pas index f2cb2523..89cace6e 100644 --- a/Source/PMapper/SQL/BoldSQLQuery.pas +++ b/Source/PMapper/SQL/BoldSQLQuery.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSQLQuery; interface @@ -5,6 +8,7 @@ interface uses Db, Classes, + BoldBase, BoldSQLDataBaseConfig, BoldId, BoldContainers, @@ -43,7 +47,7 @@ TBoldSqlTableReferenceList = class; TBoldSQLQueryMode = (qmSelect, qmInsert, qmUpdate, qmDelete); { TBoldSQLJoin } - TBoldSQLJoin = class + TBoldSQLJoin = class(TBoldMemoryManagedObject) private fColumnRef1: TBoldSQLColumnReference; fColumnRef2: TBoldSQLColumnReference; @@ -56,26 +60,26 @@ TBoldSQLJoin = class end; { TBoldSQLTableReference } - TBoldSQLTableReference = class + TBoldSQLTableReference = class(TBoldMemoryManagedObject) private fTableDescription: TBoldSQLTableDescription; fColumnReferences: TBoldObjectArray; fQuery: TBoldSQLQuery; fAliasName: String; - function GetAliasName: String; - function GetTableAliasDeclaration: String; - procedure EnsureColumnExists(ColumnName, Operation: String); + function GetAliasName: String; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetTableAliasDeclaration: String; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure EnsureColumnExists(const ColumnName, Operation: String); public constructor Create(Query: TBoldSQLQuery); destructor Destroy; override; - function GetColumnReference(ColumnName: String): TBoldSQLColumnReference; + function GetColumnReference(const ColumnName: String): TBoldSQLColumnReference; property TableDescription: TBoldSQLTableDescription read fTableDescription; property AliasName: String read GetAliasName; property TableAliasDeclaration: String read GetTableAliasDeclaration; end; { TBoldSQLColumnReference } - TBoldSQLColumnReference = class + TBoldSQLColumnReference = class(TBoldMemoryManagedObject) private fColumnDescription: TBoldSQLColumnDescription; fTableReference: TBoldSQLTableReference; @@ -87,8 +91,19 @@ TBoldSQLColumnReference = class property PrefixedColumnName: String read GetPrefixedColumnName; end; + { TBoldSQLOrderByInfo } + TBoldSQLOrderByInfo = class(TBoldMemoryManagedObject) + private + FColumn: TBoldSQLColumnReference; + FDescending: Boolean; + public + constructor Create(Column: TBoldSQLColumnReference; const Descending: Boolean); + property Column: TBoldSQLColumnReference read FColumn; + property Descending: Boolean read FDescending; + end; + { TBoldSqlWCF } - TBoldSqlWCF = class + TBoldSqlWCF = class(TBoldMemoryManagedObject) public function GetAsString(Query: TBoldSQlQuery): String; virtual; abstract; end; @@ -100,7 +115,7 @@ TBoldSQLWCFBinary = class(TBoldSqlWCF) fArg2: TBoldSqlWCF; fSymbol: string; public - constructor Create(arg1, arg2: TBoldSqlWCF; Symbol: String); + constructor Create(arg1, arg2: TBoldSqlWCF; const Symbol: String); destructor Destroy; override; end; @@ -117,6 +132,16 @@ TBoldSQLWCFBinaryPrefix = class(TBoldSqlWCFBinary) function GetAsString(Query: TBoldSQlQuery): String; override; end; + { TBoldSQLWCFXOR } + TBoldSQLWCFXOR = class(TBoldSqlWCF) + private + fArg1: TBoldSqlWCF; + fArg2: TBoldSqlWCF; + public + constructor Create(arg1, arg2: TBoldSqlWCF); + function GetAsString(Query: TBoldSQlQuery): String; override; + end; + { TBoldSQLWCFUnary } TBoldSQLWCFUnary = class(TBoldSqlWCF) private @@ -133,6 +158,12 @@ TBoldSQLWCFUnaryPrefix = class(TBoldSqlWCFUnary) function GetAsString(Query: TBoldSQlQuery): String; override; end; + { TBoldSQLWCFUnaryTransforLikeString } + TBoldSQLWCFUnaryTransformLikeString = class(TBoldSqlWCFUnary) + public + function GetAsString(Query: TBoldSQlQuery): String; override; + end; + { TBoldSQLWCFUnaryPostfix } TBoldSQLWCFUnaryPostfix = class(TBoldSqlWCFUnary) public @@ -144,7 +175,7 @@ TBoldSQLWCFString = class(TBoldSqlWCF) private fStr: String; public - constructor Create(Value: String); + constructor Create(const Value: String); function GetAsString(Query: TBoldSQlQuery): String; override; end; @@ -161,7 +192,7 @@ TBoldSQLWCFInteger = class(TBoldSqlWCF) TBoldSQLWCFFloat = class(TBoldSqlWCF) private fFloat: Double; - fParam:TParam; //<- Add param variable to avoid multiple create (HK) + fParam:TParam; public constructor Create(Value: Double); function GetAsString(Query: TBoldSQlQuery): String; override; @@ -171,7 +202,7 @@ TBoldSQLWCFFloat = class(TBoldSqlWCF) TBoldSQLWCFDate = class(TBoldSqlWCF) private fDate: TDateTime; - fParam:TParam; //<- Add param variable to avoid multiple create (HK) + fParam:TParam; public constructor Create(Value: TDateTime); function GetAsString(Query: TBoldSQlQuery): String; override; @@ -181,7 +212,7 @@ TBoldSQLWCFDate = class(TBoldSqlWCF) TBoldSQLWCFTime = class(TBoldSqlWCF) private fTime: TDateTime; - fParam:TParam; //<- Add param variable to avoid multiple create (HK) + fParam:TParam; public constructor Create(Value: TDateTime); function GetAsString(Query: TBoldSQlQuery): String; override; @@ -215,8 +246,7 @@ TBoldSQLWCFWithQuery = class(TBoldSqlWCF) fQuery: TBoldSQLQuery; protected function QueryAsString: String; - procedure CopyParams(Query: TBoldSQlQuery);//<- Provide a way to copy parameters (HK) - + procedure CopyParams(Query: TBoldSQlQuery); public constructor Create(query: TBoldSQLQuery); destructor Destroy; override; @@ -268,25 +298,25 @@ TBoldSQLWCFGenericExpression = class(TBoldSqlWCF) private fExpr: String; public - constructor Create(Expr: String); + constructor Create(const Expr: String); function GetAsString(Query: TBoldSQlQuery): String; override; end; { TBoldSQLNameSpace } - TBoldSQLNameSpace = class + TBoldSQLNameSpace = class(TBoldMemoryManagedObject) private fUsedNames: TStringList; fUsedParams: integer; public constructor Create; destructor Destroy; override; - function GetUnusedParamNumber: integer; + function GetUnusedParamNumber: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} - function GetUniqueAlias(TableName: String): String; + function GetUniqueAlias(const TableName: String): String; end; { TBoldSQLQuery } - TBoldSQLQuery = class + TBoldSQLQuery = class(TBoldMemoryManagedObject) private fMode: TBoldSQLQueryMode; fJoins: TBoldObjectArray; @@ -294,6 +324,9 @@ TBoldSQLQuery = class fSystemDescription: TBoldSQLSystemDescription; fColumnsToRetrieve: TBoldObjectArray; fColumnsToOrderBy: TBoldObjectArray; + fDistinct: Boolean; + fLimit: Integer; + fLimitTop: Boolean; fWhereClauseFragments: TBoldObjectArray; fParams: TParams; fRetrieveCountStar: Boolean; @@ -302,15 +335,14 @@ TBoldSQLQuery = class fMainTable: TBoldSqlTableReference; fIgnoreHistoricObjects: Boolean; fSQLDatabaseConfig: TBoldSQLDatabaseConfig; - function GetColumnToRetrieve(Index: Integer): TBoldSQLColumnReference; - function GetJoin(index: integer): TBoldSQLJoin; - function GetUniqueAlias(TableName: String): String; - function GetWCF(index: integer): TBoldSqlWCF; + function GetColumnToRetrieve(Index: Integer): TBoldSQLColumnReference; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetJoin(index: integer): TBoldSQLJoin; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetUniqueAlias(const TableName: String): String; + function GetWCF(index: integer): TBoldSqlWCF; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure GenerateSelect(Strings: TStrings); procedure EnsureTableExists(tableName, Operation: String); function GetAsString: string; protected - property TableReferences: TBoldSQLTableReferenceList read fTableReferences; property ColumnToRetrieve[Index: Integer]: TBoldSQLColumnReference read GetColumnToRetrieve; property Join[Index: integer]: TBoldSQLJoin read GetJoin; property WCF[index: integer]: TBoldSqlWCF read GetWCF; @@ -318,32 +350,36 @@ TBoldSQLQuery = class constructor Create(Mode: TBoldSQLQueryMode; SystemDescription: TBoldSQLSystemDescription; SQLDatabaseConfig: TBoldSQLDatabaseConfig; NameSpace: TBoldSqlNameSpace); destructor Destroy; override; function AddJoin(ColumnRef1, ColumnRef2: TBoldSQLColumnReference): TBoldSQLJoin; - function AddTableReference(TableName: String): TBoldSQLTableReference; + function AddTableReference(const TableName: String): TBoldSQLTableReference; procedure AddColumnToRetrieve(ColumnReference: TBoldSQLColumnReference); - procedure AddColumnToOrderBy(Columnreference: TBoldSQlColumnReference); + procedure AddColumnToOrderBy(Columnreference: TBoldSQlColumnReference; const + Descending: Boolean); procedure GenerateSQL(Strings: TStrings); - function AddParam(name: string=''): TParam; + function AddParam(const name: string=''): TParam; function HastableReferenceInList(TableReference: TBoldSQLTablereference): boolean; - procedure RetrieveCountStar; - procedure AddWCF(WCF: TBoldSqlWCF); - procedure ClearColumnsToRetrieve; + procedure RetrieveCountStar; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure AddWCF(WCF: TBoldSqlWCF); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure ClearColumnsToRetrieve; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetLimit(const Top: Boolean = True; const Limit: Integer = 1); property Mode: TBoldSQLQueryMode read fMode; property SystemDescription: TBoldSQLSystemDescription read fSystemDescription; property MainTable: TBoldSQLTableReference read fMaintable; property AsString: string read GetAsString; + property Distinct: Boolean read fDistinct write fDistinct; property SQLDatabaseConfig: TBoldSQLDatabaseConfig read fSQLDatabaseConfig; - property Params: TParams read fParams; //<- Expose params so we may Copy them to real Query (HK) + property Params: TParams read fParams; property IgnoreHistoricObjects: Boolean read fIgnoreHistoricObjects write fIgnoreHistoricObjects; + property TableReferences: TBoldSQLTableReferenceList read fTableReferences; end; { TBoldSqlTableReferenceList } TBoldSqlTableReferenceList = class(TBoldObjectArray) private - function Get(Index: Integer): TBoldSqlTableReference; - procedure Put(Index: Integer; const Value: TBoldSqlTableReference); + function Get(Index: Integer): TBoldSqlTableReference; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure Put(Index: Integer; const Value: TBoldSqlTableReference); {$IFDEF BOLD_INLINE} inline; {$ENDIF} public - function Add(Item: TBoldSqlTableReference): Integer; - procedure Insert(Index: Integer; Item: TBoldSqlTableReference); + function Add(Item: TBoldSqlTableReference): Integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure Insert(Index: Integer; Item: TBoldSqlTableReference); {$IFDEF BOLD_INLINE} inline; {$ENDIF} property Items[Index: Integer]: TBoldSqlTableReference read Get write Put; default; end; @@ -353,13 +389,18 @@ implementation BoldDefs, BoldPSDescriptionsDefault, SysUtils, - BoldUtils; + BoldIndex, +{$IFNDEF BOLD_UNICODE} + StringBuilder, +{$ENDIF} + BoldUtils, + BoldIndexableList; { TBoldSQLQuery } -function TBoldSQLQuery.AddTableReference(TableName: String): TBoldSQLTableReference; +function TBoldSQLQuery.AddTableReference(const TableName: String): TBoldSQLTableReference; var RootTable: TBoldSQLTableDescription; RootTableRef: TBoldSQLTableReference; @@ -368,7 +409,7 @@ function TBoldSQLQuery.AddTableReference(TableName: String): TBoldSQLTableRefere MyIdCol, RootIdCol, MyStartCol, RootStartCol: TBoldSQLColumnReference; begin - EnsureTableExists(TableName, 'AddTableReference'); // do not localize + EnsureTableExists(TableName, 'AddTableReference'); result := TBoldSQLTableReference.Create(self); Result.fTableDescription := SystemDescription.SQLTablesList.ItemsBySQLName[TableName]; @@ -404,13 +445,16 @@ constructor TBoldSQLQuery.Create(Mode: TBoldSQLQueryMode; SystemDescription: TBo fJoins := TBoldObjectArray.Create(0, [bcoDataOwner]); fTableReferences := TBoldSqlTableReferenceList.Create(0, [bcoDataOwner]); fColumnsToRetrieve := TBoldObjectArray.Create(0, []); - fColumnsToOrderBy := TBoldObjectArray.Create(0, []); + fColumnsToOrderBy := TBoldObjectArray.Create(0, [bcoDataOwner]); fSQLDatabaseConfig := SQLDatabaseConfig; fWhereClauseFragments := TBoldObjectArray.Create(0, [bcoDataOwner]); fSystemDescription := SystemDescription; fParams := TParams.Create; fNameSpace := nameSpace; fIgnoreHistoricObjects := true; + fDistinct := False; + fLimit := 0; + fLimitTop := True; end; destructor TBoldSQLQuery.Destroy; @@ -438,9 +482,49 @@ procedure TBoldSQLQuery.GenerateSQL(Strings: TStrings); {$HINTS ON} procedure TBoldSQLQuery.GenerateSelect(Strings: TStrings); + + procedure AddOrderByClause(const LimitTop: Boolean); + var + temp: string; + i: Integer; + OrderByInfo: TBoldSQLOrderByInfo; + begin + temp := ''; + if (fColumnsToOrderBy.Count = 0) and (fLimit > 0) then begin + // Use default sort on BOLD_ID column for limit, when no sort was spezified + if Assigned(MainTable) then begin + temp := MainTable.GetColumnReference(IDCOLUMN_NAME).PrefixedColumnName; + end else begin + temp := TableReferences[TableReferences.Count - 1].GetColumnReference(IDCOLUMN_NAME).PrefixedColumnName; + end; + if not LimitTop then begin + temp := temp + ' DESC'; // do not localize + end; + end; + + if (fColumnsToOrderBy.Count > 0) then begin + for i := 0 to fColumnsToOrderBy.Count - 1 do + begin + OrderByInfo := TBoldSQLOrderByInfo(fColumnsToOrderBy[i]); + if temp <> '' then + temp := temp + ', '; + temp := temp + OrderByInfo.Column.PrefixedColumnName; + // If last records are fetched (not LimitTop) then sorting must be reversed. + if not (OrderByInfo.Descending xor LimitTop) then begin + temp := temp + ' DESC'; // do not localize + end; + end; + end; + + if temp <> '' then begin + Strings.Add('ORDER BY ' + temp); // do not localize + end; + end; + + var - i, j: integer; temp: String; + i, j: integer; TempStringList: TStringList; PrefixOfNextWCF: string; PrevTable: String; @@ -453,9 +537,24 @@ procedure TBoldSQLQuery.GenerateSelect(Strings: TStrings); TempStringlist.Add(ColumnToRetrieve[i].PrefixedColumnName); if fGroupOperation <> '' then TempStringList[0] := fGroupOperation + '(' + TempStringList[0] + ')'; - if fRetrieveCountStar then - TempStringList.Add('COUNT(*)'); // do not localize - Strings.Add('SELECT ' + BoldSeparateStringList(tempStringList, ', ', '', '')); // do not localize + if fRetrieveCountStar then begin + if fDistinct and (TableReferences.Count > 0) then begin + // Use ID column of last added table als distinct column. + TempStringList.Add('COUNT(DISTINCT ' + + TableReferences[TableReferences.Count - 1].GetColumnReference( + IDCOLUMN_NAME).PrefixedColumnName + ')'); // do not localize + end else begin + TempStringList.Add('COUNT(*)'); // do not localize + end; + end; + temp := 'SELECT '; // do not localize + if fDistinct and (not fRetrieveCountStar) then begin + temp := temp + 'DISTINCT '; // do not localize + end; + if fLimit > 0 then begin + temp := temp + 'TOP ' + IntToStr(fLimit) + ' '; // do not localize + end; + Strings.Add(temp + BoldSeparateStringList(tempStringList, ', ', '', '')); PrefixOfNextWCF := 'WHERE'; // do not localize @@ -497,7 +596,7 @@ procedure TBoldSQLQuery.GenerateSelect(Strings: TStrings); end else temp := temp + format(' JOIN %s ON (%s)', [TableReferences[i].TableAliasDeclaration, cond]); // do not localize - end; + end; Strings.Add(temp); for i := 0 to UnprocessedJoins.Count - 1 do begin @@ -524,17 +623,22 @@ procedure TBoldSQLQuery.GenerateSelect(Strings: TStrings); Strings.Add(PrefixOfNextWCF + ' ' + TBoldSqlWCF(fWhereClauseFragments[i]).GetAsString(self)); PrefixOfNextWCF := ' AND'; // do not localize end; - temp := ''; - if fColumnsToOrderBy.Count > 0 then - begin - for i := 0 to fColumnsToOrderBy.Count - 1 do - begin - if temp <> '' then - temp := temp + ', '; - temp := temp + TBoldSQlColumnReference(fColumnsToOrderBy[i]).PrefixedColumnName; - end; - Strings.Add('ORDER BY ' + temp); // do not localize + + AddOrderByClause(fLimitTop); + + // The following must be done last! + // Special case, when multiple last records are to be selected: + // Through the reversed sort the result set has the wanted records, + // but in reverse order. (Theoretcal problem, because Limit is 1 on ->first/last) + // Therefore original order must be restored: + if (not fLimitTop) and (fLimit > 1) then begin + Strings.Insert(0, 'SELECT * FROM ('); + // SubSelect must be provided with Alias, + // otherwise its not possible to resort the outer select. + Strings.Add(') AS ReverseOrderSelect'); + AddOrderByClause(True); end; + TempStringList.Free; end; @@ -554,7 +658,7 @@ function TBoldSQLQuery.GetColumnToRetrieve(Index: Integer): TBoldSQLColumnRefere result := TBoldSQLColumnReference(fColumnsToRetrieve[index]); end; -function TBoldSQLQuery.GetUniqueAlias(TableName: String): String; +function TBoldSQLQuery.GetUniqueAlias(const TableName: String): String; var i, Counter: Integer; OK: Boolean; @@ -613,7 +717,7 @@ function TBoldSQLQuery.GetWCF(index: integer): TBoldSqlWCF; result := TBoldSqlWCF(fWhereClauseFragments[index]); end; -function TBoldSQLQuery.AddParam(name: string=''): TParam; +function TBoldSQLQuery.AddParam(const name: string=''): TParam; begin result := fParams.Add as tParam; if Name = '' then @@ -650,9 +754,16 @@ function TBoldSQLQuery.HastableReferenceInList( result := fTableReferences.IndexOf(TableReference) <> -1; end; +procedure TBoldSQLQuery.SetLimit(const Top: Boolean = True; const Limit: + Integer = 1); +begin + fLimit := Limit; + fLimitTop := Top; +end; + { TBoldSQLTableReference } -function TBoldSQLTableReference.GetColumnReference(ColumnName: String): TBoldSQLColumnReference; +function TBoldSQLTableReference.GetColumnReference(const ColumnName: String): TBoldSQLColumnReference; var i: integer; begin @@ -680,7 +791,7 @@ destructor TBoldSQLTableReference.Destroy; inherited; end; -procedure TBoldSQLTableReference.EnsureColumnExists(ColumnName, +procedure TBoldSQLTableReference.EnsureColumnExists(const ColumnName, Operation: String); begin if not assigned(TableDescription.ColumnsList.ItemsBySQLName[ColumnName]) then @@ -713,6 +824,15 @@ function TBoldSQLColumnReference.GetPrefixedColumnName: String; result := format('%s.%s', [TableReference.AliasName, ColumnDescription.SQLName]) // do not localize end; +{ TBoldSQLOrderByInfo } + +constructor TBoldSQLOrderByInfo.Create(Column: TBoldSQLColumnReference; + const Descending: Boolean); +begin + FColumn := Column; + FDescending := Descending; +end; + { TBoldSQLJoin } constructor TBoldSQLJoin.Create(ColumnRef1, ColumnRef2: TBoldSqlColumnReference); @@ -772,7 +892,7 @@ procedure TBoldSqlTableReferenceList.Put(Index: Integer; { TBoldSQLWCFBinary } -constructor TBoldSQLWCFBinary.Create(arg1, arg2: TBoldSqlWCF; Symbol: String); +constructor TBoldSQLWCFBinary.Create(arg1, arg2: TBoldSqlWCF; const Symbol: String); begin inherited Create; fArg1 := Arg1; @@ -791,7 +911,21 @@ destructor TBoldSQLWCFBinary.destroy; function TBoldSQLWCFBinaryInfix.GetAsString(Query: TBoldSQlQuery): String; begin - result := '(' + fArg1.GetAsString(Query) + ' ' + fSymbol + ' ' + fArg2.GetAsString(Query) + ')'; + Result := '('; + if Assigned(fArg1) then begin + Result := Result + fArg1.GetAsString(Query) + ' '; + end; + if Assigned(fArg1) and Assigned(fArg2) then begin + Result := Result + fSymbol; + end; + if Assigned(fArg2) then begin + Result := Result + ' ' + fArg2.GetAsString(Query); + end; + // Add the escape character to use % and _ ( and [ ) within a search. + if SameStr(fSymbol, 'LIKE') then begin + Result := Result + ' ESCAPE ''\'''; + end; + Result := Result + ')'; end; class function TBoldSQLWCFBinaryInfix.CreateWCFForIdList( @@ -825,9 +959,31 @@ function TBoldSQLWCFBinaryPrefix.GetAsString(Query: TBoldSQlQuery): String; result := '(' + fSymbol + '(' + fArg1.GetAsString(Query) + ', ' + fArg2.GetAsString(Query) + '))'; end; +{ TBoldSQLWCFXOR } + +constructor TBoldSQLWCFXOR.Create(arg1, arg2: TBoldSqlWCF); +begin + inherited Create; + fArg1 := Arg1; + fArg2 := Arg2; +end; + +function TBoldSQLWCFXOR.GetAsString(Query: TBoldSQlQuery): String; +begin + Result := '('; + if Assigned(fArg1) and Assigned(fArg2) then begin + Result := Result + Format('(%s AND NOT %s) or (%1:s AND NOT %0:s)', + [fArg1.GetAsString(Query), + fArg2.GetAsString(Query)]); + end else begin + Result := Result + 'FALSE'; // This case does not exist + end; + Result := Result + ')'; +end; + { TBoldSQLWCFString } -constructor TBoldSQLWCFString.Create(Value: String); +constructor TBoldSQLWCFString.Create(const Value: String); begin fStr := Value; end; @@ -962,8 +1118,11 @@ constructor TBoldSQLWCFInQuery.create(Arg1: TBoldSqlWCF; destructor TBoldSQLWCFInQuery.destroy; begin // a workaround, the In-condition does not really own its query - fQuery := nil; + // -> No, not a workaroung, but a memory leak! + // -> TBoldSQLWCFInQuery is used only in 2 places, and there the query is not freed. +// fQuery := nil; + freeAndNil(fArg1); inherited; freeAndNil(fArg1); end; @@ -976,7 +1135,7 @@ function TBoldSQLWCFInQuery.GetAsString(Query: TBoldSQlQuery): String; { TBoldSQLWCFGenericExpression } -constructor TBoldSQLWCFGenericExpression.Create(Expr: String); +constructor TBoldSQLWCFGenericExpression.Create(const Expr: String); begin fExpr := Expr; end; @@ -1085,7 +1244,7 @@ destructor TBoldSQLNameSpace.destroy; inherited; end; -function TBoldSQLNameSpace.GetUniqueAlias(TableName: String): String; +function TBoldSQLNameSpace.GetUniqueAlias(const TableName: String): String; var i: integer; begin @@ -1097,9 +1256,10 @@ function TBoldSQLNameSpace.GetUniqueAlias(TableName: String): String; fUsedNames.Add(result); end; -procedure TBoldSQLQuery.AddColumnToOrderBy(Columnreference: TBoldSQlColumnReference); +procedure TBoldSQLQuery.AddColumnToOrderBy(Columnreference: + TBoldSQlColumnReference; const Descending: Boolean); begin - fColumnsToOrderBy.Add(ColumnReference); + fColumnsToOrderBy.Add(TBoldSQLOrderByInfo.Create(ColumnReference, Descending)); end; function TBoldSQLNameSpace.GetUnusedParamNumber: integer; @@ -1140,5 +1300,33 @@ function TBoldSQLWCFTime.GetAsString(Query: TBoldSQlQuery): String; result := ':' + fParam.Name; end; -end. + +{ TBoldSQLWCFUnaryTransforLikeString } + +function TBoldSQLWCFUnaryTransformLikeString.GetAsString( + Query: TBoldSQlQuery): String; +var + SB: TStringBuilder; + Ch: Char; +begin + Result := fArg1.GetAsString(Query); + if true or Query.SQLDatabaseConfig.QuoteLeftBracketInLike then + begin + Sb := TStringBuilder.Create(Length(Result)+10); + try + for Ch in Result do + if Ch = '[' then + SB.Append('[[]') + else + SB.Append(Ch); + Result := SB.ToString; + finally + sb.free; + end; + end; +end; + +initialization + +end. diff --git a/Source/PMapper/SQL/BoldSqlNodeMaker.pas b/Source/PMapper/SQL/BoldSqlNodeMaker.pas index b700fef5..aeced272 100644 --- a/Source/PMapper/SQL/BoldSqlNodeMaker.pas +++ b/Source/PMapper/SQL/BoldSqlNodeMaker.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSqlNodeMaker; interface @@ -43,7 +46,8 @@ implementation uses Classes, - SysUtils; + SysUtils, + BoldRev; { TBoldSqlNodeMaker } @@ -59,20 +63,18 @@ destructor TBoldSqlNodeMaker.destroy; var i: integer; begin - // simply let go of all the OLWVarBindings, they will be owned by the condition. for i := fOLWVarBindings.Count-1 downto 0 do fOLWVarBindings[i] := nil; FreeAndNil(fOLWVarBindings); for i := fSQLVarBindings.Count-1 downto 0 do begin - // external variables should be freed, internal should just be removed, they will be freed by the rootnode. if TBoldSqlVariableBinding(fSQLVarBindings[i]).IsExternal then TBoldSqlVariableBinding(fSQLVarBindings[i]).Free; fSQLVarBindings[i] := nil; end; FreeAndNil(fSqlVarbindings); - + FreeAndNil(fRootNode); inherited; end; @@ -85,7 +87,7 @@ function TBoldSqlNodeMaker.SQLBindingForVarBinding( begin result := nil; for i := 0 to fOLWVarBindings.Count-1 do - if (fOLWVarBindings[i] as TBoldOLWVariableBinding).variablename = VarBinding.VariableName then + if CompareText((fOLWVarBindings[i] as TBoldOLWVariableBinding).variablename, VarBinding.VariableName) = 0 then begin result := TBoldSQLVariableBinding(fSqlVarBindings[i]); break; @@ -95,7 +97,7 @@ function TBoldSqlNodeMaker.SQLBindingForVarBinding( procedure TBoldSqlNodeMaker.VisitTBoldOLWEnumLiteral(N: TBoldOLWEnumLiteral); begin - fRootNode := TBoldSqlEnumLiteral.create(n.Position, n.name); + fRootNode := TBoldSqlEnumLiteral.create(n.Position, n.Intvalue, n.name); end; procedure TBoldSqlNodeMaker.VisitTBoldOLWIntLiteral(N: TBoldOLWIntLiteral); @@ -126,7 +128,6 @@ procedure TBoldSqlNodeMaker.VisitTBoldOLWListCoercion(N: TBoldOLWListCoercion); procedure TBoldSqlNodeMaker.VisitTBoldOLWLiteral(N: TBoldOLWLiteral); begin - // Abstract class end; procedure TBoldSqlNodeMaker.VisitTBoldOLWMember(N: TBoldOLWMember); @@ -151,7 +152,6 @@ procedure TBoldSqlNodeMaker.VisitTBoldOLWMember(N: TBoldOLWMember); procedure TBoldSqlNodeMaker.VisitTBoldOLWNode(N: TBoldOLWNode); begin - // abstract class end; procedure TBoldSqlNodeMaker.VisitTBoldOLWFloatLiteral(N: TBoldOLWFloatLiteral); @@ -196,7 +196,7 @@ procedure TBoldSqlNodeMaker.VisitTBoldOLWVariableBinding(N: TBoldOLWVariableBind begin varBind := nil; for i := 0 to SQLVarBindings.Count-1 do - if ((SQLVarBindings[i] as TBoldSqlVariableBinding).VariableName = n.variableName) then + if CompareText((SQLVarBindings[i] as TBoldSqlVariableBinding).VariableName, n.variableName) = 0 then VarBind := SQLVarBindings[i] as TBoldSqlVariableBinding; if not assigned(VarBind) then diff --git a/Source/PMapper/SQL/BoldSqlNodes.pas b/Source/PMapper/SQL/BoldSqlNodes.pas index a81431e2..b0e78f10 100644 --- a/Source/PMapper/SQL/BoldSqlNodes.pas +++ b/Source/PMapper/SQL/BoldSqlNodes.pas @@ -1,9 +1,14 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSqlNodes; interface + uses DB, Classes, + BoldBase, BoldPSDescriptionsSQL, BoldPMappersSQL, BoldSqlQuery, @@ -51,27 +56,27 @@ TBoldSqlNodeVisitor = class(TObject) TBoldSqlNodeList = class(TList) private - function GetItem(index: Integer): TBoldSqlNode; - procedure PutItem(index: Integer; Value: TBoldSqlNode); + function GetItem(index: Integer): TBoldSqlNode; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure PutItem(index: Integer; Value: TBoldSqlNode); {$IFDEF BOLD_INLINE} inline; {$ENDIF} public destructor Destroy; override; - function Add(Item: TBoldSqlNode): Integer; + function Add(Item: TBoldSqlNode): Integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure TraverseList(V: TBoldSqlNodeVisitor); virtual; property Items[index: Integer]: TBoldSqlNode read GetItem write PutItem; default; end; - TBoldSqlNode = class(TObject) + TBoldSqlNode = class(TBoldMemoryManagedObject) private fPosition: integer; fObjectMapper: TBoldObjectSQLMapper; fTableReferences: TBoldSqlTableReferenceList; fWCF: TBoldSqlWCF; fQuery: TBoldSqlQuery; - function GetHasObjectMapper: Boolean; - function GetHasQuery: boolean; + function GetHasObjectMapper: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetTableReferences: TBoldSqlTableReferenceList; virtual; protected + function GetHasQuery: boolean; virtual; function GetQuery: TBoldSqlQuery; virtual; function GetObjectMapper: TBoldObjectSQLMapper; virtual; procedure SetObjectMapper(const Value: TBoldObjectSQLMapper); virtual; @@ -152,7 +157,7 @@ TBoldSqlMember = class(TBoldSqlNode) fMemberMapper: TBoldMemberSQLMapper; fIsBoolean: Boolean; public - constructor Create(Position: integer; memberName: String; MemberIndex: Integer; MemberOf: TBoldSqlNode; IsBoolean: Boolean); + constructor Create(Position: integer; const memberName: String; MemberIndex: Integer; MemberOf: TBoldSqlNode; IsBoolean: Boolean); destructor Destroy; override; function TableReferenceForTable(Table: TBoldSqlTableDescription; Query: TBoldSqlQuery; ForceOwnTable: Boolean): TBoldSqlTableReference; override; procedure AcceptVisitor(V: TBoldSqlNodeVisitor); override; @@ -191,6 +196,7 @@ TBoldSqlVariableReference = class(TBoldSqlNode) fVariableBinding: TBoldSqlVariableBinding; function GetTableReferences: TBoldSqlTableReferenceList; override; protected + function GetHasQuery: boolean; override; function GetQuery: TBoldSqlQuery; override; function GetObjectMapper: TBoldObjectSQLMapper; override; procedure SetObjectMapper(const Value: TBoldObjectSQLMapper); override; @@ -277,13 +283,13 @@ TBoldSqlEnumLiteral = class(TBoldSqlLiteral) protected function GetAsString: String; override; public - constructor Create(Position: integer; Name: String); + constructor Create(Position, IntValue: integer; Name: String); property Name: string read fName; property Intvalue: integer read fIntValue write fIntvalue; procedure AcceptVisitor(V: TBoldSqlNodeVisitor); override; end; - TBoldSqlSymbol = class + TBoldSqlSymbol = class(TBoldMemoryManagedObject) protected function GetName: String; virtual; abstract; function GetSQLName: String; virtual; @@ -294,7 +300,7 @@ TBoldSqlSymbol = class property SQLName: String read GetSQLName; end; - TBoldSQLWCFVariable = class(TBoldSqlWCF) //<- New WCFclass to handle variables (HK) + TBoldSQLWCFVariable = class(TBoldSqlWCF) private fParam:TParam; fVariableBinding:TBoldSqlVariableBinding; @@ -302,7 +308,7 @@ TBoldSQLWCFVariable = class(TBoldSqlWCF) //<- New WCFclass to handle constructor Create(VariableBinding: TBoldSqlVariableBinding); function GetAsString(Query: TBoldSQlQuery): String; override; destructor Destroy;override; - end; //<- End (HK) + end; implementation @@ -310,7 +316,6 @@ implementation uses SysUtils, BoldDefs, - BoldPMConsts, BoldSQLMappingInfo, BoldPMappersDefault; @@ -340,10 +345,9 @@ constructor TBoldSqlOperation.create(Position: integer; OperationName: String); destructor TBoldSqlOperation.Destroy; begin FreeAndNil(fArgs); - inherited; + inherited; end; - { TBoldSqlNode } procedure TBoldSqlNode.AcceptVisitor(V: TBoldSqlNodeVisitor); @@ -360,10 +364,10 @@ constructor TBoldSqlNode.Create(Position: integer); destructor TBoldSqlNode.destroy; begin - inherited; FreeAndNil(fTableReferences); FreeAndNil(fWCF); FreeAndNil(fQuery); + inherited; end; function TBoldSqlNode.GetHasObjectMapper: Boolean; @@ -418,11 +422,12 @@ procedure TBoldSqlNode.CopyTableReferences(node: TBoldSqlNode); fTableReferences.Add(Node.GetTableReferences[i]); end; + procedure TBoldSqlNode.SetObjectMapper(const Value: TBoldObjectSQLMapper); begin fObjectmapper := Value; if HasObjectMapper and (length(ObjectMapper.SystemPersistenceMapper.MappingInfo.GetAllInstancesMapping(ObjectMapper.ExpressionName)) > 1) then - raise EBold.CreateFmt(sChildMappedClassesNotSupported, [ObjectMapper.ExpressionName]); + raise EBold.Create('ChildMapped classes not supported: '+ObjectMapper.ExpressionName); end; procedure TBoldSqlNode.SetQuery(const Value: TBoldSqlQuery); @@ -430,6 +435,7 @@ procedure TBoldSqlNode.SetQuery(const Value: TBoldSqlQuery); fQuery := Value; end; + function TBoldSqlNode.TableReferenceForTable(Table: TBoldSQLTableDescription; Query: TBoldSqlQuery; ForceOwntable: Boolean): TBoldSqlTableReference; var i: integer; @@ -448,8 +454,6 @@ function TBoldSqlNode.TableReferenceForTable(Table: TBoldSQLTableDescription; Qu if assigned(ObjectMapper) and (ObjectMapper.AllTables.IndexOf(Table) = -1) then raise EBoldInternal.createFmt('Table %s does not belong to class %s', [Table.SQLName, ObjectMapper.ExpressionName]); - // if the table reference has been used before, by the same query, then reuse it. - for i := 0 to fTableReferences.Count-1 do if (fTablereferences[i].TableDescription = Table) and Query.HastableReferenceInList(fTablereferences[i]) then @@ -475,8 +479,8 @@ function TBoldSqlNode.TableReferenceForTable(Table: TBoldSQLTableDescription; Qu TypeIDWCF := TBoldSQLWCFGenericExpression.Create('('+(ObjectMapper as TBoldObjectDefaultMapper).SubClassesID+')'); TypeColRef := Result.GetColumnReference(TYPECOLUMN_NAME); TypeColRefWCF := TBoldSQLWCFColumnRef.Create(TypeColRef); - TypeWCF := TBoldSQLWCFBinaryInfix.Create(TypeColRefWCF, TypeIDWCF, 'IN'); // do not localize - Query.AddWCF(TypeWCF); // ensures the maintable as first table; + TypeWCF := TBoldSQLWCFBinaryInfix.Create(TypeColRefWCF, TypeIDWCF, 'IN'); + Query.AddWCF(TypeWCF); end; end; end; @@ -550,8 +554,8 @@ constructor TBoldSqlIteration.Create(Position: integer; OperationName: String; L destructor TBoldSqlIteration.Destroy; begin - inherited; FreeandNil(fLoopVar); + inherited; end; function TBoldSqlIteration.TableReferenceForTable( @@ -570,7 +574,7 @@ procedure TBoldSqlMember.AcceptVisitor(V: TBoldSqlNodeVisitor); v.VisitTBoldSqlMember(self); end; -constructor TBoldSqlMember.Create(Position: integer; memberName: String; MemberIndex: Integer; MemberOf: TBoldSqlNode; IsBoolean: Boolean); +constructor TBoldSqlMember.Create(Position: integer; const memberName: String; MemberIndex: Integer; MemberOf: TBoldSqlNode; IsBoolean: Boolean); begin inherited Create(Position); fMemberName := memberName; @@ -588,7 +592,6 @@ destructor TBoldSqlMember.Destroy; end; function TBoldSqlMember.QueryOfMemberOfIsEnclosing: Boolean; -// Checks if the query of the memberOf-node will enclose this node, or if we can steal it. begin result := (MemberOf is TBoldSQLVariableReference) and (MemberOf as TBoldSQLVariableReference).VariableBinding.IsLoopVar; @@ -646,13 +649,15 @@ procedure TBoldSqlVariableBinding.AcceptVisitor(V: TBoldSqlNodeVisitor); v.VisitTBoldSqlVariableBinding(self); end; + procedure TBoldSqlVariableBinding.AddRef; begin inc(fRefCount); if (fRefCount > 1) and not fIsLoopVar then - raise EBold.Create(sExternalVarsCanOnlyBereferencedOnce); + raise EBold.Create('external variables (and self) can currently only be referenced once'); end; + constructor TBoldSqlVariableBinding.Create(Position: integer; VariableName: String; TopSortedIndex: integer); begin inherited Create(Position); @@ -660,6 +665,7 @@ constructor TBoldSqlVariableBinding.Create(Position: integer; VariableName: Stri fTopSortedIndex := TopSortedIndex; end; + { TBoldSqlStrLiteral } procedure TBoldSqlStrLiteral.AcceptVisitor(V: TBoldSqlNodeVisitor); @@ -667,6 +673,7 @@ procedure TBoldSqlStrLiteral.AcceptVisitor(V: TBoldSqlNodeVisitor); v.VisitTBoldSqlStrLiteral(self); end; + constructor TBoldSqlStrLiteral.Create(Position: integer; StrValue: String); begin inherited Create(Position); @@ -771,6 +778,15 @@ constructor TBoldSqlVariableReference.Create(Position: integer; VariableBinding: fVariableBinding := VariableBinding; end; +function TBoldSqlVariableReference.GetHasQuery: boolean; +begin + if VariableBinding.IsLoopVar then begin + Result := inherited GetHasQuery; + end else begin + Result := VariableBinding.HasQuery; + end; +end; + function TBoldSqlVariableReference.GetObjectMapper: TBoldObjectSQLMapper; begin result := VariableBinding.ObjectMapper; @@ -783,7 +799,7 @@ function TBoldSqlVariableReference.GetQuery: TBoldSqlQuery; function TBoldSqlVariableReference.RelinquishWCF: TBoldSqlWCF; begin - result := TBoldSQLWCFVariable.Create(VariableBinding); //<- Use new WCF class for variables (HK) + result := TBoldSQLWCFVariable.Create(VariableBinding); end; function TBoldSqlVariableReference.RelinquishQuery: TBoldSqlQuery; @@ -841,9 +857,11 @@ destructor TBoldSqlListCoercion.destroy; inherited; end; -constructor TBoldSqlEnumLiteral.Create(Position: integer; Name: String); +constructor TBoldSqlEnumLiteral.Create(Position, IntValue: integer; Name: + String); begin inherited Create(Position); + fIntValue := IntValue; fName := Name; end; @@ -917,9 +935,6 @@ function TBoldSqlSymbol.ResolveObjectMapper(OperationNode: TBoldSqlOperation): T end; { TBoldSQLWCFVariable } - - -//<- Implement new WCFclass for variables (HK) constructor TBoldSQLWCFVariable.Create( VariableBinding: TBoldSqlVariableBinding); begin @@ -940,7 +955,6 @@ function TBoldSQLWCFVariable.GetAsString(Query: TBoldSQlQuery): String; fParam.Value:=fVariableBinding.ExternalVarValue; result := ':'+fParam.Name; end; -//<- END (HK) { TBoldSqlDateLiteral } diff --git a/Source/PMapper/SQL/BoldSqlNodesResolver.pas b/Source/PMapper/SQL/BoldSqlNodesResolver.pas index 3a901cbc..ddf67268 100644 --- a/Source/PMapper/SQL/BoldSqlNodesResolver.pas +++ b/Source/PMapper/SQL/BoldSqlNodesResolver.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSqlNodesResolver; interface @@ -19,6 +22,7 @@ TBoldSqlNodeResolver = class(TBoldSqlNodeVisitor) fRootNode: TBoldSQLNode; fExternalVariables: TBoldSQLNodeList; protected + function FindSymbolByName(const Name: string): TBSS_Symbol; procedure VisitTBoldSqlNode(N: TBoldSqlNode); override; procedure VisitTBoldSqlListCoercion(N: TBoldSqlListCoercion); override; procedure VisitTBoldSqlOperation(N: TBoldSqlOperation); override; @@ -44,7 +48,10 @@ implementation uses SysUtils, BoldUtils, - BoldPMappersLinkDefault; + BoldPMappersLinkDefault, + BoldPMappers, + BoldIndex, + BoldIndexableList; { TBoldSqlNodeResolver } @@ -67,6 +74,11 @@ procedure TBoldSqlNodeResolver.Execute; fRootNode.AcceptVisitor(self); end; +function TBoldSqlNodeResolver.FindSymbolByName(const Name: string): TBSS_Symbol; +begin + result := SqlSymbolDictionary.SymbolByName[Name]; +end; + procedure TBoldSqlNodeResolver.VisitTBoldSqlDateLiteral( N: TBoldSqlDateLiteral); begin @@ -114,8 +126,17 @@ procedure TBoldSqlNodeResolver.VisitTBoldSqlLiteral(N: TBoldSqlLiteral); procedure TBoldSqlNodeResolver.VisitTBoldSqlMember(N: TBoldSqlMember); begin n.MemberOf.AcceptVisitor(self); - - n.MemberMapper := n.MemberOf.ObjectMapper.MemberPersistenceMappers[n.MemberOf.ObjectMapper.MemberMapperIndexByMemberIndex[n.MemberIndex]] as TBoldMemberSQLMapper; + try + n.MemberMapper := n.MemberOf.ObjectMapper.MemberPersistenceMappers[n.MemberOf.ObjectMapper.MemberMapperIndexByMemberIndex[n.MemberIndex]] as TBoldMemberSQLMapper; + except + on EAssertionFailed do + begin + if not n.MemberOf.HasObjectMapper then + raise EBold.CreateFmt('ObjectMapper not found for member ''%s'', possibly due to unsupported combination of child/parent mapping.', [n.MemberName]) + else + raise; + end; + end; if n.MemberMapper is TBoldLinkDefaultMapper then n.ObjectMapper := (n.MemberMapper as TBoldLinkDefaultMapper).OtherEndObjectMapper; @@ -130,8 +151,12 @@ procedure TBoldSqlNodeResolver.VisitTBoldSqlOperation(N: TBoldSqlOperation); if n.ClassType = TBoldSQLOperation then begin n.Symbol := FindSymbolByName(n.OperationName); + if not Assigned(n.Symbol) then + raise EBold.CreateFmt('InPs SQLSymbol ''%s'' not found, possibly not available for InPs evaluation.', [n.OperationName]); n.Args.TraverseList(self); n.ObjectMapper := n.Symbol.ResolveObjectMapper(n); + if not n.HasObjectMapper then + n.ObjectMapper := n.Symbol.ResolveObjectMapper(n); end; end; diff --git a/Source/PMapper/SQL/BoldSqlQueryGenerator.pas b/Source/PMapper/SQL/BoldSqlQueryGenerator.pas index c5a708bb..b14bc9c9 100644 --- a/Source/PMapper/SQL/BoldSqlQueryGenerator.pas +++ b/Source/PMapper/SQL/BoldSqlQueryGenerator.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSqlQueryGenerator; interface @@ -44,7 +47,8 @@ implementation BoldPMappersSQL, BoldPmappersDefault, BoldPMappersLinkDefault, - BoldPMappersAttributeDefault; + BoldPMappersAttributeDefault, + BoldRev; { TBoldSqlQueryGenerator } @@ -120,7 +124,6 @@ procedure TBoldSqlQueryGenerator.HandleRelation(N: TBoldSqlMember); if (n.MemberMapper is TBoldEmbeddedSingleLinkDefaultMapper) then begin - // embedded Singlelinks LastJoinLeftColumn := n.MemberMapper.ColumnDescriptions[0] as TBoldSQLColumnDescription; TableForLastJoinLeft := n.MemberOf.TableReferenceForTable(LastJoinLeftColumn.TableDescription, n.Query, true); n.Query.AddJoin(n.MainTableRef.GetColumnReference(IDCOLUMN_NAME), TableForLastJoinLeft.GetColumnReference(LastJoinLeftColumn.SQLName)); @@ -130,7 +133,6 @@ procedure TBoldSqlQueryGenerator.HandleRelation(N: TBoldSqlMember); LinkMapper := n.MemberMapper as TBoldNonEmbeddedLinkDefaultMapper; if LinkMapper.IsIndirect then begin - // Nonembedded Indirect links TableRefForLink := n.Query.AddTableReference(LinkMapper.LinkClassTableName); n.Query.AddJoin(TablerefForlink.GetColumnReference(LInkMapper.ClosestColumnName), @@ -141,7 +143,6 @@ procedure TBoldSqlQueryGenerator.HandleRelation(N: TBoldSqlMember); end else begin - // Nonembedded Direct links n.Query.AddJoin( n.MainTableRef.GetColumnReference(LinkMapper.ClosestColumnName), n.MemberOf.MainTableRef(n.Query).GetColumnReference(IDCOLUMN_NAME)); @@ -162,11 +163,10 @@ procedure TBoldSqlQueryGenerator.HandleAttribute(N: TBoldSqlMember); ColumnRef := TableRef.GetColumnReference(MainColumn.SQlName); if n.isBoolean and (n.MemberMapper is TBoldPMInteger) then begin - // "boolattr = 1" WCF := TBoldSQLWCFBinaryInfix.Create( TBoldSQLWCFColumnRef.Create(ColumnRef), TBoldSQLWCFInteger.Create(1), '='); - + if not n.QueryOfMemberOfIsEnclosing then begin Query := n.MemberOf.RelinquishQuery; @@ -239,6 +239,6 @@ procedure TBoldSqlQueryGenerator.VisitTBoldSqlTimeLiteral( n.WCF := TBoldSQLWCFTime.Create(n.TimeValue); end; -end. - +initialization +end. diff --git a/Source/PMapper/SQL/BoldSqlSymbols.pas b/Source/PMapper/SQL/BoldSqlSymbols.pas index a213f756..f4fcbc68 100644 --- a/Source/PMapper/SQL/BoldSqlSymbols.pas +++ b/Source/PMapper/SQL/BoldSqlSymbols.pas @@ -1,10 +1,12 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSqlSymbols; interface uses - BoldPMappersSql, - BoldSQLQuery, + BoldIndexableList, BoldSqlNodes; type @@ -13,6 +15,80 @@ TBSS_Symbol = class(TBoldSqlSymbol) function GetName: String; override; end; + {---TBoldSymbolDictionary---} + TBoldSqlSymbolDictionary = class(TBoldIndexableList) + private + function GetSymbol(const Name: string): TBSS_Symbol; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetSymbolByIndex(index: Integer): TBSS_Symbol; + class var IX_SymbolName: integer; + public + constructor Create(); + property SymbolByName[const name: string]: TBSS_Symbol read GetSymbol; + property Symbols[i: Integer]: TBSS_Symbol read GetSymbolByIndex; default; + end; + +function SqlSymbolDictionary: TBoldSqlSymbolDictionary; + +implementation + +uses + BoldPMappersSql, + BoldSQLQuery, + BoldHashIndexes, + BoldPMappersDefault, + SysUtils, + BoldDefs, + BoldContainers, + BoldPSDescriptionsSQL, BoldPMappersLinkDefault; + +var + SqlSymbols: TBoldSqlSymbolDictionary; + +type + {---TSymbolNameIndex---} + TSymbolNameIndex = class(TBoldStringHashIndex) + protected + function ItemAsKeyString(Item: TObject): string; override; + end; + +function SqlSymbolDictionary: TBoldSqlSymbolDictionary; +begin + result := SqlSymbols; +end; + + {---TSymbolNameIndex---} +function TSymbolNameIndex.ItemAsKeyString(Item: TObject): string; +begin + Result := TBSS_Symbol(Item).Name; +end; + +{ TBSS_Symbol } + +function TBSS_Symbol.GetName: String; +begin + result := copy(ClassName, 6, maxint); +end; + +{ TBoldSqlSymbolDictionary } + +constructor TBoldSqlSymbolDictionary.Create(); +begin + inherited create; + SetIndexCapacity(1); + SetIndexVariable(IX_SymbolName, AddIndex(TSymbolNameIndex.Create)); +end; + +function TBoldSqlSymbolDictionary.GetSymbol(const Name: string): TBSS_Symbol; +begin + Result := TBSS_Symbol(TBoldStringHashIndex(indexes[IX_SymbolName]).FindByString(Name)); +end; + +function TBoldSqlSymbolDictionary.GetSymbolByIndex(index: Integer): TBSS_Symbol; +begin + Result := TBSS_Symbol(Items[index]); +end; + +type TBSS_BinarySymbol = class(TBSS_Symbol) protected procedure ConvertQueryToWCF(SourceNode, DestNode: TBoldSqlNode); @@ -51,12 +127,14 @@ TBSS_LessEQ = class(TBSS_BinaryBooleanSymbol) end; TBSS_GreaterEQ = class(TBSS_BinaryBooleanSymbol) - protected function GetName: String; override; + protected + function GetName: String; override; end; TBSS_SQLLike = class(TBSS_BinarySymbol) protected function GetSQLName: String; override; + procedure BuildWCFOrQuery(OperationNode: TBoldSQLOperation; NameSpace: TBoldSqlNameSpace); override; end; TBSS_SQLLikeCaseInsensitive = class(TBSS_SQLLike) @@ -126,14 +204,14 @@ TBSS_Floor = class(TBSS_UnarySymbol) TBSS_Round = class(TBSS_UnarySymbol) end; - TBSS_ToUpper = class(TBSS_Symbol) + TBSS_ToUpper = class(TBSS_UnarySymbol) protected function GetSQLName: String; override; public procedure BuildWCFOrQuery(OperationNode: TBoldSQLOperation; NameSpace: TBoldSqlNameSpace); override; end; - TBSS_toLower = class(TBSS_Symbol) + TBSS_toLower = class(TBSS_UnarySymbol) protected function GetSQLName: String; override; public @@ -235,6 +313,8 @@ TBSS_includes = class(TBSS_Symbol) end; TBSS_Length = class(TBSS_UnarySymbol) + protected + function GetSQLName: String; override; end; TBSS_ListOperations = class(TBSS_Symbol) @@ -280,12 +360,52 @@ TBSS_OclAsType = class(TBSS_Symbol) procedure BuildWCFOrQuery(OperationNode: TBoldSQLOperation; NameSpace: TBoldSqlNameSpace); override; end; + TBSS_SafeCast = class(TBSS_OclAsType); + TBSS_FilterOnType = class(TBSS_Symbol) public function ResolveObjectMapper(OperationNode: TBoldSqlOperation): TBoldObjectSqlMapper; override; procedure BuildWCFOrQuery(OperationNode: TBoldSQLOperation; NameSpace: TBoldSqlNameSpace); override; end; + TBSS_AsSet = class(TBSS_Symbol) + public + procedure BuildWCFOrQuery(OperationNode: TBoldSQLOperation; NameSpace: + TBoldSqlNameSpace); override; + function ResolveObjectMapper(OperationNode: TBoldSqlOperation): + TBoldObjectSqlMapper; override; + end; + + TBSS_First = class(TBSS_Symbol) + protected + function IsTopLimit: Boolean; virtual; + public + procedure BuildWCFOrQuery(OperationNode: TBoldSQLOperation; NameSpace: + TBoldSqlNameSpace); override; + end; + + TBSS_Last = class(TBSS_First) + protected + function IsTopLimit: Boolean; override; + end; + + TBSS_BoldId = class(TBSS_Symbol) + public + procedure BuildWCFOrQuery(OperationNode: TBoldSQLOperation; NameSpace: TBoldSqlNameSpace); override; + end; + +type + TBSS_BoldIDIs = class(TBSS_BinarySymbol) + public + procedure BuildWCFOrQuery(OperationNode: TBoldSQLOperation; NameSpace: TBoldSqlNameSpace); override; + end; + +type + TBSS_BoldIDIn = class(TBSS_BinarySymbol) + public + procedure BuildWCFOrQuery(OperationNode: TBoldSQLOperation; NameSpace: TBoldSqlNameSpace); override; + end; + { These operations are available in OCL, but have not yet been implemented in ocl2sql @@ -377,43 +497,6 @@ TBSS_Existing = class(TBSS_Symbol) end; } -function FindSymbolByName(Name: String): TBSS_Symbol; - -implementation - -uses - BoldPMappersDefault, - SysUtils, - BoldDefs, - BoldContainers, - BoldPSDescriptionsSQL, - BoldPMConsts; - -var - SqlSymbols: TBoldObjectArray; - -function FindSymbolByName(Name: String): TBSS_Symbol; -var - i: integer; -begin - for i := 0 to sqlSymbols.Count-1 do - begin - if CompareText(TBSS_Symbol(sqlSymbols[i]).name, Name) = 0 then - begin - result := TBSS_Symbol(sqlSymbols[i]); - exit; - end; - end; - raise EBold.CreateFmt(sUnableToFindSymbolForX, [Name]); -end; - -{ TBSS_Symbol } - -function TBSS_Symbol.GetName: String; -begin - result := copy(ClassName, 6, maxint); -end; - { TBSS_Select } procedure TBSS_Select.BuildWCFOrQuery(OperationNode: TBoldSQLOperation; NameSpace: TBoldSqlNameSpace); @@ -548,7 +631,7 @@ procedure TBSS_BinarySymbol.ConvertQueryToWCF(SourceNode, DestNode: TBoldSqlNode function TBSS_UnaryMinus.GetName: String; begin - result := 'unary-'; // do not localize + result := 'unary-'; end; function TBSS_UnaryMinus.GetSQLName: String; @@ -556,13 +639,27 @@ function TBSS_UnaryMinus.GetSQLName: String; result := '-'; end; +{ TBSS_Length } + +function TBSS_Length.GetSQLName: String; +begin + result := 'LEN'; // do not localize +end; + { TBSS_UnarySymbol } procedure TBSS_UnarySymbol.BuildWCFOrQuery( OperationNode: TBoldSQlOperation; NameSpace: TBoldSqlNameSpace); +var + WCF: TBoldSQLWCF; begin - OperationNode.WCF := TBoldSQLWCFUnaryPrefix.Create( - OperationNode.Args[0].RelinquishWCF, sqlName); + WCF := TBoldSQLWCFUnaryPrefix.Create( + OperationNode.Args[0].RelinquishWCF, SQLName); + + if OperationNode.Args[0].HasQuery then + OperationNode.Query := OperationNode.Args[0].RelinquishQuery; + + OperationNode.WCF := WCF; end; { TBSS_Size } @@ -574,9 +671,19 @@ procedure TBSS_Size.BuildWCFOrQuery(OperationNode: TBoldSQLOperation; NameSpace: { TBSS_SQLLike } +procedure TBSS_SQLLike.BuildWCFOrQuery(OperationNode: TBoldSQLOperation; + NameSpace: TBoldSqlNameSpace); +begin + OperationNode.WCF := TBoldSQLWCFBinaryInfix.Create( + OperationNode.Args[0].RelinquishWCF, + TBoldSQLWCFUnaryTransformLikeString.Create(OperationNode.Args[1].RelinquishWCF, ''), SQLname); + + CollectArgWCFs(OperationNode); +end; + function TBSS_SQLLike.GetSQLName: String; begin - result := 'LIKE'; // do not localize + result := 'LIKE'; end; { TBSS_SQLLikeCaseInsensitive } @@ -619,7 +726,7 @@ procedure TBSS_ToUpper.BuildWCFOrQuery(OperationNode: TBoldSQLOperation; function TBSS_ToUpper.GetSQLName: String; begin - result := 'UPPER'; // do not localize + result := 'UPPER'; end; { TBSS_toLower } @@ -633,7 +740,7 @@ procedure TBSS_toLower.BuildWCFOrQuery(OperationNode: TBoldSQLOperation; function TBSS_toLower.GetSQLName: String; begin - result := 'LOWER'; // do not localize + result := 'LOWER'; end; { TBSS_reject } @@ -644,7 +751,7 @@ procedure TBSS_reject.BuildWCFOrQuery(OperationNode: TBoldSQLOperation; NameSpac begin Sel := OperationNode as TBoldSQLIteration; Sel.Query := Sel.LoopVar.RelinquishQuery; - Sel.Query.AddWCF(TBoldSQLWCFUnaryPrefix.Create(OperationNode.Args[1].RelinquishWCF, 'NOT')); // do not localize + Sel.Query.AddWCF(TBoldSQLWCFUnaryPrefix.Create(OperationNode.Args[1].RelinquishWCF, 'NOT')); end; { TBSS_isNull } @@ -654,7 +761,7 @@ procedure TBSS_isNull.BuildWCFOrQuery(OperationNode: TBoldSQLOperation; NameSpac WCF: TBoldSQLWCF; Query: TBoldSQLQuery; begin - WCF := TBoldSQLWCFUnaryPostfix.Create(OperationNode.Args[0].RelinquishWCF, 'IS NULL'); // do not localize + WCF := TBoldSQLWCFUnaryPostfix.Create(OperationNode.Args[0].RelinquishWCF, 'IS NULL'); if OperationNode.args[0].HasQuery then begin @@ -681,11 +788,11 @@ procedure TBSS_GroupFunctions.BuildWCFOrQuery(OperationNode: TBoldSQLOperation; (WCF as TBoldSQLWCFColumnRef).Columnref, SQLName); end else - raise EBoldInternal.CreateFmt('Argument to %s has has no ColumnRef WCF', [Name]) // do not localize + raise EBoldInternal.CreateFmt('Argument to %s has has no ColumnRef WCF', [Name]) end else - raise EBoldInternal.CreateFmt('Argument to %s has no Query', [Name]) // do not localize + raise EBoldInternal.CreateFmt('Argument to %s has no Query', [Name]) end; { TBSS_includes } @@ -698,7 +805,7 @@ procedure TBSS_includes.BuildWCFOrQuery(OperationNode: TBoldSQLOperation; NameSp VarReference: TBoldSQlVariableReference; begin if not OperationNode.args[0].HasQuery then - raise EBoldInternal.Create('Arg 0 for Includes has no Query'); // do not localize + raise EBoldInternal.Create('Arg 0 for Includes has no Query'); Q1IdColumnRef := OperationNode.Args[0].MainTableRef.GetColumnReference(IDCOLUMN_NAME); @@ -708,14 +815,12 @@ procedure TBSS_includes.BuildWCFOrQuery(OperationNode: TBoldSQLOperation; NameSp if VarReference.IsExternalVariable then WCF := TBoldSQLWCFBinaryInfix.CreateWCFForIdList(Q1IDColumnRef, VarReference.VariableBinding.Context) else - // BoldId = VariabelReference.BoldId WCF := TBoldSQLWCFBinaryInfix.create( TBoldSQLWCFColumnRef.Create(Q1IDColumnRef), TBoldSQLWCFColumnRef.Create(OperationNode.Args[1].MainTableRef.GetColumnReference(IDCOLUMN_NAME)) ,'=') end else begin - // BoldID in (Arg1.Query) Query := OperationNode.Args[1].RelinquishQuery; WCF := TBoldSQLWCFInQuery.Create(TBoldSQLWCFColumnRef.Create(Q1IdColumnRef), Query, OperationNode.Args[1].MainTableRef(Query)); end; @@ -729,21 +834,21 @@ procedure TBSS_includes.BuildWCFOrQuery(OperationNode: TBoldSQLOperation; NameSp function TBSS_Average.GetSQLName: String; begin - result := 'AVG'; // do not localize + result := 'AVG'; end; { TBSS_MinValue } function TBSS_MinValue.GetSQLName: String; begin - result := 'MIN'; // do not localize + result := 'MIN'; end; { TBSS_Maxvalue } function TBSS_Maxvalue.GetSQLName: String; begin - result := 'MAX'; // do not localize + result := 'MAX'; end; { TBSS_Exists } @@ -763,13 +868,12 @@ procedure TBSS_ForAll.BuildWCFOrQuery(OperationNode: TBoldSQLOperation; NameSpac var Query: TBoldSqlQuery; TempWCF: TBoldSqlWCF; - // ForAll(x) -> not Exists(not x) begin Query := (OperationNode as TBoldSqlIteration).LoopVar.RelinquishQuery; - tempWcf := TBoldSQLWCFUnaryPrefix.Create(OperationNode.Args[1].RelinquishWCF, 'NOT'); // do not localize + tempWcf := TBoldSQLWCFUnaryPrefix.Create(OperationNode.Args[1].RelinquishWCF, 'NOT'); Query.AddWCF(TempWcf); TempWCF := TBoldSQLWCFExists.Create(Query, OperationNode.Args[0].MaintableRef(Query)); - OperationNode.WCF := TBoldSQLWCFUnaryPrefix.Create(TempWCF, 'NOT') // do not localize + OperationNode.WCF := TBoldSQLWCFUnaryPrefix.Create(TempWCF, 'NOT') end; { TBSS_orderby } @@ -785,12 +889,12 @@ procedure TBSS_orderby.BuildWCFOrQuery(OperationNode: TBoldSQLOperation; NameSpa Loopvar: TBoldSqlVariableBinding; begin if not (OperationNode.args[1] is TBoldSqlMember) then - raise EBold.Create(sArgToOrderByMustBeMember); + raise EBold.Create('Argument to OrderBy must be a Member'); OrderByMember := OperationNode.args[1] as TBoldSqlMember; if OrderByMember.MemberMapper.ColumnCount <> 1 then - raise EBold.Create(sArgToOrderByMustHaveExactlyOneColumn); + raise EBold.Create('Argument to OrderBy must have exactly 1 column'); Loopvar := (OperationNode as TBoldSQlIteration).Loopvar; @@ -802,7 +906,7 @@ procedure TBSS_orderby.BuildWCFOrQuery(OperationNode: TBoldSQLOperation; NameSpa OrderByColumnName := OrderByMember.MemberMapper.ColumnDescriptions[0].SQLName; ColRef := TableRef.GetColumnReference(OrderByColumnName); - Query.AddColumnToOrderBy(ColRef); + Query.AddColumnToOrderBy(ColRef, False); OperationNode.WCF := Loopvar.RelinquishWCF; @@ -812,8 +916,41 @@ procedure TBSS_orderby.BuildWCFOrQuery(OperationNode: TBoldSQLOperation; NameSpa { TBSS_orderDescending } procedure TBSS_orderDescending.BuildWCFOrQuery(OperationNode: TBoldSQLOperation; NameSpace: TBoldSqlNameSpace); +var + Query: TBoldSqlQuery; + OrderByMember: TBoldSqlMember; + OrderByColumnName: String; + tableDescription: TBoldSQLTableDescription; + TableRef: TBoldSQlTableReference; + ColRef: TBoldSqlColumnReference; + Loopvar: TBoldSqlVariableBinding; +const + sArgToOrderByMustBeMember = 'Argument to OrderBy must be a Member'; + sArgToOrderByMustHaveExactlyOneColumn = 'Argument to OrderBy must have exactly 1 column'; begin - Raise EBold.Create(sOrderByDescendingNotImplemented); + if not (OperationNode.args[1] is TBoldSqlMember) then + raise EBold.Create(sArgToOrderByMustBeMember); + + OrderByMember := OperationNode.args[1] as TBoldSqlMember; + + if OrderByMember.MemberMapper.ColumnCount <> 1 then + raise EBold.Create(sArgToOrderByMustHaveExactlyOneColumn); + + Loopvar := (OperationNode as TBoldSQlIteration).Loopvar; + + Query := Loopvar.RelinquishQuery; + + TableDescription := (OrderByMember.MemberMapper.ColumnDescriptions[0].Owner as TBoldSQLTableDescription); + TableRef := OperationNode.TableReferenceForTable(TableDescription, Query, false); + + OrderByColumnName := OrderByMember.MemberMapper.ColumnDescriptions[0].SQLName; + ColRef := TableRef.GetColumnReference(OrderByColumnName); + + Query.AddColumnToOrderBy(ColRef, True); + + OperationNode.WCF := Loopvar.RelinquishWCF; + + OperationNode.Query := Query; end; { TBSS_isEmpty } @@ -873,13 +1010,39 @@ procedure TBSS_Intersection.BuildWCFOrQuery( procedure TBSS_SymmetricDifference.BuildWCFOrQuery( OperationNode: TBoldSQLOperation; NameSpace: TBoldSqlNameSpace); // a->symmetricDifference(b) >> ((id in a) xor (id in b)) +// SQL does not support XOR, so we have to use inline version: +// a->symmetricDifference(b) >> (id in a) and (not (id in b)) or +// (id in b) and (not (id in a)) begin OperationNode.NewQuery(nameSpace); +// OperationNode.Query.AddWCF( +// TBoldSQLWCFBinaryInfix.Create( +// CreateBoldIdMatchWCF(OperationNode, OperationNode.args[0]), +// CreateBoldIdMatchWCF(OperationNode, OperationNode.args[1]), +// 'XOR')); // do not localize + +{ Doesnt work, because queries of the args are relinquished for the first part OperationNode.Query.AddWCF( TBoldSQLWCFBinaryInfix.Create( + TBoldSQLWCFBinaryInfix.Create( + CreateBoldIdMatchWCF(OperationNode, OperationNode.args[0]), + TBoldSQLWCFUnaryPrefix.Create( + CreateBoldIdMatchWCF(OperationNode, OperationNode.args[1]), + 'NOT'), // do not localize + 'AND'), // do not localize + TBoldSQLWCFBinaryInfix.Create( + CreateBoldIdMatchWCF(OperationNode, OperationNode.args[1]), + TBoldSQLWCFUnaryPrefix.Create( + CreateBoldIdMatchWCF(OperationNode, OperationNode.args[0]), + 'NOT'), // do not localize + 'AND'), // do not localize + 'OR')); // do not localize +} + // Solution: custom WCF for XOR + OperationNode.Query.AddWCF( + TBoldSQLWCFXOR.Create( CreateBoldIdMatchWCF(OperationNode, OperationNode.args[0]), - CreateBoldIdMatchWCF(OperationNode, OperationNode.args[1]), - 'XOR')); // do not localize + CreateBoldIdMatchWCF(OperationNode, OperationNode.args[1]))); end; { TBSS_Difference } @@ -997,7 +1160,10 @@ procedure TBSS_OclAsType.BuildWCFOrQuery(OperationNode: TBoldSQLOperation; OperationNode.Args[0].MainTableRef.GetColumnReference(IDCOLUMN_NAME)); end else + begin OperationNode.Query := OperationNode.Args[0].RelinquishQuery; + OperationNode.CopyTableReferences(OperationNode.Args[0]); + end; end; function TBSS_OclAsType.ResolveObjectMapper( @@ -1018,8 +1184,8 @@ procedure TBSS_FilterOnType.BuildWCFOrQuery( begin ObjectMapper := OperationNode.Args[1].ObjectMapper as TBoldObjectDefaultMapper; TypeColRef := TBoldSQLWCFColumnRef.Create(OperationNode.Args[0].MainTableRef.GetColumnReference(TYPECOLUMN_NAME)); - TypeValue := TBoldSQLWCFGenericExpression.Create('(' + ObjectMapper.SubClassesID + ')'); - WCF := TBoldSQLWCFBinaryInfix.Create(TypeColRef, TypeValue, 'IN'); // do not localize + TypeValue := TBoldSQLWCFGenericExpression.Create('('+ObjectMapper.SubClassesID+')'); + WCF := TBoldSQLWCFBinaryInfix.Create(TypeColRef, TypeValue, 'IN'); if OperationNode.Args[0].HasQuery then OperationNode.Query := OperationNode.Args[0].RelinquishQuery; @@ -1029,7 +1195,7 @@ procedure TBSS_FilterOnType.BuildWCFOrQuery( else begin if assigned(OperationNode.Args[0].WCF) then - WCF := TBoldSQLWCFBinaryInfix.Create(WCF, OperationNode.Args[0].RelinquishWCF, 'AND'); // do not localize + WCF := TBoldSQLWCFBinaryInfix.Create(WCF, OperationNode.Args[0].RelinquishWCF, 'AND'); OperationNode.WCF := WCF; end; @@ -1042,8 +1208,137 @@ function TBSS_FilterOnType.ResolveObjectMapper( result := OperationNode.Args[1].ObjectMapper; end; +{ TBSS_AsSet } + +procedure TBSS_AsSet.BuildWCFOrQuery(OperationNode: TBoldSQLOperation; + NameSpace: TBoldSqlNameSpace); +var + Query: TBoldSqlQuery; +begin + Query := OperationNode.Args[0].RelinquishQuery; + + // Distinct is usually not necessary because inPS evaluation returns no + // duplicate objects. But if asSet is used in a (Sub-)Select, this is indeed needed. + Query.Distinct := True; + + // Further simply pass Result without doing anything more + OperationNode.WCF := operationNode.Args[0].RelinquishWCF; + OperationNode.Query := Query; +end; + +function TBSS_AsSet.ResolveObjectMapper(OperationNode: TBoldSqlOperation): + TBoldObjectSqlMapper; +begin + result := OperationNode.Args[0].ObjectMapper; +end; + +{ TBSS_First } + +procedure TBSS_First.BuildWCFOrQuery(OperationNode: TBoldSQLOperation; + NameSpace: TBoldSqlNameSpace); +var + Query: TBoldSqlQuery; +begin + Query := OperationNode.Args[0].RelinquishQuery; + + // Limit in Query einstellen + Query.SetLimit(IsTopLimit); + + // Ansonsten simple Weitergabe des Ergebnisses ohne etwas zu machen + OperationNode.WCF := operationNode.Args[0].RelinquishWCF; + OperationNode.Query := Query; +end; + +function TBSS_First.IsTopLimit: Boolean; +begin + Result := True; +end; + +{ TBSS_Last } + +function TBSS_Last.IsTopLimit: Boolean; +begin + Result := False; +end; + +{ TBSS_BoldIDIs } + +procedure TBSS_BoldIDIs.BuildWCFOrQuery( + OperationNode: TBoldSQLOperation; NameSpace: TBoldSqlNameSpace); +var + TypeColRef: TBoldSQLWCFColumnRef; +begin + TypeColRef := TBoldSQLWCFColumnRef.Create(OperationNode.Args[0].MainTableRef.GetColumnReference(IDCOLUMN_NAME)); + OperationNode.WCF := TBoldSQLWCFBinaryInfix.Create(TypeColRef, OperationNode.Args[1].RelinquishWCF, '='); + CollectArgWCFs(OperationNode); +end; + +{ TBSS_BoldIDIn } + +procedure TBSS_BoldIDIn.BuildWCFOrQuery( + OperationNode: TBoldSQLOperation; NameSpace: TBoldSqlNameSpace); +var + TypeColRef: TBoldSQLWCFColumnRef; + TypeValue: TBoldSQLWCFGenericExpression; + aWCF: TBoldSqlWCF; + sIDs: string; +begin + TypeColRef := TBoldSQLWCFColumnRef.Create(OperationNode.Args[0].MainTableRef.GetColumnReference(IDCOLUMN_NAME)); + aWCF := OperationNode.Args[1].RelinquishWCF; + sIDs := aWCF.GetAsString(OperationNode.Args[0].Query); + aWCF.Free; + // Übergebenen String in ID-Liste umwandeln -> "" entfernen + // Außer es ist Paramter (:Param) + if (Length(sIDs) > 0) then begin + if (sIDs[1] = '''') then begin + sIDs := Copy(sIDs, 2, Length(sIDs) - 2); + end else if (sIDs[1] = ':') then begin + sIDs := OperationNode.Args[0].Query.Params.ParamValues[Copy(sIDs, 2, MaxInt)]; + end; + end; + TypeValue := TBoldSQLWCFGenericExpression.Create('(' + sIDs + ')'); + OperationNode.WCF := TBoldSQLWCFBinaryInfix.Create(TypeColRef, TypeValue, 'in'); // do not localize + CollectArgWCFs(OperationNode); +end; + +{ TBSS_BoldId } + +procedure TBSS_BoldId.BuildWCFOrQuery(OperationNode: TBoldSQLOperation; + NameSpace: TBoldSqlNameSpace); +var + SQLNode: TBoldSQLNode; + Query: TBoldSqlQuery; + SqlMember: TBoldSqlMember; + TableRefs: TBoldSQLTableReferenceList; + ColumnName: string; +begin + Query := nil; + SQLNode := OperationNode.Args[0]; + if SQLNode is TBoldSqlVariableReference then + begin + Query := TBoldSqlVariableReference(SQLNode).Query; + ColumnName := IDCOLUMN_NAME; + end + else + if (SQLNode is TBoldSqlMember) then + begin + SqlMember := TBoldSqlMember(SQLNode); + if SqlMember.MemberMapper.IsStoredInObject and + (SqlMember.memberOf is TBoldSqlVariableReference) then + begin + ColumnName := SqlMember.MemberMapper.ColumnDescriptions[0].sqlName; + Query := TBoldSqlVariableReference(SqlMember.memberOf).VariableBinding.Query; + end; + end; + if not Assigned(Query) then + raise EBoldInternal.Create(className + ': No Query found.'); + TableRefs := Query.TableReferences; + OperationNode.WCF := TBoldSQLWCFColumnRef.Create(TableRefs[TableRefs.Count-1].GetColumnReference(ColumnName)); +end; + initialization - sqlSymbols := TBoldObjectArray.Create(0, [bcoDataOwner]); + TBoldSqlSymbolDictionary.IX_SymbolName := -1; + sqlSymbols := TBoldSqlSymbolDictionary.Create; sqlSymbols.Add(TBSS_Add.Create); sqlSymbols.Add(TBSS_Equal.Create); sqlSymbols.Add(TBSS_NotEqual.Create); @@ -1064,6 +1359,9 @@ initialization sqlSymbols.Add(TBSS_not.Create); sqlSymbols.Add(TBSS_UnaryMinus.Create); sqlSymbols.Add(TBSS_isNull.Create); + sqlSymbols.Add(TBSS_Abs.Create); + sqlSymbols.Add(TBSS_Floor.Create); + sqlSymbols.Add(TBSS_Round.Create); sqlSymbols.Add(TBSS_Size.Create); sqlSymbols.Add(TBSS_Select.Create); sqlSymbols.Add(TBSS_Reject.Create); @@ -1086,14 +1384,19 @@ initialization sqlSymbols.Add(TBSS_ToLower.Create); sqlSymbols.Add(TBSS_Union.Create); sqlSymbols.Add(TBSS_Intersection.Create); + sqlSymbols.Add(TBSS_SymmetricDifference.Create); sqlSymbols.Add(TBSS_Difference.Create); sqlSymbols.Add(TBSS_oclIsTypeOf.Create); sqlSymbols.Add(TBSS_oclIsKindOf.Create); sqlSymbols.Add(TBSS_oclAsType.Create); + sqlSymbols.Add(TBSS_SafeCast.Create); sqlSymbols.Add(TBSS_FilterOnType.Create); - - // SymmetricDiffernece is not supported since SQL does not support XOR -// sqlSymbols.Add(TBSS_SymmetricDifference.Create); + sqlSymbols.Add(TBSS_AsSet.Create); + sqlSymbols.Add(TBSS_First.Create); + sqlSymbols.Add(TBSS_Last.Create); + sqlSymbols.Add(TBSS_BoldId.Create); + sqlSymbols.Add(TBSS_BoldIDIs.Create); + sqlSymbols.Add(TBSS_BoldIDIn.Create); finalization FreeAndNil(sqlSymbols); diff --git a/Source/PMapper/Validator/BoldDbDataValidator.pas b/Source/PMapper/Validator/BoldDbDataValidator.pas index 7e73b22b..99e00568 100644 --- a/Source/PMapper/Validator/BoldDbDataValidator.pas +++ b/Source/PMapper/Validator/BoldDbDataValidator.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDbDataValidator; interface @@ -21,6 +24,7 @@ TBoldDbDataValidator = class(TBoldDbValidator) fTypeTestedTables: TStringList; fQuery: IBoldQuery; fExistenceInParentTestedTables: TStringList; + FPauseBetweenQueries: integer; function GetQuery: IBoldQuery; procedure SuggesttableInsert(table: TBoldSQLTableDescription; IdList, TypeList: TStrings); @@ -29,18 +33,22 @@ TBoldDbDataValidator = class(TBoldDbValidator) function Prepare2TableTest(SQLTemplate: String; CheckList: TStringList; args: array of const; table1, table2: String; IdList: TStrings; TypeList: TStrings = nil): Boolean; procedure AddRemedyForDeleteObjects(Mapper: TBoldObjectSQLMapper; IdList: TStringList); procedure DeActivate; override; + procedure OpenQuery; property Query: IBoldQuery read GetQuery; property TypeTestedTables: TStringList read fTypeTestedTables; property ExistenceInParentTestedTables: TStringList read fExistenceInParentTestedTables; public - constructor Create(owner: Tcomponent); override; - destructor Destroy; override; + constructor Create(owner: TComponent); override; + destructor destroy; override; procedure ValidateExistence(ObjectSQLMapper: TBoldObjectSQLMapper); procedure ValidateStrayObjects(ObjectDefaultMapper: TBoldObjectDefaultMapper); procedure ValidateRelations(ObjectSQLMapper: TBoldObjectSQLMapper); + procedure ValidateNotNullColumns(ObjectSQLMapper: TBoldObjectSQLMapper); + procedure ValidateNotNullForColumn(BoldSQLColumnDescription: TBoldSQLColumnDescription); procedure ValidateLinkObjectDupes(ObjectSQLMapper: TBoldObjectSQLMapper); procedure ValidateLinkObjects(ObjectSQLMapper: TBoldObjectSQLMapper); procedure Validate; override; + property PauseBetweenQueries: integer read FPauseBetweenQueries write FPauseBetweenQueries; end; implementation @@ -54,10 +62,13 @@ implementation BoldDefs, SysUtils, BoldUtils, - BoldPMConsts; + BoldPMConsts, + BoldMath; const Field_BOLD_ID = 'BOLD_ID'; + Field_BOLD_TYPE = 'BOLD_TYPE'; + ExistenceInParentTest: String = 'SELECT OWN.BOLD_ID, OWN.BOLD_TYPE ' + BOLDCRLF + 'FROM %s OWN ' + BOLDCRLF + @@ -65,7 +76,7 @@ implementation ' SELECT PARENT.BOLD_ID ' + BOLDCRLF + ' FROM %s PARENT ' + BOLDCRLF + ' WHERE PARENT.BOLD_ID = OWN.BOLD_ID)'; - // [Own, Parent] +// [Own, Parent] ExistenceInChildTest: string = 'SELECT PARENT.BOLD_ID, PARENT.BOLD_TYPE ' + BOLDCRLF + @@ -75,16 +86,17 @@ implementation ' SELECT BOLD_ID' + BOLDCRLF + ' FROM %s OWN ' + BOLDCRLF + ' WHERE OWN.BOLD_ID = PARENT.BOLD_ID)'; - // [parent, types, Own] +// [parent, types, Own] + TypeTest: String = 'SELECT PARENT.BOLD_ID, PARENT.BOLD_TYPE, OWN.BOLD_TYPE' + BOLDCRLF + 'FROM %s PARENT, %s OWN' + BOLDCRLF + 'WHERE (PARENT.BOLD_ID = OWN.BOLD_ID) AND' + BOLDCRLF + ' (PARENT.BOLD_TYPE <> OWN.BOLD_TYPE)'; - // [Parent, Own] +// [Parent, Own] - // find all objects that are related, but the other end does not exist. +// find all objects that are related, but the other end does not exist. RelationTest: String = 'SELECT OWN.%s, OWN.BOLD_ID' + BOLDCRLF + @@ -93,7 +105,14 @@ implementation ' SELECT RELATED.BOLD_ID' + BOLDCRLF + ' FROM %2:s RELATED' + BOLDCRLF + ' WHERE RELATED.BOLD_ID = OWN.%0:s)'; - // [Link, OwnTable, RelatedTable] +// [Link, OwnTable, RelatedTable] + + DuplicateSingleLinkTest: String = + 'SELECT %0:s' + BOLDCRLF + + 'FROM %s' + BOLDCRLF + + 'WHERE %0:s <> -1 ' + BOLDCRLF + + 'GROUP BY %0:s' + BOLDCRLF + + 'HAVING COUNT(*) > 1'; LinkObjectDupesTest: String = 'SELECT LINKTABLE.BOLD_ID, LINKTABLE.%s, LINKTABLE.%s, COUNT(*)' + BOLDCRLF + @@ -101,21 +120,20 @@ implementation 'GROUP BY LINKTABLE.%0:s, LINKTABLE.%1:s' + BOLDCRLF + 'HAVING COUNT(*) >= 2' + BOLDCRLF + 'ORDER BY %0:s, %1:s'; - // [Link1, link2, linktable] +// [Link1, link2, linktable] - // linkobjects with empty ends +// linkobjects with empty ends LinkObjectTest: String = 'SELECT BOLD_ID' + BOLDCRLF + 'FROM %s' + BOLDCRLF + 'WHERE %s = -1 or %s = -1'; - // Linkobjects pointing to nonexisting objects +// Linkobjects pointing to nonexisting objects LinkObjectTest2: String = 'SELECT LT.BOLD_ID' + BOLDCRLF + 'FROM %s LT' + BOLDCRLF + 'WHERE NOT EXISTS (SELECT T.BOLD_ID FROM %s T WHERE LT.%s = T.BOLD_ID)'; - //[LinkTable, OtherTable, LinkColumn] - +//[LinkTable, OtherTable, LinkColumn] StrayObjectsTest: string = 'SELECT BOLD_ID, BOLD_TYPE ' + BOLDCRLF + @@ -126,7 +144,7 @@ implementation 'SELECT T1.BOLD_ID, T1.BOLD_TYPE ' + BOLDCRLF + 'FROM %s T1, %s T2 ' + BOLDCRLF + 'WHERE (T1.%s = T2.BOLD_ID) and (T2.%s <> T1.BOLD_ID)'; - // [Table1, table2, link1, link2Own, Parent] +// [Table1, table2, link1, link2Own, Parent] { TBoldDbDataValidator } @@ -147,7 +165,16 @@ function TBoldDbDataValidator.MemberIsInherited( result := MemberMapper.MemberIndex < MemberMapper.ObjectPersistenceMapper.SuperClass.MemberPersistenceMappers.count; end; +procedure TBoldDbDataValidator.OpenQuery; +begin + Sleep(1000*PauseBetweenQueries); + Query.Open; +end; + function TBoldDbDataValidator.Prepare2TableTest(SQLTemplate: String; CheckList: TStringList; args: array of const; table1, table2: String; IdList: TStrings; TypeList: TStrings = nil): Boolean; +var + BoldIdField: IBoldField; + BoldTypeField: IBoldField; begin if not assigned(CheckList) or ((CheckList.IndexOf(Table1 + ':' + Table2) = -1) and @@ -156,13 +183,16 @@ function TBoldDbDataValidator.Prepare2TableTest(SQLTemplate: String; CheckList: IdList.Clear; if assigned(typelist) then typeList.Clear; + Query.Close; Query.AssignSQLText(format(SQLTemplate, args)); - Query.Open; + OpenQuery; + BoldIdField := Query.FieldByName(Field_BOLD_ID); + BoldTypeField := Query.FieldByName(Field_BOLD_TYPE); while not query.eof do begin - IdList.Add(Query.FieldByName(Field_BOLD_ID).AsString); + IdList.Add(BoldIdField.AsString); if assigned(Typelist) then - TypeList.Add(Query.FieldByName('BOLD_TYPE').AsString); // do not localize + TypeList.Add(BoldTypeField.AsString); Query.Next; end; Query.Close; @@ -179,30 +209,27 @@ procedure TBoldDbDataValidator.Validate; i: integer; ObjectPMapper: TBoldObjectSQLMapper; begin +(* if not PersistenceHandle.DatabaseInterface.Connected then begin - Remedy.Add(sDBNotOpened); - BoldLog.Log(sDBMustBeOpened); + BoldLog.Log('Database must be opened before Structurevalidation is performed!'); exit; end; - +*) BoldLog.ProgressMax := SystemSQLMapper.ObjectPersistenceMappers.count - 1; for i := 0 to SystemSQLMapper.ObjectPersistenceMappers.count - 1 do begin ObjectPMapper := SystemSQLMapper.ObjectPersistenceMappers[i] as TBoldObjectSQLMapper; if assigned(ObjectPMapper) then begin - BoldLog.LogHeader := Format(sProcessingClass, [ObjectPMapper.ExpressionName]); + BoldLog.LogHeader := Format('Processing class %d %s', [i, ObjectPMapper.ExpressionName]); ValidateExistence(ObjectPMapper); ValidateRelations(ObjectPMapper); + ValidateNotNullColumns(ObjectPMapper); if ObjectPmapper is TBoldObjectDefaultMapper then ValidateStrayObjects(ObjectPMapper as TBoldObjectDefaultMapper); - if ObjectPMapper.IsLinkClass then begin - // The SQL for this is broken... why? - // - // ValidateLinkObjectDupes(ObjectPMapper); ValidateLinkObjects(ObjectPmapper); end; end; @@ -224,7 +251,6 @@ procedure TBoldDbDataValidator.SuggesttableInsert(table: TBoldSQLTableDescriptio UnsupportedColumns := ''; Skip := false; - // check all columns except BodlID/BoldType for j := 2 to Table.ColumnsList.Count - 1 do begin Column := Table.ColumnsList[j] as TBoldSQLColumnDescription; @@ -236,18 +262,17 @@ procedure TBoldDbDataValidator.SuggesttableInsert(table: TBoldSQLTableDescriptio NotNullValues := NotNullvalues + ', '''''; ftLargeint, ftBCD, ftCurrency, ftFloat, ftSmallint, ftInteger, ftWord : NotNullvalues := NotNullvalues + ', 0'; - ftBoolean: NotNullValues := NotNullValues + ', false'; // do not localize + ftBoolean: NotNullValues := NotNullValues + ', false'; ftDate: NotNullValues := NotNullValues + ', ' + DateToStr(0.0); ftTime: NotNullValues := NotNullValues + ', ' + TimeToStr(0.0); ftDateTime: NotNullValues := NotNullValues + ', ' + DateTimeToStr(0.0); else begin - // ftBytes, ftVarBytes, ftAutoInc, ftGraphic, ftFmtMemo, - // ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor, - // ftADT, ftArray, ftReference, ftDataSet, ftOraBlob, ftOraClob, - // ftVariant, ftInterface, ftIDispatch, ftGuid + + + skip := true; - NotNullValues := NotNullValues + ', '; // do not localize + NotNullValues := NotNullValues + ', '; if UnsupportedColumns <> '' then UnsupportedColumns := UnsupportedColumns + ', '; @@ -257,14 +282,14 @@ procedure TBoldDbDataValidator.SuggesttableInsert(table: TBoldSQLTableDescriptio end; end; - remedySQL := 'INSERT INTO %s (BOLD_ID, BOLD_TYPE%s) VALUES (%s, %s%s)'; // do not localize + remedySQL := 'INSERT INTO %s (BOLD_ID, BOLD_TYPE%s) VALUES (%s, %s%s)'; if skip then begin - Remedy.add(format(sColumnsHaveUnsupportedType, [UnsupportedColumns])); - remedySQL := '// ' + remedySQL; + Remedy.add(format('-- Required column(s) %s has unsupported type(s)', [UnsupportedColumns])); + remedySQL := '-- '+ remedySQL; end else - remedy.Add(Format(sAddMissingEntries, [Table.SQLName])); + remedy.Add(Format('-- add missing entries into %s', [Table.SQLName])); for j := 0 to idlist.count - 1 do Remedy.Add(format(remedySQL, [Table.SQLName, NotNullColumns, IdList[j], TypeList[j], NotNullValues])); @@ -292,26 +317,36 @@ procedure TBoldDbDataValidator.ValidateExistence(ObjectSQLMapper: TBoldObjectSQL tempMapper := ObjectSQLMapper; while assigned(TempMapper) do begin - if assigned(tempMapper.Maintable) and (Tables.IndexOf(tempMapper.Maintable) = -1) then + if (tempMapper.Maintable<>nil) and (Tables.IndexOf(tempMapper.Maintable) = -1) then Tables.Add(tempMapper.Maintable); TempMapper := TempMapper.Superclass as TBoldObjectSQLMapper; end; - for i := 0 to Tables.count - 2 do + for i := 0 to Tables.count-2 do begin + if Tables[i]=nil then + begin + BoldLog.LogFmt('TBoldDbDataValidator.ValidateExistence: %s Tables[%d]=nil', [ObjectSQLMapper.ExpressionName, I]); + Continue; + end; + if Tables[i+1]=nil then + begin + BoldLog.LogFmt('TBoldDbDataValidator.ValidateExistence: %s Tables[%d+1]=nil', [ObjectSQLMapper.ExpressionName, I]); + Continue; + end; SubTable := Tables[i].SQLName; - SuperTable := Tables[i + 1].SQLName; + SuperTable := Tables[i+1].SQLName; if Prepare2TableTest(ExistenceInParentTest, ExistenceInParentTestedTables, [SubTable, SuperTable], SubTable, SuperTable, IdList, TypeList) then begin - BoldLog.LogFmt(sLogObjectsMissingInParentTable, [SubTable, SuperTable]); - Boldlog.Log(IdList.CommaText); + BoldLog.LogFmt('The following objects exists in %s, but not in parent table %s', [SubTable, SuperTable], ltWarning); + Boldlog.Log(IdList.CommaText, ltDetail); SuggestTableInsert(Tables[i+1], IdList, TypeList); end; if Prepare2TableTest(TypeTest, TypeTestedTables, [SuperTable, SubTable], SuperTable, SubTable, IdList) then begin - BoldLog.LogFmt(sLogObjectsHaveDifferentType, [SuperTable, SubTable]); - Boldlog.Log(IdList.CommaText); + BoldLog.LogFmt('The following objects have different type in table %s and %s', [SuperTable, SubTable], ltWarning); + Boldlog.Log(IdList.CommaText, ltDetail); end; end; @@ -330,12 +365,28 @@ procedure TBoldDbDataValidator.ValidateExistence(ObjectSQLMapper: TBoldObjectSQL (ObjectSQLMapper as TBoldObjectDefaultMapper).SubClassesID, SubTable], SubTable, SuperTable, IdList, TypeList) then begin - BoldLog.LogFmt(sLogObjectsMissingInChildtable, [SuperTable, SubTable]); - Boldlog.Log(IdList.CommaText); + BoldLog.LogFmt('The following objects exists in %s, but not in child table %s', [SuperTable, SubTable], ltWarning); + Boldlog.Log(IdList.CommaText, ltDetail); SuggesttableInsert(ObjectSQLMapper.MainTable, IdList, TypeList); end; end; end; + + for i:= Tables.Count-1 downto 1 do + begin + SuperTable := Tables[i].SQLName; + SubTable := Tables[i-1].SQLName; + if Prepare2TableTest(ExistenceInChildTest, nil, [ + SuperTable, + (ObjectSQLMapper as TBoldObjectDefaultMapper).SubClassesID, + SubTable], SubTable, SuperTable, IdList, TypeList) then + begin + BoldLog.LogFmt('The following objects exists in %s, but not in child table %s', [SuperTable, SubTable], ltWarning); + Boldlog.Log(IdList.CommaText, ltDetail); + SuggesttableInsert(ObjectSQLMapper.MainTable, IdList, TypeList); + end; + end; + finally tables.free; IdList.Free; @@ -350,23 +401,29 @@ procedure TBoldDbDataValidator.ValidateLinkObjectDupes( LinkTable, LinkColumn1, LinkColumn2: String; IdList: TStringList; + Link1Field: IBoldField; + Link2Field: IBoldField; + BoldIdField: IBoldField; begin IdList := TStringList.create; LinkColumn1 := (ObjectSQLMapper.LinkClassRole1 as TBoldEmbeddedSingleLinkDefaultMapper).MainColumnName; LinkColumn2 := (ObjectSQLMapper.LinkClassRole2 as TBoldEmbeddedSingleLinkDefaultMapper).MainColumnName; LinkTable := ObjectSQLMapper.MainTable.SQLName; - + Query.Close; Query.AssignSQLText(format(LinkObjectDupesTest, [LInkColumn1, LinkColumn2, LInkTable])); - Query.Open; + OpenQuery; LastLink1 := -Maxint; LastLInk2 := -MaxInt; + Link1Field := Query.FieldByName(LinkColumn1); + Link2Field := Query.FieldByName(LinkColumn2); + BoldIdField := Query.FieldByName('BOLD_ID'); while not query.eof do begin - link1 := Query.FieldByName(LinkColumn1).AsInteger; - link2 := Query.FieldByName(LinkColumn2).AsInteger; + link1 := Link1Field.AsInteger; + link2 := Link2Field.AsInteger; if (Link1 = LastLink1) and (link2 = lastlink2) then - IdList.Add(Query.FieldByName(Field_BOLD_ID).AsString) + IdList.Add(BoldIdField.AsString) else begin LastLInk1 := link1; @@ -375,8 +432,8 @@ procedure TBoldDbDataValidator.ValidateLinkObjectDupes( end; if IdList.Count > 0 then begin - BoldLog.Log(sLogLinkObjectsAreDupes); - BoldLog.Log(IdList.CommaText); + BoldLog.Log('The following Linkobjects are duplicates:', ltWarning); + BoldLog.Log(IdList.CommaText, ltDetail); end; IdList.Free; end; @@ -387,48 +444,82 @@ procedure TBoldDbDataValidator.ValidateLinkObjects(ObjectSQLMapper: TBoldObjectS LinkColumn1, LinkColumn2: String; IdList: TStringList; -procedure CheckSpacePointers(LinkMApper: TBoldEmbeddedSingleLInkDefaultMapper); -begin - Query.AssignSQLText(format(LinkObjectTest2, [ - LinkTable, - LInkMapper.OtherEndObjectMapper.Maintable.SQLName, - LinkMapper.MainColumnName])); - Query.Open; - - while not query.eof do - begin - IdList.Add(Query.FieldByName(Field_BOLD_ID).AsString); - Query.Next; - end; - - if IdList.Count > 0 then + procedure CheckSpacePointers(LinkMApper: TBoldEmbeddedSingleLInkDefaultMapper); + var + MainTableName: string; + TempIdList: TStringList; + s: string; + BoldIdField: IBoldField; begin - BoldLog.LogFmt(sLogLinkObjectsLinkUnexistingObjects, [ObjectSQLmapper.ExpressionName]); - BoldLog.Log(IdList.CommaText); - Remedy.Add(Format(sCommentRemoveSpaceLinkObjects, [ObjectSQLmapper.ExpressionName])); - AddRemedyForDeleteObjects(ObjectSQLMapper, IDList); + if LinkMapper=nil then + begin + BoldLog.LogFmt('TBoldDbDataValidator.ValidateLinkObjects->CheckSpacePointers: %s: LinkMapper=nil', [ObjectSQLMapper.ExpressionName]); + Exit; + end; + Assert(PersistenceHandle.BoldModel.MoldModel.GetClassByName(LinkMapper.OtherEndObjectMapper.ExpressionName) <> nil, 'Class ' + LinkMapper.ObjectPersistenceMapper.ExpressionName + ' not found.'); + if LInkMapper.OtherEndObjectMapper=nil then + begin + BoldLog.LogFmt('TBoldDbDataValidator.ValidateLinkObjects->CheckSpacePointers: %s: LinkMapper.OtherEndObjectMapper=nil', [ObjectSQLMapper.ExpressionName]); + Exit; + end; + if LInkMapper.OtherEndObjectMapper.Maintable<>nil then + MainTableName := LinkMapper.OtherEndObjectMapper.Maintable.SQLName + else + begin + MainTableName := 'Bold_Object'; // it would be more efficient to find first concrete superclass so that we search more concrete table instead of all in Bold_Object + if not PersistenceHandle.BoldModel.MoldModel.GetClassByName(LinkMapper.OtherEndObjectMapper.ExpressionName).IsAbstract or not LinkMapper.OtherEndObjectMapper.HasSubClasses then + BoldLog.LogFmt('TBoldDbDataValidator.ValidateLinkObjects->CheckSpacePointers: %s: Link: %s LinkMapper.OtherEndObjectMapper.Maintable=nil, substituting bold_object', [ObjectSQLMapper.ExpressionName, LinkMapper.MainColumnName]); + end; + Query.Close; + Query.AssignSQLText(format(LinkObjectTest2, [ + LinkTable, + MainTableName, + LinkMapper.MainColumnName])); + OpenQuery; + BoldIdField := Query.FieldByName('BOLD_ID'); + TempIdList := TStringList.Create; + try + while not query.eof do + begin + s := BoldIdField.AsString; + if IdList.IndexOf(s) = -1 then + begin + TempIdList.Add(s); + IdList.Add(s); + end; + Query.Next; + end; + if TempIdList.Count > 0 then begin + BoldLog.LogFmt('The following Linkobjects (class %s) have links to nonexisting objects:', [ObjectSQLmapper.ExpressionName], ltWarning); + BoldLog.Log(TempIdList.CommaText, ltDetail); + Remedy.Add(Format('-- Clean Linkobjects (%s) with space pointers', [ObjectSQLmapper.ExpressionName])); + AddRemedyForDeleteObjects(ObjectSQLMapper, IDList); + end; + finally + TempIdList.free; + end; end; -end; +var + BoldIdField: IBoldField; begin IdList := TStringList.create; LinkColumn1 := (ObjectSQLMapper.LinkClassRole1 as TBoldEmbeddedSingleLinkDefaultMapper).MainColumnName; LinkColumn2 := (ObjectSQLMapper.LinkClassRole2 as TBoldEmbeddedSingleLinkDefaultMapper).MainColumnName; LinkTable := ObjectSQLMapper.MainTable.SQLName; - + Query.Close; Query.AssignSQLText(format(LinkObjectTest, [LinkTable, LinkColumn1, LinkColumn2])); - Query.Open; + OpenQuery; + BoldIdField := Query.FieldByName('BOLD_ID'); while not query.eof do begin - IdList.Add(Query.FieldByName(Field_BOLD_ID).AsString); + IdList.Add(BoldIdField.AsString); Query.Next; end; - - if IdList.Count > 0 then - begin - BoldLog.LogFmt(sLogBrokenLinkObjects, [ObjectSQLmapper.ExpressionName]); - BoldLog.Log(IdList.CommaText); - Remedy.Add(Format(sCommentRemoveBrokenLinkObjects, [ObjectSQLmapper.ExpressionName])); + if IdList.Count > 0 then begin + BoldLog.LogFmt('The following Linkobjects (class %s) have empty links in one direction:', [ObjectSQLmapper.ExpressionName], ltWarning); + BoldLog.Log(IdList.CommaText, ltDetail); + Remedy.Add(Format('-- Clean Linkobjects (%s) with broken links', [ObjectSQLmapper.ExpressionName])); AddRemedyForDeleteObjects(ObjectSQLMapper, IdLIst); end; @@ -438,9 +529,60 @@ procedure CheckSpacePointers(LinkMApper: TBoldEmbeddedSingleLInkDefaultMapper); IdList.Free; end; +procedure TBoldDbDataValidator.ValidateNotNullForColumn( + BoldSQLColumnDescription: TBoldSQLColumnDescription); +var + FieldNames: TStrings; + TableName: String; + ColumnName: String; + NullCount: integer; +begin + FieldNames := TStringList.Create; + query.Close; + TableName := BoldSQLColumnDescription.tableDescription.SQLName; + ColumnName := BoldSQLColumnDescription.SQLName; + try + Query.AssignSQLText(Format('SELECT count(*) FROM %s WHERE %s.%s IS NULL', + [TableName, + TableName, + ColumnName])); + OpenQuery; + nullcount := Query.Fields[0].AsInteger; + Query.Close; + if NullCount <> 0 then + begin + BoldLog.LogFmtIndent('%d Null-values found in Table %s, Column %s: ', + [NullCount, tableName, ColumnName], ltWarning); + Remedy.Add(Format('UPDATE %s SET %s = WHERE %1:s IS NULL;', + [TableName, ColumnName])); + end; + finally + FieldNames.Free; + end; +end; + +procedure TBoldDbDataValidator.ValidateNotNullColumns( + ObjectSQLMapper: TBoldObjectSQLMapper); +var + i, j: integer; + BoldSQLTableDescription: TBoldSQLTableDescription; + BoldSQLColumnDescription: TBoldSQLColumnDescription; +begin + for j := 0 to ObjectSQLMapper.AllTables.Count-1 do + begin + BoldSQLTableDescription := ObjectSQLMapper.AllTables[j]; + for i := 0 to BoldSQLTableDescription.ColumnsList.count - 1 do + begin + BoldSQLColumnDescription := BoldSQLTableDescription.ColumnsList[i] as TBoldSQlColumnDescription; + if BoldSQLColumnDescription.Mandatory then + ValidateNotNullForColumn(BoldSQLColumnDescription); + end; + end; +end; + procedure TBoldDbDataValidator.ValidateRelations(ObjectSQLMapper: TBoldObjectSQLMapper); var - i: integer; + i,j: integer; IdList: TStringList; SingleLink: TBoldEmbeddedSingleLinkDefaultMapper; RelatedTable, @@ -449,6 +591,10 @@ procedure TBoldDbDataValidator.ValidateRelations(ObjectSQLMapper: TBoldObjectSQL MemberOfOtherEnd: TBoldMemberSQLMapper; SingleRoleOfOtherEnd: TBoldEmbeddedSingleLInkDefaultMapper; MemberMappings: TBoldMemberMappingArray; + BoldIdField: IBoldField; + FetchBlockSize: integer; + Block, Start,Stop: integer; + s: string; begin IdList := TStringList.create; LinkTable := ObjectSQLMapper.MainTable; @@ -461,60 +607,152 @@ procedure TBoldDbDataValidator.ValidateRelations(ObjectSQLMapper: TBoldObjectSQL begin SingleLink := ObjectSQLMapper.MemberPersistenceMappers[i] as TBoldEmbeddedSingleLinkDefaultMapper; MemberMappings := ObjectSQLMapper.SystemPersistenceMapper.MappingInfo.GetMemberMappings(ObjectSQLMapper.ExpressionName, SingleLink.ExpressionName); - // check if the member is stored in our table. if (length(MemberMappings) = 1) and SameText(MemberMappings[0].TableName, LinkTable.SQLName) then begin - RelatedTable := (SystemSQLMapper.ObjectPersistenceMappers[SingleLink.OtherEndObjectPMIndex] as TBoldObjectSQLMapper).MainTable; + ClassOfOtherEnd := SystemSQLMapper.ObjectPersistenceMappers[SingleLink.OtherEndObjectPMIndex] as TBoldObjectSQlMapper; + MemberOfOtherEnd := ClassOfOtherEnd.MemberPersistenceMappers[SingleLink.OtherEndMemberPMIndex] as TBoldMemberSQLMapper; + RelatedTable := ClassOfOtherEnd.MainTable; + if RelatedTable = nil then //childmapped abstract class + RelatedTable := ObjectSQLMapper.SystemPersistenceMapper.RootClassObjectPersistenceMapper.MainTable; + if SingleLink=nil then + begin + BoldLog.LogFmt('TBoldDbDataValidator.ValidateRelations: %s:%d SingleLink=nil', [ObjectSQLMapper.ExpressionName, I]); + Continue; + end; + if LinkTable=nil then + begin + BoldLog.LogFmt('TBoldDbDataValidator.ValidateRelations: %s:%d LinkTable=nil', [ObjectSQLMapper.ExpressionName, I]); + Continue; + end; + if RelatedTable=nil then + begin + BoldLog.LogFmt('TBoldDbDataValidator.ValidateRelations: %s:%d RelatedTable=nil', [ObjectSQLMapper.ExpressionName, I]); + Continue; + end; + Query.Close; Query.AssignSQLText(format(RelationTest, [SingleLink.MainColumnName, LInkTable.SQLName, relatedtable.SQLName])); - Query.Open; + OpenQuery; + BoldIdField := Query.FieldByName('BOLD_ID'); IdList.Clear; while not query.eof do begin - IdList.Add(Query.FieldByName(Field_BOLD_ID).AsString); + IdList.Add(BoldIdField.AsString); Query.Next; end; Query.Close; if IdList.Count > 0 then begin - BoldLog.LogFmt(sLogObjectsWithBrokenLinks, [ObjectSQlMapper.ExpressionName, SingleLink.ExpressionName]); - BoldLog.Log(IdList.CommaText); - Remedy.Add(Format(sCommentCleanRelation, [ObjectSQlMapper.ExpressionName, SingleLink.ExpressionName])); - - remedy.Add(format('UPDATE %s SET %s = -1 WHERE BOLD_ID IN (%s);', // do not localize - [LinkTable.SQLName, SingleLink.MainColumnName, IdList.CommaText])); + BoldLog.LogFmt('The following (%d) objects of class %s have invalid links in %s:', [IdList.Count, ObjectSQlMapper.ExpressionName, SingleLink.ExpressionName], ltWarning); + FetchBlockSize := SystemSQLMapper.SQLDataBaseConfig.FetchBlockSize; + for Block := 0 to (IdList.Count div FetchBlockSize) do + begin + s := ''; + Start := Block * FetchBlockSize; + Stop := MinIntValue([Pred(Succ(Block) * FetchBlockSize), IdList.Count-1]); + for j := Start to Stop do + begin + s := s + IdList[j]; + if j < stop then + s := s + ','; + end; + BoldLog.Log(s, ltDetail); + Remedy.Add(Format('-- Clean relation (%s.%s) ', [ObjectSQlMapper.ExpressionName, SingleLink.ExpressionName])); + Remedy.Add(format('UPDATE %s SET %s = -1 WHERE BOLD_ID IN (%s);', + [LinkTable.SQLName, SingleLink.MainColumnName, s])); + end; end; - // find inconsistent single-single embedded links - ClassOfOtherEnd := ObjectSQLMapper.SystemPersistenceMapper.ObjectPersistencemappers[SingleLInk.OtherEndObjectPMIndex] as TBoldObjectSQlMapper; if assigned(ClassOfOtherEnd) then begin MemberOfOtherEnd := ClassOfOtherEnd.MemberPersistenceMappers[SingleLink.OtherEndMemberPMIndex] as TBoldMemberSQLMapper; + if (MemberofOtherEnd is TBoldSingleLinkDefaultMapper) and (not ObjectSQlMapper.IsLinkClass) then + begin + BoldLog.LogFmt('Validating 1-1 singlelinks for duplicate values: %s.%s',[ObjectSQlMapper.MainTable.SQlName, SingleLink.MainColumnName]); + Query.Close; + Query.AssignSQLText(format(DuplicateSingleLinkTest, [ + SingleLink.MainColumnName, ObjectSQlMapper.MainTable.SQlName, SingleLink.MainColumnName, + SingleLink.MainColumnName])); + OpenQuery; + BoldIdField := Query.FieldByName(SingleLink.MainColumnName); + IdList.Clear; + while not query.eof do + begin + IdList.Add(BoldIdField.AsString); + Query.Next; + end; + Query.Close; + while not query.eof do + begin + IdList.Add(BoldIdField.AsString); + Query.Next; + end; + Query.Close; + if IdList.Count > 0 then + begin + BoldLog.LogFmt('The following %d objects of class %s have duplicate values in singlelinks (%s) :', + [IdList.Count, ObjectSQlMapper.ExpressionName, SingleLink.ExpressionName]); + FetchBlockSize := SystemSQLMapper.SQLDataBaseConfig.FetchBlockSize; + for Block := 0 to (IdList.Count div FetchBlockSize) do + begin + s := ''; + Start := Block * FetchBlockSize; + Stop := MinIntValue([Pred(Succ(Block) * FetchBlockSize), IdList.Count-1]); + for j := Start to Stop do + begin + s := s + IdList[j]; + if j < stop then + s := s + ','; + end; + BoldLog.Log(s); + Remedy.Add(Format('-- Unlink relation (%s.%s) ', [ObjectSQlMapper.ExpressionName, SingleLink.ExpressionName])); + Remedy.Add(format('UPDATE %s SET %s = -1 WHERE %s IN (%s);', + [ObjectSQlMapper.MainTable.SQlName, SingleLink.MainColumnName, SingleLink.MainColumnName, s])); + end; + end; + end; if MemberofOtherEnd is TBoldEmbeddedSingleLinkDefaultMapper then + if ClassOfOtherEnd.MainTable = nil then + BoldLog.LogFmt('Can''t validate 1-1 : %s.%s',[ClassOfOtherEnd.ExpressionName, MemberOfOtherEnd.ExpressionName], ltError) + else begin + BoldLog.LogFmt('Validating 1-1 : %s.%s',[ClassOfOtherEnd.ExpressionName, MemberOfOtherEnd.ExpressionName]); SingleRoleOfOtherEnd := MemberOfOtherEnd as TBoldEmbeddedSingleLinkDefaultMapper; + Query.Close; Query.AssignSQLText(format(SingleSingleEmbeddInconsistencyTest, [ ObjectSQlMapper.MainTable.SQlName, ClassOfOtherEnd.MainTable.sqlName, SingleLink.MainColumnName, SingleRoleOfOtherEnd.MainColumnName])); - Query.Open; + OpenQuery; + BoldIdField := Query.FieldByName('BOLD_ID'); IdList.Clear; while not query.eof do begin - IdList.Add(Query.FieldByName(Field_BOLD_ID).AsString); + IdList.Add(BoldIdField.AsString); Query.Next; end; Query.Close; if IdList.Count > 0 then begin - BoldLog.LogFmt(sLogObjectsWithWrongLinks, [ObjectSQlMapper.ExpressionName, SingleLink.ExpressionName]); - BoldLog.Log(IdList.CommaText); - Remedy.Add(Format(sCommentCleanRelation, [ObjectSQlMapper.ExpressionName, SingleLink.ExpressionName])); - - remedy.Add(format('UPDATE %s SET %s = -1 WHERE BOLD_ID IN (%s);', // do not localize - [ObjectSQlMapper.MainTable.SQlName, SingleLink.MainColumnName, IdList.CommaText])); + BoldLog.LogFmt('The following %d objects of class %s have singlelinks (%s) pointing to objects that don''t point back (they might point elsewhere):', [IdList.Count, ObjectSQlMapper.ExpressionName, SingleLink.ExpressionName]); + FetchBlockSize := SystemSQLMapper.SQLDataBaseConfig.FetchBlockSize; + for Block := 0 to (IdList.Count div FetchBlockSize) do + begin + s := ''; + Start := Block * FetchBlockSize; + Stop := MinIntValue([Pred(Succ(Block) * FetchBlockSize), IdList.Count-1]); + for j := Start to Stop do + begin + s := s + IdList[j]; + if j < stop then + s := s + ','; + end; + BoldLog.Log(s, ltDetail); + Remedy.Add(Format('-- Clean relation (%s.%s) ', [ObjectSQlMapper.ExpressionName, SingleLink.ExpressionName])); + Remedy.Add(format('UPDATE %s SET %s = -1 WHERE BOLD_ID IN (%s);', + [ObjectSQlMapper.MainTable.SQlName, SingleLink.MainColumnName, s])); + end; end; - end; end; end; @@ -525,33 +763,64 @@ procedure TBoldDbDataValidator.ValidateRelations(ObjectSQLMapper: TBoldObjectSQL procedure TBoldDbDataValidator.ValidateStrayObjects(ObjectDefaultMapper: TBoldObjectDefaultMapper); var + i: integer; IdList: TStringList; + TypeList: TStringList; + TypeId: string; OwnMapping: TBoldAllInstancesMappingArray; + FetchBlockSize: integer; + Block, Start,Stop: integer; + s: string; + BoldIdField: IBoldField; + BoldTypeField: IBoldField; begin OwnMapping := SystemSQLMapper.MappingInfo.GetAllInstancesMapping(ObjectdefaultMapper.ExpressionName); if (length(OwnMapping)=1) and not OwnMapping[0].ClassIdRequired then begin IdList := TStringList.Create; + TypeList := TStringList.Create; try + Query.Close; Query.AssignSQLText(format(StrayObjectsTest, [ObjectDefaultMapper.MainTable.SQLName, ObjectDefaultMapper.SubClassesID])); - Query.Open; + OpenQuery; + BoldIdField := Query.FieldByName(Field_BOLD_ID); + BoldTypeField := Query.FieldByName(Field_BOLD_TYPE); while not query.eof do begin - IdList.Add(Query.FieldByName(Field_BOLD_ID).AsString); + IdList.Add(BoldIdField.AsString); + TypeId := BoldTypeField.AsString; + if not TypeList.Indexof(TypeId) > -1 then + TypeList.Add(TypeId); Query.Next; end; Query.Close; if IdList.Count > 0 then begin - BoldLog.LogFmt(sLogObjectsWithIllegalType, [ObjectDefaultMapper.MainTable.SQLName]); - BoldLog.Log(IdList.CommaText); - Remedy.Add(format(sCommentRemoveObjectsWithIllegaltype, [ObjectDefaultMapper.MainTable.SQLName])); - Remedy.Add(format('DELETE FROM %s WHERE BOLD_ID IN (%s);', [ObjectDefaultMapper.MainTable.SQLName, IdList.CommaText])); // do not localize - Query.AssignSQLText(Format('SELECT * FROM %s WHERE BOLD_ID IN (%s)', [ObjectDefaultMapper.MainTable.SQLName, IdList.CommaText])); // do not localize + BoldLog.Log('The following invalid types occur in the objects listed below:', ltWarning); + BoldLog.Log(TypeList.CommaText, ltDetail); + FetchBlockSize := SystemSQLMapper.SQLDataBaseConfig.FetchBlockSize; + for Block := 0 to (IdList.Count div FetchBlockSize) do + begin + s := ''; + Start := Block * FetchBlockSize; + Stop := MinIntValue([Pred(Succ(Block) * FetchBlockSize), IdList.Count-1]); + for i := Start to Stop do + begin + s := s + IdList[i]; + if i < stop then + s := s + ','; + end; + BoldLog.Log(s, ltDetail); + end; + BoldLog.LogFmt('The following %d objects are in table %s, but with an illegal type:', [IdList.Count, ObjectDefaultMapper.MainTable.SQLName], ltWarning); + Remedy.Add(format('-- Remove objects with illegal type in table %s', [ObjectDefaultMapper.MainTable.SQLName])); + Remedy.Add(format('DELETE FROM %s WHERE BOLD_ID IN (%s);', [ObjectDefaultMapper.MainTable.SQLName, s])); + Query.AssignSQLText(Format('SELECT * FROM %s WHERE BOLD_ID IN (%s)', [ObjectDefaultMapper.MainTable.SQLName, s])); end; finally FreeAndNil(IdList); + FreeAndNil(TypeList); end; end; end; @@ -579,12 +848,29 @@ procedure TBoldDbDataValidator.DeActivate; procedure TBoldDbDataValidator.AddRemedyForDeleteObjects(Mapper: TBoldObjectSQLMapper; IdList: TStringList); var - i: integer; + i,j: integer; + FetchBlockSize: integer; + Block, Start,Stop: integer; + s: string; begin + FetchBlockSize := SystemSQLMapper.SQLDataBaseConfig.FetchBlockSize; for i := 0 to Mapper.AllTables.Count - 1 do if Mapper.Alltables[i] <> (Mapper.SystemPersistenceMapper.PSSystemDescription as TBoldDefaultSystemDescription).XFilestable then - Remedy.Add(format('DELETE FROM %s WHERE BOLD_ID IN (%s);', [Mapper.AllTables[i].SQLName, IdList.CommaText])); // do not localize + begin + for Block := 0 to (IdList.Count div FetchBlockSize) do + begin + s := ''; + Start := Block * FetchBlockSize; + Stop := MinIntValue([Pred(Succ(Block) * FetchBlockSize), IdList.Count-1]); + for j := Start to Stop do + begin + s := s + IdList[j]; + if j < stop then + s := s + ','; + end; + Remedy.Add(format('DELETE FROM %s WHERE BOLD_ID IN (%s);', [Mapper.AllTables[i].SQLName, s])); + end; + end; end; end. - diff --git a/Source/PMapper/Validator/BoldDbStructureValidator.pas b/Source/PMapper/Validator/BoldDbStructureValidator.pas index 6aadcb0f..ab50c753 100644 --- a/Source/PMapper/Validator/BoldDbStructureValidator.pas +++ b/Source/PMapper/Validator/BoldDbStructureValidator.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDbStructureValidator; interface @@ -17,10 +20,10 @@ TBoldDbStructureValidator = class(TBoldDbValidator) fCurrentTable: IBoldTable; function GetCurrentTable: IBoldTable; protected - procedure ValidateNotNullForColumn(BoldSQLColumnDescription: TBoldSQLColumnDescription); procedure ValidateColumn(BoldSQLColumnDescription: TBoldSQLColumnDescription); procedure ValidateColumnsForTable(BoldSQLTableDescription: TBoldSQLTableDescription); procedure ValidateIndicesForTable(BoldSQLTableDescription: TBoldSQLTableDescription); + procedure FindExtraIndiciesForTable(BoldSQLTableDescription: TBoldSQLTableDescription); procedure ValidateIndex(BoldSQLIndexDescription: TBoldSQLIndexDescription); procedure ValidateTable(BoldSQLTableDescription: TBoldSQLTableDescription); procedure DeActivate; override; @@ -42,8 +45,8 @@ implementation BoldPMappersDefault, BoldPMappersSQL, BoldPMappers, - BoldPMConsts, - SysUtils; + SysUtils, + BoldRev; { TBoldDbStructureValidator } procedure TBoldDbStructureValidator.Validate; @@ -67,32 +70,35 @@ procedure TBoldDbStructureValidator.Validate; for i := 0 to PMapper.ObjectPersistenceMappers.Count - 1 do begin ObjectMapper := PMapper.ObjectPersistenceMappers[i]; - if MappingInfo.GetDbTypeMapping(ObjectMapper.ExpressionName) = NO_CLASS then + if Assigned(ObjectMapper) then begin - if QueryRes <> qrYesAll then - QueryRes := QueryUser(sMissingID, format(sAnIDWasMissing, [ObjectMapper.ExpressionName])); - if QueryRes in [qrYesAll, qrYes] then + if MappingInfo.GetDbTypeMapping(ObjectMapper.ExpressionName) = NO_CLASS then begin - MappingInfo.AddTypeIdMapping(ObjectMapper.ExpressionName, MappingInfo.HighestUsedDbType+1); - MappingsAdded := true; - end - else - exit; - end; + if QueryRes <> qrYesAll then + QueryRes := QueryUser('Missing ID', format('A databaseId was missing for %s. Do you want to add an unused ID?', [ObjectMapper.ExpressionName])); + if QueryRes in [qrYesAll, qrYes] then + begin + MappingInfo.AddTypeIdMapping(ObjectMapper.ExpressionName, MappingInfo.HighestUsedDbType+1); + MappingsAdded := true; + end + else + exit; + end; + end; // PMapper.ObjectPersistenceMappers[i] = nil ??? /FRHA end; if MappingsAdded then MappingInfo.WriteDataToDB(PersistenceHandle.DataBaseInterface); finally PersistenceHandle.DataBaseInterface.Close; end; - + PersistenceHandle.Active := false; PersistenceHandle.Active := true; try BoldLog.ProgressMax := SystemSQLMapper.AllTables.count - 1; for i := 0 to SystemSQLMapper.AllTables.count - 1 do begin ValidateTable(SystemSQLMapper.AllTables[i]); - BoldLog.LogHeader := Format(sCheckingTable, [SystemSQLMapper.AllTables[i].SQLName]); + BoldLog.LogHeader := 'Checking table ' + SystemSQLMapper.AllTables[i].SQLName; BoldLog.Progress := i; end; finally @@ -111,35 +117,139 @@ procedure TBoldDbStructureValidator.ValidateColumnsForTable(BoldSQLTableDescript procedure TBoldDbStructureValidator.ValidateColumn( BoldSQLColumnDescription: TBoldSQLColumnDescription); var + aQuery: IBoldQuery; + bColumnExists: Boolean; TableName: String; ColumnName: String; + FieldDef: TFieldDef; +const + sColumnMissing = 'Column missing: %s.%s (SQLType: %s)'; + sColumnSizeMismatch = 'Column %s in table %s has wrong size %d, should be %d'; + sColumnAllowsNull = 'Column %s in table %s allows null but the model does not'; + sColumnNotAllows = 'Column %s in table %s does not allow null but the model does'; + BlobFieldTypes = [{$IFDEF BOLD_DELPHI15_OR_LATER}ftStream,{$ENDIF} ftBlob..ftTypedBinary, ftWideMemo, ftOraBlob, ftOraClob]; begin TableName := BoldSQLColumnDescription.tableDescription.SQLName; ColumnName := BoldSQLColumnDescription.SQLName; - if not assigned(Currenttable.FindField(ColumnName)) then - begin + aQuery := SystemSQLMapper.GetQuery; + try + aQuery.AssignSQLText(SystemSQLMapper.SQLDataBaseConfig.GetColumnExistsQuery(TableName, ColumnName)); + aQuery.Open; + bColumnExists := aQuery.RecordCount = 1; + aQuery.Close; + if bColumnExists then + begin + FieldDef := CurrentTable.FieldDefs.Find(ColumnName); + if not (FieldDef.DataType in BlobFieldTypes) then + begin + if FieldDef.Size <> BoldSQLColumnDescription.Size then + BoldLog.LogFmt(sColumnSizeMismatch, + [ColumnName, Tablename, FieldDef.Size, BoldSQLColumnDescription.Size ], ltWarning); + end; + if FieldDef.Required <> BoldSQLColumnDescription.Mandatory then + begin + if FieldDef.Required then + BoldLog.LogFmt(sColumnNotAllows, + [ColumnName, Tablename], ltWarning) + else + BoldLog.LogFmt(sColumnAllowsNull, + [ColumnName, Tablename], ltWarning) + end; + end; + finally + SystemSQLMapper.ReleaseQuery(aQuery); + end; + + if not bColumnExists then begin BoldLog.LogFmt(sColumnMissing, - [Tablename, ColumnName, BoldSQLColumnDescription.SQLType]); - Remedy.add(format('alter table %s add %s %s %s;', [TableName, ColumnName, BoldSQLColumnDescription.SQLType, BoldSQLColumnDescription.SQLAllowNull])); // do not localize - end - else - if BoldSQLColumnDescription.Mandatory then - ValidateNotNullForColumn(BoldSQLColumnDescription); + [Tablename, ColumnName, BoldSQLColumnDescription.SQLType], ltWarning); + Remedy.add(format('alter table %s add %s %s %s;', [TableName, ColumnName, + BoldSQLColumnDescription.SQLType, BoldSQLColumnDescription.SQLAllowNull])); // do not localize + end else if BoldSQLColumnDescription.Mandatory then begin + // Moved to BoldDbDataValidator +// ValidateNotNullForColumn(BoldSQLColumnDescription); + end; end; procedure TBoldDbStructureValidator.ValidateIndex( BoldSQLIndexDescription: TBoldSQLIndexDescription); var - Index: TIndexDef; - IndexFields: String; + i,j: Integer; + sTableName: string; + sIndexFields: string; + aIndexFields: TStringList; + aQuery: IBoldQuery; + bIndexExists: Boolean; + MatchList, TempList: TStringList; + sIndexName: string; + isMultiIndex: boolean; + NameField: IBoldField; +const + sIndexMissing = 'Index missing: %s.(%s)'; + cIndexNameColumn = 'name'; // mssql specific, should it be a setting in sqlconfig ? begin - IndexFields := BoldSQLIndexDescription.IndexedFields; - Index := CurrentTable.IndexDefs.GetIndexForFields(IndexFields, false); - if not assigned(Index) then + MatchList := TStringList.Create; + TempList := TStringList.Create; + bIndexExists := False; + sTableName := TBoldSQLTableDescription(BoldSQLIndexDescription.Owner).SQLName; + sIndexFields := BoldSQLIndexDescription.IndexedFields; + aQuery := DataBase.GetQuery; + aIndexFields := TStringList.Create; + try + if pos(',', sIndexFields) > 1 then + aIndexFields.Delimiter := ',' + else + aIndexFields.Delimiter := ';'; + aIndexFields.DelimitedText := sIndexFields; + //At this time only indices exists with one index-field + //but maybe more in future + isMultiIndex := aIndexFields.Count > 1; + for i := 0 to aIndexFields.Count - 1 do + begin + aQuery.AssignSQLText(SystemSQLMapper.SQLDataBaseConfig + .GetIndexColumnExistsQuery(sTableName, Trim(aIndexFields[i]))); + aQuery.Open; + NameField := aQuery.FieldByName(cIndexNameColumn); + bIndexExists := aQuery.RecordCount > 0; + if isMultiIndex then + begin // for multi field indexes we have to determine if at least one index exists for all IndexFields + TempList.Clear; + while not aQuery.Eof do + begin + sIndexName := NameField.asString; + if i = 0 then // for first column we add all index names to list + MatchList.Add(sIndexName) + else // for all other columns we check if index exists + TempList.Add(sIndexName); + aQuery.next; + end; + if i > 0 then + begin + for j := MatchList.Count - 1 downto 0 do + if TempList.IndexOf(MatchList[j]) = -1 then + MatchList.Delete(j); + bIndexExists := MatchList.Count > 0; + end; + end; + aQuery.Close; + if not bIndexExists then begin + Break; + end; + end; + finally + if isMultiIndex then + bIndexExists := MatchList.count > 0; + aIndexFields.Free; + DataBase.ReleaseQuery(aQuery); + TempList.free; + MatchList.free; + end; + if not bIndexExists then begin - BoldLog.LogFmt(sIndexMissing, [CurrentTable.TableName, IndexFields]); - if ixPrimary in BoldSQLIndexDescription.IndexOptions then - Remedy.Add(Format('alter table %s add %s', [CurrentTable.TableName, BoldSQLIndexDescription.SQLForPrimaryKey])) // do not localize + BoldLog.LogFmt(sIndexMissing, [sTableName, sIndexFields], ltWarning); + if BoldPSDescriptionsSQL.ixPrimary in BoldSQLIndexDescription.IndexOptions then + Remedy.Add(Format('alter table %s add %s', [sTableName, + BoldSQLIndexDescription.SQLForPrimaryKey])) // do not localize else Remedy.Add(BoldSQLIndexDescription.SQLForSecondaryKey); end; @@ -151,56 +261,28 @@ procedure TBoldDbStructureValidator.ValidateIndicesForTable( i: integer; begin for i := 0 to BoldSQLTableDescription.IndexList.count - 1 do + begin ValidateIndex(BoldSQLTableDescription.IndexList[i] as TBoldSQLIndexDescription); -end; - -procedure TBoldDbStructureValidator.ValidateNotNullForColumn( - BoldSQLColumnDescription: TBoldSQLColumnDescription); -var - query: IBoldQuery; - FieldNames: TStrings; - TableName: String; - ColumnName: String; - NullCount: integer; -begin - FieldNames := TStringList.Create; - query := SystemSQLMapper.GetQuery; - TableName := BoldSQLColumnDescription.tableDescription.SQLName; - ColumnName := BoldSQLColumnDescription.SQLName; - try - Query.AssignSQLText(Format('SELECT count(*) FROM %s WHERE %s IS NULL', // do not localize - [TableName, - ColumnName])); - Query.Open; - nullcount := Query.Fields[0].AsInteger; - Query.Close; - if NullCount <> 0 then - begin - BoldLog.LogFmtIndent(sNullValuesFound, - [NullCount, tableName, ColumnName]); - Remedy.Add(Format('UPDATE %s SET %s = WHERE %1:s IS NULL;', // do not localize - [TableName, ColumnName])); - end; - finally - FieldNames.Free; - SystemSQLMapper.ReleaseQuery(query); end; end; procedure TBoldDbStructureValidator.ValidateTable( BoldSQLTableDescription: TBoldSQLTableDescription); +var + TableName: string; begin - CurrentTable.TableName := BoldSQLTableDescription.SQLName; + TableName := BoldSQLTableDescription.MappedSQLName(BoldSQLTableDescription.SQLNameUpper); + CurrentTable.TableName := TableName; if CurrentTable.Exists then begin - currentTable.Open; + CurrentTable.FieldDefs.Update; ValidateColumnsForTable(BoldSQLTableDescription); ValidateIndicesForTable(BoldSQLTableDescription); - CurrentTable.Close; + FindExtraIndiciesForTable(BoldSQLTableDescription); end else begin - BoldLog.LogFmt(sTableDoesNotExist, [BoldSQLTableDescription.SQLName]); + BoldLog.LogFmt('Table %s does not exist', [BoldSQLTableDescription.MappedSQLName(BoldSQLTableDescription.SQLNameUpper)], ltWarning); remedy.Add(BoldSQLTableDescription.sqlforCreateTable(DataBase)); end; end; @@ -212,6 +294,48 @@ destructor TBoldDbStructureValidator.destroy; inherited; end; +procedure TBoldDbStructureValidator.FindExtraIndiciesForTable( + BoldSQLTableDescription: TBoldSQLTableDescription); + + function SameFields(const s1, s2: String): boolean; + begin + result := SameText(TBoldSQLIndexDescription.NormalizeFields(s1), TBoldSQLIndexDescription.NormalizeFields(s2)); + end; + + function DefinedInModel(IndexDef: TBoldIndexDescription): Boolean; + var + j: Integer; + begin + Result := false; + for j := 0 to BoldSQLTableDescription.IndexList.count - 1 do + if SameText(IndexDef.IndexName, BoldSQLTableDescription.IndexList[j].GeneratedName) and + SameFields(IndexDef.IndexedColumns, BoldSQLTableDescription.IndexList[j].IndexedFields) then + begin + result := True; + Exit; + end; + for j := 0 to PersistenceHandle.CustomIndexes.Count - 1 do + begin + if SameText(IndexDef.IndexName, PersistenceHandle.CustomIndexes.IndexDefinition[j].TableName) and + SameFields(IndexDef.IndexedColumns, PersistenceHandle.CustomIndexes.IndexDefinition[j].Columns) and + (IndexDef.IsUnique = PersistenceHandle.CustomIndexes.IndexDefinition[j].Unique) then + begin + result := True; + Exit; + end; + end; + end; + +var + i: Integer; + IndexDefs: TBoldIndexDescriptionArray; +begin + IndexDefs := DataBase.GetIndexDescriptions(BoldSQLTableDescription.SQlName); + for I := 0 to length(IndexDefs) - 1 do + if not DefinedInModel(IndexDefs[i]) then + BoldLog.LogFmt('Extra Index: %s(%s)', [BoldSQLTableDescription.SQLName, IndexDefs[i].IndexedColumns], ltWarning); +end; + function TBoldDbStructureValidator.GetCurrentTable: IBoldTable; begin if not assigned(fCurrentTable) then @@ -223,10 +347,10 @@ procedure TBoldDbStructureValidator.DeActivate; begin if assigned(fCurrentTable) then DataBase.ReleaseTable(fCurrentTable); + inherited; end; -end. - - +initialization +end. diff --git a/Source/PMapper/Validator/BoldDbValidator.pas b/Source/PMapper/Validator/BoldDbValidator.pas index 69798fd2..075e92a2 100644 --- a/Source/PMapper/Validator/BoldDbValidator.pas +++ b/Source/PMapper/Validator/BoldDbValidator.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDbValidator; interface @@ -6,7 +9,8 @@ interface Classes, BoldDbInterfaces, BoldAbstractPersistenceHandleDB, - BoldPMappersSQL; + BoldPMappersSQL, + BoldSubscription; type { forward declarations } @@ -19,10 +23,12 @@ TBoldDbValidator = class(TComponent) fRemedy: TStringList; fPersistenceHandle: TBoldAbstractPersistenceHandleDB; FEnabled: Boolean; + fSubscriber: TBoldPassThroughSubscriber; function GetSystemSQLMapper: TBoldSystemSQLMApper; procedure SetEnabled(const Value: Boolean); procedure CheckTypeTableConsistency(SystemSQLMapper: TBoldSystemSQLMapper); function GetDataBase: IBoldDataBase; + procedure Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); protected procedure DeActivate; virtual; procedure SetPersistenceHandle(const Value: TBoldAbstractPersistenceHandleDB); virtual; @@ -35,7 +41,7 @@ TBoldDbValidator = class(TComponent) procedure Activate; procedure Validate; virtual; abstract; function Execute: Boolean; - property remedy: TStringList read fRemedy; + property Remedy: TStringList read fRemedy; published property PersistenceHandle: TBoldAbstractPersistenceHandleDB read fPersistenceHandle write SetPersistenceHandle; property Enabled: Boolean read FEnabled write SetEnabled; @@ -49,7 +55,6 @@ implementation BoldNameExpander, BoldDefs, SysUtils, - BoldPMConsts, Dialogs, Controls; @@ -63,20 +68,35 @@ procedure TBoldDbValidator.SetEnabled(const Value: Boolean); destructor TBoldDbValidator.destroy; begin FreeAndNil(fRemedy); + FreeAndNil(fSubscriber); inherited; end; function TBoldDbValidator.GetSystemSQLMapper: TBoldSystemSQLMApper; begin if not assigned(fSystemMapper) then + begin fSystemMapper := PersistenceHandle.PersistenceControllerDefault.PersistenceMapper as TBoldSystemSQLMapper; + fSystemMapper.AddSmallSubscription(fSubscriber, [beDestroying], beDestroying); + end; result := fSystemMapper; end; -constructor TBoldDbValidator.create(owner: TComponent); +procedure TBoldDbValidator.Receive(Originator: TObject; + OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); +begin + if RequestedEvent = beDestroying then + begin + fSystemMapper := nil; + fSubscriber.CancelAllSubscriptions; + end; +end; + +constructor TBoldDbValidator.Create(owner: TComponent); begin inherited; fRemedy := TStringList.Create; + fSubscriber := TBoldPassThroughSubscriber.Create(Receive); end; procedure TBoldDbValidator.SetPersistenceHandle(const Value: TBoldAbstractPersistenceHandleDB); @@ -94,21 +114,26 @@ procedure TBoldDbValidator.CheckTypeTableConsistency(SystemSQLMapper: TBoldSyste Found: Boolean; MissingClasses: Boolean; ObjectPMapper: TBoldObjectSQLMapper; + TypeParam, ClassParam: IBoldParameter; + BoldDBTypeField: IBoldField; + ClassNameField: IBoldField; begin query := SystemSQLMapper.GetQuery; ExecQuery := SystemSQLMapper.GetExecQuery; - query.AssignSQLText(format('SELECT * FROM %s', [TypeTableName])); // do not localize + query.AssignSQLText(format('SELECT * FROM %s', [TypeTableName])); HighestBoldDbType := -1; Query.Open; + BoldDBTypeField := Query.FieldByName('BOLD_TYPE'); + ClassNameField := Query.FieldByName('CLASSNAME'); while not query.eof do begin - BoldDbType := Query.FieldByName('BOLD_TYPE').AsInteger; // do not localize + BoldDbType := BoldDBTypeField.AsInteger; if BoldDbType > HighestBoldDbType then HighestBoldDbType := BoldDbType; - Name := Query.FieldByName('CLASSNAME').AsString; // do not localize + Name := ClassNameField.AsString; Found := false; for i := 0 to SystemSQLMapper.ObjectPersistenceMappers.count - 1 do @@ -123,7 +148,7 @@ procedure TBoldDbValidator.CheckTypeTableConsistency(SystemSQLMapper: TBoldSyste end; end; if not found then - BoldLog.LogFmt(sClassInDBNotInModel, [Name, BoldDbType]); + BoldLog.LogFmt('Database contains a class %s with BoldType %d that is not in the model...', [Name, BoldDbType]); Query.Next; end; Query.Close; @@ -136,24 +161,27 @@ procedure TBoldDbValidator.CheckTypeTableConsistency(SystemSQLMapper: TBoldSyste begin if not MissingClasses then BoldLog.Separator; - BoldLog.LogFmt(sClassWithoutDBID, [ObjectPMapper.ExpressionName]); + BoldLog.LogFmt('Model contains a class %s that does not have a database id', [ObjectPMapper.ExpressionName]); MissingClasses := true; end; end; if MissingClasses and - (MessageDlg(sCorrectClassesWithNoID, + (MessageDlg('There are classes with no database ID. Do you want to correct this now?', mtConfirmation, [mbYes, mbNo], 0) = mrYes) then begin BoldLog.Separator; Execquery.AssignSQLText( - format('INSERT INTO %s (%s, %s) VALUES (:%s, :%s)', [ // do not localize + format('INSERT INTO %s (%s, %s) VALUES (:%s, :%s)', [ TypeTablename, TYPECOLUMN_NAME, CLASSNAMECOLUMN_NAME, TYPECOLUMN_NAME, CLASSNAMECOLUMN_NAME])); + ExecQuery.ParamCheck := true; + TypeParam := ExecQuery.ParamByName(TYPECOLUMN_NAME); + ClassParam := ExecQuery.ParamByName(CLASSNAMECOLUMN_NAME); for i := 0 to SystemSQLMapper.ObjectPersistenceMappers.count - 1 do begin ObjectPMapper := SystemSQLMapper.ObjectPersistenceMappers[i] as TBoldObjectSQLMapper; @@ -161,9 +189,9 @@ procedure TBoldDbValidator.CheckTypeTableConsistency(SystemSQLMapper: TBoldSyste begin Inc(HighestBoldDbType); ObjectPMapper.BoldDbType := HighestBoldDbType; - BoldLog.LogFmt(sAddingBoldDBType, [ObjectPMapper.BoldDbType, ObjectPMapper.expressionName]); - ExecQuery.ParamByName(TYPECOLUMN_NAME).AsInteger := HighestBoldDbType; - ExecQuery.ParamByName(CLASSNAMECOLUMN_NAME).AsString := ObjectPMapper.ExpressionName; + BoldLog.LogFmt('Adding BoldDbType %d for %s', [ObjectPMapper.BoldDbType, ObjectPMapper.expressionName]); + TypeParam.AsInteger := HighestBoldDbType; + ClassParam.AsString := ObjectPMapper.ExpressionName; ExecQuery.ExecSQL; end; end; @@ -193,7 +221,7 @@ function TBoldDbValidator.Execute: Boolean; var i: integer; begin - BoldLog.StartLog(sDatabaseValidation); + BoldLog.StartLog('Database validation'); result := false; if assigned(PersistenceHandle) then begin @@ -204,24 +232,25 @@ function TBoldDbValidator.Execute: Boolean; if remedy.Count <> 0 then begin BoldLog.Separator; - BoldLog.Log(sInconsistenciesFound, ltWarning); + BoldLog.Log('Inconsistencies found', ltWarning); for i := 0 to remedy.Count - 1 do - BoldLog.Log(remedy[i]); + BoldLog.Log(remedy[i], ltDetail); BoldLog.Separator; end; result := Remedy.Count = 0; finally + BoldLog.Log('Database validation finished', ltInfo); DeActivate; end; except on e: Exception do begin - BoldLog.LogFmt(sDBValidationFailed, [e.message], ltError); + BoldLog.LogFmt('Database validation failed: %s', [e.message], ltError); end; end; end else - BoldLog.Log(sCannotValidateWithoutPHandle, ltError); + BoldLog.Log('Unable to perform validation, missing a PersistenceHandle', ltError); BoldLog.EndLog; end; diff --git a/Source/Persistence/ADO/ADOConsts.pas b/Source/Persistence/ADO/ADOConsts.pas index 5248c6e9..8a70c3a8 100644 --- a/Source/Persistence/ADO/ADOConsts.pas +++ b/Source/Persistence/ADO/ADOConsts.pas @@ -15,4 +15,4 @@ interface implementation -end. \ No newline at end of file +end. diff --git a/Source/Persistence/ADO/BoldADOInterfaces.pas b/Source/Persistence/ADO/BoldADOInterfaces.pas index 3c0ee6b6..d2b4be08 100644 --- a/Source/Persistence/ADO/BoldADOInterfaces.pas +++ b/Source/Persistence/ADO/BoldADOInterfaces.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldADOInterfaces; interface @@ -6,6 +9,7 @@ interface Classes, Db, ADODB, + BoldDefs, BoldSQLDatabaseConfig, BoldDBInterfaces; @@ -13,7 +17,8 @@ interface { forward declarations } TBoldADOParameter = class; TBoldADOQuery = class; - TBoldADOTable = class; TBoldADOConnection = class; + TBoldADOTable = class; + TBoldADOConnection = class; TBoldADOQueryClass = class of TBoldADOQuery; { TBoldADOParameter } @@ -27,6 +32,7 @@ TBoldADOParameter = class(TBoldParameterWrapper, IBoldParameter) function GetDataType: TFieldType; procedure SetDataType(Value: TFieldType); function GetAsBCD: Currency; + function GetAsblob: TBoldBlobData; function GetAsBoolean: Boolean; function GetAsDateTime: TDateTime; function GetAsCurrency: Currency; @@ -34,9 +40,10 @@ TBoldADOParameter = class(TBoldParameterWrapper, IBoldParameter) function GetAsInteger: Longint; function GetAsMemo: string; function GetAsString: string; + function GetAsInt64: Int64; function GetIsNull: Boolean; procedure SetAsBCD(const Value: Currency); - procedure SetAsBlob(const Value: TBlobData); + procedure SetAsBlob(const Value: TBoldBlobData); procedure SetAsBoolean(Value: Boolean); procedure SetAsCurrency(const Value: Currency); procedure SetAsDate(const Value: TDateTime); @@ -48,9 +55,14 @@ TBoldADOParameter = class(TBoldParameterWrapper, IBoldParameter) procedure SetAsSmallInt(Value: LongInt); procedure SetAsTime(const Value: TDateTime); procedure SetAsWord(Value: LongInt); + procedure SetAsInt64(const Value: Int64); procedure SetText(const Value: string); function GetParameter: TParameter; procedure AssignFieldValue(source: IBoldField); + function GetAsAnsiString: TBoldAnsiString; + function GetAsWideString: WideString; + procedure SetAsAnsiString(const Value: TBoldAnsiString); + procedure SetAsWideString(const Value: Widestring); property Parameter: TParameter read GetParameter; public constructor create(AdoParameter: TParameter; DatasetWrapper: TBoldDatasetWrapper); @@ -70,9 +82,13 @@ TBoldADOQuery = class(TBoldDataSetWrapper, IBoldQuery, IBoldExecQuery, IBoldPa procedure SetRequestLiveQuery(NewValue: Boolean); function GetSQLText: String; procedure AssignSQL(SQL: TStrings); virtual; - procedure AssignSQLText(SQL: String); + procedure AssignSQLText(const SQL: String); function GetRowsAffected: integer; function GetRecordCount: integer; + function GetParamCheck: Boolean; + procedure SetParamCheck(value: Boolean); + function GetUseReadTransactions: boolean; + procedure SetUseReadTransactions(value: boolean); protected procedure StartSQLBatch; virtual; procedure EndSQLBatch; virtual; @@ -96,7 +112,7 @@ TBoldADOTable = class(TBoldDataSetWrapper, IBoldTable) procedure CreateTable; procedure DeleteTable; function GetIndexDefs: TIndexDefs; - procedure SetTableName(NewName: String); + procedure SetTableName(const NewName: String); function GetTableName: String; procedure SetExclusive(NewValue: Boolean); function GetExclusive: Boolean; @@ -126,18 +142,20 @@ TBoldADOConnection = class(TBoldDatabaseWrapper, IBoldDataBase) procedure RollBack; procedure Open; procedure Close; + procedure Reconnect; - function GetTable: IBoldTable; - procedure ReleaseTable(var Table: IBoldTable); + function GetIsExecutingQuery: Boolean; function SupportsTableCreation: Boolean; procedure ReleaseCachedObjects; protected procedure AllTableNames(Pattern: String; ShowSystemTables: Boolean; TableNameList: TStrings); override; function GetQuery: IBoldQuery; override; procedure ReleaseQuery(var Query: IBoldQuery); override; + function GetTable: IBoldTable; override; + procedure ReleaseTable(var Table: IBoldTable); override; public - constructor Create(DataBase: TADOConnection; SQLDataBaseConfig: TBoldSQLDatabaseConfig); - destructor Destroy; override; + constructor create(DataBase: TADOConnection; SQLDataBaseConfig: TBoldSQLDatabaseConfig); + destructor destroy; override; end; var @@ -146,13 +164,11 @@ TBoldADOConnection = class(TBoldDatabaseWrapper, IBoldDataBase) implementation uses - BoldDefs, BoldUtils, SysUtils, Variants, Masks, - BoldGuard, - BoldCoreConsts; + BoldGuard; { TBoldADOQuery } @@ -175,7 +191,6 @@ procedure TBoldADOQuery.AssignSQL(SQL: TStrings); Guard: IBoldGuard; begin Guard := TBoldGuard.Create(BackupQuery); - // ADO sometimes tries to bind the params at this point, unless we disconnect the connection first OldConnection := Query.Connection; if Query.Parameters.count > 0 then begin @@ -183,7 +198,6 @@ procedure TBoldADOQuery.AssignSQL(SQL: TStrings); BackupQuery.Parameters.Assign(Query.Parameters); end; - Query.Close; // safe operation even if the query is closed. Open queries will cause "invalid operation" on next line Query.Connection := nil; Query.SQL.BeginUpdate; Query.SQL.Assign(SQL); @@ -194,15 +208,16 @@ procedure TBoldADOQuery.AssignSQL(SQL: TStrings); Query.Connection := OldConnection; end; -procedure TBoldADOQuery.AssignSQLText(SQL: String); -var - StringList: TStringList; - Guard: IBoldguard; +procedure TBoldADOQuery.AssignSQLText(const SQL: String); begin - Guard := tBoldGuard.Create(StringList); - StringList := TStringList.create; - BoldAppendToStrings(StringList, SQL, true); - AssignSQL(StringList); + Query.SQL.BeginUpdate; + Query.SQL.Clear; +{$IFDEF BOLD_DELPHI10_OR_LATER} + Query.SQL.Append(SQL); // FIXME, this gives one long line. +{$ELSE} + BoldAppendToStrings(Query.SQL, SQL, true); +{$ENDIF} + Query.SQL.EndUpdate; end; procedure TBoldADOQuery.ClearParams; @@ -214,6 +229,7 @@ constructor TBoldADOQuery.Create(Query: TADOQuery; DatabaseWrapper: TBoldDatabas begin inherited create(DatabaseWrapper); fQuery := Query; + SetParamCheck(true); end; function TBoldADOQuery.Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; @@ -225,18 +241,21 @@ function TBoldADOQuery.Createparam(FldType: TFieldType; const ParamName: string; procedure TBoldADOQuery.EndSQLBatch; begin - // intentionally left blank end; procedure TBoldADOQuery.ExecSQL; begin +{$IFDEF BOLD_DELPHI10_OR_LATER} + BoldLogSQLWide(Query.SQL, self); +{$ELSE} BoldLogSQL(Query.SQL); +{$ENDIF} try Query.ExecSQL; except on e: Exception do begin - e.Message := e.Message + BOLDCRLF + 'SQL: ' + Query.SQL.text; // do not localize + e.Message := e.Message + BOLDCRLF + 'SQL: ' + Query.SQL.text; raise; end; end; @@ -244,7 +263,6 @@ procedure TBoldADOQuery.ExecSQL; procedure TBoldADOQuery.FailSQLBatch; begin - // intentionally left blank end; function TBoldADOQuery.GetDataSet: TDataSet; @@ -252,6 +270,11 @@ function TBoldADOQuery.GetDataSet: TDataSet; result := Query; end; +function TBoldADOQuery.GetParamCheck: Boolean; +begin + Result := Query.ParamCheck; +end; + function TBoldADOQuery.GetParamCount: integer; begin result := Query.Parameters.count; @@ -287,18 +310,24 @@ function TBoldADOQuery.GetSQLText: String; result := Query.SQL.Text; end; +function TBoldADOQuery.GetUseReadTransactions: boolean; +begin + result := false; +end; + procedure TBoldADOQuery.Open; begin +{$IFDEF BOLD_DELPHI10_OR_LATER} + BoldLogSQLWide(Query.SQL, self); +{$ELSE} BoldLogSQL(Query.SQL); +{$ENDIF} try - Query.CacheSize := 10000; - Query.CursorType := ctOpenForwardOnly; - Query.LockType := ltReadOnly; inherited; except on e: Exception do begin - e.Message := e.Message + BOLDCRLF + 'SQL: ' + Query.SQL.text; // do not localize + e.Message := e.Message + BOLDCRLF + 'SQL: ' + Query.SQL.text; raise; end; end; @@ -315,14 +344,22 @@ function TBoldADOQuery.ParamByName(const Value: string): IBoldParameter; result := nil; end; +procedure TBoldADOQuery.SetParamCheck(value: Boolean); +begin + Query.ParamCheck := Value; +end; + procedure TBoldADOQuery.SetRequestLiveQuery(NewValue: Boolean); begin - // ignore +end; + +procedure TBoldADOQuery.SetUseReadTransactions(value: boolean); +begin + end; procedure TBoldADOQuery.StartSQLBatch; begin - // intentionally left blank end; { TBoldADOTable } @@ -330,7 +367,7 @@ procedure TBoldADOQuery.StartSQLBatch; procedure TBoldADOTable.AddIndex(const Name, Fields: string; Options: TIndexOptions; const DescFields: string); begin - raise EBold.CreateFmt(sMethodNotImplemented, [ClassName, 'AddIndex']); // do not localize + raise EBold.CreateFmt('%s.AddIndex: not implemented', [ClassName]); end; constructor TBoldADOTable.Create(Table: TADOTable; DatabaseWrapper: TBoldDatabaseWrapper); @@ -341,12 +378,12 @@ constructor TBoldADOTable.Create(Table: TADOTable; DatabaseWrapper: TBoldDatabas procedure TBoldADOTable.CreateTable; begin - raise EBold.CreateFmt(sMethodNotImplemented, [ClassName, 'CreateTable']); // do not localize + raise EBold.CreateFmt('%s.CreateTable: not implemented', [ClassName]); end; procedure TBoldADOTable.DeleteTable; begin - raise EBold.CreateFmt(sMethodNotImplemented, [ClassName, 'DeleteTable']); // do not localize + raise EBold.CreateFmt('%s.DeleteTable: not implemented', [ClassName]); end; function TBoldADOTable.GetDataSet: TDataSet; @@ -366,11 +403,8 @@ function TBoldADOTable.GetExists: Boolean; begin Guard := TBoldGuard.Create(AllTables); Result := False; - - // First we make sure we have a table component and that it is connected to a database if Assigned(Table) and Assigned(Table.Connection) then begin - // We now create a list that will hold all the table names in the database Alltables := TStringList.Create; Table.Connection.GetTableNames(AllTables); Result := AllTables.IndexOf(GetTableName) <> -1; @@ -400,14 +434,12 @@ procedure TBoldADOTable.SetExclusive(NewValue: Boolean); Table.LockType := ltOptimistic; end; -procedure TBoldADOTable.SetTableName(NewName: String); +procedure TBoldADOTable.SetTableName(const NewName: String); begin Table.TableName := NewName; end; { TBoldADOConnection } - -// Populate the "TableNameList" with tablenames from the database that maches "pattern" procedure TBoldADOConnection.AllTableNames(Pattern: String; ShowSystemTables: Boolean; TableNameList: TStrings); var TempList: TStringList; @@ -422,19 +454,17 @@ procedure TBoldADOConnection.AllTableNames(Pattern: String; ShowSystemTables: Bo else TempPattern := Pattern; - // Retrieve the list of table names - // Note: This does not include views or procedures, there is a specific - // method in TADOConnection for that + GetDataBase.GetTableNames(TempList, ShowSystemTables); - // MatchesMask is used to compare filenames with wildcards, suits us here - // but there should be some care taken, when using tablenames with period - // signes, as that might be interpreted as filename extensions + for i := 0 to TempList.Count-1 do if MatchesMask(TempList[i], tempPattern) then TableNameList.Add(TempList[i]); end; + + procedure TBoldADOConnection.Commit; begin DataBase.CommitTrans; @@ -445,6 +475,11 @@ function TBoldADOConnection.GetInTransaction: Boolean; result := DataBase.InTransaction; end; +function TBoldADOConnection.GetIsExecutingQuery: Boolean; +begin + result := false; // TODO: implement +end; + function TBoldADOConnection.GetIsSQLBased: Boolean; begin result := true; @@ -452,7 +487,6 @@ function TBoldADOConnection.GetIsSQLBased: Boolean; function TBoldADOConnection.GetKeepConnection: Boolean; begin - //CheckMe; result := true; end; @@ -468,7 +502,6 @@ procedure TBoldADOConnection.RollBack; procedure TBoldADOConnection.SetKeepConnection(NewValue: Boolean); begin - //CheckMe; end; procedure TBoldADOConnection.SetlogInPrompt(NewValue: Boolean); @@ -481,9 +514,8 @@ procedure TBoldADOConnection.StartTransaction; DataBase.BeginTrans; end; -destructor TBoldADOConnection.Destroy; +destructor TBoldADOConnection.destroy; begin -// FreeAndNil(fParameters); FreeAndNil(fCachedQuery); FreeAndNil(fCachedTable); inherited; @@ -493,7 +525,7 @@ constructor TBoldADOConnection.create(DataBase: TADOConnection; SQLDataBaseConfi begin inherited create(SQLDataBaseConfig); fDatabase := DataBase; -end; +end; procedure TBoldADOConnection.Close; begin @@ -597,7 +629,6 @@ function TBoldADOConnection.SupportsTableCreation: Boolean; procedure TBoldADOParameter.Clear; begin - // FIXME end; constructor TBoldADOParameter.create(AdoParameter: TParameter; DatasetWrapper: TBoldDatasetWrapper); @@ -606,11 +637,23 @@ constructor TBoldADOParameter.create(AdoParameter: TParameter; DatasetWrapper: T fParameter := AdoParameter; end; +function TBoldADOParameter.GetAsAnsiString: TBoldAnsiString; +begin + result := TBoldAnsiString(Parameter.Value); + if string(result) = DatasetWrapper.DatabaseWrapper.SQLDatabaseConfig.EmptyStringMarker then + result := ''; +end; + function TBoldADOParameter.GetAsBCD: Currency; begin result := parameter.Value; end; +function TBoldADOParameter.GetAsblob: TBoldBlobData; +begin + result := TBoldAnsiString(parameter.Value); +end; + function TBoldADOParameter.GetAsBoolean: Boolean; begin result := parameter.Value; @@ -631,6 +674,11 @@ function TBoldADOParameter.GetAsFloat: Double; result := parameter.Value; end; +function TBoldADOParameter.GetAsInt64: Int64; +begin + result := parameter.Value; +end; + function TBoldADOParameter.GetAsInteger: Longint; begin result := parameter.Value; @@ -645,7 +693,7 @@ function TBoldADOParameter.GetAsString: string; begin result := parameter.Value; if result = DatasetWrapper.DatabaseWrapper.SQLDatabaseConfig.EmptyStringMarker then - result := ''; + result := ''; end; function TBoldADOParameter.GetAsVariant: Variant; @@ -653,6 +701,13 @@ function TBoldADOParameter.GetAsVariant: Variant; result := parameter.Value; end; +function TBoldADOParameter.GetAsWideString: WideString; +begin + result := Parameter.Value; + if string(result) = DatasetWrapper.DatabaseWrapper.SQLDatabaseConfig.EmptyStringMarker then + result := ''; +end; + function TBoldADOParameter.GetDataType: TFieldType; begin result := parameter.DataType; @@ -673,6 +728,14 @@ function TBoldADOParameter.GetParameter: TParameter; result := fParameter; end; +procedure TBoldADOParameter.SetAsAnsiString(const Value: TBoldAnsiString); +begin + if value = '' then + Parameter.Value := DatasetWrapper.DatabaseWrapper.SQLDatabaseConfig.EmptyStringMarker + else + Parameter.Value := Value +end; + procedure TBoldADOParameter.SetAsBCD(const Value: Currency); begin Parameter.Value := Value; @@ -713,6 +776,11 @@ procedure TBoldADOParameter.SetAsFloat(const Value: Double); Parameter.Value := Value; end; +procedure TBoldADOParameter.SetAsInt64(const Value: Int64); +begin + Parameter.Value := Value; +end; + procedure TBoldADOParameter.SetAsInteger(Value: Integer); begin Parameter.Value := Value; @@ -746,6 +814,14 @@ procedure TBoldADOParameter.SetAsVariant(const NewValue: Variant); Parameter.Value := NewValue; end; +procedure TBoldADOParameter.SetAsWideString(const Value: Widestring); +begin + if value = '' then + Parameter.Value := DatasetWrapper.DatabaseWrapper.SQLDatabaseConfig.EmptyStringMarker + else + Parameter.Value := Value +end; + procedure TBoldADOParameter.SetAsWord(Value: Integer); begin Parameter.Value := Value; @@ -766,14 +842,21 @@ procedure TBoldADOParameter.AssignFieldValue(source: IBoldField); Parameter.Assign(Source.Field); end; +procedure TBoldADOConnection.Reconnect; +begin + if Assigned(fDataBase) then begin + fDataBase.Connected := False; + fDataBase.Connected := True; + end; +end; + procedure TBoldADOConnection.ReleaseCachedObjects; begin FreeAndNil(fCachedTable); FreeAndNil(fCachedQuery); end; -end. - - +initialization +end. diff --git a/Source/Persistence/ADO/BoldDatabaseAdapterADO.pas b/Source/Persistence/ADO/BoldDatabaseAdapterADO.pas index 55fcafc8..621b1f8e 100644 --- a/Source/Persistence/ADO/BoldDatabaseAdapterADO.pas +++ b/Source/Persistence/ADO/BoldDatabaseAdapterADO.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDatabaseAdapterADO; interface @@ -22,7 +25,7 @@ TBoldDatabaseAdapterADO = class(TBoldAbstractDatabaseAdapter) procedure ReleaseBoldDatabase; override; function GetDataBaseInterface: IBoldDatabase; override; public - destructor Destroy; override; + destructor destroy; override; published property Connection: TADOConnection read GetDataBase write SetDataBase; {$IFNDEF T2H} @@ -34,12 +37,11 @@ implementation uses SysUtils, - BoldDefs, - ADOConsts; + BoldDefs; { TBoldDatabaseAdapterADO } -destructor TBoldDatabaseAdapterADO.Destroy; +destructor TBoldDatabaseAdapterADO.destroy; begin Changed; FreePublisher; @@ -55,7 +57,7 @@ function TBoldDatabaseAdapterADO.GetDataBase: TADOConnection; function TBoldDatabaseAdapterADO.GetDataBaseInterface: IBoldDatabase; begin if not assigned(Connection) then - raise EBold.CreateFmt(sAdapterNotConnected, [classname]); + raise EBold.CreateFmt('%s.GetDatabaseInterface: The adapter is not connected to an ADO connection', [classname]); if not assigned(fBoldDatabase) then fBoldDatabase := TBoldADOConnection.create(Connection, SQLDataBaseConfig); result := fBoldDatabase; @@ -71,4 +73,6 @@ procedure TBoldDatabaseAdapterADO.SetDataBase(const Value: TADOConnection); InternalDatabase := value; end; +initialization + end. diff --git a/Source/Persistence/ADO/BoldPersistenceHandleADO.pas b/Source/Persistence/ADO/BoldPersistenceHandleADO.pas index b7a7c189..776f731a 100644 --- a/Source/Persistence/ADO/BoldPersistenceHandleADO.pas +++ b/Source/Persistence/ADO/BoldPersistenceHandleADO.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleADO; interface @@ -47,8 +50,8 @@ TBoldPersistenceHandleADO = class(TBoldDBPersistenceHandle) procedure InternalTransferproperties(const target: TBoldPersistenceHandleDB); override; {$ENDIF} public - constructor Create(owner: tComponent); override; - destructor Destroy; override; + constructor create(owner: tComponent); override; + destructor destroy; override; function GetDataBaseInterface: IBoldDatabase; override; procedure Assign(Source: TPersistent); override; published @@ -74,8 +77,7 @@ implementation SysUtils, BoldDefs, BoldDatabaseAdapterAdo, - BoldUtils, - ADOConsts; + BoldUtils; function BoldStringToNetworkProtocol(s: String): TBoldNetworkProtocol; var @@ -87,7 +89,7 @@ function BoldStringToNetworkProtocol(s: String): TBoldNetworkProtocol; result := i; exit; end; - + result := bnwpLocal; end; @@ -97,13 +99,13 @@ procedure TBoldPersistenceHandleADO.AddExtendedProperties( Result: TStrings); begin if trim(DataSource) <> '' then - result.Add('DSN='+trim(DataSource)); // do not localize + result.Add('DSN='+trim(DataSource)); if trim(HostName) <> '' then - Result.Add('Hostname='+trim(HostName)); // do not localize + Result.Add('Hostname='+trim(HostName)); if trim(InitialCatalog) <> '' then - Result.Add('Initial Catalog='+trim(InitialCatalog)); // do not localize + Result.Add('Initial Catalog='+trim(InitialCatalog)); - result.Add('NetworkProt='+BoldNetWorkProtocolStringRep[NetWorkProtocol]); // do not localize + result.Add('NetworkProt='+BoldNetWorkProtocolStringRep[NetWorkProtocol]); Result.AddStrings(ExtendedProperties); end; @@ -127,7 +129,7 @@ procedure TBoldPersistenceHandleADO.UpdateInternalConnectionString; LExtendedProperties := TStringList.Create; AddExtendedProperties(LExtendedProperties); - ConnectionString := format('Provider=%s;Persist Security Info=%s;Data Source=%s;Extended Properties=%s', // do not localize + ConnectionString := format('Provider=%s;Persist Security Info=%s;Data Source=%s;Extended Properties=%s', [Provider, BoolToStr[PersistSecurityInfo], DataSource, @@ -140,11 +142,12 @@ procedure TBoldPersistenceHandleADO.UpdateInternalConnectionString; constructor TBoldPersistenceHandleADO.create(owner: tComponent); begin inherited; - FHostName := ''; // do not localize + FHostName := ''; fExtendedProperties := TStringList.Create; end; -destructor TBoldPersistenceHandleADO.Destroy; + +destructor TBoldPersistenceHandleADO.destroy; begin Active := false; FreeAndNil(fOwnConnection); @@ -152,12 +155,13 @@ destructor TBoldPersistenceHandleADO.Destroy; inherited; end; + procedure TBoldPersistenceHandleADO.SetADOConnection( const Value: TADOConnection); begin if fADOConnection <> Value then begin - CheckInactive('SetDataBase'); // do not localize + CheckInactive('SetDataBase'); if assigned(fOwnConnection) then begin FreeAndNil(fOwnConnection); @@ -186,7 +190,7 @@ procedure TBoldPersistenceHandleADO.SetHostName(const Value: String); begin FHostName := Value; if trim(fHostName) = '' then - FHostName := ''; // do not localize + FHostName := ''; UpdateInternalConnectionString; end; @@ -243,7 +247,7 @@ function TBoldPersistenceHandleADO.getEffectiveConnection: TADOConnection; UpdateInternalConnectionString; end; result := fOwnConnection; - end; + end; end; procedure TBoldPersistenceHandleADO.SetPassword(const Value: string); @@ -280,14 +284,14 @@ procedure TBoldPersistenceHandleADO.InternalTransferproperties( if not assigned(Target.DatabaseAdapter) then begin Target.DatabaseAdapter := TBoldDatabaseAdapterADO.Create(Target.Owner); - Target.DatabaseAdapter.Name := GetNewComponentName(Target.DatabaseAdapter, 'BoldDatabaseAdapterADO'); // do not localize - LongRec(DesInfo).Lo := LongRec(DesInfo).lo+16; //set Left - LongRec(DesInfo).Hi := LongRec(DesInfo).hi+16; //Set Top; + Target.DatabaseAdapter.Name := GetNewComponentName(Target.DatabaseAdapter, 'BoldDatabaseAdapterADO'); + LongRec(DesInfo).Lo := LongRec(DesInfo).lo+16; + LongRec(DesInfo).Hi := LongRec(DesInfo).hi+16; Target.DatabaseAdapter.DesignInfo := DesInfo; - showmessage(sCreatedNewAdapter); + showmessage('Created a new DatabaseAdapterADO'); end else if not (target.DatabaseAdapter is TBoldDatabaseAdapterADO) then - raise Exception.CreateFmt(sCanOnlyTransferToADOAdapter, [target.DatabaseAdapter.ClassName] ); + raise Exception.CreateFmt('The persistencehandle is connected to a %s, properties can only be transfered to a TBoldDatabaseAdapterADO', [target.DatabaseAdapter.ClassName] ); Adapter := target.DatabaseAdapter as tBoldDatabaseAdapterADO; if assigned(fADOConnection) then @@ -296,17 +300,17 @@ procedure TBoldPersistenceHandleADO.InternalTransferproperties( if not assigned(Adapter.Connection) then begin Adapter.Connection := TADOConnection.Create(Target.owner); - Adapter.Connection.Name := GetNewComponentName(Adapter.Connection, 'ADODatabase'); // do not localize - showmessage(sCreatedNewDB); - LongRec(DesInfo).Lo := LongRec(DesInfo).lo+16; //set Left - LongRec(DesInfo).Hi := LongRec(DesInfo).hi+16; //Set Top; + Adapter.Connection.Name := GetNewComponentName(Adapter.Connection, 'ADODatabase'); + showmessage('Created a new ADODatabase'); + LongRec(DesInfo).Lo := LongRec(DesInfo).lo+16; + LongRec(DesInfo).Hi := LongRec(DesInfo).hi+16; Adapter.Connection.DesignInfo := DesInfo; try LExtendedProperties := TStringList.Create; AddExtendedProperties(LExtendedProperties); - ConnectionString := format('Provider=%s;Persist Security Info=%s;Data Source=%s;Extended Properties=%s', // do not localize + ConnectionString := format('Provider=%s;Persist Security Info=%s;Data Source=%s;Extended Properties=%s', [Provider, BoolToStr[PersistSecurityInfo], DataSource, @@ -316,9 +320,9 @@ procedure TBoldPersistenceHandleADO.InternalTransferproperties( except on e: exception do begin - showmessage(sCouldNotTransferConnectionString+BOLDCRLF+BOLDCRLF+ + showmessage('Connection string settings could not be transferred to the new ADO connection: '+BOLDCRLF+BOLDCRLF+ e.message + BOLDCRLF+BOLDCRLF + - sTransferManually); + 'Please transfer these manually!'); Adapter.Connection.ConnectionString := ''; end; @@ -326,7 +330,6 @@ procedure TBoldPersistenceHandleADO.InternalTransferproperties( end; end; +initialization end. - - diff --git a/Source/Persistence/ADO/BoldPersistenceHandleADOReg.pas b/Source/Persistence/ADO/BoldPersistenceHandleADOReg.pas index a5be7268..3a25a197 100644 --- a/Source/Persistence/ADO/BoldPersistenceHandleADOReg.pas +++ b/Source/Persistence/ADO/BoldPersistenceHandleADOReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleADOReg; interface @@ -17,9 +20,7 @@ implementation procedure Register; begin - {$WARNINGS OFF} - RegisterComponents(BOLDPAGENAME_DEPRECATED, [TBoldPersistenceHandleADO]); - {$WARNINGS ON} + RegisterComponents(BOLDPAGENAME_DEPRECATED, [TBoldPersistenceHandleADO]); RegisterComponents(BOLDPAGENAME_PERSISTENCE, [TBoldDatabaseAdapterADO]); end; diff --git a/Source/Persistence/Advantage/BoldAdvantageInterfaces.pas b/Source/Persistence/Advantage/BoldAdvantageInterfaces.pas index 6eb4c4ad..c715cc28 100644 --- a/Source/Persistence/Advantage/BoldAdvantageInterfaces.pas +++ b/Source/Persistence/Advantage/BoldAdvantageInterfaces.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAdvantageInterfaces; interface @@ -10,7 +13,7 @@ interface adstable, BoldSQLDatabaseConfig, BoldDBInterfaces; - + type { forward declarations } TBoldAdvantageDatabase = class; @@ -33,7 +36,9 @@ TBoldAdvantageQuery = class(TBoldDataSetWrapper, IBoldQuery, IBoldExecQuery, I procedure AssignParams(Sourceparams: TParams); procedure ClearParams; procedure AssignSQL(SQL: TStrings); - procedure AssignSQLText(SQL: String); + procedure AssignSQLText(const SQL: String); + function GetParamCheck: Boolean; + procedure SetParamCheck(value: Boolean); procedure SetRequestLiveQuery(NewValue: Boolean); function Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; protected @@ -57,7 +62,7 @@ TBoldAdvantageTable = class(TBoldDataSetWrapper, IBoldTable) procedure DeleteTable; function GetTable: TADSTable; function GetIndexDefs: TIndexDefs; - procedure SetTableName(NewName: String); + procedure SetTableName(const NewName: String); function GetTableName: String; procedure SetExclusive(NewValue: Boolean); function GetExclusive: Boolean; @@ -82,12 +87,10 @@ TBoldAdvantageDatabase = class(TBolddatabaseWrapper, IBoldDataBase) function GetIsSQLBased: Boolean; function GetKeepConnection: Boolean; function GetLogInPrompt: Boolean; - function GetTable: IBoldTable; function SupportsTableCreation: boolean; procedure Close; procedure Commit; procedure Open; - procedure ReleaseTable(var Table: IBoldTable); procedure Rollback; procedure SetKeepConnection(NewValue: Boolean); procedure SetlogInPrompt(NewValue: Boolean); @@ -98,9 +101,11 @@ TBoldAdvantageDatabase = class(TBolddatabaseWrapper, IBoldDataBase) procedure AllTableNames(Pattern: String; ShowSystemTables: Boolean; TableNameList: TStrings); override; function GetQuery: IBoldQuery; override; procedure ReleaseQuery(var Query: IBoldQuery); override; + function GetTable: IBoldTable; override; + procedure ReleaseTable(var Table: IBoldTable); override; public - constructor Create(Database: TADSConnection; SQLDataBaseConfig: TBoldSQLDatabaseConfig); - destructor Destroy; override; + constructor create(Database: TADSConnection; SQLDataBaseConfig: TBoldSQLDatabaseConfig); + destructor destroy; override; end; var @@ -141,7 +146,7 @@ procedure TBoldAdvantageQuery.AssignSQL(SQL: TStrings); Query.SQL.EndUpdate; end; -procedure TBoldAdvantageQuery.AssignSQLText(SQL: String); +procedure TBoldAdvantageQuery.AssignSQLText(const SQL: String); begin Query.SQL.BeginUpdate; Query.SQL.Clear; @@ -158,6 +163,7 @@ constructor TBoldAdvantageQuery.Create(Query: TADSQuery; DatabaseWrapper: TBoldD begin inherited create(DatabaseWrapper); FQuery := Query; + SetParamCheck(true); end; function TBoldAdvantageQuery.Createparam(FldType: TFieldType; @@ -191,6 +197,11 @@ function TBoldAdvantageQuery.GetDataSet: TDataSet; result := Query; end; +function TBoldAdvantageQuery.GetParamCheck: Boolean; +begin + Result := Query.ParamCheck; +end; + function TBoldAdvantageQuery.GetParamCount: integer; begin result := Query.Params.count; @@ -244,6 +255,11 @@ function TBoldAdvantageQuery.ParamByName(const Value: string): IBoldParameter; end; +procedure TBoldAdvantageQuery.SetParamCheck(value: Boolean); +begin + Query.ParamCheck := Value; +end; + procedure TBoldAdvantageQuery.SetRequestLiveQuery(NewValue: Boolean); begin end; @@ -313,19 +329,16 @@ procedure TBoldAdvantageTable.SetExclusive(NewValue: Boolean); Table.Exclusive := NewValue; end; -procedure TBoldAdvantageTable.SetTableName(NewName: String); +procedure TBoldAdvantageTable.SetTableName(const NewName: String); begin Table.TableName := NewName; end; - - { TBoldSDDataBase } procedure TBoldAdvantageDatabase.AllTableNames(Pattern: String; ShowSystemTables: Boolean; TableNameList: TStrings); begin -// if (Pattern <> '') and (Pattern <> '*') then -// raise Exception.CreateFmt('%s.AlltableNames: This call does not allow patterns ("%s")', [ClassName, Pattern]); + Database.GetTableNames(TableNameList, Pattern {ShowSystemTables}); end; @@ -345,7 +358,7 @@ constructor TBoldAdvantageDatabase.create(DataBase: TADSConnection; SQLDataBaseC FDataBase := DataBase; end; -destructor TBoldAdvantageDatabase.Destroy; +destructor TBoldAdvantageDatabase.destroy; begin inherited; FDatabase := nil; diff --git a/Source/Persistence/Advantage/BoldDatabaseAdapterAdvantage.pas b/Source/Persistence/Advantage/BoldDatabaseAdapterAdvantage.pas index 3cf8fd37..0f15bc85 100644 --- a/Source/Persistence/Advantage/BoldDatabaseAdapterAdvantage.pas +++ b/Source/Persistence/Advantage/BoldDatabaseAdapterAdvantage.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDatabaseAdapterAdvantage; interface @@ -22,7 +25,7 @@ TBoldDatabaseAdapterAdvantage = class(TBoldAbstractDatabaseAdapter) procedure ReleaseBoldDatabase; override; function GetDataBaseInterface: IBoldDatabase; override; public - destructor Destroy; override; + destructor destroy; override; published property DataBase: TADSConnection read GetDataBase write SetDataBase; {$IFNDEF T2H} @@ -36,14 +39,14 @@ implementation SysUtils, BoldDefs; -{ TBoldDatabaseAdapterAdvantage } +{ TBoldDatabaseAdapterAdvantage } -destructor TBoldDatabaseAdapterAdvantage.Destroy; +destructor TBoldDatabaseAdapterAdvantage.destroy; begin Changed; FreePublisher; FreeAndNil(fBoldDatabase); - inherited; + inherited; end; function TBoldDatabaseAdapterAdvantage.GetDataBase: TADSConnection; @@ -54,7 +57,7 @@ function TBoldDatabaseAdapterAdvantage.GetDataBase: TADSConnection; function TBoldDatabaseAdapterAdvantage.GetDataBaseInterface: IBoldDatabase; begin if not assigned(Database) then - raise EBold.CreateFmt('%s.GetDatabaseInterface: The adapter is not connected to a database', [classname]); + raise EBold.CreateFmt('%s.GetDatabaseInterface: The adapter is not connected to a database', [classname]); if not assigned(fBoldDatabase) then fBoldDatabase := TBoldAdvantageDataBase.create(Database, SQLDataBaseConfig); result := fBoldDatabase; @@ -70,4 +73,6 @@ procedure TBoldDatabaseAdapterAdvantage.SetDataBase(const Value: TADSConnection) InternalDatabase := value; end; +initialization + end. diff --git a/Source/Persistence/Advantage/BoldPersistenceHandleAdvantage.pas b/Source/Persistence/Advantage/BoldPersistenceHandleAdvantage.pas index 17618b49..579c1b17 100644 --- a/Source/Persistence/Advantage/BoldPersistenceHandleAdvantage.pas +++ b/Source/Persistence/Advantage/BoldPersistenceHandleAdvantage.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleAdvantage; interface @@ -21,7 +24,7 @@ TBoldPersistenceHandleAdvantage = class(TBoldDBPersistenceHandle) property DatabaseAdapter: TBoldAdvantageDatabase read FDatabaseAdapter; property EffectiveDatabase: TAdsConnection read GetEffectiveDatabase; public - destructor Destroy; override; + destructor destroy; override; function GetDataBaseInterface: IBoldDatabase; override; published property AdsConnection: TAdsConnection read FAdsConnection write SetDatabase; @@ -30,11 +33,12 @@ TBoldPersistenceHandleAdvantage = class(TBoldDBPersistenceHandle) implementation uses - SysUtils; + SysUtils, + BoldRev; { TBoldPersistenceHandleAdvantage } -destructor TBoldPersistenceHandleAdvantage.Destroy; +destructor TBoldPersistenceHandleAdvantage.destroy; begin Active := false; FreeAndNil(FEffectiveDatabase); @@ -84,4 +88,6 @@ procedure TBoldPersistenceHandleAdvantage.SetDataBase(const Value: TAdsConnectio end; end; +initialization + end. diff --git a/Source/Persistence/Advantage/BoldPersistenceHandleAdvantageReg.pas b/Source/Persistence/Advantage/BoldPersistenceHandleAdvantageReg.pas index 72dafceb..4de7925e 100644 --- a/Source/Persistence/Advantage/BoldPersistenceHandleAdvantageReg.pas +++ b/Source/Persistence/Advantage/BoldPersistenceHandleAdvantageReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleAdvantageReg; interface @@ -13,15 +16,21 @@ implementation Classes, registry, BoldIDESupport, + BoldVersionInfo, BoldDatabaseAdapterAdvantage, BoldPersistenceHandleAdvantage, BoldIDEConsts; procedure Register; begin - RemovePackageFromDisabledPackagesRegistry(format('BoldAdvantage%s', [LIBSUFFIX])); // do not localize + RemovePackageFromDisabledPackagesRegistry(format('Bold%d%d%sAdvantage', [ + BoldBuildVersionNumberMajor, + BoldBuildVersionNumberMinor, + BoldBuildTarget])); RegisterComponents(BOLDPAGENAME_DEPRECATED, [TBoldPersistenceHandleAdvantage]); RegisterComponents(BOLDPAGENAME_PERSISTENCE, [TBoldDatabaseAdapterAdvantage]); end; +initialization + end. diff --git a/Source/Persistence/BDE/BDEConsts.pas b/Source/Persistence/BDE/BDEConsts.pas index 09abc161..0487eba5 100644 --- a/Source/Persistence/BDE/BDEConsts.pas +++ b/Source/Persistence/BDE/BDEConsts.pas @@ -20,4 +20,4 @@ interface implementation -end. \ No newline at end of file +end. diff --git a/Source/Persistence/BDE/BoldBDEBatchInterfaces.pas b/Source/Persistence/BDE/BoldBDEBatchInterfaces.pas index 22d7cd6c..da44a58c 100644 --- a/Source/Persistence/BDE/BoldBDEBatchInterfaces.pas +++ b/Source/Persistence/BDE/BoldBDEBatchInterfaces.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldBDEBatchInterfaces; interface @@ -30,10 +33,11 @@ TBoldBDEBatchQuery = class(TBoldBDEQuery) property InBatch: Boolean read FInBatch write fInBatch; property HasCachedStatements: boolean read GetHasCachedStatements; public - destructor Destroy; override; + destructor destroy; override; class procedure InstallBatchQueries; end; + var BOLDBATCHQUERYMAXSIZE: integer = 30000; BOLDBATCHQUERYSEPARATOR: string = ';'; @@ -43,8 +47,7 @@ implementation uses SysUtils, dbTables, - BoldDefs, - BDEConsts; + BoldDefs; function ReplaceParamMarkers(const sql: String; Counter: integer; SourceParams, DestParams: TParams): String; const @@ -98,7 +101,7 @@ function ReplaceParamMarkers(const sql: String; Counter: integer; SourceParams, NewParam := DestParams.CreateParam(OldParam.DataType, prefix+OldParam.Name, OldParam.ParamType); NewParam.Assign(OldParam); - NewParam.Name:=prefix+OldParam.Name; // HK Assign also transfers name + NewParam.Name:=prefix+OldParam.Name; if OldParam.IsNull then NewParam.Clear else @@ -109,7 +112,7 @@ function ReplaceParamMarkers(const sql: String; Counter: integer; SourceParams, CurPos := StartPos; end else - if IsLiteral then + if IsLiteral then Literal := not Literal; Inc(CurPos); until CurPos > Length(TempResult); @@ -138,7 +141,7 @@ procedure TBoldBDEBatchQuery.BatchExecSQL; ExecuteBatch; end; -destructor TBoldBDEBatchQuery.Destroy; +destructor TBoldBDEBatchQuery.destroy; begin FreeAndNil(fAccumulatedParams); FreeAndNil(fAccumulatedSQL); @@ -189,10 +192,12 @@ procedure TBoldBDEBatchQuery.ExecuteBatch; if assigned(BatchQuery.DBSession) then begin Driver := Query.DBSession.GetAliasDriverName(query.DatabaseName); - if pos('INFORMIX', UpperCase(Driver)) = 0 then // do not localize - DriverMsg := Format(sOnlyTestedWithInformix, [BOLDCRLF]); + if pos('INFORMIX', UpperCase(Driver)) = 0 then + DriverMsg := 'Batch operations has only been tested with Informix' + BOLDCRLF; end; - e.Message := Format(sBatchFailure, [DriverMsg, e.Message, BOLDCRLF, BatchQuery.SQL.Text]); + e.Message := DriverMsg+ + 'Batch operation failed: ' + e.MEssage + BOLDCRLF + + 'SQL: '+BatchQuery.SQL.Text; raise; end; end; @@ -247,4 +252,3 @@ procedure TBoldBDEBatchQuery.StartSQLBatch; end; end. - diff --git a/Source/Persistence/BDE/BoldBDEInterfaces.pas b/Source/Persistence/BDE/BoldBDEInterfaces.pas index 24837d7f..bf291cfb 100644 --- a/Source/Persistence/BDE/BoldBDEInterfaces.pas +++ b/Source/Persistence/BDE/BoldBDEInterfaces.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldBDEInterfaces; interface @@ -24,16 +27,25 @@ TBoldBDEQuery = class(TBoldDataSetWrapper, IBoldQuery, IBoldExecQuery, IBoldPa function GetQuery: TQuery; procedure AssignParams(SourceParams: TParams); function GetParamCount: integer; - function GetParams(i: integer): IBoldParameter; + function GetParams: TParams; + function GetParam(i: integer): IBoldParameter; function GetRequestLiveQuery: Boolean; function ParamByName(const Value: string): IBoldParameter; procedure SetRequestLiveQuery(NewValue: Boolean); function GetSQLText: String; + function GetSQLStrings: TStrings; procedure AssignSQL(SQL: TStrings); - procedure AssignSQLText(SQL: String); + procedure AssignSQLText(const SQL: String); + function GetParamCheck: Boolean; + procedure SetParamCheck(value: Boolean); function GetRowsAffected: integer; function GetRecordCount: integer; - function Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; + function Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; override; + function GetUseReadTransactions: boolean; + procedure SetUseReadTransactions(value: boolean); + procedure BeginExecuteQuery; + procedure EndExecuteQuery; + function GetBatchQueryParamCount: integer; protected function GetDataSet: TDataSet; override; procedure StartSQLBatch; virtual; @@ -56,7 +68,7 @@ TBoldBDETable = class(TBoldDataSetWrapper, IBoldTable) procedure DeleteTable; function GetTable: TTable; function GetIndexDefs: TIndexDefs; - procedure SetTableName(NewName: String); + procedure SetTableName(const NewName: String); function GetTableName: String; procedure SetExclusive(NewValue: Boolean); function GetExclusive: Boolean; @@ -74,6 +86,7 @@ TBoldBDEDataBase = class(TBoldDatabaseWrapper, IBoldDataBase) fDataBase: TDataBase; fCachedTable: TTable; fCachedQuery: TQuery; + fExecuteQueryCount: integer; function GetConnected: Boolean; function GetInTransaction: Boolean; function GetIsSQLBased: Boolean; @@ -86,17 +99,22 @@ TBoldBDEDataBase = class(TBoldDatabaseWrapper, IBoldDataBase) procedure RollBack; procedure Open; procedure Close; + procedure Reconnect; function GetTable: IBoldTable; procedure ReleaseTable(var Table: IBoldTable); function SupportsTableCreation: Boolean; procedure ReleaseCachedObjects; + function GetIsExecutingQuery: Boolean; + procedure BeginExecuteQuery; + procedure EndExecuteQuery; protected procedure AllTableNames(Pattern: String; ShowSystemTables: Boolean; TableNameList: TStrings); override; function GetQuery: IBoldQuery; override; procedure ReleaseQuery(var Query: IBoldQuery); override; public - constructor Create(DataBase: TDataBase; SQLDataBaseConfig: TBoldSQLDatabaseConfig); - destructor Destroy; override; + constructor create(DataBase: TDataBase; SQLDataBaseConfig: TBoldSQLDatabaseConfig); + destructor destroy; override; + procedure CreateDatabase; end; var @@ -107,8 +125,7 @@ implementation uses SysUtils, BoldDefs, - BoldUtils, - BDEConsts; + BoldUtils; { TBoldBDEQuery } @@ -127,12 +144,22 @@ function TBoldBDEQuery.GetQuery: TQuery; result := fQuery; end; +function TBoldBDEQuery.GetParamCheck: Boolean; +begin + Result := Query.ParamCheck; +end; + function TBoldBDEQuery.GetParamCount: integer; begin result := Query.params.count; end; -function TBoldBDEQuery.GetParams(I: integer): IBoldParameter; +function TBoldBDEQuery.GetParams: TParams; +begin + result := Query.Params; +end; + +function TBoldBDEQuery.GetParam(I: integer): IBoldParameter; begin result := TBoldDbParameter.Create(Query.Params[i], self); end; @@ -153,11 +180,26 @@ function TBoldBDEQuery.ParamByName(const Value: string): IBoldParameter; result := nil; end; +procedure TBoldBDEQuery.SetParamCheck(value: Boolean); +begin + Query.ParamCheck := Value; +end; + procedure TBoldBDEQuery.SetRequestLiveQuery(NewValue: Boolean); begin Query.RequestLive := NewValue; end; +procedure TBoldBDEQuery.SetUseReadTransactions(value: boolean); +begin + +end; + +function TBoldBDEQuery.GetBatchQueryParamCount: integer; +begin + result := 0 +end; + function TBoldBDEQuery.GetDataSet: TDataSet; begin result := Query; @@ -165,60 +207,72 @@ function TBoldBDEQuery.GetDataSet: TDataSet; procedure TBoldBDEQuery.ExecSQL; begin + BeginExecuteQuery; + try BoldLogSQL(Query.SQL); try Query.ExecSQL; except on e: Exception do begin - e.Message := Format(sSQLFailure, [e.Message, BOLDCRLF, Query.SQL.text]); + e.Message := e.Message + BOLDCRLF + 'SQL: ' + Query.SQL.text; raise; end; end + finally + EndExecuteQuery; + end; end; constructor TBoldBDEQuery.Create(Query: TQuery; DatabaseWrapper: TBoldDatabaseWrapper); begin inherited Create(DatabaseWrapper); fQuery := Query; + SetParamCheck(true); +end; + +procedure TBoldBDEQuery.EndExecuteQuery; +begin + (DatabaseWrapper as TBoldBDEDataBase).EndExecuteQuery; end; procedure TBoldBDEQuery.EndSQLBatch; begin - // intentionally left blank end; procedure TBoldBDEQuery.StartSQLBatch; begin - // intentionally left blank end; procedure TBoldBDEQuery.FailSQLBatch; begin - // intentionally left blank end; procedure TBoldBDEQuery.Open; begin + BeginExecuteQuery; + try BoldLogSQL(Query.SQL); try inherited; except on e: Exception do begin - e.Message := Format(sSQLFailure, [e.Message, BOLDCRLF, Query.SQL.text]); + e.Message := e.Message + BOLDCRLF + 'SQL: ' + Query.SQL.text; raise; end; end + finally + EndExecuteQuery; + end; end; procedure TBoldBDEQuery.AssignSQL(SQL: TStrings); begin - // Assign already calls BeginUpdate and EndUpdate before and after doing the actual assign Query.SQL.Assign(SQL); end; -procedure TBoldBDEQuery.AssignSQLText(SQL: String); +procedure TBoldBDEQuery.AssignSQLText(const SQL: String); begin Query.SQL.BeginUpdate; Query.SQL.Clear; @@ -226,11 +280,26 @@ procedure TBoldBDEQuery.AssignSQLText(SQL: String); Query.SQL.EndUpdate; end; +procedure TBoldBDEQuery.BeginExecuteQuery; +begin + (DatabaseWrapper as TBoldBDEDataBase).EndExecuteQuery; +end; + +function TBoldBDEQuery.GetSQLStrings: TStrings; +begin + result := Query.SQL; +end; + function TBoldBDEQuery.GetSQLText: String; begin result := Query.SQL.text; end; +function TBoldBDEQuery.GetUseReadTransactions: boolean; +begin + result := false; +end; + function TBoldBDEQuery.GetRowsAffected: integer; begin result := Query.RowsAffected; @@ -312,7 +381,7 @@ procedure TBoldBDETable.SetExclusive(NewValue: Boolean); Table.Exclusive := NewValue; end; -procedure TBoldBDETable.SetTableName(NewName: String); +procedure TBoldBDETable.SetTableName(const NewName: String); begin Table.TableName := NewName; end; @@ -331,6 +400,11 @@ function TBoldBDEDataBase.GetInTransaction: Boolean; result := fDataBase.InTransaction; end; +function TBoldBDEDataBase.GetIsExecutingQuery: Boolean; +begin + Result := fExecuteQueryCount > 0; +end; + function TBoldBDEDataBase.GetIsSQLBased: Boolean; begin result := fDataBase.IsSQLBased; @@ -362,6 +436,11 @@ constructor TBoldBDEDataBase.create(DataBase: TDataBase; SQLDataBaseConfig: TBol fDataBase := DataBase; end; +procedure TBoldBDEDataBase.CreateDatabase; +begin + Assert(false, 'Not implemented.'); +end; + function TBoldBDEDataBase.GetConnected: Boolean; begin result := fDataBase.Connected; @@ -387,12 +466,22 @@ procedure TBoldBDEDataBase.Open; fDataBase.Open; end; +procedure TBoldBDEDataBase.BeginExecuteQuery; +begin + inc(fExecuteQueryCount); +end; + +procedure TBoldBDEDataBase.EndExecuteQuery; +begin + dec(fExecuteQueryCount); +end; + procedure TBoldBDEDataBase.Close; begin fDataBase.Close; end; -destructor TBoldBDEDataBase.Destroy; +destructor TBoldBDEDataBase.destroy; begin inherited; fDatabase := nil; @@ -478,6 +567,14 @@ function TBoldBDEDataBase.SupportsTableCreation: Boolean; result := true; end; +procedure TBoldBDEDataBase.Reconnect; +begin + if Assigned(FDataBase) then begin + FDataBase.Connected := False; + FDataBase.Connected := True; + end; +end; + procedure TBoldBDEDataBase.ReleaseCachedObjects; begin FreeAndNil(fCachedTable); @@ -485,6 +582,3 @@ procedure TBoldBDEDataBase.ReleaseCachedObjects; end; end. - - - diff --git a/Source/Persistence/BDE/BoldDatabaseAdapterBDE.pas b/Source/Persistence/BDE/BoldDatabaseAdapterBDE.pas index 4a8bb882..6d306daa 100644 --- a/Source/Persistence/BDE/BoldDatabaseAdapterBDE.pas +++ b/Source/Persistence/BDE/BoldDatabaseAdapterBDE.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDatabaseAdapterBDE; interface @@ -22,7 +25,7 @@ TBoldDatabaseAdapterBDE = class(TBoldAbstractDatabaseAdapter) procedure ReleaseBoldDatabase; override; function GetDataBaseInterface: IBoldDatabase; override; public - destructor Destroy; override; + destructor destroy; override; published property DataBase: TDataBase read GetDataBase write SetDataBase; {$IFNDEF T2H} @@ -34,17 +37,16 @@ implementation uses SysUtils, - BoldDefs, - BDEConsts; + BoldDefs; -{ TBoldDatabaseAdapterBDE } +{ TBoldDatabaseAdapterBDE } -destructor TBoldDatabaseAdapterBDE.Destroy; +destructor TBoldDatabaseAdapterBDE.destroy; begin Changed; FreePublisher; FreeAndNil(fBoldDatabase); - inherited; + inherited; end; function TBoldDatabaseAdapterBDE.GetDataBase: TDataBase; @@ -55,7 +57,7 @@ function TBoldDatabaseAdapterBDE.GetDataBase: TDataBase; function TBoldDatabaseAdapterBDE.GetDataBaseInterface: IBoldDatabase; begin if not assigned(Database) then - raise EBold.CreateFmt(sAdapterNotConnected, [classname]); + raise EBold.CreateFmt('%s.GetDatabaseInterface: The adapter is not connected to a database', [classname]); if not assigned(fBoldDatabase) then fBoldDatabase := TBoldBDEDataBase.create(Database, SQLDataBaseConfig); result := fBoldDatabase; @@ -71,4 +73,6 @@ procedure TBoldDatabaseAdapterBDE.SetDataBase(const Value: TDataBase); InternalDatabase := value; end; +initialization + end. diff --git a/Source/Persistence/BDE/BoldPersistenceHandleBDE.pas b/Source/Persistence/BDE/BoldPersistenceHandleBDE.pas index 319a964b..4007ffbc 100644 --- a/Source/Persistence/BDE/BoldPersistenceHandleBDE.pas +++ b/Source/Persistence/BDE/BoldPersistenceHandleBDE.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleBDE; interface @@ -39,7 +42,7 @@ TBoldPersistenceHandleBDE = class(TBoldDBPersistenceHandle) procedure InternalTransferproperties(const target: TBoldPersistenceHandleDB); override; {$ENDIF} public - destructor Destroy; override; + destructor destroy; override; function GetDataBaseInterface: IBoldDatabase; override; published property DatabaseName: string read GetDataBasename write SetDataBaseName; @@ -51,16 +54,11 @@ implementation uses SysUtils, - BoldDatabaseAdapterBDE, - BDEConsts; - -const - USERNAME = 'USER NAME'; - PASSWORD = 'PASSWORD'; + BoldDatabaseAdapterBDE; { TBoldPersistenceHandleBDE } -destructor TBoldPersistenceHandleBDE.Destroy; +destructor TBoldPersistenceHandleBDE.destroy; begin Active := false; FreeAndNil(fOwnDataBase); @@ -111,10 +109,10 @@ function TBoldPersistenceHandleBDE.getEffectiveDataBase: TDataBase; if not fExistingDatabase.Connected then begin if UserName <> '' then - fExistingDataBase.Params.Values[USERNAME] := Username; + fExistingDataBase.Params.Values['USER NAME'] := Username; if Password <> '' then begin - fExistingDataBase.Params.Values[PASSWORD] := Password; + fExistingDataBase.Params.Values['PASSWORD'] := Password; fExistingDataBase.LoginPrompt := false; end; end; @@ -124,14 +122,12 @@ function TBoldPersistenceHandleBDE.getEffectiveDataBase: TDataBase; end; end; - // we had no database, and were not able to find any database... - fOwnDataBase := TDataBase.Create(nil); - fOwnDataBase.name := name+'_DataBase'; // do not localize + fOwnDataBase.name := name+'_DataBase'; fOwnDataBase.DatabaseName := DatabaseName; fOwnDataBase.SessionName := SessionName; - fOwnDataBase.Params.Values[USERNAME] := Username; - fOwnDataBase.Params.Values[PASSWORD] := Password; + fOwnDataBase.Params.Values['USER NAME'] := Username; + fOwnDataBase.Params.Values['PASSWORD'] := Password; if PassWord <> '' then fOwnDataBase.LoginPrompt := false; result := fOwnDataBase; @@ -148,14 +144,14 @@ procedure TBoldPersistenceHandleBDE.InternalTransferproperties( if not assigned(Target.DatabaseAdapter) then begin Target.DatabaseAdapter := TBoldDatabaseAdapterBDE.Create(Target.Owner); - Target.DatabaseAdapter.Name := GetNewComponentName(Target.DatabaseAdapter, 'BoldDatabaseAdapterBDE'); // do not localize - LongRec(DesInfo).Lo := LongRec(DesInfo).lo+16; //set Left - LongRec(DesInfo).Hi := LongRec(DesInfo).hi+16; //Set Top; + Target.DatabaseAdapter.Name := GetNewComponentName(Target.DatabaseAdapter, 'BoldDatabaseAdapterBDE'); + LongRec(DesInfo).Lo := LongRec(DesInfo).lo+16; + LongRec(DesInfo).Hi := LongRec(DesInfo).hi+16; Target.DatabaseAdapter.DesignInfo := DesInfo; - showmessage(sCreatedNewAdapter); + showmessage('Created a new DatabaseAdapterBDE'); end else if not (target.DatabaseAdapter is tBoldDatabaseAdapterBDE) then - raise Exception.CreateFmt(sPropertiesCannotBeTransferred, [target.DatabaseAdapter.ClassName] ); + raise Exception.CreateFmt('The persistencehandle is connected to a %s, properties can only be transfered to a TBoldDatabaseAdapterBDE', [target.DatabaseAdapter.ClassName] ); Adapter := target.DatabaseAdapter as tBoldDatabaseAdapterBDE; if assigned(fDatabase) then @@ -164,15 +160,15 @@ procedure TBoldPersistenceHandleBDE.InternalTransferproperties( if not assigned(Adapter.Database) then begin Adapter.DataBase := TDatabase.Create(Target.owner); - Adapter.DataBase.Name := GetNewComponentName(Adapter.DataBase, 'Database'); // do not localize - showmessage(sCreatedNewDB); - LongRec(DesInfo).Lo := LongRec(DesInfo).lo+16; //set Left - LongRec(DesInfo).Hi := LongRec(DesInfo).hi+16; //Set Top; + Adapter.DataBase.Name := GetNewComponentName(Adapter.DataBase, 'Database'); + showmessage('Created a new Database'); + LongRec(DesInfo).Lo := LongRec(DesInfo).lo+16; + LongRec(DesInfo).Hi := LongRec(DesInfo).hi+16; Adapter.DataBase.DesignInfo := DesInfo; end; - Adapter.Database.Params.Values[PASSWORD] := Password; - Adapter.Database.Params.Values[USERNAME] := Username; - if Adapter.Database.Params.Values[PASSWORD] <> '' then + Adapter.Database.Params.Values['PASSWORD'] := Password; + Adapter.Database.Params.Values['USER NAME'] := Username; + if Adapter.Database.Params.Values['PASSWORD'] <> '' then Adapter.Database.LoginPrompt := false; if not assigned(Database) then Adapter.DataBase.DatabaseName := DatabaseName; @@ -204,7 +200,7 @@ procedure TBoldPersistenceHandleBDE.SetDataBase(const Value: TDataBase); begin if fDataBase <> Value then begin - CheckInactive('SetDataBase'); // do not localize + CheckInactive('SetDataBase'); if assigned(fOwnDataBase) then begin FreeAndNil(FOwnDataBase); @@ -225,7 +221,7 @@ procedure TBoldPersistenceHandleBDE.SetDatabaseName(const Value: string); begin if FDatabaseName <> Value then begin - CheckInactive('SetDataBaseName'); // do not localize + CheckInactive('SetDataBaseName'); if assigned(fOwnDataBase) then fOwnDataBase.DatabaseName := DatabaseName; FDatabaseName := Value; @@ -238,18 +234,18 @@ procedure TBoldPersistenceHandleBDE.SetPassword(const Value: string); if Value <> PassWord then begin if assigned(fOwnDataBase) then - fOwnDataBase.Params.Values[PASSWORD] := value; + fOwnDataBase.Params.Values['PASSWORD'] := value; if assigned(fExistingDataBase) then - fExistingDataBase.Params.Values[PASSWORD] := Value; + fExistingDataBase.Params.Values['PASSWORD'] := Value; end; - inherited; + inherited; end; procedure TBoldPersistenceHandleBDE.SetSessionName(const Value: String); begin if FSessionName <> Value then begin - CheckInactive('SetSessionName'); // do not localize + CheckInactive('SetSessionName'); FSessionName := Value; if assigned(fOwnDataBase) then fOwnDataBase.SessionName := SessionName; @@ -262,11 +258,13 @@ procedure TBoldPersistenceHandleBDE.SetUserName(const Value: string); if value <> Username then begin if assigned(fOwnDataBase) then - fOwnDataBase.Params.Values[USERNAME] := UserName; + fOwnDataBase.Params.Values['USER NAME'] := UserName; if assigned(fExistingDataBase) then - fExistingDataBase.Params.Values[USERNAME] := UserName; + fExistingDataBase.Params.Values['USER NAME'] := UserName; end; inherited; end; +initialization + end. diff --git a/Source/Persistence/BDE/BoldPersistenceHandleBDEPropertyEditors.pas b/Source/Persistence/BDE/BoldPersistenceHandleBDEPropertyEditors.pas index 1e0a45f3..fd9a48fc 100644 --- a/Source/Persistence/BDE/BoldPersistenceHandleBDEPropertyEditors.pas +++ b/Source/Persistence/BDE/BoldPersistenceHandleBDEPropertyEditors.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleBDEPropertyEditors; interface @@ -7,7 +10,7 @@ interface BoldPropertyEditors; type - { forward declarations } + { forward declarations } TBoldDatabaseNameProperty = class; TBoldSessionNameProperty = class; @@ -23,7 +26,7 @@ TBoldSessionNameProperty = class(TBoldStringSelectionProperty) procedure GetValueList(List: TStrings); override; end; -implementation +implementation uses DBTables; @@ -43,4 +46,6 @@ procedure TBoldSessionNameProperty.GetValueList(List: TStrings); Sessions.GetSessionNames(List); end; +initialization + end. diff --git a/Source/Persistence/BDE/BoldPersistenceHandleBde.RES b/Source/Persistence/BDE/BoldPersistenceHandleBde.RES new file mode 100644 index 00000000..3263cc29 Binary files /dev/null and b/Source/Persistence/BDE/BoldPersistenceHandleBde.RES differ diff --git a/Source/Persistence/BDE/BoldPersistenceHandleBde.rc b/Source/Persistence/BDE/BoldPersistenceHandleBde.rc index cbc9c495..f2449cf8 100644 --- a/Source/Persistence/BDE/BoldPersistenceHandleBde.rc +++ b/Source/Persistence/BDE/BoldPersistenceHandleBde.rc @@ -1,2 +1,2 @@ -TBOLDPERSISTENCEHANDLEBDE BITMAP LOADONCALL TBoldPersistenceHandleBde.bmp -TBOLDDATABASEADAPTERBDE BITMAP LOADONCALL TBoldDatabaseAdapterBde.bmp +TBOLDPERSISTENCEHANDLEBDE BITMAP LOADONCALL ..\..\..\Images\Components\TBoldPersistenceHandleBde.bmp +TBOLDDATABASEADAPTERBDE BITMAP LOADONCALL ..\..\..\Images\Components\TBoldDatabaseAdapterBde.bmp diff --git a/Source/Persistence/BDE/BoldPersistenceHandleBdeReg.pas b/Source/Persistence/BDE/BoldPersistenceHandleBdeReg.pas index 60c280a5..8907b913 100644 --- a/Source/Persistence/BDE/BoldPersistenceHandleBdeReg.pas +++ b/Source/Persistence/BDE/BoldPersistenceHandleBdeReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleBDEReg; interface @@ -20,11 +23,9 @@ implementation procedure Register; begin RegisterComponents(BOLDPAGENAME_PERSISTENCE, [TBoldDatabaseAdapterBDE]); - {$WARNINGS OFF} RegisterComponents(BOLDPAGENAME_DEPRECATED, [TBoldPersistenceHandleBDE]); - RegisterPropertyEditor(TypeInfo(string), TBoldPersistenceHandleBDE, 'DatabaseName', TBoldDatabaseNameProperty); // do not localize - RegisterPropertyEditor(TypeInfo(string), TBoldPersistenceHandleBDE, 'SessionName', TBoldSessionNameProperty); // do not localize - {$WARNINGS ON} + RegisterPropertyEditor(TypeInfo(string), TBoldPersistenceHandleBDE, 'DatabaseName', TBoldDatabaseNameProperty); + RegisterPropertyEditor(TypeInfo(string), TBoldPersistenceHandleBDE, 'SessionName', TBoldSessionNameProperty); end; end. diff --git a/Source/Persistence/COM/BoldAbstractComClientPersistenceHandles.pas b/Source/Persistence/COM/BoldAbstractComClientPersistenceHandles.pas index 466c57c9..83966d2e 100644 --- a/Source/Persistence/COM/BoldAbstractComClientPersistenceHandles.pas +++ b/Source/Persistence/COM/BoldAbstractComClientPersistenceHandles.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAbstractComClientPersistenceHandles; interface @@ -139,5 +142,7 @@ procedure TBoldAbstractComClientPersistenceHandle.SetObjectName(const Value: str end; end; -end. +initialization + +end. diff --git a/Source/Persistence/COM/BoldAbstractComPersistenceControllerProxy.pas b/Source/Persistence/COM/BoldAbstractComPersistenceControllerProxy.pas index 1f0dbae9..50e52491 100644 --- a/Source/Persistence/COM/BoldAbstractComPersistenceControllerProxy.pas +++ b/Source/Persistence/COM/BoldAbstractComPersistenceControllerProxy.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAbstractComPersistenceControllerProxy; interface @@ -29,6 +32,7 @@ TBoldAbstractComPersistenceControllerProxy = class(TBoldPersistenceController) implementation + { TBoldAbstractComPersistenceControllerProxy } destructor TBoldAbstractComPersistenceControllerProxy.Destroy; @@ -48,7 +52,7 @@ procedure TBoldAbstractComPersistenceControllerProxy.ExactifyIds( begin TranslationList := TBoldIDTranslationList.Create; try - PMExactifyIds(ObjectIdList, TranslationList); + PMExactifyIds(ObjectIdList, TranslationList, false); ValueSpace.ExactifyIds(TranslationList); ObjectIdList.ExactifyIds(TranslationList); finally @@ -62,5 +66,6 @@ procedure TBoldAbstractComPersistenceControllerProxy.SubscribeToPeristenceEvents inherited; end; -end. +initialization +end. diff --git a/Source/Persistence/Core/BoldAbstractSnooper.pas b/Source/Persistence/Core/BoldAbstractSnooper.pas index 9ec0b6d3..b62c3577 100644 --- a/Source/Persistence/Core/BoldAbstractSnooper.pas +++ b/Source/Persistence/Core/BoldAbstractSnooper.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAbstractSnooper; interface @@ -15,39 +18,58 @@ interface {forward declarations} TBoldAbstractSnooper = class; + TBooleanArray = array of boolean; + TBoldAbstractSnooper = class(TBoldPersistenceControllerPassthrough) private fMoldModel: TMoldModel; fEvents: TStringList; + fEventsLength: integer; + fEventClassFlags: TBooleanArray; fSubscriptions: TStringList; fCancelledSubscriptions: TStringList; fModelSorted: Boolean; FOnPropagatorFailure: TBoldNotifyEventWithErrorMessage; + fClassesToIgnore: string; + fArrayOfClassesToIgnore: TBooleanArray; + fUseSubscriptions: boolean; + fUseClassEvents: boolean; + fUseMemberLevelOSS: boolean; + fEventTimeStamp: TDateTime; + procedure SetClassesToIgnore(const Value: string); protected - procedure GenerateNonEmbeddedStateChangedEvent(OldID, NewID: TBoldObjectId; const NonEmbeddedLinkName: string); + procedure GenerateNonEmbeddedStateChangedEvent(OldID, NewID: TBoldObjectId; MoldClass: TMoldClass; const NonEmbeddedLinkName: string); procedure SubscribeToNonEmbeddedStateChangedEvent(Id: TBoldObjectId; const NonEmbeddedLinkName: string); function ObjectIdByMemberIndex(Object_Content: IBoldObjectContents; MemberIndex: integer): TBoldObjectID; - function MemberIsEmbeddedSingleLink(MoldMember: TMoldMember; var NonEmbeddedLinkName: string): Boolean; + function MemberIsEmbeddedSingleLink(MoldMember: TMoldMember; var NonEmbeddedLink: TMoldRole): Boolean; function MemberIsNonEmbeddedLink(MoldMember: TMoldMember; var MemberName: string): Boolean; function ClassNameFromClassID(const TopSortedIndex: integer): string; - procedure NonEmbeddedStateOfObjectChanged(Object_Content, NewObject_Content: IBoldObjectContents; MoldClass: TMoldClass); + procedure NonEmbeddedStateOfObjectChanged(const Object_Content, NewObject_Content: IBoldObjectContents; MoldClass: TMoldClass); procedure ClearEvents; procedure EnsureDataBaseLock(const ClientID: TBoldClientID); virtual; procedure ReleaseDataBaseLock(const ClientID: TBoldClientID); virtual; procedure DoPropagatorFailure(Sender: TObject; const ErrorMessage: string); procedure AddClassEvents(TopsortedIndex: integer); + procedure AddEvent(const AEvent: string); + procedure AddSubscription(const AEvent: string); + procedure CancelSubscription(const AEvent: string); + function EventLimitReached: boolean; public - constructor Create(MoldModel: TMoldModel); + constructor Create(MoldModel: TMoldModel); virtual; destructor Destroy; override; procedure PMFetch(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; BoldClientID: TBoldClientID); override; procedure PMFetchIDListWithCondition(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; FetchMode: Integer; Condition: TBoldCondition; BoldClientID: TBoldClientID); override; - procedure PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; BoldClientID: TBoldClientID); override; + procedure PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; var TimeOfLatestUpdate: TDateTime; BoldClientID: TBoldClientID); override; procedure TransmitEvents(const ClientID: TBoldClientID); virtual; abstract; property MoldModel: TMoldModel read fMoldModel; property Events: TStringList read fEvents; + property UseClassEvents: boolean read fUseClassEvents write fUseClassEvents; + property UseMemberLevelOSS: boolean read fUseMemberLevelOSS write fUseMemberLevelOSS; + property UseSubscriptions: boolean read fUseSubscriptions write fUseSubscriptions; property Subscriptions: TStringList read fSubscriptions; property CancelledSubscriptions: TStringList read fCancelledSubscriptions; property OnPropagatorFailure: TBoldNotifyEventWithErrorMessage read FOnPropagatorFailure write FOnPropagatorFailure; + property ClassesToIgnore: string read fClassesToIgnore write SetClassesToIgnore; end; implementation @@ -68,6 +90,12 @@ constructor TBoldAbstractSnooper.Create(MoldModel: TMoldModel); fEvents.Duplicates := dupIgnore; fSubscriptions := TStringList.Create; fCancelledSubscriptions := TStringList.Create; + SetLength(fEventClassFlags, MoldModel.Classes.Count); + SetLength(fArrayOfClassesToIgnore, MoldModel.Classes.Count); + + UseClassEvents := False; // Bold original behaviour = true + UseMemberLevelOSS := True; // Bold original behaviour = false + UseSubscriptions := False; // // Bold original behaviour = true end; destructor TBoldAbstractSnooper.Destroy; @@ -89,7 +117,7 @@ procedure TBoldAbstractSnooper.PMFetch(ObjectIdList: TBoldObjectIdList; ValueSpa Object_Content: IBoldObjectContents; begin inherited; - if (BoldClientID = NOTVALIDCLIENTID) or not Assigned(MoldModel) then + if {(BoldClientID = NOTVALIDCLIENTID) or} not Assigned(MoldModel) or not UseSubscriptions then Exit; if not fModelSorted then begin @@ -97,13 +125,11 @@ procedure TBoldAbstractSnooper.PMFetch(ObjectIdList: TBoldObjectIdList; ValueSpa fModelSorted := true; end; try - // SubscribeToEmbeddedStateOfObject for i:= 0 to ObjectIdList.Count - 1 do begin LoadingEmbedded := false; Object_Content := ValueSpace.ObjectContentsbyObjectId[ObjectIdList[i]]; - // SubscribeToNonEmbeddedStateOfObject - // explicit MemberIdList + if Assigned(MemberIdList) then begin @@ -122,19 +148,18 @@ procedure TBoldAbstractSnooper.PMFetch(ObjectIdList: TBoldObjectIdList; ValueSpa end else begin - if Assigned(Object_Content) then // get not delayed members + if Assigned(Object_Content) then begin LoadingEmbedded := true; MoldClass := MoldModel.Classes[ObjectIdList[i].TopSortedIndex]; for j:= 0 to Object_Content.MemberCount - 1 do - //if member is not delayed if not (MoldClass.AllBoldMembers[j].EffectiveDelayedFetch) and MemberIsNonEmbeddedLink(MoldClass.AllBoldMembers[j], MemberName) then SubscribeToNonEmbeddedStateChangedEvent(ObjectIdList[i], MemberName); end; end; - if LoadingEmbedded then - Subscriptions.Add(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsEmbeddedStateOfObjectChanged, '', '', '', ObjectIdList[i])); + if UseSubscriptions and LoadingEmbedded then + AddSubscription(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsEmbeddedStateOfObjectChanged, '', '', '', ObjectIdList[i])); end; TransmitEvents(BoldClientID); finally @@ -148,22 +173,21 @@ procedure TBoldAbstractSnooper.PMFetchIDListWithCondition(ObjectIdList: TBoldObj TopSortedIndex: integer; begin inherited; - if (BoldClientID = NOTVALIDCLIENTID) then - Exit; - // SubscribeToClassChanged +// if (BoldClientID = NOTVALIDCLIENTID) then +// Exit; if (Condition.ClassType = TBoldConditionWithClass) then begin TopSortedIndex := (Condition as TBoldConditionWithClass).TopSortedIndex; - Subscriptions.Add(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsClassChanged, ClassNameFromClassId(TopSortedIndex), - '', '', nil)); + if UseSubscriptions then + AddSubscription(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsClassChanged, ClassNameFromClassId(TopSortedIndex), '', '', nil)); end; TransmitEvents(BoldClientID); end; procedure TBoldAbstractSnooper.PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; - Precondition: TBoldUpdatePrecondition; - TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; + Precondition: TBoldUpdatePrecondition; + TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; var TimeOfLatestUpdate: TDateTime; BoldClientID: TBoldClientID); var i, j: integer; @@ -174,12 +198,12 @@ procedure TBoldAbstractSnooper.PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSp ObjectId: TBoldObjectID; MoldClass: TMoldClass; MemberName: string; + MemberValue: IBoldValue; + sl: TStringList; begin - //make a copy of objectIDList assert(assigned(MoldModel), 'Snooper has no Model'); LocalObjectIdList := ObjectIdList.Clone; try - //get old values LocalOld_Values := nil; LocalTranslationList := nil; if not Assigned(Old_Values) then @@ -197,45 +221,84 @@ procedure TBoldAbstractSnooper.PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSp ValueSpace.ApplytranslationList(TranslationList); LocalObjectIdList.ApplyTranslationList(TranslationList); - if (BoldClientID <> NOTVALIDCLIENTID) then - for i := 0 to LocalObjectIDList.Count - 1 do - begin - Object_Content := ValueSpace.ObjectContentsByObjectId[LocalObjectIdList[i]]; - Assert(Assigned(Object_Content), 'Object does not exist'); - if Object_Content.BoldPersistenceState = bvpsModified then - case Object_Content.BoldExistenceState of - besExisting: - begin + EnsureDataBaseLock(BoldClientID); + try + inherited PMUpdate(LocalObjectIdList, ValueSpace, Old_Values, Precondition, nil, TimeStamp, TimeOfLatestUpdate, BoldClientID); + finally + ReleaseDataBaseLock(BoldClientID); + end; + if (assigned(Precondition) and (Precondition.failed)) {or (BoldClientID = NOTVALIDCLIENTID)} then + exit; + +// if (BoldClientID <> NOTVALIDCLIENTID) then + for i := 0 to LocalObjectIDList.Count - 1 do + begin + MoldClass := MoldModel.Classes[LocalObjectIdList[i].TopSortedIndex]; + Object_Content := ValueSpace.ObjectContentsByObjectId[LocalObjectIdList[i]]; + Assert(Assigned(Object_Content), Format('Object [%s] of type [%s] does not exist', + [LocalObjectIdList[i].AsString, + MoldClass.ExpandedExpressionName])); + if Object_Content.BoldPersistenceState = bvpsModified then + case Object_Content.BoldExistenceState of + besExisting: + begin + if UseClassEvents and not fArrayOfClassesToIgnore[LocalObjectIdList[i].TopSortedIndex] then AddClassEvents(LocalObjectIdList[i].TopSortedIndex); - Subscriptions.Add(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsEmbeddedStateOfObjectChanged, '', '', '', TranslationList.TranslateToNewId[LocalObjectIdList[i]])); + if UseSubscriptions then + AddSubscription(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsEmbeddedStateOfObjectChanged, '', '', '', TranslationList.TranslateToNewId[LocalObjectIdList[i]])); + if not fArrayOfClassesToIgnore[MoldClass.TopSortedIndex] then + AddEvent(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsObjectCreated, MoldClass.ExpandedExpressionName, '', '', LocalObjectIdList[i])); + end; + besDeleted: + begin + if not fArrayOfClassesToIgnore[LocalObjectIdList[i].TopSortedIndex] then + begin + if UseClassEvents then + AddClassEvents(LocalObjectIdList[i].TopSortedIndex); + Events.Add(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsObjectDeleted, MoldClass.ExpandedExpressionName, '', '', LocalObjectIdList[i])); end; - besDeleted: + if UseSubscriptions then + CancelSubscription(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsEmbeddedStateOfObjectChanged, '', '', '', LocalObjectIdList[i])) ; + for j:= 0 to MoldClass.AllBoldMembers.Count - 1 do begin - AddClassEvents(LocalObjectIdList[i].TopSortedIndex); - Events.Add(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsObjectDeleted, '', '', '', LocalObjectIdList[i])) ; - CancelledSubscriptions.Add(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsEmbeddedStateOfObjectChanged, '', '', '', LocalObjectIdList[i])) ; - //Cancel subscriptions to NonEmbeddedStateOfObjectChanged events - MoldClass := MoldModel.Classes[ObjectIDList[i].TopSortedIndex]; - for j:= 0 to MoldClass.AllBoldMembers.Count - 1 do + MemberName := MoldClass.AllBoldMembers.Items[j].ExpandedExpressionName; + if UseSubscriptions and MemberIsNonEmbeddedLink(MoldClass.AllBoldMembers[j], MemberName) then + CancelSubscription(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsNonEmbeddedStateOfObjectChanged, '', MemberName, '', LocalObjectIdList[i])); + end; + end; + end + else + begin + if not fArrayOfClassesToIgnore[LocalObjectIdList[i].TopSortedIndex] then + begin + if UseMemberLevelOss then + begin + sl:= TStringList.Create; + try + for j := 0 to Object_Content.MemberCount -1 do + begin + MemberValue := Object_Content.ValueByIndex[j]; + if Assigned(MemberValue) and (MemberValue.BoldPersistenceState = bvpsModified) then begin - MemberName := MoldClass.AllBoldMembers.Items[j].ExpandedExpressionName; - if MemberIsNonEmbeddedLink(MoldClass.AllBoldMembers[j], MemberName) then - CancelledSubscriptions.Add(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsNonEmbeddedStateOfObjectChanged, '', MemberName, '', LocalObjectIdList[i])); + if MoldClass.AllBoldMembers[j] is TMoldAttribute then + sl.Add(MoldClass.AllBoldMembers[j].ExpandedExpressionName) + else + if MoldClass.AllBoldMembers[j] is TMoldRole and TMoldRole(MoldClass.AllBoldMembers[j]).EffectiveEmbedded then + sl.Add(MoldClass.AllBoldMembers[j].ExpandedExpressionName) end; end; - end //case - else - Events.Add(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsEmbeddedStateOfObjectChanged, '', '', '', LocalObjectIdList[i])); - end; //for - - EnsureDataBaseLock(BoldClientID); - try - inherited PMUpdate(LocalObjectIdList, ValueSpace, Old_Values, Precondition, nil, TimeStamp, BoldClientID); - finally - ReleaseDataBaseLock(BoldClientID); + if sl.Count > 0 then + begin + AddEvent(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsMemberChanged, MoldClass.ExpandedExpressionName, sl.CommaText, '', LocalObjectIdList[i])); + end; + finally + sl.free; + end; + end; + AddEvent(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsEmbeddedStateOfObjectChanged, MoldClass.ExpandedExpressionName, '', '', LocalObjectIdList[i])); + end; + end; end; - if (not assigned(Precondition) or (not Precondition.failed)) and - (BoldClientID <> NOTVALIDCLIENTID) then begin for i:= LocalObjectIdList.Count - 1 downto 0 do @@ -246,18 +309,17 @@ procedure TBoldAbstractSnooper.PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSp NewObject_Content := ValueSpace.ObjectContentsByObjectId[ObjectId] else NewObject_Content := nil; - NonEmbeddedStateOfObjectChanged(Object_Content, NewObject_Content, + if not fArrayOfClassesToIgnore[LocalObjectIdList[i].TopSortedIndex] then + NonEmbeddedStateOfObjectChanged(Object_Content, NewObject_Content, MoldModel.Classes[LocalObjectIdList[i].TopSortedIndex]); end; TransmitEvents(BoldClientID); end; finally - // release the interfaces Object_Content := nil; NewObject_Content := nil; if assigned(LocalOld_Values) then begin - // must release the interface before removing the underlying object Old_Values := nil; FreeAndNil(LocalOld_Values); end; @@ -266,55 +328,87 @@ procedure TBoldAbstractSnooper.PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSp end; end; -procedure TBoldAbstractSnooper.GenerateNonEmbeddedStateChangedEvent(OldID, NewID: TBoldObjectId; const NonEmbeddedLinkName: string); +procedure TBoldAbstractSnooper.GenerateNonEmbeddedStateChangedEvent(OldID, NewID: TBoldObjectId; MoldClass: TMoldClass; const NonEmbeddedLinkName: string); begin if (Assigned(OldID) and Assigned(NewID) and not(OldID.IsEqual[NewID])) then begin - Events.Add(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsNonEmbeddedStateOfObjectChanged, '', NonEmbeddedLinkName, '', OldID)); - Events.Add(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsNonEmbeddedStateOfObjectChanged, '', NonEmbeddedLinkName, '', NewID)); + AddEvent(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsNonEmbeddedStateOfObjectChanged, MoldClass.ExpandedExpressionName, NonEmbeddedLinkName, '', OldID)); + AddEvent(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsNonEmbeddedStateOfObjectChanged, MoldClass.ExpandedExpressionName, NonEmbeddedLinkName, '', NewID)); end else if (Assigned(OldID) and not Assigned(NewID)) then - Events.Add(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsNonEmbeddedStateOfObjectChanged, '', NonEmbeddedLinkName, '', OldID)) + AddEvent(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsNonEmbeddedStateOfObjectChanged, MoldClass.ExpandedExpressionName, NonEmbeddedLinkName, '', OldID)) else if (Assigned(NewID) and not Assigned(OldID)) then - Events.Add(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsNonEmbeddedStateOfObjectChanged, '', NonEmbeddedLinkName, '', NewID)); + AddEvent(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsNonEmbeddedStateOfObjectChanged, MoldClass.ExpandedExpressionName, NonEmbeddedLinkName, '', NewID)); +end; + +procedure TBoldAbstractSnooper.SetClassesToIgnore(const Value: string); +var + sl: TStringList; + MoldClass: TMoldClass; + i: integer; +begin + if fClassesToIgnore = Value then + exit; + for i := 0 to high(fArrayOfClassesToIgnore) do + fArrayOfClassesToIgnore[i] := false; + sl := TStringList.Create; + try + Sl.CommaText := Value; + for i := 0 to sl.count -1 do + begin + MoldClass := MoldModel.Classes.ItemsByName[sl[i]]; + if not Assigned(MoldClass) then + raise Exception.CreateFmt('Invalid class name %s', [sl[i]]); + fArrayOfClassesToIgnore[MoldClass.TopSortedIndex] := true; + end; + fClassesToIgnore := Value; + finally + sl.free; + end; end; procedure TBoldAbstractSnooper.SubscribeToNonEmbeddedStateChangedEvent(Id: TBoldObjectId; const NonEmbeddedLinkName: string); begin - if Assigned(Id) then - Subscriptions.Add(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsNonEmbeddedStateOfObjectChanged, '', NonEmbeddedLinkName, '', Id)) + if Assigned(Id) and UseSubscriptions then + AddSubscription(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsNonEmbeddedStateOfObjectChanged, '', NonEmbeddedLinkName, '', Id)) end; function TBoldAbstractSnooper.ObjectIdByMemberIndex(Object_Content: IBoldObjectContents; MemberIndex: integer): TBoldObjectID; var Value: IBoldValue; IDRef: IBoldObjectIDRef; + IDRefPair: IBoldObjectIdrefPair; begin Result := nil; if Assigned(Object_Content) then begin Value := Object_Content.ValueByIndex[MemberIndex]; - if Assigned(Value) and (Value.QueryInterface(IBoldObjectIDRef, IDRef) = S_OK) then - Result := IDRef.Id; + if Assigned(Value) then + begin + if (Value.QueryInterface(IBoldObjectIDRef, IDRef) = S_OK) then + Result := IDRef.Id + else + if (Value.QueryInterface(IBoldObjectIdrefPair, IDRefPair) = S_OK) then + Result := IDRefPair.Id1; // or ID2 ? + end; end; end; -function TBoldAbstractSnooper.MemberIsEmbeddedSingleLink(MoldMember: TMoldMember; var NonEmbeddedLinkName: string): Boolean; +function TBoldAbstractSnooper.MemberIsEmbeddedSingleLink(MoldMember: TMoldMember; var NonEmbeddedLink: TMoldRole): Boolean; var MoldRole: TMoldRole; - NonEmbeddedLink: TMoldRole; begin Result := false; + NonEmbeddedLink := nil; if (MoldMember is TMoldRole) then begin MoldRole := MoldMember as TMoldRole; - Result := MoldRole.EffectiveEmbedded; + Result := MoldRole.EffectiveEmbedded and MoldRole.EffectivePersistent; if Result then begin NonEmbeddedLink := MoldRole.OtherEnd ; if (NonEmbeddedLink.RoleType = rtLinkRole) then NonEmbeddedLink := NonEmbeddedLink.MainRole; - NonEmbeddedLinkName := NonEmbeddedLink.ExpandedExpressionName; end; end; end; @@ -333,13 +427,14 @@ function TBoldAbstractSnooper.MemberIsNonEmbeddedLink(MoldMember: TMoldMember; v end; end; -procedure TBoldAbstractSnooper.NonEmbeddedStateOfObjectChanged(Object_Content, NewObject_Content: IBoldObjectContents; MoldClass: TMoldClass); +procedure TBoldAbstractSnooper.NonEmbeddedStateOfObjectChanged(const Object_Content, NewObject_Content: IBoldObjectContents; MoldClass: TMoldClass); var j: integer; MemberCount: integer; Id: TBoldObjectID; NewId: TBoldObjectID; NonEmbeddedLinkName: string; + NonEmbeddedLink: TMoldRole; begin MemberCount := 0; if Assigned(Object_Content) then @@ -347,24 +442,52 @@ procedure TBoldAbstractSnooper.NonEmbeddedStateOfObjectChanged(Object_Content, N else if Assigned(NewObject_Content) then MemberCount := NewObject_Content.MemberCount; for j:= 0 to MemberCount - 1 do - if MemberIsEmbeddedSingleLink(MoldClass.AllBoldMembers[j], NonEmbeddedLinkName) then - begin + if MemberIsEmbeddedSingleLink(MoldClass.AllBoldMembers[j], NonEmbeddedLink) then + begin; Id := ObjectIdByMemberIndex(Object_Content, j); NewId := ObjectIdByMemberIndex(NewObject_Content, j); - GenerateNonEmbeddedStateChangedEvent(Id, NewId,NonEmbeddedLinkName); + NonEmbeddedLinkName := NonEmbeddedLink.ExpandedExpressionName; + GenerateNonEmbeddedStateChangedEvent(Id, NewId, NonEmbeddedLink.MoldClass, NonEmbeddedLinkName); end; end; +procedure TBoldAbstractSnooper.AddEvent(const AEvent: string); +begin + if Events.Count = 0 then + begin + fEventTimeStamp := now; + fEventsLength := 0; + end; + Events.Add(AEvent); + Inc(fEventsLength, Length(AEvent)); + if EventLimitReached then + TransmitEvents(NOTVALIDCLIENTID); +end; + +procedure TBoldAbstractSnooper.AddSubscription(const AEvent: string); +begin + Subscriptions.Add(AEvent); +end; + +procedure TBoldAbstractSnooper.CancelSubscription(const AEvent: string); +begin + CancelledSubscriptions.Add(AEvent); +end; + function TBoldAbstractSnooper.ClassNameFromClassId(const TopSortedIndex: integer): string; begin Result := MoldModel.Classes[TopSortedIndex].ExpandedExpressionName; end; procedure TBoldAbstractSnooper.ClearEvents; +var + i: integer; begin Events.Clear; Subscriptions.Clear; CancelledSubscriptions.Clear; + for i := 0 to length(fEventClassFlags)-1 do + fEventClassFlags[i] := false; end; procedure TBoldAbstractSnooper.DoPropagatorFailure(Sender: TObject; const ErrorMessage: string); @@ -377,22 +500,35 @@ procedure TBoldAbstractSnooper.AddClassEvents(TopsortedIndex: integer); var MoldClass: TMoldClass; begin + if fEventClassFlags[TopSortedIndex] then + exit; MoldClass := MoldModel.Classes[TopSortedIndex]; + if not fEventClassFlags[MoldClass.TopSortedIndex] then + AddEvent(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsClassChanged, MoldClass.ExpandedExpressionName, '', '', nil)); while assigned(MoldClass) do begin - Events.Add(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsClassChanged, MoldClass.ExpandedExpressionName, '', '', nil)); + if not fEventClassFlags[MoldClass.TopSortedIndex] then + fEventClassFlags[MoldClass.TopSortedIndex] := true; MoldClass := MoldClass.SuperClass; end; end; procedure TBoldAbstractSnooper.EnsureDataBaseLock(const ClientID: TBoldClientID); begin - // intentionally left blank +end; + +function TBoldAbstractSnooper.EventLimitReached: boolean; +const + c1millisecond = 1 / 86400000; + cAgeLimit = c1millisecond * 200; // half a second; + cMessageLengthLimit = 1200; +begin + result := (fEventsLength > cMessageLengthLimit) + or (fEventTimeStamp>0) and (now - fEventTimeStamp > cAgeLimit); end; procedure TBoldAbstractSnooper.ReleaseDataBaseLock(const ClientID: TBoldClientID); begin - // intentionally left blank end; end. diff --git a/Source/Persistence/Core/BoldPersistenceController.pas b/Source/Persistence/Core/BoldPersistenceController.pas index ac97999b..fa8d2078 100644 --- a/Source/Persistence/Core/BoldPersistenceController.pas +++ b/Source/Persistence/Core/BoldPersistenceController.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceController; interface @@ -8,7 +11,9 @@ interface BoldId, BoldUpdatePrecondition, BoldValueSpaceInterfaces, - BoldDefs; + BoldDefs, + BoldElements, + BoldDBInterfaces; type { forward declarations } @@ -17,20 +22,26 @@ TBoldPersistenceController = class; {-- TBoldPersistenceController --} TBoldPersistenceController = class(TBoldSubscribableObject) public - procedure PMExactifyIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); virtual; abstract; + procedure PMExactifyIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; HandleNonExisting: Boolean); virtual; abstract; procedure PMFetch(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; BoldClientID: TBoldClientID); virtual; abstract; procedure PMFetchIDListWithCondition(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; FetchMode: Integer; Condition: TBoldCondition; BoldClientID: TBoldClientID); virtual; abstract; - procedure PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; BoldClientID: TBoldClientID); virtual; abstract; + procedure PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; var TimeOfLatestUpdate: TDateTime; BoldClientID: TBoldClientID); virtual; abstract; procedure PMTranslateToGlobalIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); virtual; abstract; procedure PMTranslateToLocalIds(GlobalIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); virtual; abstract; procedure PMSetReadOnlyness(ReadOnlyList, WriteableList: TBoldObjectIdList); virtual; abstract; procedure SubscribeToPeristenceEvents(Subscriber: TBoldSubscriber); virtual; - // this info should be stored in separate Mapping model function MultilinksAreStoredInObject: Boolean; virtual; procedure ReserveNewIds(ValueSpace: IBoldValueSpace; ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); virtual; abstract; procedure PMTimestampForTime(ClockTime: TDateTime; var Timestamp: TBoldTimestampType); virtual; procedure PMTimeForTimestamp(Timestamp: TBoldTimestampType; var ClockTime: TDateTime); virtual; + // The BoldSystem is passed as TBoldElement, + // because include of BoldSystem.pas would cause recursive dependency. + function CanEvaluateInPS(sOCL: string; aSystem: TBoldElement; aContext: TBoldElementTypeInfo = nil; const aVariableList: TBoldExternalVariableList = nil): Boolean; virtual; abstract; + procedure StartTransaction; virtual; + procedure CommitTransaction; virtual; + procedure RollbackTransaction; virtual; + function DatabaseInterface: IBoldDatabase; virtual; end; const @@ -41,10 +52,31 @@ implementation uses SysUtils, - PersistenceConsts; + BoldRev; { TBoldPersistenceController } +procedure TBoldPersistenceController.StartTransaction; +begin + // Can be overriden but not mandatory +end; + +procedure TBoldPersistenceController.CommitTransaction; +begin + // Can be overriden but not mandatory +end; + +procedure TBoldPersistenceController.RollbackTransaction; +begin + // If Rollback is ever called, then it has to be overriden so we raise an exception + raise EBoldFeatureNotImplementedYet.CreateFmt('RollbackTransaction not supported by %s', [classname]); +end; + +function TBoldPersistenceController.DatabaseInterface: IBoldDatabase; +begin + result := nil; +end; + function TBoldPersistenceController.MultilinksAreStoredInObject: Boolean; begin result := false; @@ -53,13 +85,13 @@ function TBoldPersistenceController.MultilinksAreStoredInObject: Boolean; procedure TBoldPersistenceController.PMTimeForTimestamp( Timestamp: TBoldTimestampType; var ClockTime: TDateTime); begin - raise EBoldFeatureNotImplementedYet.CreateFmt(sPMTimeForTimeStampNotSupported, [classname]); + raise EBoldFeatureNotImplementedYet.CreateFmt('PMTimeForTimestamp not supported by %s', [classname]); end; procedure TBoldPersistenceController.PMTimestampForTime( ClockTime: TDateTime; var Timestamp: TBoldTimestampType); begin - raise EBoldFeatureNotImplementedYet.CreateFmt(sPMTimeStampForTimeNotSupported, [classname]); + raise EBoldFeatureNotImplementedYet.CreateFmt('PMTimestampForTime not supported by %s', [classname]); end; procedure TBoldPersistenceController.SubscribeToPeristenceEvents( @@ -76,5 +108,3 @@ procedure TBoldPersistenceController.SubscribeToPeristenceEvents( end; end. - - diff --git a/Source/Persistence/Core/BoldPersistenceHandle.pas b/Source/Persistence/Core/BoldPersistenceHandle.pas index b0071a16..cd95526d 100644 --- a/Source/Persistence/Core/BoldPersistenceHandle.pas +++ b/Source/Persistence/Core/BoldPersistenceHandle.pas @@ -1,30 +1,37 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandle; interface uses Classes, - BoldDefs, BoldHandle, BoldSubscription, BoldPersistenceController; type + TBoldPersistenceHandle = class; + TBoldPersistenceHandleClass = class of TBoldHandle; + TBoldPersistenceHandle = class(TBoldHandle) private fActive: Boolean; fPersistenceController: TBoldPersistenceController; - fPersistenceSubscriber: TBoldPassThroughSubscriber; - function GetActive: Boolean; + fPersistenceSubscriber: TBoldExtendedPassthroughSubscriber; function GetPersistenceController: TBoldPersistenceController; function GetHasPersistenceController: Boolean; + function GetPersistenceSubscriber: TBoldExtendedPassthroughSubscriber; protected - procedure CheckInactive(Action: String); + procedure CheckInactive(const Action: String); function CreatePersistenceController: TBoldPersistenceController; virtual; abstract; function GetHandledObject: TObject; override; procedure ReceiveExtendedEvent(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const); + function GetActive: boolean; virtual; procedure SetActive(Value: Boolean); virtual; property HasPersistenceController: Boolean read GetHasPersistenceController; + property PersistenceSubscriber: TBoldExtendedPassthroughSubscriber read GetPersistenceSubscriber; public constructor Create(Owner: TComponent); override; destructor Destroy; override; @@ -38,7 +45,8 @@ implementation uses SysUtils, - PersistenceConsts; + BoldDefs, + BoldRev; function TBoldPersistenceHandle.GetHandledObject: TObject; begin @@ -52,15 +60,21 @@ function TBoldPersistenceHandle.GetActive: Boolean; procedure TBoldPersistenceHandle.SetActive(Value: Boolean); begin - fActive := Value; - if not Active then - SendEvent(self, beDeactivating); + if fActive <> Value then + begin + fActive := Value; + if not Value then + begin + SendEvent(self, beDeactivating); + ReleasePersistenceController; + end; + end; end; -procedure TBoldPersistenceHandle.CheckInactive(Action: String); +procedure TBoldPersistenceHandle.CheckInactive(const Action: String); begin - if active then - raise EBold.CreateFmt(sNotAllowedOnActiveHandle, [Action]); + if Active then + raise EBold.CreateFmt('%s Not allowed on active PersistenceHandle', [Action]); end; constructor TBoldPersistenceHandle.create(Owner: TComponent); @@ -72,15 +86,25 @@ constructor TBoldPersistenceHandle.create(Owner: TComponent); function TBoldPersistenceHandle.GetPersistenceController: TBoldPersistenceController; begin if not assigned(fPersistenceController) then + begin fPersistenceController := CreatePersistenceController; + fPersistenceController.AddSmallSubscription(PersistenceSubscriber, [beDestroying], beDestroying); + end; result := fPersistenceController; end; +function TBoldPersistenceHandle.GetPersistenceSubscriber: TBoldExtendedPassthroughSubscriber; +begin + if not Assigned(fPersistenceSubscriber) then + fPersistenceSubscriber := TBoldExtendedPassthroughSubscriber.CreateWithExtendedReceive(ReceiveExtendedEvent); + result := fPersistenceSubscriber; +end; + destructor TBoldPersistenceHandle.Destroy; begin FreePublisher; - FreeAndNil(fPersistenceController); FreeAndNil(fPersistenceSubscriber); + FreeAndNil(fPersistenceController); inherited; end; @@ -88,31 +112,44 @@ procedure TBoldPersistenceHandle.ReceiveExtendedEvent( Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const); begin - SendExtendedEvent(Originator, OriginalEvent, Args); + if (Originator = fPersistenceController) and (OriginalEvent = beDestroying) then + begin + fPersistenceController := nil; + end + else + SendExtendedEvent(Originator, OriginalEvent, Args); end; procedure TBoldPersistenceHandle.AddPersistenceSubscription(Subscriber: TBoldSubscriber); begin - fPersistenceSubscriber := TBoldPassThroughSubscriber.CreateWithExtendedReceive(ReceiveExtendedEvent); + PersistenceSubscriber.CancelAllSubscriptions; + PersistenceController.AddSmallSubscription(fPersistenceSubscriber, [beDestroying], beDestroying); PersistenceController.SubscribeToPeristenceEvents(fPersistenceSubscriber); - AddSubscription(Subscriber, bpeEndFetch, bpeEndFetch); - AddSubscription(Subscriber, bpeEndUpdate, bpeEndUpdate); - AddSubscription(Subscriber, bpeEndFetchId, bpeEndUpdate); + AddSubscription(Subscriber, bpeFetchId, bpeFetchId); AddSubscription(Subscriber, bpeFetchObject, bpeFetchObject); AddSubscription(Subscriber, bpeFetchMember, bpeFetchMember); - AddSubscription(Subscriber, bpeUpdateObject, bpeUpdateObject); AddSubscription(Subscriber, bpeCreateObject, bpeCreateObject); + AddSubscription(Subscriber, bpeUpdateObject, bpeUpdateObject); AddSubscription(Subscriber, bpeDeleteObject, bpeDeleteObject); - AddSubscription(Subscriber, bpeFetchId, bpeFetchId); + AddSubscription(Subscriber, bpeStartFetchId, bpeStartFetchId); AddSubscription(Subscriber, bpeStartFetch, bpeStartFetch); AddSubscription(Subscriber, bpeStartUpdate, bpeStartUpdate); - AddSubscription(Subscriber, bpeStartFetchId, bpeStartUpdate); + AddSubscription(Subscriber, bpeEndFetchId, bpeEndFetchId); + AddSubscription(Subscriber, bpeEndFetch, bpeEndFetch); + AddSubscription(Subscriber, bpeEndUpdate, bpeEndUpdate); + + AddSubscription(Subscriber, bpeStartFetchMember, bpeStartFetchMember); + AddSubscription(Subscriber, bpeEndFetchMember, bpeEndFetchMember); + AddSubscription(Subscriber, bpeStartFetchObjectById, bpeStartFetchObjectById); + AddSubscription(Subscriber, bpeEndFetchObjectById, bpeEndFetchObjectById); + AddSubscription(Subscriber, bpeStartFetchClass, bpeStartFetchClass); + AddSubscription(Subscriber, bpeEndFetchClass, bpeEndFetchClass); end; procedure TBoldPersistenceHandle.ReleasePersistenceController; begin - if active then - Active := false; + Active := false; + FreeAndNil(fPersistenceSubscriber); FreeAndNil(fPersistenceController); end; @@ -121,4 +158,6 @@ function TBoldPersistenceHandle.GetHasPersistenceController: Boolean; result := assigned(fPersistenceController); end; +initialization + end. diff --git a/Source/Persistence/Core/BoldPersistenceHandlePTWithModel.pas b/Source/Persistence/Core/BoldPersistenceHandlePTWithModel.pas index de4f162d..352bd5d1 100644 --- a/Source/Persistence/Core/BoldPersistenceHandlePTWithModel.pas +++ b/Source/Persistence/Core/BoldPersistenceHandlePTWithModel.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandlePTWithModel; interface @@ -27,7 +30,8 @@ TBoldPersistenceHandlePassthroughWithModel = class(TBoldPersistenceHandlePasst implementation uses - SysUtils; + SysUtils, + BoldRev; const breModelDestroyed = 42; @@ -57,7 +61,7 @@ procedure TBoldPersistenceHandlePassthroughWithModel.SetBoldModel(Value: TBoldAb procedure TBoldPersistenceHandlePassthroughWithModel.ModelChanged; begin ReleasePersistenceController; - SendEvent(self, beValueIdentityChanged); // type change regarded as idenitychange + SendEvent(self, beValueIdentityChanged); end; destructor TBoldPersistenceHandlePassthroughWithModel.Destroy; diff --git a/Source/Persistence/Core/BoldPersistenceHandlePassthrough.pas b/Source/Persistence/Core/BoldPersistenceHandlePassthrough.pas index 3ee6359c..bb16be73 100644 --- a/Source/Persistence/Core/BoldPersistenceHandlePassthrough.pas +++ b/Source/Persistence/Core/BoldPersistenceHandlePassthrough.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandlePassthrough; interface @@ -15,13 +18,15 @@ TBoldPersistenceHandlePassthrough = class(TBoldPersistenceHandle) fNextPHandleSubscriber: TBoldPassthroughSubscriber; procedure SetNextPersistenceHandle(NextPHandle: TBoldPersistenceHandle); procedure NextPHandleDeleted(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); + function GetLastPersistenceHandle: TBoldPersistenceHandle; protected procedure ChainPersistenceController(PersistenceController: TBoldPersistenceControllerPassThrough); procedure SetActive(Value: Boolean); override; - procedure InitNextPHandle(NextPHandle: TBoldPersistenceHandle); virtual; + procedure InitNextPHandle(NextPHandle: TBoldPersistenceHandle); virtual; public constructor Create(Owner: TComponent); override; destructor Destroy; override; + property LastPersistenceHandle: TBoldPersistenceHandle read GetLastPersistenceHandle; property NextPersistenceHandle: TBoldPersistenceHandle read fNextPersistenceHandle write {fNextPersistenceHandle}SetNextPersistenceHandle; end; @@ -29,15 +34,17 @@ TBoldPersistenceHandlePassthrough = class(TBoldPersistenceHandle) implementation uses - SysUtils; + SysUtils, + BoldRev; { TBoldPersistenceControllerPassthroughHandle } + procedure TBoldPersistenceHandlePassthrough.SetActive(Value: Boolean); begin - inherited; if Assigned(NextPersistenceHandle) then NextPersistenceHandle.Active := Value; + inherited; end; procedure TBoldPersistenceHandlePassthrough.SetNextPersistenceHandle( @@ -49,7 +56,7 @@ procedure TBoldPersistenceHandlePassthrough.SetNextPersistenceHandle( fNextPersistenceHandle := NextPHandle; if Assigned(fNextPersistenceHandle) then fNextPersistenceHandle.AddSmallSubscription(fNextPHandleSubscriber, [beDestroying], beDestroying); - InitNextPHandle(NextPHandle); + InitNextPHandle(NextPHandle); end; end; @@ -71,13 +78,19 @@ destructor TBoldPersistenceHandlePassthrough.Destroy; FreePublisher; FreeAndNil(fNextPHandleSubscriber); fNextPersistenceHandle := nil; - inherited; + inherited; +end; + +function TBoldPersistenceHandlePassthrough.GetLastPersistenceHandle: TBoldPersistenceHandle; +begin + result := NextPersistenceHandle; + while result is TBoldPersistenceHandlePassthrough do + result := TBoldPersistenceHandlePassthrough(result).NextPersistenceHandle; end; procedure TBoldPersistenceHandlePassthrough.InitNextPHandle( NextPHandle: TBoldPersistenceHandle); begin - //DoNothing end; procedure TBoldPersistenceHandlePassthrough.ChainPersistenceController(PersistenceController: TBoldPersistenceControllerPassThrough); @@ -86,4 +99,6 @@ procedure TBoldPersistenceHandlePassthrough.ChainPersistenceController(Persisten PersistenceController.NextPersistenceController := NextPersistenceHandle.PersistenceController; end; +initialization + end. diff --git a/Source/Persistence/Core/BoldPersistenceNotifier.pas b/Source/Persistence/Core/BoldPersistenceNotifier.pas index 94e576d5..4d62e3be 100644 --- a/Source/Persistence/Core/BoldPersistenceNotifier.pas +++ b/Source/Persistence/Core/BoldPersistenceNotifier.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceNotifier; interface @@ -26,9 +29,9 @@ TBoldAbstractPersistenceNotifier = class(TComponent) private fEvents: array[bpeMinReserved..bpeMaxReserved] of TBoldExtendedEventHandler; FPersistenceHandle: TBoldPersistenceHandle; - fSubscriber: TBoldSubscriber; + fSubscriber: TBoldExtendedPassthroughSubscriber; fFetchLog: TBoldIntegerArray; - fOnAlertExcessiveFetch: TBoldAlertExcessiveFetchEvent; + fOnAlertExcessiveFetch: TBoldAlertExcessiveFetchEvent; procedure SetPersistenceHandle(const Value: TBoldPersistenceHandle); function GetEvent(index: integer): TBoldExtendedEventHandler; procedure SetEvent(const index: integer; EventHandler: TBoldExtendedEventHandler); @@ -68,7 +71,7 @@ TBoldAbstractPersistenceNotifier = class(TComponent) property OnFetchID: TBoldExtendedEventHandler index bpeFetchID read GetEvent write SetEvent; property OnProgressStart: TBoldExtendedEventHandler index bpeProgressStart read GetEvent write SetEvent; property OnProgressEnd: TBoldExtendedEventHandler index bpeProgressEnd read GetEvent write SetEvent; - property OnAlertExcessiveFetch: TBoldAlertExcessiveFetchEvent read fOnAlertExcessiveFetch write fOnAlertExcessiveFetch; + property OnAlertExcessiveFetch: TBoldAlertExcessiveFetchEvent read fOnAlertExcessiveFetch write fOnAlertExcessiveFetch; property PersistenceHandle: TBoldPersistenceHandle read FPersistenceHandle write SetPersistenceHandle; property FetchLog: TBoldIntegerArray read GetFetchLog; public @@ -77,6 +80,7 @@ TBoldAbstractPersistenceNotifier = class(TComponent) end; { TBoldPersistenceNotifier } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldPersistenceNotifier = class(TBoldAbstractPersistenceNotifier) published property PersistenceHandle; @@ -98,9 +102,11 @@ TBoldPersistenceNotifier = class(TBoldAbstractPersistenceNotifier) end; { TBoldPersistenceProgressNotifier } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldPersistenceProgressNotifier = class(TBoldAbstractPersistenceNotifier) private { Private declarations } + fLastUpdate: TDateTime; FAnimation: TAnimate; fAnimationTimer: TTimer; FWinControl: TWinControl; @@ -116,6 +122,7 @@ TBoldPersistenceProgressNotifier = class(TBoldAbstractPersistenceNotifier) procedure SetMsgLabel(const Value: TLabel); function GetAnimationInterval: integer; procedure SetAnimationInterval(const Value: integer); + function GetAnimationTimer: TTimer; protected { Protected declarations } procedure EndEvent; @@ -123,6 +130,7 @@ TBoldPersistenceProgressNotifier = class(TBoldAbstractPersistenceNotifier) procedure StepProgress; procedure StepAnimation; procedure SetMessage(const s: String); + procedure UpdateProgressBar; procedure EndFetch(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const); override; procedure EndUpdate(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const); override; procedure EndFetchID(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const); override; @@ -136,6 +144,7 @@ TBoldPersistenceProgressNotifier = class(TBoldAbstractPersistenceNotifier) procedure StartFetchID(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const); override; procedure FetchID(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const); override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; + property AnimationTimer: TTimer read GetAnimationTimer; public { Public declarations } constructor Create(Owner: TComponent); override; @@ -159,11 +168,14 @@ implementation uses SysUtils, - PersistenceConsts; + BoldRev; const brePersistenceHandleDestroying = 100; +const + c100ms = 1/24/60/60/10; + { TBoldAbstractPersistenceNotifier } procedure TBoldAbstractPersistenceNotifier.CallIfAssigned(EventID: integer; @@ -177,7 +189,7 @@ procedure TBoldAbstractPersistenceNotifier.CallIfAssigned(EventID: integer; constructor TBoldAbstractPersistenceNotifier.create(owner: TComponent); begin inherited; - fSubscriber := TBoldPassThroughSubscriber.CreateWithExtendedReceive(ReceiveExtendedEvent); + fSubscriber := TBoldExtendedPassthroughSubscriber.CreateWithExtendedReceive(ReceiveExtendedEvent); end; procedure TBoldAbstractPersistenceNotifier.CreateObject( @@ -320,7 +332,7 @@ procedure TBoldAbstractPersistenceNotifier.ReceiveExtendedEvent( if (OriginalEvent = bpeEndFetch) or (OriginalEvent = bpeEndUpdate) or (OriginalEvent = bpeEndFetchId) then ProgressEnd(Originator, OriginalEvent, RequestedEvent, args); - + if (OriginalEvent = beDestroying) and (RequestedEvent = brePersistenceHandleDestroying) then begin PersistenceHandle := nil; @@ -341,7 +353,6 @@ procedure TBoldAbstractPersistenceNotifier.SetPersistenceHandle(const Value: TBo fSubscriber.CancelAllSubscriptions; if Assigned(Value) then begin - // delay the adding of persistence-subscriptions until "loaded". ignore in designtime if not (csDesigning in ComponentState) and not (csLoading in ComponentState) then Value.AddPersistenceSubscription(fSubscriber); @@ -393,7 +404,7 @@ procedure TBoldAbstractPersistenceNotifier.AlertExcessiveFetch(ObjectId: TBoldOb procedure TBoldAbstractPersistenceNotifier.Loaded; begin inherited; - if assigned(fPersistenceHandle) then + if assigned(fPersistenceHandle) and not (csDesigning in ComponentState) then FPersistenceHandle.AddPersistenceSubscription(fSubscriber); end; @@ -402,19 +413,18 @@ procedure TBoldAbstractPersistenceNotifier.Loaded; procedure TBoldPersistenceProgressNotifier.AnimationTurnOff(Sender: TObject); begin if assigned(Animation) then + begin Animation.Stop; - fAnimationTimer.Enabled := false; + AnimationTimer.Enabled := false; + end; end; constructor TBoldPersistenceProgressNotifier.create(owner: TComponent); begin inherited; - fAnimationTimer := TTimer.Create(self); - fAnimationTimer.OnTimer := AnimationTurnOff; - fAnimationTimer.Interval := 100; - fMsgFetchObjects := sFetchingObjects; - fMsgRetrieveIds := sRetrievingIDs; - fMsgUpdateDatabase := sUpdatingDB; + fMsgFetchObjects := 'Fetching objects'; + fMsgRetrieveIds := 'Retrieving object IDs'; + fMsgUpdateDatabase := 'Updating database'; end; procedure TBoldPersistenceProgressNotifier.CreateObject( @@ -439,11 +449,11 @@ procedure TBoldPersistenceProgressNotifier.EndEvent; begin ProgressBar.Visible := false; ProgressBar.Max := 0; - ProgressBar.Refresh; + UpdateProgressBar; end; if assigned(Animation) then begin - fAnimationTimer.Enabled := true; + AnimationTimer.Enabled := true; Animation.Refresh; end; SetMessage(''); @@ -499,10 +509,21 @@ procedure TBoldPersistenceProgressNotifier.FetchObject(Originator: TObject; type TExposedWinControl = class(TWinControl); -{ Handle removing of non-bold components } +{ Handle removing of non-bold components } function TBoldPersistenceProgressNotifier.GetAnimationInterval: integer; begin - result := fAnimationTimer.Interval; + result := AnimationTimer.Interval; +end; + +function TBoldPersistenceProgressNotifier.GetAnimationTimer: TTimer; +begin + if not Assigned(fAnimationTimer) then + begin + fAnimationTimer := TTimer.Create(self); + fAnimationTimer.OnTimer := AnimationTurnOff; + fAnimationTimer.Interval := 100; + end; + result := fAnimationTimer; end; procedure TBoldPersistenceProgressNotifier.Notification( @@ -533,7 +554,7 @@ procedure TBoldPersistenceProgressNotifier.SetAnimation( procedure TBoldPersistenceProgressNotifier.SetAnimationInterval( const Value: integer); begin - fAnimationTimer.Interval := Value; + AnimationTimer.Interval := Value; end; procedure TBoldPersistenceProgressNotifier.SetMessage(const s: String); @@ -584,11 +605,11 @@ procedure TBoldPersistenceProgressNotifier.StartEvent(Count: integer); ProgressBar.Visible := true; ProgressBar.Position := 0; ProgressBar.Max := Count; - ProgressBar.Refresh; + UpdateProgressBar; end; if Assigned(Animation) then begin - fAnimationTimer.Enabled := False; + AnimationTimer.Enabled := False; if not Animation.Active and (Animation.FrameCount > 0) then Animation.Play(0, Animation.FrameCount - 1, 0); @@ -627,7 +648,7 @@ procedure TBoldPersistenceProgressNotifier.StepAnimation; begin if assigned(Animation) then begin - fAnimationTimer.Enabled := false; + AnimationTimer.Enabled := false; if (Animation.FrameCount > 0) then Animation.Play(0, Animation.FrameCount - 1, 0); Animation.Refresh; @@ -639,7 +660,7 @@ procedure TBoldPersistenceProgressNotifier.StepProgress; if assigned(ProgressBar) then begin ProgressBar.StepIt; - ProgressBar.Refresh; + UpdateProgressBar; end; end; @@ -651,4 +672,15 @@ procedure TBoldPersistenceProgressNotifier.UpdateObject( StepProgress; end; +procedure TBoldPersistenceProgressNotifier.UpdateProgressBar; +begin + if now - fLastUpdate > c100ms then + begin + ProgressBar.Refresh; + fLastUpdate := now; + end; +end; + +initialization + end. diff --git a/Source/Persistence/Core/BoldUpdatePrecondition.pas b/Source/Persistence/Core/BoldUpdatePrecondition.pas index f939007e..8e9d106e 100644 --- a/Source/Persistence/Core/BoldUpdatePrecondition.pas +++ b/Source/Persistence/Core/BoldUpdatePrecondition.pas @@ -1,10 +1,12 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUpdatePrecondition; interface uses BoldFreeStandingValues, - BoldDefs, BoldId, BoldBase, BoldStreams, @@ -12,7 +14,6 @@ interface type TBoldUpdatePrecondition = class(TBoldNonRefCountedObject, IBoldStreamable) - protected function GetStreamName: string; virtual; abstract; function GetFailureReason: string; virtual; @@ -28,10 +29,10 @@ TBoldOptimisticLockingPrecondition = class(TBoldUpdatePrecondition) private fFreeStandingValueSpace: TBoldFreeStandingValueSpace; fFailureList: TBoldObjectIdList; - function GetValueSpace: IBoldValueSpace; - function GetFreeStandingValueSpace: TBoldFreeStandingValueSpace; - function GetFailureList: TBoldObjectIdList; - function GetHasOptimisticLocks: Boolean; + function GetValueSpace: IBoldValueSpace; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetFreeStandingValueSpace: TBoldFreeStandingValueSpace; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetFailureList: TBoldObjectIdList; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetHasOptimisticLocks: Boolean; // do not inline it causes problems in D2007 at least protected function GetStreamName: string; override; function GetFailureReason: string; override; @@ -52,10 +53,10 @@ implementation uses SysUtils, - BoldXMLStreaming, BoldDefaultStreamNames, BoldDefaultXMLStreaming, - PersistenceConsts; + BoldDefs, + BoldXMLStreaming; const OptimisticLockingPreConditionStreamName = 'OptimisticLockingPreCondition'; @@ -83,7 +84,6 @@ TBoldXMLOptimisticLockingPreConditionStreamer = class(TBoldXMLPreConditionStre constructor TBoldUpdatePrecondition.create; begin - // do nothing end; function TBoldUpdatePrecondition.GetFailed: Boolean; @@ -116,7 +116,7 @@ procedure TBoldOptimisticLockingPrecondition.ClearValueSpace; FreeAndNil(fFreeStandingValueSpace); end; -destructor TBoldOptimisticLockingPrecondition.destroy; +destructor TBoldOptimisticLockingPrecondition.Destroy; begin FreeAndNil(fFreeStandingValueSpace); FreeAndNil(fFailureList); @@ -136,8 +136,16 @@ function TBoldOptimisticLockingPrecondition.GetFailureList: TBoldObjectIdList; end; function TBoldOptimisticLockingPrecondition.GetFailureReason: string; +var + I: Integer; begin - result := format(sOptimisticLockingFailedForNObjects, [FailureList.Count]); + result := format('Optimistic locking failed for the following %d objects:', [FailureList.Count]); + for i := 0 to FailureList.Count - 1 do + begin + if i > 0 then + Result := Result + ', '; + result := Result + ('Id: '+ FailureList[i].AsString); + end; end; function TBoldOptimisticLockingPrecondition.GetFreeStandingValueSpace: TBoldFreeStandingValueSpace; @@ -147,27 +155,19 @@ function TBoldOptimisticLockingPrecondition.GetFreeStandingValueSpace: TBoldFree result := fFreeStandingValueSpace; end; -function TBoldOptimisticLockingPrecondition.GetHasOptimisticLocks: Boolean; -var - Ids: TBoldObjectIdList; +function TBoldOptimisticLockingPrecondition.GetValueSpace: IBoldValueSpace; begin - Ids := TBoldObjectIdList.create; - try - ValueSpace.AllObjectIds(Ids, true); - result := Ids.Count <> 0; - finally - Ids.Free; - end; + result := FreeStandingValueSpace; end; -function TBoldOptimisticLockingPrecondition.GetStreamName: string; +function TBoldOptimisticLockingPrecondition.GetHasOptimisticLocks: Boolean; begin - result := OptimisticLockingPreConditionStreamName; + result := not ValueSpace.IsEmpty; end; -function TBoldOptimisticLockingPrecondition.GetValueSpace: IBoldValueSpace; +function TBoldOptimisticLockingPrecondition.GetStreamName: string; begin - result := FreeStandingValueSpace; + result := OptimisticLockingPreConditionStreamName; end; { TBoldXMLPreConditionStreamer } @@ -176,17 +176,14 @@ procedure TBoldXMLPreConditionStreamer.ReadObject(Obj: TObject; Node: TBoldXMLNode); begin inherited; - // do nothing yet end; procedure TBoldXMLPreConditionStreamer.WriteObject( Obj: TBoldInterfacedObject; Node: TBoldXMLNode); begin inherited; - // do nothing yet end; - { TBoldXMLOptimisticLockingPreConditionStreamer } function TBoldXMLOptimisticLockingPreConditionStreamer.CreateObject: TObject; @@ -211,12 +208,12 @@ procedure TBoldXMLOptimisticLockingPreConditionStreamer.ReadObject(Obj: TObject; if Node.Manager is TBoldDefaultXMLStreamManager then begin Manager := Node.Manager as TBoldDefaultXMLStreamManager; - SubNode := Node.GetSubNode('ValueSpace'); // do not localize + SubNode := Node.GetSubNode('ValueSpace'); Manager.ReadValueSpace(Condition.ValueSpace, SubNode); SubNode.Free; end; - IdList := Node.ReadSubNodeObject('FailureList', BOLDOBJECTIDLISTNAME) as TBoldObjectIdList; // do not localize + IdList := Node.ReadSubNodeObject('FailureList', BOLDOBJECTIDLISTNAME) as TBoldObjectIdList; Condition.FailureList.Clear; Condition.FailureList.AddList(IdList); IdList.Free; @@ -243,7 +240,7 @@ procedure TBoldXMLOptimisticLockingPreConditionStreamer.WriteObject(Obj: TBoldIn Manager.PersistenceStatesToBeStreamed := [bvpsCurrent]; - SubNode := Node.NewSubNode('ValueSpace'); // do not localize + SubNode := Node.NewSubNode('ValueSpace'); Manager.WriteValueSpace(Condition.ValueSpace, IdLIst, nil, SubNode); SubNode.Free; @@ -252,7 +249,7 @@ procedure TBoldXMLOptimisticLockingPreConditionStreamer.WriteObject(Obj: TBoldIn FreeAndNil(IdList); end; end; - Node.WriteSubNodeObject('FailureList', BOLDOBJECTIDLISTNAME, Condition.FailureList); // do not localize + Node.WriteSubNodeObject('FailureList', BOLDOBJECTIDLISTNAME, Condition.FailureList); end; initialization diff --git a/Source/Persistence/Core/PersistenceConsts.pas b/Source/Persistence/Core/PersistenceConsts.pas index 580f44da..1d94b8e4 100644 --- a/Source/Persistence/Core/PersistenceConsts.pas +++ b/Source/Persistence/Core/PersistenceConsts.pas @@ -71,4 +71,4 @@ interface implementation -end. \ No newline at end of file +end. diff --git a/Source/Persistence/DB/BoldAbstractDatabaseAdapter.pas b/Source/Persistence/DB/BoldAbstractDatabaseAdapter.pas index 369d6432..67a1c264 100644 --- a/Source/Persistence/DB/BoldAbstractDatabaseAdapter.pas +++ b/Source/Persistence/DB/BoldAbstractDatabaseAdapter.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAbstractDatabaseAdapter; interface @@ -6,7 +9,8 @@ interface Classes, BoldDBInterfaces, BoldSQLDatabaseConfig, - BoldSubscription; + BoldSubscription, + BoldIndexCollection; const beDatabaseAdapterChanged = 100; @@ -19,9 +23,11 @@ TBoldAbstractDatabaseAdapter = class; TBoldAbstractDatabaseAdapter = class(TBoldSubscribableComponent) private FSQLDatabaseConfig: TBoldSQLDatabaseConfig; + fCustomIndexes: TBoldIndexCollection; fDatabaseEngine: TBoldDataBaseEngine; fInternalDatabase: TComponent; procedure SetSQLDatabaseConfig(const Value: TBoldSQLDatabaseConfig); + procedure SetCustomIndexes(const Value: TBoldIndexCollection); procedure SetInternalDatabase(const Value: TComponent); protected procedure ReleaseBoldDatabase; virtual; abstract; @@ -32,17 +38,22 @@ TBoldAbstractDatabaseAdapter = class(TBoldSubscribableComponent) property InternalDatabase: TComponent read fInternalDatabase write SetInternalDatabase; function GetDataBaseInterface: IBoldDatabase; virtual; abstract; public - constructor Create(aOwner: TComponent); override; - destructor Destroy; override; + constructor create(aOwner: TComponent); override; + destructor destroy; override; + procedure CreateDatabase(DropExisting: boolean = true); virtual; abstract; + procedure DropDatabase; virtual; abstract; + function DatabaseExists: boolean; virtual; abstract; property DatabaseInterface: IBoldDatabase read GetDatabaseInterface; published property SQLDatabaseConfig: TBoldSQLDatabaseConfig read FSQLDatabaseConfig write SetSQLDatabaseConfig; + property CustomIndexes: TBoldIndexCollection read fCustomIndexes write SetCustomIndexes; end; implementation uses - SysUtils; + SysUtils, + BoldRev; { TBoldAbstractDatabaseAdapter } @@ -55,11 +66,13 @@ constructor TBoldAbstractDatabaseAdapter.create(aOwner: TComponent); begin inherited; fSQLDatabaseConfig := TBoldSQLDatabaseConfig.Create; + fCustomIndexes := TBoldIndexCollection.Create(Self); end; destructor TBoldAbstractDatabaseAdapter.destroy; begin FreeAndNil(fSQLDatabaseConfig); + FreeAndNil(fCustomIndexes); inherited; end; @@ -87,6 +100,12 @@ procedure TBoldAbstractDatabaseAdapter.SetInternalDatabase(const Value: TCompone end; end; +procedure TBoldAbstractDatabaseAdapter.SetCustomIndexes( + const Value: TBoldIndexCollection); +begin + fCustomIndexes.Assign(value); +end; + procedure TBoldAbstractDatabaseAdapter.SetDataBaseEngine(const Value: TBoldDataBaseEngine); begin if value <> fDatabaseEngine then @@ -103,4 +122,6 @@ procedure TBoldAbstractDatabaseAdapter.SetSQLDatabaseConfig(const Value: TBoldSQ FSQLDatabaseConfig.AssignConfig(value); end; +initialization + end. diff --git a/Source/Persistence/DB/BoldAbstractPersistenceHandleDB.pas b/Source/Persistence/DB/BoldAbstractPersistenceHandleDB.pas index 2b9a6f18..76dd08e9 100644 --- a/Source/Persistence/DB/BoldAbstractPersistenceHandleDB.pas +++ b/Source/Persistence/DB/BoldAbstractPersistenceHandleDB.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAbstractPersistenceHandleDB; interface @@ -13,7 +16,7 @@ interface BoldSQLDatabaseConfig, BoldPersistenceControllerDefault, BoldDbInterfaces, - BoldPSParams; + BoldPSParams, BoldIndexCollection; type { forward declarations } @@ -42,16 +45,20 @@ TBoldAbstractPersistenceHandleDB = class(TBoldPersistenceHandle) function CreatePersistenceController: TBoldPersistenceController; override; procedure SetActive(Value: Boolean); override; function GetSQLDatabaseConfig: TBoldSQLDatabaseConfig; virtual; abstract; + function GetCustomIndexes: TBoldIndexCollection; virtual; abstract; function GetDataBaseInterface: IBoldDatabase; virtual; abstract; procedure AssertSQLDatabaseconfig(Context: String); virtual; public - constructor Create(Owner: TComponent); override; - destructor Destroy; override; + constructor create(Owner: TComponent); override; + destructor destroy; override; property PersistenceControllerDefault: TBoldPersistenceControllerDefault read GetPersistenceControllerDefault; procedure CreateDataBaseSchema(IgnoreUnknownTables: Boolean = false); + procedure CreateDataBase(DropExisting: boolean = true); + procedure DropDataBase; procedure AddModelEvolutionInfoToDatabase; property DatabaseInterface: IBoldDatabase read GetDatabaseInterface; property SQLDatabaseConfig: TBoldSQLDatabaseConfig read GetSQLDatabaseConfig; + property CustomIndexes: TBoldIndexCOllection read GetCustomIndexes; published property BoldModel: TBoldAbstractModel read FBoldModel write SetBoldModel; property OnGetCurrentTime: TBoldGetTimeEvent read fOnGetCurrentTime write fOnGetCurrentTime; @@ -68,7 +75,7 @@ implementation BoldLogHandler, BoldPSDescriptionsSQL, BoldPMappersDefault, - PersistenceConsts; + BoldPersistenceControllerPassthrough; const breModelChanged = 100; @@ -150,6 +157,11 @@ constructor TBoldAbstractPersistenceHandleDB.create(Owner: TComponent); fComponentSubscriber := TBoldPassthroughSubscriber.Create(_ReceiveComponentEvents); end; +procedure TBoldAbstractPersistenceHandleDB.CreateDataBase(DropExisting: boolean); +begin + DatabaseInterface.CreateDatabase(DropExisting); +end; + procedure TBoldAbstractPersistenceHandleDB.CreateDataBaseSchema( IgnoreUnknownTables: Boolean); var @@ -157,16 +169,17 @@ procedure TBoldAbstractPersistenceHandleDB.CreateDataBaseSchema( begin fIgnoreUnknownTables := IgnoreUnknownTables; if Active then - raise EBold.Create(sCannotGenerateWhenHandleIsActive); + raise EBold.Create('Can not generate database schema when the PersistenceHandle is Active'); if not assigned(BoldModel) then - raise EBold.CreateFmt(sModelComponentMissing, [ClassName, Name]); - AssertSQLDatabaseconfig(sCreateSchema); + raise EBold.CreateFmt('%s.CreateDataBaseSchema: Can not create database schema for %s without a Model-component', [ClassName, Name]); + AssertSQLDatabaseconfig('Create DatabaseSchema'); - PMapper := TBoldSystemDefaultMapper.CreateFromMold(BoldModel.RawMoldModel, BoldModel.TypeNameDictionary, SQLDataBaseConfig, GetDataBaseInterface); + PMapper := TBoldSystemDefaultMapper.CreateFromMold(BoldModel.RawMoldModel, BoldModel.TypeNameDictionary, + CustomIndexes, SQLDataBaseConfig, GetDataBaseInterface); try try - BoldLog.StartLog(sGenerateSchema); + BoldLog.StartLog('Generate Database Schema'); PMapper.OpenDatabase(false, false); PMapper.OnPreparePSParams := PreparePSParams; PMapper.CreatePersistentStorage; @@ -174,7 +187,7 @@ procedure TBoldAbstractPersistenceHandleDB.CreateDataBaseSchema( except on e: Exception do begin - BoldLog.LogFmt(sSchemaGenerationAborted,[e.message], ltError); + BoldLog.LogFmt('Generation of Database Schema Aborted (%s)',[e.message], ltError); raise; end; end; @@ -189,8 +202,11 @@ function TBoldAbstractPersistenceHandleDB.CreatePersistenceController: TBoldPers PController: TBoldPersistenceControllerDefault; begin if not assigned(BoldModel) then - raise EBold.createFmt(sCannotGetPControllerWithoutModel, [ClassName]); - PController := TBoldPersistenceControllerDefault.CreateFromMold(BoldModel.MoldModel, BoldModel.TypeNameDictionary, SQLDataBaseConfig, GetDataBaseInterface); + raise EBold.createFmt('%s.CreatePersistenceController: Can not get a PersistenceController without a Model', [ClassName]); + if not assigned(SQLDataBaseConfig) then + raise EBold.createFmt('%s.CreatePersistenceController: Can not get a PersistenceController without SQLDataBaseConfig', [ClassName]); + PController := TBoldPersistenceControllerDefault.CreateFromMold(BoldModel.MoldModel, BoldModel.TypeNameDictionary, + CustomIndexes, SQLDataBaseConfig, GetDataBaseInterface); PController.PersistenceMapper.OnGetCurrentTime := fOnGetCurrentTime; PController.PersistenceMapper.ClockLogGranularity := fClockLogGranularity; @@ -205,17 +221,27 @@ destructor TBoldAbstractPersistenceHandleDB.destroy; inherited; end; +procedure TBoldAbstractPersistenceHandleDB.DropDataBase; +begin + DatabaseInterface.DropDatabase; +end; + function TBoldAbstractPersistenceHandleDB.GetClockLogGranularity: string; var hrs, mins, secs, msecs: Word; begin DecodeTime(fClockLogGranularity, hrs, mins, secs, msecs); - result := Format('%d:%d:%d.%d', [hrs, mins, secs, msecs]); // do not localize + result := Format('%d:%d:%d.%d', [hrs, mins, secs, msecs]); end; function TBoldAbstractPersistenceHandleDB.GetPersistenceControllerDefault: TBoldPersistenceControllerDefault; +var + vPersistenceController: TBoldPersistenceController; begin - result := PersistenceController as TBoldPersistenceControllerDefault; + vPersistenceController := PersistenceController; + while not (vPersistenceController is TBoldPersistenceControllerDefault) and (vPersistenceController is TBoldPersistenceControllerPassthrough) do + vPersistenceController := (vPersistenceController as TBoldPersistenceControllerPassthrough).NextPersistenceController; + result := vPersistenceController as TBoldPersistenceControllerDefault; end; procedure TBoldAbstractPersistenceHandleDB.PlaceComponentSubscriptions; @@ -239,10 +265,11 @@ procedure TBoldAbstractPersistenceHandleDB.SetActive(Value: Boolean); begin if value <> Active then begin + Assert(Assigned(PersistenceControllerDefault)); if value then begin if assigned(UpgraderHandle) and not BoldModel.MoldModel.UseModelVersion then - raise EBold.CreateFmt(sCannotActivate_UpgraderMismatch, [classname]); + raise EBold.CreateFmt('%s.SetActive: Cannot activate, there is an UpgraderHandle but the Model does not have UseModelVersion true', [classname]); PersistenceControllerDefault.OpenDatabase(EvolutionSupport); end else @@ -267,11 +294,11 @@ procedure TBoldAbstractPersistenceHandleDB.SetClockLogGranularity(const Value: s input: string; function GetNext(Delimiter: string): Integer; + const + ErrorMessage = '%s.SetClockLogGranularity: string is not properly formatted. Should be ::.'; var - ErrorMessage: string; p: Integer; begin - ErrorMessage := sClockStringFormatError; if Delimiter <> '' then begin p := pos(Delimiter, input); @@ -304,7 +331,7 @@ procedure TBoldAbstractPersistenceHandleDB.SetEvolutionSupport(const Value: Bool if Value <> FEvolutionSupport then begin if Active then - raise EBold.CreateFmt(sCannotSetWhenHandleIsActive, [classname, 'SetEvolutionSupport', name]); // do not localize + raise EBold.CreateFmt('%s.SetEvolutionSupport: Cannot set this property when the handle (%s) is active', [classname, name]); FEvolutionSupport := Value; end; end; @@ -330,7 +357,9 @@ procedure TBoldAbstractPersistenceHandleDB.AssertSQLDatabaseconfig( Context: String); begin if not assigned(SQLDatabaseConfig) then - raise EBold.CreateFmt(sSQLDatabaseConfigMissing, [classname, Context]); + raise EBold.CreateFmt('%s: Unable to %s. There is no SQLDatabaseConfig available', [classname, Context]); end; +initialization + end. diff --git a/Source/Persistence/DB/BoldDBActions.pas b/Source/Persistence/DB/BoldDBActions.pas index 6f4d07da..2049bef5 100644 --- a/Source/Persistence/DB/BoldDBActions.pas +++ b/Source/Persistence/DB/BoldDBActions.pas @@ -1,30 +1,96 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDBActions; interface uses Classes, + BoldHandleAction, BoldPersistenceHandleDB, + BoldSubscription, + BoldDbValidator, + BoldDbStructureValidator, + BoldDbDataValidator, ActnList; +const + cDefaultPauseBetweenQueries = 1; //ms + type + TBoldPersistenceHandleAction = class; TBoldGenerateSchemaAction = class; + TBoldValidateDBStructureAction = class; + TBoldValidateDBDataAction = class; + TBoldEvolveDBAction = class; + + { TBoldSystemHandleAction } + TBoldPersistenceHandleAction = class(TAction) + private + fHandleSubscriber: TBoldPassThroughSubscriber; + fBoldPersistenceHandleDB: TBoldPersistenceHandleDB; + procedure SetBoldPersistenceHandle(const Value: TBoldPersistenceHandleDB); virtual; + protected + procedure _HandleSubscriberReceive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); virtual; + procedure CheckAllowEnable(var EnableAction: boolean); virtual; + property BoldPersistenceHandleDB: TBoldPersistenceHandleDB read fBoldPersistenceHandleDB write SetBoldPersistenceHandle; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure UpdateTarget(Target: TObject); override; + function HandlesTarget(Target: TObject): Boolean; override; + end; { TBoldGenerateSchemaAction } - TBoldGenerateSchemaAction = class(TAction) + TBoldGenerateSchemaAction = class(TBoldPersistenceHandleAction) private - FBoldPersistenceHandleDB: TBoldPersistenceHandleDB; fIgnoreUnknownTables: boolean; - procedure SetBoldPersistenceHandleDB(const Value: TBoldPersistenceHandleDB); protected - procedure Notification(AComponent: TComponent; Operation: TOperation); override; + procedure CheckAllowEnable(var EnableAction: boolean); override; public constructor Create(AOwner: TComponent); override; procedure ExecuteTarget(Target: TObject); override; - function HandlesTarget(Target: TObject): Boolean; override; published - property BoldPersistenceHandleDB: TBoldPersistenceHandleDB read FBoldPersistenceHandleDB write SetBoldPersistenceHandleDB; property IgnoreUnknownTables: boolean read fIgnoreUnknownTables write fIgnoreUnknownTables; + property BoldPersistenceHandleDB; + end; + + { TBoldValidateDBStructureAction } + TBoldValidateDBStructureAction = class(TBoldPersistenceHandleAction) + private + fValidator: TBoldDbStructureValidator; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure ExecuteTarget(Target: TObject); override; + published + property BoldPersistenceHandleDB; + end; + + { TBoldValidateDBDataAction } + TBoldValidateDBDataAction = class(TBoldPersistenceHandleAction) + private + fValidator: TBoldDbDataValidator; + fPauseBetweenQueries: integer; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure ExecuteTarget(Target: TObject); override; + published + property PauseBetweenQueries: integer read fPauseBetweenQueries write fPauseBetweenQueries default cDefaultPauseBetweenQueries; + property BoldPersistenceHandleDB; + end; + + TBoldEvolveDBAction = class(TBoldPersistenceHandleAction) + private + fGenerateGenericScript: boolean; + public + constructor Create(AOwner: TComponent); override; + procedure ExecuteTarget(Target: TObject); override; + published + property BoldPersistenceHandleDB; + property GenerateGenericScript: boolean read fGenerateGenericScript write fGenerateGenericScript; end; implementation @@ -33,45 +99,154 @@ implementation BoldDefs, SysUtils, BoldActionDefs, - BoldUtils, - PersistenceConsts; + BoldDbEvolutor, + BoldDbEvolutorForm, + BoldUtils; + +const + breFreeHandle = 44; + breValueIdentityChanged = 45; + +{ TBoldPersistenceHandleAction } + +procedure TBoldPersistenceHandleAction._HandleSubscriberReceive( + Originator: TObject; OriginalEvent: TBoldEvent; + RequestedEvent: TBoldRequestedEvent); +begin + Assert(Originator = fBoldPersistenceHandleDB); + Assert(RequestedEvent in [breFreeHandle]); + case RequestedEvent of + breFreeHandle: fBoldPersistenceHandleDB := nil; + end; +end; + +constructor TBoldPersistenceHandleAction.Create(AOwner: TComponent); +begin + inherited; + fHandleSubscriber := TBoldPassthroughSubscriber.Create(_HandleSubscriberReceive); +end; + +destructor TBoldPersistenceHandleAction.Destroy; +begin + inherited; + FreeAndNil(fHandleSubscriber); +end; + +function TBoldPersistenceHandleAction.HandlesTarget(Target: TObject): Boolean; +begin + Result := True; +end; + +procedure TBoldPersistenceHandleAction.SetBoldPersistenceHandle( + const Value: TBoldPersistenceHandleDB); +begin + if (fBoldPersistenceHandleDB <> Value) then + begin + fHandleSubscriber.CancelAllSubscriptions; + fBoldPersistenceHandleDB := Value; + if Assigned(fBoldPersistenceHandleDB) then + fBoldPersistenceHandleDB.AddSmallSubscription(fHandleSubscriber, [beDestroying], breFreeHandle); + end; +end; + +procedure TBoldPersistenceHandleAction.UpdateTarget(Target: TObject); +var + EnableAction: boolean; +begin + inherited; + EnableAction := True; + CheckAllowEnable(EnableAction); + Enabled := EnableAction; +end; +procedure TBoldPersistenceHandleAction.CheckAllowEnable(var EnableAction: boolean); +begin + EnableAction := Assigned(fBoldPersistenceHandleDB); +end; { TBoldGenerateSchemaAction } +procedure TBoldGenerateSchemaAction.CheckAllowEnable(var EnableAction: boolean); +begin + inherited; + EnableAction := EnableAction and + Assigned(BoldPersistenceHandleDB.DatabaseAdapter) + and not BoldPersistenceHandleDB.Active; +end; + constructor TBoldGenerateSchemaAction.Create(AOwner: TComponent); begin inherited; - Caption := sGenerateSchema; + Caption := 'Generate Schema'; end; procedure TBoldGenerateSchemaAction.ExecuteTarget(Target: TObject); begin inherited; - if HandlesTarget(nil) then - BoldPersistenceHandleDB.CreateDataBaseSchema(IgnoreUnknownTables); + BoldPersistenceHandleDB.CreateDataBaseSchema(IgnoreUnknownTables); +end; + + +{ TBoldValidateDBStructureAction } + +constructor TBoldValidateDBStructureAction.Create(AOwner: TComponent); +begin + inherited; + Caption := 'Validate DB Structure'; +end; + +destructor TBoldValidateDBStructureAction.Destroy; +begin + FreeAndNil(fValidator); + inherited; +end; + +procedure TBoldValidateDBStructureAction.ExecuteTarget(Target: TObject); +begin + inherited; + if not assigned(fValidator) then + fValidator := TBoldDbStructureValidator.Create(nil); + fValidator.PersistenceHandle := BoldPersistenceHandleDB; + fValidator.Execute; +end; + +{ TBoldValidateDBDataAction } + +constructor TBoldValidateDBDataAction.Create(AOwner: TComponent); +begin + inherited; + Caption := 'Validate DB Data'; + PauseBetweenQueries := 1; end; -function TBoldGenerateSchemaAction.HandlesTarget(Target: TObject): Boolean; +destructor TBoldValidateDBDataAction.Destroy; begin - Result := Assigned(BoldPersistenceHandleDB) and - Assigned(BoldPersistenceHandleDB.DatabaseAdapter) and - not BoldPersistenceHandleDB.Active; + FreeAndNil(fValidator); + inherited; end; -procedure TBoldGenerateSchemaAction.Notification(AComponent: TComponent; - Operation: TOperation); +procedure TBoldValidateDBDataAction.ExecuteTarget(Target: TObject); begin inherited; - if (AComponent = BoldPersistenceHandleDB) and (operation = opRemove) then - fBoldPersistenceHandleDB := nil; + if not assigned(fValidator) then + fValidator := TBoldDbDataValidator.Create(nil); + fValidator.PersistenceHandle := BoldPersistenceHandleDB; + fValidator.PauseBetweenQueries := PauseBetweenQueries; + fValidator.Execute; end; -procedure TBoldGenerateSchemaAction.SetBoldPersistenceHandleDB(const Value: TBoldPersistenceHandleDB); +{ TBoldEvolveDBAction } + +constructor TBoldEvolveDBAction.Create(AOwner: TComponent); begin - FBoldPersistenceHandleDB := Value; - if Assigned(fBoldPersistenceHandleDB) then - fBoldPersistenceHandleDB.FreeNotification(Self); + inherited; + Caption := 'Evolve DB'; +end; + +procedure TBoldEvolveDBAction.ExecuteTarget(Target: TObject); +begin + inherited; + TfrmBoldDbEvolutor.EvolveDB(BoldPersistenceHandleDB, GenerateGenericScript); end; end. diff --git a/Source/Persistence/DB/BoldDBInterfaces.pas b/Source/Persistence/DB/BoldDBInterfaces.pas index d575e291..cee54a9f 100644 --- a/Source/Persistence/DB/BoldDBInterfaces.pas +++ b/Source/Persistence/DB/BoldDBInterfaces.pas @@ -1,28 +1,55 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDBInterfaces; interface uses + {$IFNDEF BOLD_UNICODE} + StringBuilder, + {$ENDIF} Classes, Db, + SysUtils, BoldBase, BoldSQLDatabaseConfig, - BoldLogHandler; + WideStrings, + BoldLogHandler, + BoldDefs; +const + cInitialBatchBufferSize = 1024*64; // 64 kb type IBoldQuery = interface; IBoldDataBase = interface; IBoldTable = interface; IBoldField = interface; IBoldParameter = interface; + IBoldParameterized = interface; TBoldDataSetWrapper = class; TBoldDatabaseWrapper = class; TBoldFieldWrapper = class; + TBoldAbstractQueryWrapper = class; TBoldFieldWrapperClass = class of TBoldFieldWrapper; TBoldGetDatabaseEvent = function: IBoldDatabase of object; + {$IFDEF BOLD_UNICODE} + TBoldBlobData = AnsiString; + {$ELSE} + TBoldBlobData = TBlobData; + {$ENDIF} + + TBoldIndexDescription = record + IndexName: String; + IndexedColumns: String; // separated by ; + IsPrimary: Boolean; + IsUnique: Boolean; + end; + + TBoldIndexDescriptionArray = array of TBoldIndexDescription; IBoldField = interface ['{F4126F4C-F1B2-472B-B53F-2ECEC8EE9253}'] @@ -31,7 +58,11 @@ TBoldFieldWrapperClass = class of TBoldFieldWrapper; function GetAsVariant: Variant; procedure SetAsVariant(const Value: Variant); function GetAsString: String; - procedure SetAsString(const Value: String); + procedure SetAsString(const Value: string); + function GetAsAnsiString: TBoldAnsiString; + procedure SetAsAnsiString(const Value: TBoldAnsiString); + function GetAsWideString: TBoldUnicodeString; + procedure SetAsWideString(const Value: TBoldUnicodeString); function GetAsInteger: Integer; procedure SetAsInteger(const Value: Integer); function GetAsBoolean: Boolean; @@ -47,13 +78,17 @@ TBoldFieldWrapperClass = class of TBoldFieldWrapper; function GetAsTime: TDateTime; procedure SetAsTime(const Value: TDateTime); procedure SetAsDate(const Value: TDateTime); - procedure SetAsBlob(const Value: string); - function GetAsBlob: string; + procedure SetAsBlob(const Value: TBoldAnsiString); + function GetAsBlob: TBoldAnsiString; + function GetAsInt64: Int64; + procedure SetAsInt64(const Value: Int64); property Field: TField read GetField; property AsVariant: Variant read GetAsVariant write SetAsVariant; property Value: Variant read GetAsVariant write SetAsVariant; property AsString: String read GetAsString write SetAsString; + property AsAnsiString: TBoldAnsiString read GetAsAnsiString write SetAsAnsiString; + property AsWideString: TBoldUnicodeString read GetAsWideString write SetAsWideString; property AsInteger: Integer read GetAsInteger write SetAsInteger; property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean; property AsCurrency: Currency read GetAsCurrency write SetAsCurrency; @@ -61,11 +96,18 @@ TBoldFieldWrapperClass = class of TBoldFieldWrapper; property AsFloat: Double read GetAsFloat write SetAsFloat; property AsDate: TDateTime read GetAsDate write SetAsDate; property AsTime: TDateTime read GetAsTime write SetAsTime; - property AsBlob: String read GetAsBlob write SetAsBlob; + property AsBlob: TBoldAnsiString read GetAsBlob write SetAsBlob; + property AsInt64: Int64 read GetAsInt64 write SetAsInt64; property IsNull: Boolean read GetIsNull; property FieldName: String read GetFieldName; end; + IBoldDBParam = interface + ['{FB3D383D-2F7E-49DC-9834-40ABDCAA3445}'] + // some libraries use non TParam descendant implementations, for those that use TParam, this interface can be implemented + function GetParameter: TParam; + property Parameter: TParam read GetParameter; + end; IBoldParameter = interface ['{FFAD2670-423A-11D3-89F6-006008F62CFF}'] @@ -76,6 +118,7 @@ TBoldFieldWrapperClass = class of TBoldFieldWrapper; function GetDataType: TFieldType; procedure SetDataType(Value: TFieldType); function GetAsBCD: Currency; + function GetAsBlob: TBoldBlobData; function GetAsBoolean: Boolean; function GetAsDateTime: TDateTime; function GetAsCurrency: Currency; @@ -83,10 +126,12 @@ TBoldFieldWrapperClass = class of TBoldFieldWrapper; function GetAsInteger: Longint; function GetAsMemo: string; function GetAsString: string; -// function GetAsWideString: WideString; + function GetAsAnsiString: TBoldAnsiString; + function GetAsInt64: Int64; + function GetAsWideString: WideString; function GetIsNull: Boolean; procedure SetAsBCD(const Value: Currency); - procedure SetAsBlob(const Value: TBlobData); + procedure SetAsBlob(const Value: TBoldBlobData); procedure SetAsBoolean(Value: Boolean); procedure SetAsCurrency(const Value: Currency); procedure SetAsDate(const Value: TDateTime); @@ -95,29 +140,34 @@ TBoldFieldWrapperClass = class of TBoldFieldWrapper; procedure SetAsInteger(Value: Longint); procedure SetAsMemo(const Value: string); procedure SetAsString(const Value: string); -// procedure SetAsWideString(const Value: Widestring); + procedure SetAsAnsiString(const Value: TBoldAnsiString); + procedure SetAsWideString(const Value: Widestring); procedure SetAsSmallInt(Value: LongInt); procedure SetAsTime(const Value: TDateTime); procedure SetAsWord(Value: LongInt); + procedure SetAsInt64(const Value: Int64); procedure SetText(const Value: string); - procedure AssignFieldValue(source: IBoldField); - property asVariant: Variant read GetAsVariant write SetAsVariant; + procedure AssignFieldValue(const source: IBoldField); + procedure Assign(const source: IBoldParameter); + property AsVariant: Variant read GetAsVariant write SetAsVariant; property Name: String read GetName; property DataType: TFieldType read GetDataType write SetDataType; property AsBCD: Currency read GetAsBCD write SetAsBCD; -//marco property AsBlob: TBlobData read GetAsString write SetAsBlob; + property AsBlob: TBoldBlobData read GetAsBlob write SetAsBlob; property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean; property AsCurrency: Currency read GetAsCurrency write SetAsCurrency; property AsDate: TDateTime read GetAsDateTime write SetAsDate; property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime; property AsFloat: Double read GetAsFloat write SetAsFloat; property AsInteger: LongInt read GetAsInteger write SetAsInteger; + property AsInt64: Int64 read GetAsInt64 write SetAsInt64; property AsSmallInt: LongInt read GetAsInteger write SetAsSmallInt; property AsMemo: string read GetAsMemo write SetAsMemo; property AsString: string read GetAsString write SetAsString; + property AsAnsiString: TBoldAnsiString read GetAsAnsiString write SetAsAnsiString; property AsTime: TDateTime read GetAsDateTime write SetAsTime; property AsWord: LongInt read GetAsInteger write SetAsWord; -// property AsWideString: WideString read GetAsWideString write SetAsWideString; + property AsWideString: WideString read GetAsWideString write SetAsWideString; property IsNull: Boolean read GetIsNull; property Text: string read GetAsString write SetText; end; @@ -126,7 +176,8 @@ TBoldFieldWrapperClass = class of TBoldFieldWrapper; ['{D00CA0A0-41CE-11D3-89F5-006008F62CFF}'] procedure Append; procedure Close; - function FieldByName(const FieldName: string): IBoldField; + function FieldByUpperCaseName(const FieldName: string): IBoldField; + function FieldByName(const FieldName: string): IBoldField; function FindField(const FieldName: string): IBoldField; procedure First; function GetDataSet: TDataSet; @@ -156,7 +207,27 @@ TBoldFieldWrapperClass = class of TBoldFieldWrapper; property State: TDataSetState read GetState; end; - IBoldExecQuery = interface + IBoldParameterized = interface + ['{B9020CF8-0300-4476-9453-4A3760E13225}'] + function GetParamCheck: Boolean; + procedure SetParamCheck(value: Boolean); + procedure ClearParams; + procedure AssignParams(Params: TParams); + function ParamByName(const Value: string): IBoldParameter; + function FindParam(const Value: string): IBoldParameter; + function EnsureParamByName(const Value: string): IBoldParameter; + function GetParamCount: integer; + function GetParam(i:integer): IBoldParameter; + function CreateParam(FldType: TFieldType; const ParamName: string): IBoldParameter; overload; + function Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; overload; + function GetParams: TParams; + property Param[i: integer]: IBoldParameter read GetParam; + property ParamCount: integer read GetParamCount; + property ParamCheck: Boolean read GetParamCheck write SetParamCheck; + property Params: TParams read GetParams; + end; + + IBoldExecQuery = interface(IBoldParameterized) ['{219D1FF1-F509-42A3-96E9-D7F62C28C1EA}'] function GetSQLText: String; procedure StartSQLBatch; @@ -164,26 +235,19 @@ TBoldFieldWrapperClass = class of TBoldFieldWrapper; procedure FailSQLBatch; procedure ExecSQL; procedure AssignSQL(SQL: TStrings); - procedure AssignSQLText(SQL: String); - procedure ClearParams; - function ParamByName(const Value: string): IBoldParameter; + procedure AssignSQLText(const SQL: String); function GetRowsAffected: integer; function GetImplementor: TObject; + function GetUseReadTransactions: boolean; + procedure SetUseReadTransactions(value: boolean); + function GetSQLStrings: TStrings; + function GetBatchQueryParamCount: integer; property RowsAffected: integer read GetRowsAffected; property Implementor: TObject read GetImplementor; property SQLText: String read GetSQLText; - end; - - IBoldParameterized = interface - ['{B9020CF8-0300-4476-9453-4A3760E13225}'] - procedure ClearParams; - procedure AssignParams(Params: TParams); - function ParamByName(const Value: string): IBoldParameter; - function GetParamCount: integer; - function GetParams(i:integer): IBoldParameter; - function Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; - property Params[i: integer]: IBoldParameter read GetParams; - property ParamCount: integer read GetParamCount; + property SQLStrings: TStrings read GetSQLStrings; + property UseReadTransactions: boolean read GetUseReadTransactions write SetUseReadTransactions; + property BatchQueryParamCount: integer read GetBatchQueryParamCount; end; IBoldQuery = interface(IBoldDataSet) @@ -192,21 +256,27 @@ TBoldFieldWrapperClass = class of TBoldFieldWrapper; function GetRequestLiveQuery: Boolean; procedure SetRequestLiveQuery(NewValue: Boolean); function GetRecordCount: integer; - procedure AssignSQLText(SQL: String); + procedure AssignSQLText(const SQL: String); procedure AssignSQL(SQL: TStrings); procedure ClearParams; procedure AssignParams(Params: TParams); function ParamByName(const Value: string): IBoldParameter; + function FindParam(const Value: string): IBoldParameter; + function GetUseReadTransactions: boolean; + procedure SetUseReadTransactions(value: boolean); + function GetRecNo: integer; property RequestLiveQuery: Boolean read GetRequestLiveQuery write SetRequestLiveQuery; property RecordCount: integer read GetRecordCount; - property SQLText: String read GetSQLText; + property SQLText: String read GetSQLText write AssignSQLText; + property UseReadTransactions: boolean read GetUseReadTransactions write SetUseReadTransactions; + property RecNo: integer read GetRecNo; end; IBoldTable = interface(IBoldDataSet) ['{D6698E80-41CE-11D3-89F5-006008F62CFF}'] procedure AddIndex(const Name, Fields: string; Options: TIndexOptions; const DescFields: string = ''); function GetIndexDefs: TIndexDefs; - procedure SetTableName(NewName: String); + procedure SetTableName(const NewName: String); function GetTableName: String; procedure SetExclusive(NewValue: Boolean); function GetExclusive: Boolean; @@ -227,6 +297,7 @@ TBoldFieldWrapperClass = class of TBoldFieldWrapper; procedure RollBack; procedure Open; procedure Close; + procedure Reconnect; function GetInTransaction: Boolean; function GetIsSQLBased: Boolean; procedure AllTableNames(Pattern: String; SystemTables: Boolean; TableNameList: TStrings); @@ -250,51 +321,64 @@ TBoldFieldWrapperClass = class of TBoldFieldWrapper; function SupportsTableCreation: Boolean; procedure ReleaseCachedObjects; function TableExists(const TableName: String): Boolean; + function GetIndexDescriptions(const TableName: String): TBoldIndexDescriptionArray; function GetSQLDatabaseConfig: TBoldSQLDatabaseConfig; property SQLDatabaseConfig: TBoldSQLDatabaseConfig read GetSQLDatabaseConfig; + function GetIsExecutingQuery: Boolean; + property IsExecutingQuery: Boolean read GetIsExecutingQuery; + procedure CreateDatabase(DropExisting: boolean = true); + procedure DropDatabase; + function DatabaseExists: boolean; end; TBoldParameterWrapper = class(TBoldRefCountedObject) private - fDatasetWrapper: TBolddatasetWrapper; + fDatasetWrapper: TBoldAbstractQueryWrapper; protected - property DatasetWrapper: TBoldDatasetWrapper read fDatasetWrapper; + property DatasetWrapper: TBoldAbstractQueryWrapper read fDatasetWrapper; public - constructor create(DatasetWrapper: TBoldDatasetWrapper); + constructor Create(DatasetWrapper: TBoldAbstractQueryWrapper); end; TBoldDbParameter = class(TBoldParameterWrapper, IBoldParameter) private - fParameter: TParam; - function GetAsVariant: Variant; - procedure SetAsVariant(const NewValue: Variant); - function GetName: String; - procedure Clear; - function GetDataType: TFieldType; - procedure SetDataType(Value: TFieldType); - function GetAsBCD: Currency; - function GetAsBoolean: Boolean; - function GetAsCurrency: Currency; - function GetAsFloat: Double; - function GetAsInteger: Longint; - function GetAsMemo: string; + FParameter: TParam; + function GetAsVariant: Variant; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsVariant(const NewValue: Variant); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetName: String; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure Clear; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetDataType: TFieldType; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetDataType(Value: TFieldType); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetAsBCD: Currency; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetAsBlob: TBoldBlobData; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetAsBoolean: Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetAsCurrency: Currency; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetAsFloat: Double; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetAsInteger: Longint; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetAsMemo: string; {$IFDEF BOLD_INLINE}inline;{$ENDIF} function GetAsString: string; - function GetIsNull: Boolean; - procedure SetAsBCD(const Value: Currency); - procedure SetAsBlob(const Value: TBlobData); - procedure SetAsBoolean(Value: Boolean); - procedure SetAsCurrency(const Value: Currency); - procedure SetAsDate(const Value: TDateTime); - procedure SetAsFloat(const Value: Double); - procedure SetAsInteger(Value: Longint); - procedure SetAsMemo(const Value: string); + function GetAsAnsiString: TBoldAnsiString; + function GetAsWideString: WideString; + function GetAsInt64: Int64; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetIsNull: Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsBCD(const Value: Currency); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsBlob(const Value: TBoldBlobData); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsBoolean(Value: Boolean); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsCurrency(const Value: Currency); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsDate(const Value: TDateTime); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsFloat(const Value: Double); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsInteger(Value: Longint); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsMemo(const Value: string); {$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure SetAsString(const Value: string); - procedure SetAsSmallInt(Value: LongInt); - procedure SetAsTime(const Value: TDateTime); -// procedure SetAsWideString(const Value: Widestring); - procedure SetAsWord(Value: LongInt); - procedure SetText(const Value: string); - procedure AssignFieldValue(source: IBoldField); + procedure SetAsAnsiString(const Value: TBoldAnsiString); + procedure SetAsWideString(const Value: Widestring); + procedure SetAsSmallInt(Value: LongInt); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsTime(const Value: TDateTime); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsInt64(const Value: Int64); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsWord(Value: LongInt); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetText(const Value: string); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure AssignFieldValue(const source: IBoldField); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure Assign(const source: IBoldParameter); {$IFDEF BOLD_INLINE}inline;{$ENDIF} function GetParameter: TParam; protected property Parameter: TParam read GetParameter; @@ -305,55 +389,128 @@ TBoldDbParameter = class(TBoldParameterWrapper, IBoldParameter) destructor Destroy; override; end; - TBoldDataSetWrapper = class(TBoldNonRefCountedObject) + TBoldAbstractQueryWrapper = class(TBoldNonRefCountedObject) private - fLastKnowFieldIndex: integer; fDatabaseWrapper: TBoldDatabaseWrapper; + protected + function GetImplementor: TObject; + public + constructor Create(DatabaseWrapper: TBoldDatabaseWrapper); virtual; + procedure Clear; virtual; + property DatabaseWrapper: TBoldDatabaseWrapper read fDatabaseWrapper; + end; + + TBoldDataSetWrapper = class(TBoldAbstractQueryWrapper) + private + fLastUsedFieldIndex: integer; + // Names in uppercase. May differ from what is + // in the dataset. + fFieldNames: array of string; + fNamesInited: Boolean; + fWrapper1: TBoldFieldWrapper; + fWrapper1AsInterface: IBoldField; + fWrapper2: TBoldFieldWrapper; + fWrapper2AsInterface: IBoldField; + private function GetWrappedField(Field: TField): IBoldField; protected function GetFieldWrapperClass: TBoldFieldWrapperClass; virtual; function GetDataSet: TDataSet; virtual; abstract; - function GetEof: Boolean; + function GetEof: Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} function GetFields(Index: integer): IBoldField; - function GetFieldCount: integer; - function GetFieldValue(const FieldName: string): Variant; - procedure SetFieldValue(const FieldName: string; const Value: Variant); - function GetFieldDefs: TFieldDefs; - procedure Append; - function Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; + function GetFieldCount: integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetFieldValue(const FieldName: string): Variant; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetFieldValue(const FieldName: string; const Value: Variant); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetFieldDefs: TFieldDefs; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure Append; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function ParamByName(const Value: string): IBoldParameter; virtual; abstract; + function FindParam(const Value: string): IBoldParameter; virtual; abstract; + function Createparam(FldType: TFieldType; const ParamName: string): IBoldParameter; overload; virtual; + function Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; overload; virtual; + function EnsureParamByName(const Value: string): IBoldParameter; virtual; procedure Close; virtual; - function FieldByName(const FieldName: string): IBoldField; + function FieldByName(const FieldName: string): IBoldField; virtual; + function FieldByUpperCaseName(const FieldNameUpper: string): IBoldField; function FindField(const FieldName: string): IBoldField; - procedure First; - procedure Delete; - procedure Next; + procedure First; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure Delete; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure Next; {$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure Open; virtual; procedure Edit; function MoveBy(Distance: integer): integer; function Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; procedure Post; - function GetImplementor: TObject; function GetState: TDataSetState; + function GetRecNo: integer; virtual; + procedure Reconnect; public - constructor Create(DatabaseWrapper: TBoldDatabaseWrapper); - property DatabaseWrapper: TBoldDatabaseWrapper read fDatabaseWrapper; property DataSet: TDataSet read GetDataSet; end; - TBoldDatabaseWrapper = class(TBoldNonRefCountedObject) + TBoldBatchDataSetWrapper = class(TBoldDataSetWrapper) private + fBatchQuery: IBoldExecQuery; + FInBatch: Boolean; + fAccumulatedSQLLength: integer; + fParamsInBeginUpdate: Boolean; + SB: TStringBuilder; + function GetAccumulatedSQL: TStrings; + function GetHasCachedStatements: boolean; + procedure ReplaceParamMarkers(sql: TStrings; const Source, Dest: IBoldExecQuery); + procedure SetInBatch(const Value: Boolean); + protected + procedure StartSQLBatch; virtual; + procedure EndSQLBatch; virtual; + procedure FailSQLBatch; virtual; + procedure ExecSQL; virtual; abstract; + function GetParams: TParams; virtual; abstract; + function GetSqlText: string; virtual; abstract; + procedure AssignSQLText(const SQL: string); virtual; abstract; + function GetSQLStrings: TStrings; virtual; abstract; + function GetSqlLength: integer; + function ParamsContainBlob: Boolean; + function GetBatchQueryParamCount: integer; + procedure BatchExecSQL; + procedure ExecuteBatch; + property AccumulatedSQL: TStrings read GetAccumulatedSQL; + property InBatch: Boolean read FInBatch write SetInBatch; + property HasCachedStatements: boolean read GetHasCachedStatements; + property BatchQuery: IBoldExecQuery read fBatchQuery; + public + constructor Create(DatabaseWrapper: TBoldDatabaseWrapper); override; + destructor Destroy; override; + property SqlText: string read GetSqlText write AssignSQLText; + property SQLStrings: TStrings read GetSQLStrings; + property Params: TParams read GetParams; + end; + + TBoldDatabaseWrapper = class(TBoldNonRefCountedObject) + strict private fSQLDataBaseConfig: TBoldSQLDatabaseConfig; + fAllTableNames: TStringList; + function GetWindowsLoginName: string; + function GetIndexDescriptionsViaTable( const TableName: String): TBoldIndexDescriptionArray; + function GetIndexDescriptionsViaQuery( const TableName: String): TBoldIndexDescriptionArray; protected function SupportsDefaultColumnValues: Boolean; virtual; procedure AllTableNames(Pattern: String; SystemTables: Boolean; TableNameList: TStrings); virtual; abstract; + function GetIndexDescriptions(const TableName: String): TBoldIndexDescriptionArray; virtual; + function GetTable: IBoldTable; virtual; abstract; + procedure ReleaseTable(var Table: IBoldTable); virtual; abstract; function TableExists(const TableName: String): Boolean; function GetQuery: IBoldQuery; virtual; abstract; procedure ReleaseQuery(var Query: IBoldQuery); virtual; abstract; function GetExecQuery: IBoldExecQuery; virtual; procedure ReleaseExecQuery(var Query: IBoldExecQuery); virtual; - function GetSQLDatabaseConfig: TBoldSQLDatabaseConfig; + function GetSQLDatabaseConfig: TBoldSQLDatabaseConfig; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function InternalGetDatabaseError(const aErrorType: TBoldDatabaseErrorType; + const E: Exception; sSQL, sServer, sDatabase, sUserName: string; + bUseWindowsAuth: Boolean): EBoldDatabaseError; public constructor Create(SQLDataBaseConfig: TBoldSQLDatabaseConfig); destructor Destroy; override; + procedure CreateDatabase(DropExisting: boolean = true); virtual; abstract; + procedure DropDatabase; virtual; abstract; + function DatabaseExists: boolean; virtual; abstract; property SQLDatabaseConfig: TBoldSQLDatabaseConfig read GetSQLDatabaseConfig; end; @@ -362,52 +519,66 @@ TBoldFieldWrapper = class(TBoldRefcountedObject, IBoldField) fSavedValue: Variant; fField: TField; fDatasetWrapper: TBoldDataSetWrapper; - function GetField: TField; - function GetAsVariant: Variant; + function GetField: TField; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetAsVariant: Variant; {$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure SetAsVariant(const Value: Variant); procedure SetAsString(const Value: String); - function GetAsInteger: Integer; - procedure SetAsInteger(const Value: Integer); - function GetAsBoolean: Boolean; - function GetAsCurrency: Currency; - function GetAsDateTime: TDateTime; - function GetAsFloat: Double; - function GetIsNull: Boolean; - procedure SetAsBoolean(const Value: Boolean); - procedure SetAsCurrency(const Value: Currency); - procedure SetAsDateTime(const Value: TDateTime); - procedure SetAsFloat(const Value: Double); - function GetFieldName: String; - function GetAsDate: TDateTime; - function GetAsTime: TDateTime; - procedure SetAsTime(const Value: TDateTime); - procedure SetAsDate(const Value: TDateTime); - procedure SetAsBlob(const Value: string); - function GetAsBlob: string; + function GetAsAnsiString: TBoldAnsiString; + procedure SetAsAnsiString(const Value: TBoldAnsiString); + function GetAsWideString: TBoldUnicodeString; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsWideString(const Value: TBoldUnicodeString); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetAsInteger: Integer; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsInteger(const Value: Integer); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetAsBoolean: Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetAsCurrency: Currency; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetAsDateTime: TDateTime; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetAsFloat: Double; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetIsNull: Boolean; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsBoolean(const Value: Boolean); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsCurrency(const Value: Currency); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsDateTime(const Value: TDateTime); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsFloat(const Value: Double); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetFieldName: String; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetAsDate: TDateTime; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetAsTime: TDateTime; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsTime(const Value: TDateTime); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsDate(const Value: TDateTime); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsBlob(const Value: TBoldAnsiString); {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetAsBlob: TBoldAnsiString; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetAsInt64: Int64; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + procedure SetAsInt64(const Value: Int64); {$IFDEF BOLD_INLINE}inline;{$ENDIF} protected function GetAsString: String; virtual; property DataSetWrapper: TBoldDatasetWrapper read fDatasetWrapper; public - constructor create(Field: TField; DatasetWrapper: TBoldDatasetWrapper); + constructor Create(Field: TField; DatasetWrapper: TBoldDatasetWrapper); + procedure ReTarget(Field: TField); {$IFDEF BOLD_INLINE} inline; {$ENDIF} property Field: TField read GetField; property FieldName: String read GetFieldName; end; procedure BoldLogSQL(const sql: TStrings); +procedure BoldLogSQLWide(const sql: TWideStrings; const Params: IBoldParameterized); +procedure BoldLogSQLWithParams(const sql: TStrings; const Params: IBoldParameterized); +function BoldQueryAsString(const sql: TStrings; const Params: IBoldParameterized): string; +procedure kiCLogSQL(const s: String); +procedure kiCLogSQLException(const s: String); var BoldSQLLogHandler: TBoldLogHandler = nil; BoldSQLLogCount: integer = 0; + BoldSQLMessage: string = ''; + kiCSQLLogHandler: TBoldLogHandler = nil; + kiCSQLExceptionLogHandler: TBoldLogHandler = nil; implementation uses - Bolddefs, - BoldSharedStrings, Variants, - SysUtils, + Windows, + BoldSharedStrings, BoldUtils, - BoldPMConsts; + BoldIsoDateTime; procedure BoldLogSQL(const sql: TStrings); var @@ -416,21 +587,118 @@ procedure BoldLogSQL(const sql: TStrings); Inc(BoldSQLLogCount); if assigned(BoldSQLLogHandler) then begin + if BoldSQLMessage <> '' then + BoldSQLLogHandler.Log(BoldSQLMessage); + BoldSQLLogHandler.Log( + AsIsoDateTimeMs(now) +':'+ + format('SQL %3d- %s', [BoldSQLLogCount, trim(SQL[0])])); + for i := 1 to SQL.Count - 1 do + begin + if trim(SQL[i]) <> '' then + BoldSQLLogHandler.Log(' ' + + Trim(SQL[i])); + end; + end; +end; + +procedure BoldLogSQLWide(const sql: TWideStrings; const Params: IBoldParameterized); +var + i: integer; +begin + Inc(BoldSQLLogCount); + if assigned(BoldSQLLogHandler) then + begin + if BoldSQLMessage <> '' then + BoldSQLLogHandler.Log(BoldSQLMessage); + BoldSQLLogHandler.Log( + AsIsoDateTimeMs(now) +':'+ + format('SQL %3d- %s', [BoldSQLLogCount, trim(SQL[0])])); + for i := 1 to SQL.Count - 1 do + begin + if trim(SQL[i]) <> '' then + BoldSQLLogHandler.Log(' ' + + Trim(SQL[i])); + end; + if Params <> nil then + for I := 0 to Params.ParamCount - 1 do + begin + BoldSQLLogHandler.Log( + ' ' + + Format(' [%s]:%s', [Params.Param[i].Name, Params.Param[i].AsString]) + ); + end; + end; +end; + +function BoldQueryAsString(const sql: TStrings; const Params: IBoldParameterized): string; +var + i: integer; +begin + result := ''; + for i := 0 to SQL.Count - 1 do + begin + if trim(SQL[i]) <> '' then + result := result + Trim(SQL[i]); + end; + if Params <> nil then + for I := 0 to Params.ParamCount - 1 do + begin + result := result + Format(' [%s]:%s', [Params.Param[i].Name, Params.Param[i].AsString]); + end; +end; + +procedure BoldLogSQLWithParams(const sql: TStrings; const Params: IBoldParameterized); +var + i: integer; +begin + Inc(BoldSQLLogCount); + if assigned(BoldSQLLogHandler) then + begin + if BoldSQLMessage <> '' then + BoldSQLLogHandler.Log(BoldSQLMessage); BoldSQLLogHandler.Log( - formatDateTime('c: ', now) + // do not localize - format('SQL %3d- %s', [BoldSQLLogCount, trim(SQL[0])])); // do not localize + AsIsoDateTimeMs(now) +':'+ + format('SQL %3d- %s', [BoldSQLLogCount, trim(SQL[0])])); for i := 1 to SQL.Count - 1 do begin if trim(SQL[i]) <> '' then BoldSQLLogHandler.Log(' ' + Trim(SQL[i])); end; + if Params <> nil then + for I := 0 to Params.ParamCount - 1 do + begin + BoldSQLLogHandler.Log( + ' ' + + Format(' [%s]:%s', [Params.Param[i].Name, Params.Param[i].AsString]) + ); + end; + end; +end; + +procedure kiCLogSQL(const s: String); +begin + if assigned(kiCSQLLogHandler) then begin + kiCSQLLogHandler.Log(s); + end; +end; + +procedure kiCLogSQLException(const s: String); +begin + if assigned(kiCSQLExceptionLogHandler) then + begin + kiCSQLExceptionLogHandler.Log(s); end; end; { TBoldDbParameter } -procedure TBoldDbParameter.AssignFieldValue(source: IBoldField); +procedure TBoldDbParameter.Assign(const source: IBoldParameter); +begin + Parameter.Value := Source.AsVariant; +end; + +procedure TBoldDbParameter.AssignFieldValue(const source: IBoldField); begin Parameter.AssignFieldValue(Source.Field, Source.AsVariant); end; @@ -440,13 +708,13 @@ procedure TBoldDbParameter.Clear; Parameter.Clear; end; -constructor TBoldDbParameter.create(DbParameter: TParam; DatasetWrapper: TBoldDatasetWrapper); +constructor TBoldDbParameter.Create(DbParameter: TParam; DatasetWrapper: TBoldDatasetWrapper); begin inherited Create(DatasetWrapper); fParameter := DbParameter; end; -destructor TBoldDbParameter.destroy; +destructor TBoldDbParameter.Destroy; begin inherited; end; @@ -456,6 +724,11 @@ function TBoldDbParameter.GetAsBCD: Currency; result := Parameter.AsBCD; end; +function TBoldDbParameter.GetAsBlob: TBoldBlobData; +begin + result := TBoldBlobData(Parameter.AsBlob); +end; + function TBoldDbParameter.GetAsBoolean: Boolean; begin result := Parameter.AsBoolean @@ -481,6 +754,15 @@ function TBoldDbParameter.GetAsInteger: Longint; result := Parameter.AsInteger end; +function TBoldDBParameter.GetAsInt64: Int64; +begin +{$IFDEF BOLD_DELPHI15_OR_LATER} + result := parameter.AsLargeInt; +{$ELSE} + result := parameter.AsInteger; +{$ENDIF} +end; + function TBoldDbParameter.GetAsMemo: string; begin result := Parameter.AsMemo; @@ -493,6 +775,24 @@ function TBoldDbParameter.GetAsString: string; result := ''; end; +function TBoldDbParameter.GetAsAnsiString: TBoldAnsiString; +begin + {$IFDEF BOLD_UNICODE} + result := Parameter.AsAnsiString; + {$ELSE} + result := Parameter.AsString; + {$ENDIF} + if string(result) = DatasetWrapper.DatabaseWrapper.SQLDatabaseConfig.EmptyStringMarker then + result := ''; +end; + +function TBoldDbParameter.GetAsWideString: WideString; +begin + result := Parameter.AsWideString; + if string(result) = DatasetWrapper.DatabaseWrapper.SQLDatabaseConfig.EmptyStringMarker then + result := ''; +end; + function TBoldDbParameter.GetAsVariant: Variant; begin result := Parameter.Value; @@ -523,9 +823,9 @@ procedure TBoldDbParameter.SetAsBCD(const Value: Currency); Parameter.AsBCD := Value; end; -procedure TBoldDbParameter.SetAsBlob(const Value: TBlobData); +procedure TBoldDbParameter.SetAsBlob(const Value: TBoldBlobData); begin - Parameter.AsBlob := Value; + Parameter.AsBlob := TBlobData(Value); end; procedure TBoldDbParameter.SetAsBoolean(Value: Boolean); @@ -558,6 +858,16 @@ procedure TBoldDbParameter.SetAsInteger(Value: Integer); Parameter.AsInteger := Value; end; +procedure TBoldDBParameter.SetAsInt64(const Value: Int64); +begin +{$IFDEF BOLD_DELPHI15_OR_LATER} + Parameter.AsLargeInt := Value; +{$ELSE} + Parameter.AsInteger:= Value; +{$ENDIF} +end; + + procedure TBoldDbParameter.SetAsMemo(const Value: string); begin Parameter.AsMemo := Value; @@ -576,6 +886,26 @@ procedure TBoldDbParameter.SetAsString(const Value: string); Parameter.Value := Value end; +procedure TBoldDbParameter.SetAsAnsiString(const Value: TBoldAnsiString); +begin + if value = '' then + Parameter.Value := DatasetWrapper.DatabaseWrapper.SQLDatabaseConfig.EmptyStringMarker + else + {$IFDEF BOLD_UNICODE} + Parameter.AsAnsiString := Value + {$ELSE} + Parameter.AsString := Value + {$ENDIF} +end; + +procedure TBoldDbParameter.SetAsWideString(const Value: Widestring); +begin + if value = '' then + Parameter.Value := DatasetWrapper.DatabaseWrapper.SQLDatabaseConfig.EmptyStringMarker + else + Parameter.AsWideString := Value +end; + procedure TBoldDbParameter.SetAsTime(const Value: TDateTime); begin Parameter.AsTime := Value; @@ -586,11 +916,6 @@ procedure TBoldDbParameter.SetAsVariant(const NewValue: Variant); Parameter.Value := NewValue; end; -//procedure TBoldDbParameter.SetAsWideString(const Value: Widestring); -//begin -// Parameter.AsWi TParam -//end; - procedure TBoldDbParameter.SetAsWord(Value: Integer); begin Parameter.AsWord := Value; @@ -615,18 +940,20 @@ procedure TBoldDataSetWrapper.Append; procedure TBoldDataSetWrapper.Close; begin - DataSet.Close; + if Assigned(DataSet) then // some subclasses perform tricks here + DataSet.Close; end; -constructor TBoldDataSetWrapper.Create(DatabaseWrapper: TBoldDatabaseWrapper); +function TBoldDataSetWrapper.Createparam(FldType: TFieldType; + const ParamName: string; ParamType: TParamType; + Size: integer): IBoldParameter; begin - inherited Create; - fDatabaseWrapper := DatabaseWrapper; + raise EBold.CreateFmt('%s.Createparam: Not supported yet... override in this subclass needed', [classname]); end; -function TBoldDataSetWrapper.Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; +function TBoldDataSetWrapper.Createparam(FldType: TFieldType; const ParamName: string): IBoldParameter; begin - raise EBold.CreateFmt(sCreateParamNotImplemented, [classname]); + result := Createparam(FldType, Paramname, ptUnknown, 0); end; procedure TBoldDataSetWrapper.Delete; @@ -639,40 +966,86 @@ procedure TBoldDataSetWrapper.Edit; DataSet.Edit; end; +function TBoldDataSetWrapper.EnsureParamByName( + const Value: string): IBoldParameter; +begin + result := FindParam(Value); + if not Assigned(result) then + result := CreateParam(db.ftUnknown, Value); +end; + function TBoldDataSetWrapper.FieldByName(const FieldName: string): IBoldField; -var - Wrapper: TBoldFieldWrapper; begin - Dataset.FieldList.Update; - if (fLastKnowFieldIndex + 1 >= 0) and - (fLastKnowFieldIndex + 1 <= DataSet.FieldCount - 1) and - (DataSet.FieldList.strings[fLastKnowFieldIndex + 1] = FieldName) then + Result := FieldByUpperCaseName(AnsiUpperCase(FieldName)); +end; + +function TBoldDataSetWrapper.FieldByUpperCaseName(const FieldNameUpper: string): IBoldField; +var + DataSetFieldList :TFieldList; + + procedure FoundIndex(Index: Integer); begin - inc(fLastKnowFieldIndex); - end - else - if (fLastKnowFieldIndex < 0) or - (fLastKnowFieldIndex > DataSet.FieldCount - 1) or - (DataSet.FieldList.Strings[fLastKnowFieldIndex] <> FieldName) then - begin - fLastKnowFieldIndex := DataSet.FieldList.FieldByName(FieldName).FieldNo - 1; - end; + fLastUsedFieldIndex := Index; + fFieldNames[Index] := FieldNameUpper; + end; + + function TryIndex(Index: Integer): Boolean; + begin + Result := + (Index >= 0) and + (Index < Length(fFieldNames)) and + (FieldNameUpper = fFieldNames[Index]); + if Result then + FoundIndex(Index); + end; + + function SearchIndex: Boolean; + var + I: Integer; + begin + result := false; + for I := 0 to DataSet.FieldCount - 1 do + if FieldNameUpper = fFieldNames[I] then + begin + FoundIndex(I); + Result := true; + break; + end; + end; - Wrapper := GetFieldWrapperClass.Create(DataSet.FieldList.Fields[fLastKnowFieldIndex], self); - Wrapper.GetInterface(IBoldField, result); + procedure InitNames; + var + F: integer; + begin + DataSetFieldList.Update; + SetLength(fFieldNames, DataSet.FieldCount); + for F := 0 to DataSet.FieldCount - 1 do + fFieldNames[F] := AnsiUpperCase(DataSetFieldList.Fields[F].FieldName); + fNamesInited := true; + end; + +begin + DataSetFieldList := DataSet.FieldList; + if not fNamesInited then + InitNames; + if not TryIndex(fLastUsedFieldIndex+1) then + if not TryIndex(fLastUsedFieldIndex-1) then + if not TryIndex(fLastUsedFieldIndex) then + if not SearchIndex then + fLastUsedFieldIndex := -1; + if fLastUsedFieldIndex = -1 then + Result := nil + else + Result := GetWrappedField(DataSetFieldList.Fields[fLastUsedFieldIndex]); end; function TBoldDataSetWrapper.FindField(const FieldName: string): IBoldField; var - Wrapper: TBoldFieldWrapper; Field: TField; begin Field := DataSet.FindField(FieldName); if assigned(field) then - begin - Wrapper := GetFieldWrapperClass.Create(Field, self); - Wrapper.GetInterface(IBoldField, result); - end + Result := GetWrappedField(Field) else result := nil; end; @@ -698,11 +1071,8 @@ function TBoldDataSetWrapper.GetFieldDefs: TFieldDefs; end; function TBoldDataSetWrapper.GetFields(Index: integer): IBoldField; -var - Wrapper: TBoldFieldWrapper; begin - Wrapper := GetFieldWrapperClass.Create(DataSet.Fields[Index], self); - Wrapper.GetInterface(IBoldField, Result); + Result := GetWrappedField(DataSet.Fields[Index]); end; function TBoldDataSetWrapper.GetFieldValue(const FieldName: string): Variant; @@ -715,9 +1085,9 @@ function TBoldDataSetWrapper.GetFieldWrapperClass: TBoldFieldWrapperClass; result := TBoldFieldWrapper; end; -function TBoldDataSetWrapper.GetImplementor: TObject; +function TBoldDataSetWrapper.GetRecNo: integer; begin - result := self; + result := Dataset.RecNo; end; function TBoldDataSetWrapper.GetState: TDataSetState; @@ -725,6 +1095,33 @@ function TBoldDataSetWrapper.GetState: TDataSetState; result := DataSet.State; end; +function TBoldDataSetWrapper.GetWrappedField(Field: TField): IBoldField; +begin + // Reuse wrapper if we hold only reference + if Assigned(fWrapper1) and (fWrapper1.RefCount =1) then + begin + fWrapper1.Retarget(Field); + Result := fWrapper1AsInterface; + end + else if Assigned(fWrapper2) and (fWrapper2.RefCount =1) then + begin + fWrapper2.Retarget(Field); + Result := fWrapper2AsInterface; + end + else if not Assigned(fWrapper1) then + begin + fWrapper1 := GetFieldWrapperClass.Create(Field, self); + fWrapper1.GetInterface(IBoldField, fWrapper1AsInterface); + Result := fWrapper1AsInterface; + end + else + begin + fWrapper2 := GetFieldWrapperClass.Create(Field, self); + fWrapper2.GetInterface(IBoldField, fWrapper2AsInterface); + Result := fWrapper2AsInterface; + end; +end; + function TBoldDataSetWrapper.Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; begin @@ -744,7 +1141,8 @@ procedure TBoldDataSetWrapper.Next; procedure TBoldDataSetWrapper.Open; begin Dataset.Open; - fLastKnowFieldIndex := -1; + fLastUsedFieldIndex := -1; + fNamesInited := false; end; procedure TBoldDataSetWrapper.Post; @@ -752,6 +1150,13 @@ procedure TBoldDataSetWrapper.Post; DataSet.Post; end; +procedure TBoldDataSetWrapper.Reconnect; +begin + if DatabaseWrapper.SupportsInterface(IBoldDataBase) then begin + (DatabaseWrapper as IBoldDataBase).Reconnect; + end; +end; + procedure TBoldDataSetWrapper.SetFieldValue(const FieldName: string; const Value: Variant); begin @@ -760,22 +1165,26 @@ procedure TBoldDataSetWrapper.SetFieldValue(const FieldName: string; { TBoldFieldWrapper } -procedure TBoldFieldWrapper.SetAsBlob(const Value: string); +procedure TBoldFieldWrapper.SetAsBlob(const Value: TBoldAnsiString); begin Field.AsVariant := Value; end; -constructor TBoldFieldWrapper.create(Field: TField; DatasetWrapper: TBoldDatasetWrapper); +constructor TBoldFieldWrapper.Create(Field: TField; DatasetWrapper: TBoldDatasetWrapper); begin inherited create; fField := Field; - fSavedValue := Field.Value; + fSavedValue := Field.Value; fDatasetWrapper := DatasetWrapper; end; -function TBoldFieldWrapper.GetAsBlob: string; +function TBoldFieldWrapper.GetAsBlob: TBoldAnsiString; begin - result := Field.AsVariant; + {$IFDEF BOLD_UNICODE} + Result := Field.AsAnsiString; + {$ELSE} + Result := Field.AsString; + {$ENDIF} end; function TBoldFieldWrapper.GetAsBoolean: Boolean; @@ -815,11 +1224,42 @@ function TBoldFieldWrapper.GetAsString: String; result := ''; end; +function TBoldFieldWrapper.GetAsAnsiString: TBoldAnsiString; +begin + {$IFDEF BOLD_UNICODE} + result := BoldSharedStringManager.GetSharedAnsiString(Field.AsAnsiString); + if String(result) = DatasetWrapper.DatabaseWrapper.SQLDatabaseConfig.EmptyStringMarker then + result := ''; + {$ELSE} + Result := GetAsString; + {$ENDIF} +end; + +function TBoldFieldWrapper.GetAsWideString: TBoldUnicodeString; +begin + {$IFDEF BOLD_UNICODE} + result := GetAsString; + {$ELSE} + result := Field.AsWideString; + if result = DatasetWrapper.DatabaseWrapper.SQLDatabaseConfig.EmptyStringMarker then + result := ''; + {$ENDIF} +end; + function TBoldFieldWrapper.GetAsTime: TDateTime; begin result := frac(Field.AsDateTime); end; +function TBoldFieldWrapper.GetAsInt64; +begin +{$IFDEF BOLD_DELPHI15_OR_LATER} + Result := fField.AsLargeInt; +{$ELSE} + Result := fField.AsInteger; +{$ENDIF} +end; + function TBoldFieldWrapper.GetAsVariant: Variant; begin result := fSavedValue; @@ -840,6 +1280,21 @@ function TBoldFieldWrapper.GetIsNull: Boolean; result := VarType(fSavedValue) = varNull; end; +procedure TBoldFieldWrapper.ReTarget(Field: TField); +begin + fField := Field; + fSavedValue := Field.Value; +end; + +procedure TBoldFieldWrapper.SetAsInt64(const Value: Int64); +begin +{$IFDEF BOLD_DELPHI15_OR_LATER} + Field.AsLargeInt := Value; +{$ELSE} + Field.AsInteger:= Value; +{$ENDIF} +end; + procedure TBoldFieldWrapper.SetAsBoolean(const Value: Boolean); begin Field.AsBoolean := Value; @@ -873,10 +1328,35 @@ procedure TBoldFieldWrapper.SetAsString(const Value: String); Field.AsString := Value; end; +procedure TBoldFieldWrapper.SetAsAnsiString(const Value: TBoldAnsiString); +begin + {$IFDEF BOLD_UNICODE} + if value = '' then + Field.AsAnsiString := TBoldAnsiString( + DataSetWrapper.DatabaseWrapper.SQLDatabaseConfig.EmptyStringMarker) + else + Field.AsAnsiString := Value; + {$ELSE} + SetAsString(Value); + {$ENDIF} +end; + +procedure TBoldFieldWrapper.SetAsWideString(const Value: TBoldUnicodeString); +begin + {$IFDEF BOLD_UNICODE} + SetAsString(Value); + {$ELSE} + if value = '' then + Field.AsWideString := TBoldUnicodeString(DataSetWrapper.DatabaseWrapper.SQLDatabaseConfig.EmptyStringMarker) + else + Field.AsWideString := Value; + {$ENDIF} +end; + procedure TBoldFieldWrapper.SetAsVariant(const Value: Variant); begin Field.AsVariant := value; - fSavedValue := Value; + fSavedValue := Value; end; procedure TBoldFieldWrapper.SetAsDate(const Value: TDateTime); @@ -891,17 +1371,16 @@ procedure TBoldFieldWrapper.SetAsTime(const Value: TDateTime); { TBoldDatabaseWrapper } -constructor TBoldDatabaseWrapper.create(SQLDatabaseConfig: TBoldSQLDatabaseConfig); +constructor TBoldDatabaseWrapper.Create(SQLDatabaseConfig: TBoldSQLDatabaseConfig); begin inherited Create; - fSQLDatabaseConfig := TBoldSQLDataBaseConfig.Create; - fSQlDatabaseConfig.AssignConfig(SQLDatabaseConfig); + fSQLDatabaseConfig := SQLDatabaseConfig; end; destructor TBoldDatabaseWrapper.destroy; begin - FreeAndNil(fSQLDatabaseConfig); - inherited; + FreeAndNil(fAllTableNames); + inherited; end; function TBoldDatabaseWrapper.GetExecQuery: IBoldExecQuery; @@ -918,11 +1397,177 @@ function TBoldDatabaseWrapper.GetExecQuery: IBoldExecQuery; end; end; +function TBoldDatabaseWrapper.GetIndexDescriptions( + const TableName: String): TBoldIndexDescriptionArray; +begin + if SQLDatabaseConfig.IndexInfoTemplate = '' then + Result := GetIndexDescriptionsViaTable(TableName) + else + Result := GetIndexDescriptionsViaQuery(TableName); +end; + +function TBoldDatabaseWrapper.GetIndexDescriptionsViaQuery( + const TableName: String): TBoldIndexDescriptionArray; +var + DbQuery: IBoldQuery; + CurrentIndex: integer; + LastIndexName: string; + SQL: string; + vIndexField: IBoldField; + vColumnField: IBoldField; + vIsPrimaryField: IBoldField; + vIsUniqueField: IBoldField; +const + cIndexName = 'indexName'; + cColumnName = 'columnName'; + cIsPrimary = 'isPrimary'; + cisUnique = 'isUnique'; + cFieldNotFoundMessage = 'Field %s not found in IndexInfoQuery result set.'; +begin + SetLength(result, 0); + DbQuery := GetQuery; + lastIndexName := ''; + try + SQL := SQLDatabaseConfig.GetIndexInfoQuery(TableName); + DbQuery.AssignSQLText(SQL); + DbQuery.Open; + Assert(Assigned(DbQuery.FindField(cIndexName)), Format(cFieldNotFoundMessage, [cIndexName])); + Assert(Assigned(DbQuery.FindField(cColumnName)), Format(cFieldNotFoundMessage, [cColumnName])); + Assert(Assigned(DbQuery.FindField(cIsPrimary)), Format(cFieldNotFoundMessage, [cIsPrimary])); + Assert(Assigned(DbQuery.FindField(cIsUnique)), Format(cFieldNotFoundMessage, [cIsUnique])); + vIndexField := DbQuery.FieldByName(cIndexName); + vColumnField := DbQuery.FieldByName(cColumnName); + vIsPrimaryField := DbQuery.FieldByName(cIsPrimary); + vIsUniqueField := DbQuery.FieldByName(cIsUnique); + CurrentIndex := -1; + // IndexName, IsPrimary, IsUnique, ColumnName + while not DbQuery.Eof do + begin + if vIndexField.AsString <> LastIndexName then // new Index + begin + INC(CurrentIndex); + SetLength(Result, CurrentIndex+1); + LastIndexName := vIndexField.AsString; + Result[CurrentIndex].IndexName := LastIndexName; + Result[CurrentIndex].IsPrimary := vIsPrimaryField.AsBoolean; + Result[CurrentIndex].IsUnique := vIsUniqueField.AsBoolean; + end; + if Result[CurrentIndex].IndexedColumns = '' then + Result[CurrentIndex].IndexedColumns := vColumnField.AsString + else + Result[CurrentIndex].IndexedColumns := Result[CurrentIndex].IndexedColumns + ';' + vColumnField.AsString; + DbQuery.Next; + end; + finally + DbQuery.Close; + releaseQuery(DbQuery); + end; +end; + +function TBoldDatabaseWrapper.GetIndexDescriptionsViaTable( + const TableName: String): TBoldIndexDescriptionArray; +var + DbTable: IBoldTable; + I: integer; + IndexDef: TIndexDef; +begin + SetLength(result, 0); + DbTable := GetTable; + try + DbTable.Tablename := TableName; + DbTable.Open; + SetLength(Result, DbTable.IndexDefs.Count); + for I := 0 to DbTable.IndexDefs.Count - 1 do + begin + IndexDef := DbTable.IndexDefs[i]; + result[i].IndexName := IndexDef.Name; + Result[i].IndexedColumns := IndexDef.Fields; + result[i].IsPrimary := ixPrimary in IndexDef.Options; + result[i].IsUnique := ixUnique in IndexDef.Options; + end; + finally + DbTable.Close; + releaseTable(DbTable); + end; + +end; + function TBoldDatabaseWrapper.GetSQLDatabaseConfig: TBoldSQLDatabaseConfig; begin result := fSQLDataBaseConfig; end; +function TBoldDatabaseWrapper.GetWindowsLoginName: string; +var + User: PChar; + Size: DWord; +begin + Result := ''; + Size := 256; + User := StrAlloc(Size); + try + try + if WNetGetUser(PChar(0), User, Size) = 0 then begin + Result := string(User); + end else begin + RaiseLastOSError; + end; + except + if GetUserName(User, Size) then begin + Result := string(User); + end else begin + RaiseLastOSError; + end; + end; + finally + StrDispose(User); + end; +end; + + +function TBoldDatabaseWrapper.InternalGetDatabaseError(const aErrorType: + TBoldDatabaseErrorType; const E: Exception; sSQL, sServer, sDatabase, + sUserName: string; bUseWindowsAuth: Boolean): EBoldDatabaseError; +var + sMsg, + sWindowsAuth: string; +begin + case aErrorType of + bdetConnection: begin + sMsg := Format(BOLD_DATABASE_ERROR_CONNECTION, [sServer]); + Result := EBoldDatabaseConnectionError.Create(sMsg); + end; + bdetSQL: begin + sMsg := Format(BOLD_DATABASE_ERROR_SQL, [sSQL, E.Message]); + Result := EBoldDatabaseSQLError.Create(sMsg); + end; + bdetUpdate: begin + Result := EBoldDatabaseSQLError.Create(BOLD_DATABASE_ERROR_UPDATE); + end; + bdetDeadlock: begin + sMsg := Format(BOLD_DATABASE_ERROR_DEADLOCK, [E.Message]); + Result := EBoldDatabaseDeadlockError.Create(sMsg); + end; + bdetLogin: begin + if bUseWindowsAuth then begin + sWindowsAuth := BOLD_DATABASE_ERROR_LOGIN_WINDOWS_AUTH; + sUserName := GetWindowsLoginName; + end else begin + sWindowsAuth := ''; + end; + sMsg := Format(BOLD_DATABASE_ERROR_LOGIN, [sUserName, sDatabase, sServer]); + Result := EBoldDatabaseLoginError.Create(sMsg); + end; +// bdetError: begin + else begin + sMsg := Format(BOLD_DATABASE_ERROR_UNKNOWN, [E.Message]); + Result := EBoldDatabaseError.Create(sMsg); + end; + end; + result.OriginalExceptionClass := E.ClassName; + result.OriginalExceptionMessage := E.Message; +end; + procedure TBoldDatabaseWrapper.ReleaseExecQuery(var Query: IBoldExecQuery); var Query2: IBoldQuery; @@ -940,29 +1585,321 @@ function TBoldDatabaseWrapper.SupportsDefaultColumnValues: Boolean; result := true; end; -function TBoldDatabaseWrapper.TableExists( - const TableName: String): Boolean; -var - TableNames: TStringList; - i: integer; +function TBoldDatabaseWrapper.TableExists(const TableName: String): Boolean; begin - TableNames := TStringList.Create; - result := false; - AllTableNames('*', true, TableNames); - for i := 0 to Tablenames.Count-1 do + if not Assigned(fAllTableNames) then begin - if SameText(TableNames[i], TableName) then - result := true; + fAllTableNames := TStringList.Create; + fAllTableNames.Sorted := true; + AllTableNames('*', true, fAllTableNames); end; - TableNames.Free; + result := fAllTableNames.IndexOf(TableName) <> -1; end; { TBoldParameterWrapper } -constructor TBoldParameterWrapper.create(DatasetWrapper: TBoldDatasetWrapper); +constructor TBoldParameterWrapper.Create(DatasetWrapper: TBoldAbstractQueryWrapper); begin inherited create; fDatasetWrapper := DatasetWrapper; end; +{ TBoldAbstractQueryWrapper } + +procedure TBoldAbstractQueryWrapper.Clear; +begin +// to be override +end; + +constructor TBoldAbstractQueryWrapper.Create( + DatabaseWrapper: TBoldDatabaseWrapper); +begin + inherited Create; + fDatabaseWrapper := DatabaseWrapper; +end; + +function TBoldAbstractQueryWrapper.GetImplementor: TObject; +begin + result := self; +end; + +{ TBoldBatchDataSetWrapper } + +function TBoldBatchDataSetWrapper.ParamsContainBlob: Boolean; +var + i: integer; +const + BlobFieldTypes = [{$IFDEF BOLD_DELPHI15_OR_LATER}db.ftStream,{$ENDIF} db.ftBlob, db.ftGraphic..db.ftTypedBinary, db.ftOraBlob, db.ftOraClob]; +begin + result := false; + for i := 0 to self.Params.Count-1 do + if (Params[i].DataType in BlobFieldTypes) then + begin + result := true; + exit; + end; +end; + +type TCollectionAccess = class(TCollection); + +procedure TBoldBatchDataSetWrapper.ReplaceParamMarkers(sql: TStrings; + const Source, Dest: IBoldExecQuery); +const + Literals = ['''', '"', '`']; +var + SourceParams, DestParams: TParams; + Name: String; + Prefix: String; + NewParamName: String; + CurPos, StartPos: integer; + PrevPos: integer; + i: integer; + ParamIndex, FirstParam: integer; + Line: String; + oldParam, NewParam: TParam; + Literal: Boolean; + + function NameDelimiter: Boolean; + begin + Result := CharInSet(line[CurPos], [' ', ',', ';', ')', #13, #10]); + end; + + function IsLiteral: Boolean; + begin + Result := CharInSet(line[CurPos], Literals); + end; + + function CurrentChar: Char; + begin + result := line[CurPos]; + end; + + procedure AddLine(const s: string); + begin + sb.Append(StringReplace(s, BOLDCRLF, ' ', [rfReplaceAll])); + end; + +begin + DestParams := Dest.Params; + if Source.ParamCount = 0 then + begin + for i := 0 to Sql.Count - 1 do + begin + Line := sql[i]; + AddLine(Line); + end; + end + else + begin + SourceParams := Source.Params; + if Dest.ParamCount = 0 then + begin + DestParams.Assign(SourceParams); + while TCollectionAccess(DestParams).UpdateCount > 0 do + DestParams.EndUpdate; + for i := 0 to Sql.Count - 1 do + begin + Line := sql[i]; + AddLine(Line); + end; + end + else + begin + FirstParam := Dest.ParamCount; + ParamIndex := Dest.ParamCount; + Dest.ParamCheck := false; + for i := 0 to Sql.Count - 1 do + begin + Line := Sql[i]; + if line = '' then + continue; + CurPos := 1; + PrevPos := CurPos; + Literal := False; + repeat + while CharInSet(CurrentChar, LeadBytes) do Inc(CurPos, 2); + if (CurrentChar = ':') and not Literal and (Line[CurPos+1] <> ':') then + begin + StartPos := CurPos; + while (CurrentChar <> #0) and (Literal or not NameDelimiter) do + begin + Inc(CurPos); + if Curpos > Length(Line) then + break; + while CharInSet(CurrentChar, LeadBytes) do Inc(CurPos, 2); + if IsLiteral then + begin + Literal := not Literal; + end; + end; + Name := copy(Line, StartPos+1, CurPos-(StartPos+1)); + OldParam := SourceParams[ParamIndex-FirstParam]; + Assert(OldParam.Name = Name); + Prefix := 'P'+IntToStr(ParamIndex); + NewParamName := prefix {+ Name}; + NewParam := DestParams.CreateParam(OldParam.DataType, NewParamName, ptUnknown); + NewParam.Assign(OldParam); + NewParam.Name := NewParamName; + AddLine(Copy(Line, PrevPos, StartPos-PrevPos+1)); + PrevPos := CurPos; + SB.Append(NewParamName); + inc(ParamIndex); + end + else + if IsLiteral then + Literal := not Literal; + Inc(CurPos); + until CurPos > Length(Line); + if PrevPos <= Length(Line) then + AddLine(Copy(Line, PrevPos, MaxInt)); + end; + end; + end; + SB.Append(DatabaseWrapper.SQLDatabaseConfig.BatchQuerySeparator); + Dest.AssignParams(DestParams); + Dest.SQLStrings.Add(sb.ToString); + Inc(fAccumulatedSQLLength, SB.Length + Length(Dest.SQLStrings.LineBreak)); + SB.Clear; +end; + +function TBoldBatchDataSetWrapper.GetHasCachedStatements: boolean; +begin + result := fAccumulatedSQLLength > 0; +end; + +function TBoldBatchDataSetWrapper.GetSqlLength: integer; +var + i: Integer; + LB: string; +begin + result := 0; + LB := SQLStrings.LineBreak; + for I := 0 to SQLStrings.Count - 1 do + Inc(result, Length(SQLStrings[I]) + Length(LB)); +end; + +function TBoldBatchDataSetWrapper.GetAccumulatedSQL: TStrings; +begin + result := BatchQuery.SQLStrings; +end; + +function TBoldBatchDataSetWrapper.GetBatchQueryParamCount: integer; +begin + result := 0; + if Assigned(BatchQuery) then + result := BatchQuery.ParamCount; +end; + +procedure TBoldBatchDataSetWrapper.SetInBatch(const Value: Boolean); +begin + if not DatabaseWrapper.SQLDatabaseConfig.UseBatchQueries then + exit; + if FInBatch <> Value then + begin + FInBatch := Value; + if Value then + begin + fBatchQuery := DatabaseWrapper.GetExecQuery; + fBatchQuery.SQLStrings.BeginUpdate; + fBatchQuery.Params.BeginUpdate; + fParamsInBeginUpdate := true; + if Supports(fBatchQuery, IBoldParameterized) then + (fBatchQuery as IBoldParameterized).ParamCheck := false; + end + else + begin + if fParamsInBeginUpdate then + begin + fBatchQuery.SQLStrings.EndUpdate; + fBatchQuery.Params.EndUpdate; + end; + DatabaseWrapper.ReleaseExecQuery(fBatchQuery); + end; + end; +end; + +procedure TBoldBatchDataSetWrapper.StartSQLBatch; +begin + InBatch := DatabaseWrapper.SQLDatabaseConfig.UseBatchQueries; +end; + +procedure TBoldBatchDataSetWrapper.BatchExecSQL; +var + SQLDatabaseConfig: TBoldSQLDatabaseConfig; +begin + if inBatch then + begin + SQLDatabaseConfig := DatabaseWrapper.SQLDatabaseConfig; + if ParamsContainBlob + or (fAccumulatedSQLLength + GetSqlLength + + Length(SQLDatabaseConfig.BatchQueryBegin) + Length(SQLDatabaseConfig.BatchQueryEnd) + >= SQLDatabaseConfig.MaxBatchQueryLength) + or (BatchQuery.ParamCount + ParamCount >= SQLDatabaseConfig.MaxBatchQueryParams) then + ExecuteBatch; + ReplaceParamMarkers(SQLStrings, self as IBoldExecQuery, BatchQuery); + end; +end; + +constructor TBoldBatchDataSetWrapper.Create( + DatabaseWrapper: TBoldDatabaseWrapper); +begin + inherited Create(DatabaseWrapper); + SB := TStringBuilder.Create(cInitialBatchBufferSize); +end; + +destructor TBoldBatchDataSetWrapper.Destroy; +begin + if Assigned(DatabaseWrapper) and Assigned(fBatchQuery) then + DatabaseWrapper.ReleaseExecQuery(fBatchQuery); + FreeAndNil(SB); + inherited; +end; + +procedure TBoldBatchDataSetWrapper.EndSQLBatch; +begin + if InBatch and HasCachedStatements then + ExecuteBatch; + InBatch := false; +end; + +procedure TBoldBatchDataSetWrapper.FailSQLBatch; +begin + if InBatch then + begin + AccumulatedSQL.Clear; + fAccumulatedSQLLength := 0; + end; +end; + +procedure TBoldBatchDataSetWrapper.ExecuteBatch; +begin + if HasCachedStatements then + begin + fInBatch := false; + try + if fParamsInBeginUpdate then + begin + if DatabaseWrapper.SQLDatabaseConfig.BatchQueryBegin <> '' then + fBatchQuery.SQLStrings.Insert(0, DatabaseWrapper.SQLDatabaseConfig.BatchQueryBegin); + if DatabaseWrapper.SQLDatabaseConfig.BatchQueryEnd <> '' then + fBatchQuery.SQLStrings.Append(DatabaseWrapper.SQLDatabaseConfig.BatchQueryEnd); + fBatchQuery.SQLStrings.EndUpdate; + fBatchQuery.Params.EndUpdate; + fParamsInBeginUpdate:=false; + fBatchQuery.ParamCheck := true; + end; + fBatchQuery.ExecSql; + finally + fInBatch := true; + AccumulatedSQL.Clear; + fAccumulatedSQLLength := 0; + fBatchQuery.SQLStrings.BeginUpdate; + fBatchQuery.Params.BeginUpdate; + fBatchQuery.Params.Clear; + fParamsInBeginUpdate:=true; + fBatchQuery.ParamCheck := false; + end; + end; +end; + end. diff --git a/Source/Persistence/DB/BoldPersistenceControllerDefault.pas b/Source/Persistence/DB/BoldPersistenceControllerDefault.pas index 9f43dd19..1ef634c4 100644 --- a/Source/Persistence/DB/BoldPersistenceControllerDefault.pas +++ b/Source/Persistence/DB/BoldPersistenceControllerDefault.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceControllerDefault; interface @@ -14,7 +17,9 @@ interface BoldPersistenceController, BoldSQLDatabaseConfig, BoldTypeNameDictionary, - BoldDefs; + BoldDefs, + BoldIndexCollection, + BoldElements; type { forward declarations } @@ -28,31 +33,34 @@ TBoldPersistenceControllerDefault = class(TBoldPersistenceController) fMoldModel: TMoldModel; fTypeNameDictionary: TBoldTypeNameDictionary; fSQLDataBaseConfig: TBoldSQLDataBaseConfig; + fCustomIndexes: TBoldIndexCollection; fOnGetDatabase: TBoldGetDatabaseEvent; - procedure EnsureActive(Action: String); + procedure EnsureActive(Action: String); function GetPersistenceMapper: TBoldSystemDefaultMapper; - procedure SQLDatabaseConfigChanged(Sender: TObject); public - constructor CreateFromMold(MoldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; SQLDataBaseConfig: TBoldSQLDataBaseConfig; GetDatabaseFunc: TBoldGetDatabaseEvent); + constructor CreateFromMold(MoldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; + CustomIndexes: TBoldIndexCollection; SQLDataBaseConfig: TBoldSQLDataBaseConfig; GetDatabaseFunc: TBoldGetDatabaseEvent); destructor Destroy; override; - procedure PMExactifyIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; + procedure PMExactifyIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; HandleNonExisting: Boolean); override; procedure PMFetch(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: integer; BoldClientID: TBoldClientID); override; procedure PMFetchIDListWithCondition(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; FetchMode: Integer; Condition: TBoldCondition; BoldClientID: TBoldClientID); override; - procedure PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; BoldClientID: TBoldClientID); override; + procedure PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; var TimeOfLatestUpdate: TDateTime; BoldClientID: TBoldClientID); override; procedure OpenDatabase(ReadMappingFromDb: Boolean); procedure CloseDataBase; procedure PMTranslateToGlobalIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; procedure PMTranslateToLocalIds(GlobalIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; - procedure PMSetReadOnlyness(ReadOnlyList, WriteableList: TBoldObjectIdList); override; + procedure PMSetReadonlyness(ReadOnlyList, WriteableList: TBoldObjectIdList); override; procedure SubscribeToPeristenceEvents(Subscriber: TBoldSubscriber); override; procedure ReserveNewIds(ValueSpace: IBoldValueSpace; ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; property PersistenceMapper: TBoldSystemDefaultMapper read GetPersistenceMapper; procedure PMTimestampForTime(ClockTime: TDateTime; var Timestamp: TBoldTimestampType); override; procedure PMTimeForTimestamp(Timestamp: TBoldTimestampType; var ClockTime: TDateTime); override; - procedure StartTransaction; - procedure CommitTransaction; - procedure RollbackTransaction; + procedure StartTransaction; override; + procedure CommitTransaction; override; + procedure RollbackTransaction; override; + function DatabaseInterface: IBoldDatabase; override; function InTransaction: Boolean; + function CanEvaluateInPS(sOCL: string; aSystem: TBoldElement; aContext: TBoldElementTypeInfo = nil; const aVariableList: TBoldExternalVariableList = nil): Boolean; override; property Active: Boolean read fActive; property SQLDataBaseConfig: TBoldSQLDataBaseConfig read fSQLDataBaseConfig; end; @@ -61,37 +69,40 @@ implementation uses SysUtils, + BoldUtils, BoldPMappers, BoldGuard, + BoldPMapperLists, //PATCH BoldPMappersSQL, - PersistenceConsts, - BoldPMappersAttributeDefault, // Not used, just to pull them in - BoldPMappersLinkDefault; // Not used, just to pull them in + BoldPMappersAttributeDefault, + BoldPMappersLinkDefault; {---TBoldPersistenceControllerDefault---} -constructor TBoldPersistenceControllerDefault.CreateFromMold(MoldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; SQLDataBaseConfig: TBoldSQLDataBaseConfig; GetDatabaseFunc: TBoldGetDatabaseEvent); +constructor TBoldPersistenceControllerDefault.CreateFromMold(MoldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; + CustomIndexes: TBoldIndexCollection; SQLDataBaseConfig: TBoldSQLDataBaseConfig; GetDatabaseFunc: TBoldGetDatabaseEvent); begin + inherited Create; fMoldModel := MoldModel; fTypeNameDictionary := TypeNameDictionary; fActive := false; - fSQLDataBaseConfig := TBoldSQLDataBaseConfig.Create; - fSQLDataBaseConfig.AssignConfig(SQLDataBaseConfig); - fSQLDataBaseConfig.OnChange := SQLDataBaseConfigChanged; + fSQLDataBaseConfig := SQLDataBaseConfig; + fCustomIndexes := TBoldIndexCollection.Create(nil); + fCustomIndexes.Assign(CustomIndexes); fOnGetDatabase := GetDatabaseFunc; end; -procedure TBoldPersistenceControllerDefault.PMExactifyIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); +procedure TBoldPersistenceControllerDefault.PMExactifyIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; HandleNonExisting: Boolean); begin - EnsureActive('PMExactifyIDs'); // do not localize - PersistenceMapper.RootClassObjectPersistenceMapper.EnsureIDsExact(ObjectIdlist, TranslationList); + EnsureActive('PMExactifyIDs'); + PersistenceMapper.RootClassObjectPersistenceMapper.EnsureIDsExact(ObjectIdlist, TranslationList, HandleNonExisting); end; -procedure TBoldPersistenceControllerDefault.PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; BoldClientID: TBoldClientID); +procedure TBoldPersistenceControllerDefault.PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; var TimeOfLatestUpdate: TDateTime; BoldClientID: TBoldClientID); var aTranslationList: TBoldIdTranslationList; NewTimeStamp: TBoldTimeStampType; begin - EnsureActive('PMUpdate'); // do not localize + EnsureActive('PMUpdate'); SendExtendedEvent(bpeStartUpdate, [ObjectIdList, valueSpace]); if assigned(TranslationList) then aTranslationList := TranslationList @@ -99,7 +110,7 @@ procedure TBoldPersistenceControllerDefault.PMUpdate(ObjectIdList: TBoldObjectId aTranslationList := TBoldIdTranslationList.Create; try - PersistenceMapper.PMUpdate(ObjectIdList, ValueSpace, Old_Values, Precondition, aTranslationList, NewTimeStamp); + PersistenceMapper.PMUpdate(ObjectIdList, ValueSpace, Old_Values, Precondition, aTranslationList, NewTimeStamp, TimeOfLatestUpdate); if not assigned(Precondition) or not Precondition.failed then begin TimeStamp := NewTimeStamp; @@ -112,39 +123,53 @@ procedure TBoldPersistenceControllerDefault.PMUpdate(ObjectIdList: TBoldObjectId end; end; -procedure TBoldPersistenceControllerDefault.PMFetch(ObjectIDList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; BoldClientID: TBoldClientID); +procedure TBoldPersistenceControllerDefault.PMFetch(ObjectIDList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; BoldClientID: TBoldClientID); var TranslationList: TBoldIdTranslationList; ExactifyTranslationList: TBoldIdTranslationList; DefaultMemberList: TBoldMemberPersistenceMapperList; FetchIdList: TBoldObjectIdList; WasInTransaction: Boolean; + NeedsExacitfy: boolean; + Guard: IBoldGuard; begin - EnsureActive('PMFetch'); // do not localize + Guard := TBoldguard.Create(TranslationLIst, ExactifyTranslationLIst, DefaultMemberList, FetchIdList); + EnsureActive('PMFetch'); SendExtendedEvent(bpeStartFetch, [ObjectIdList, MemberIdList]); - - TranslationList := TBoldIdTranslationList.Create; - ExactifyTranslationList := TBoldIdTranslationList.Create; - DefaultMemberList := TBoldMemberPersistenceMapperList.Create; - DefaultMemberList.OwnsEntries := false; - FetchIdList := ObjectIdList.Clone; - try WasInTransaction := PersistenceMapper.Database.InTransaction; - PMExactifyIDs(FetchIdList, ExactifyTranslationList); - ValueSpace.ExactifyIDs(ExactifyTranslationList); - ObjectIdList.ExactifyIds(ExactifyTranslationList); - FetchIdList.ExactifyIds(ExactifyTranslationList); - PersistenceMapper.PMFetch(FetchIDList, ValueSpace, MemberIdList, FetchMode, TranslationList); + NeedsExacitfy := ObjectIdList.HasInexactIds; + DefaultMemberList := TBoldMemberPersistenceMapperList.Create; + DefaultMemberList.OwnsEntries := false; + TranslationList := TBoldIdTranslationList.Create; + if NeedsExacitfy then + begin + ExactifyTranslationList := TBoldIdTranslationList.Create; + FetchIdList := ObjectIdList.Clone; + PMExactifyIDs(FetchIdList, ExactifyTranslationList, false); + ValueSpace.ExactifyIDs(ExactifyTranslationList); + ObjectIdList.ExactifyIds(ExactifyTranslationList); + FetchIdList.ExactifyIds(ExactifyTranslationList); + if FetchIdList.HasNonExistingIds then + FetchIdList.RemoveNonExistingIds; + PersistenceMapper.PMFetch(FetchIDList, ValueSpace, MemberIdList, FetchMode, TranslationList) + end + else + begin + if ObjectIdList.HasNonExistingIds then + begin + FetchIdList := ObjectIdList.Clone; + FetchIdList.RemoveNonExistingIds; + PersistenceMapper.PMFetch(FetchIdList, ValueSpace, MemberIdList, FetchMode, TranslationList); + end + else + PersistenceMapper.PMFetch(ObjectIdList, ValueSpace, MemberIdList, FetchMode, TranslationList); + end; ValueSpace.ApplyTranslationList(TranslationList); if not WasInTransaction and PersistenceMapper.Database.InTransaction then PersistenceMapper.Database.Commit; finally - TranslationLIst.Free; - ExactifyTranslationLIst.Free; - DefaultMemberList.Free; - FetchIdList.Free; - SendEvent(bpeEndFetch); + SendExtendedEvent(bpeEndFetch, [ObjectIdList, MemberIdList]); end; end; @@ -155,15 +180,18 @@ procedure TBoldPersistenceControllerDefault.PMFetchIDListWithCondition(ObjectIDL WasInTransaction: Boolean; begin Guard := TBoldguard.Create(TranslationList); - EnsureActive('PMFetchIdListWithCondition'); // do not localize + EnsureActive('PMFetchIdListWithCondition'); SendExtendedEvent(bpeStartFetchId, [Condition]); - TranslationList := TBoldIdTranslationList.Create; - WasInTransaction := PersistenceMapper.Database.InTransaction; - PersistenceMapper.PMFetchClassWithCondition(ObjectIdList, ValueSpace, Condition, FetchMode, TranslationList); - ValueSpace.ApplyTranslationList(TranslationList); - if not WasInTransaction and PersistenceMapper.Database.InTransaction then - PersistenceMapper.Database.Commit; - SendEvent(bpeEndFetchId); + try + TranslationList := TBoldIdTranslationList.Create; + WasInTransaction := PersistenceMapper.Database.InTransaction; + PersistenceMapper.PMFetchClassWithCondition(ObjectIdList, ValueSpace, Condition, FetchMode, TranslationList); + ValueSpace.ApplyTranslationList(TranslationList); + if not WasInTransaction and PersistenceMapper.Database.InTransaction then + PersistenceMapper.Database.Commit; + finally + SendExtendedEvent(bpeEndFetchId, [ObjectIdList]); + end; end; procedure TBoldPersistenceControllerDefault.OpenDatabase(ReadMappingFromDb: Boolean); @@ -177,6 +205,13 @@ procedure TBoldPersistenceControllerDefault.OpenDatabase(ReadMappingFromDb: Bool fActive := true; end; +function TBoldPersistenceControllerDefault.CanEvaluateInPS(sOCL: string; + aSystem: TBoldElement; aContext: TBoldElementTypeInfo; + const aVariableList: TBoldExternalVariableList): Boolean; +begin + Result := PersistenceMapper.CanEvaluateInPS(sOCL, aSystem, aContext, aVariableList); +end; + procedure TBoldPersistenceControllerDefault.CloseDataBase; begin PersistenceMapper.CloseDatabase; @@ -186,7 +221,7 @@ procedure TBoldPersistenceControllerDefault.CloseDataBase; destructor TBoldPersistenceControllerDefault.Destroy; begin FreeAndNil(fPersistenceMapper); - FreeAndNil(fSQLDataBaseConfig); + FreeAndNil(fCustomIndexes); inherited; end; @@ -194,7 +229,7 @@ procedure TBoldPersistenceControllerDefault.PMTranslateToGlobalIds( ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); begin - EnsureActive('PMTranslateToGlobalIds'); // do not localize + EnsureActive('PMTranslateToGlobalIds'); PersistenceMapper.PMTranslateToGlobalIds(ObjectIdList, TranslationList); end; @@ -202,14 +237,14 @@ procedure TBoldPersistenceControllerDefault.PMTranslateToLocalIds( GlobalIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); begin - EnsureActive('PMTranslateToLocalIds'); // do not localize + EnsureActive('PMTranslateToLocalIds'); PersistenceMapper.PMTranslateToLocalIds(GlobalIdList, TranslationList); end; procedure TBoldPersistenceControllerDefault.PMSetReadonlyness(ReadOnlyList, WriteableList: TBoldObjectIdList); begin - EnsureActive('PMSetReadonlyness'); // do not localize + EnsureActive('PMSetReadonlyness'); PersistenceMapper.PMSetReadonlyness(ReadOnlyList, WriteableList); end; @@ -223,44 +258,65 @@ procedure TBoldPersistenceControllerDefault.SubscribeToPeristenceEvents( procedure TBoldPersistenceControllerDefault.ReserveNewIds(ValueSpace: IBoldValueSpace; ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); begin - EnsureActive('ReserveNewIds'); // do not localize + EnsureActive('ReserveNewIds'); PersistenceMapper.ReserveNewIds(ValueSpace, ObjectIdList, TranslationList); end; procedure TBoldPersistenceControllerDefault.PMTimeForTimestamp( Timestamp: TBoldTimestampType; var ClockTime: TDateTime); begin - EnsureActive('PMTimeForTimeStamp'); // do not localize + EnsureActive('PMTimeForTimeStamp'); PersistenceMapper.PMTimeForTimestamp(Timestamp, ClockTime); end; procedure TBoldPersistenceControllerDefault.PMTimestampForTime( ClockTime: TDateTime; var Timestamp: TBoldTimestampType); begin - EnsureActive('PMTimestampForTime'); // do not localize + EnsureActive('PMTimestampForTime'); PersistenceMapper.PMTimestampForTime(ClockTime, Timestamp); end; procedure TBoldPersistenceControllerDefault.EnsureActive(Action: String); begin if not fActive then - raise EBold.CreateFmt(sNotActive, [ClassName, Action]); + raise EBold.CreateFmt('%s.%s: Not Active', [ClassName, Action]); +end; + +function TBoldPersistenceControllerDefault.DatabaseInterface: IBoldDatabase; +begin + if Assigned(PersistenceMapper) then + result := PersistenceMapper.Database + else + result := nil; end; function TBoldPersistenceControllerDefault.GetPersistenceMapper: TBoldSystemDefaultMapper; +type + TTBoldSystemDefaultMapperClass = class of TBoldSystemDefaultMapper; +var + SystemMapperDescriptor: TBoldSystemPersistenceMapperDescriptor; + SystemPMapperName: string; + SysPMapperClass: TTBoldSystemDefaultMapperClass; begin if not assigned(fPersistenceMapper) then - fPersistenceMapper := TBoldSystemDefaultMapper.CreateFromMold(fMoldModel, fTypeNameDictionary, SQLDataBaseConfig, fOnGetDatabase); + begin + SystemPMapperName := fMoldModel.PMapperName; + if BoldNamesEqual(SystemPMapperName, DEFAULTNAME) and (SQLDataBaseConfig.DefaultSystemMapper <> '') then + SystemPMapperName := SQLDataBaseConfig.DefaultSystemMapper; + + SystemMapperDescriptor := BoldSystemPersistenceMappers.DescriptorByName[SystemPMapperName]; //PATCH + if not assigned(SystemMapperDescriptor) then //PATCH + raise EBold.CreateFmt('Unable to find SystemPersistenceMapper (%s)', [SystemPMapperName]); //PATCH + + SysPMapperClass := TTBoldSystemDefaultMapperClass(SystemMapperDescriptor.SystemPersistenceMapperClass); //PATCH - This ugly code is needed to call the correct static constructor!!! + + fPersistenceMapper := SysPMapperClass.CreateFromMold(fMoldModel, fTypeNameDictionary, fCustomIndexes,SQLDataBaseConfig, fOnGetDatabase); //PATCH +// fPersistenceMapper := TBoldSystemDefaultMapper.CreateFromMold(fMoldModel, fTypeNameDictionary, SQLDataBaseConfig, fOnGetDatabase); //PATCH - Original is Hardcoded! + end; result := fPersistenceMapper; end; -procedure TBoldPersistenceControllerDefault.SQLDatabaseConfigChanged(Sender: TObject); -begin - if assigned(fPersistencemapper) then - PersistenceMapper.SQLDataBaseConfig.AssignConfig(SQLDataBaseConfig); -end; - procedure TBoldPersistenceControllerDefault.CommitTransaction; begin PersistenceMapper.Database.Commit; @@ -281,4 +337,8 @@ function TBoldPersistenceControllerDefault.InTransaction: Boolean; Result := PersistenceMapper.Database.InTransaction; end; +initialization + + + end. diff --git a/Source/Persistence/DB/BoldPersistenceHandleDB.pas b/Source/Persistence/DB/BoldPersistenceHandleDB.pas index 35eb88e5..04eae88d 100644 --- a/Source/Persistence/DB/BoldPersistenceHandleDB.pas +++ b/Source/Persistence/DB/BoldPersistenceHandleDB.pas @@ -1,17 +1,20 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleDB; interface - uses Classes, BoldSubscription, BoldDbInterfaces, BoldAbstractPersistenceHandleDB, BoldSQLDatabaseConfig, + BoldIndexCollection, BoldAbstractDataBaseAdapter; type - { TBoldPersistenceHandleDB } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldPersistenceHandleDB = class(TBoldAbstractPersistenceHandleDB) private fDatabaseAdapter: TBoldAbstractDatabaseAdapter; @@ -21,6 +24,7 @@ TBoldPersistenceHandleDB = class(TBoldAbstractPersistenceHandleDB) procedure PlaceComponentSubscriptions; protected function GetSQLDatabaseConfig: TBoldSQLDatabaseConfig; override; + function GetCustomIndexes: TBoldIndexCollection; override; function GetDataBaseInterface: IBoldDatabase; override; procedure SetActive(Value: Boolean); override; procedure AssertSQLDatabaseconfig(Context: String); override; @@ -28,8 +32,8 @@ TBoldPersistenceHandleDB = class(TBoldAbstractPersistenceHandleDB) function GetNewComponentName(Comp: Tcomponent; BaseName: string): String; {$ENDIF} public - constructor Create(aOwner: TComponent); override; - destructor Destroy; override; + constructor create(aOwner: TComponent); override; + destructor destroy; override; published property DatabaseAdapter: TBoldAbstractDatabaseAdapter read fDatabaseAdapter write SetDatabaseAdapter; end; @@ -39,7 +43,7 @@ implementation uses BoldDefs, SysUtils, - PersistenceConsts; + BoldRev; const breDatabaseAdapterDestroying = 100; @@ -56,14 +60,22 @@ constructor TBoldPersistenceHandleDB.create(aOwner: Tcomponent); destructor TBoldPersistenceHandleDB.destroy; begin FreeAndNil(fComponentSubscriber); - inherited; + inherited; end; procedure TBoldPersistenceHandleDB.AssertSQLDatabaseconfig( Context: String); begin if not assigned(DatabaseAdapter) then - raise EBold.CreateFmt(sNoDatabaseAdapterAvailable, [classname, Context]); + raise EBold.CreateFmt('%s: Unable to %s. There is no DatabaseAdapter available', [classname, Context]); +end; + +function TBoldPersistenceHandleDB.GetCustomIndexes: TBoldIndexCollection; +begin + if assigned(fDatabaseAdapter) then + result := fDatabaseAdapter.CustomIndexes + else + result := nil; end; function TBoldPersistenceHandleDB.GetDataBaseInterface: IBoldDatabase; @@ -106,7 +118,7 @@ procedure TBoldPersistenceHandleDB.PlaceComponentSubscriptions; procedure TBoldPersistenceHandleDB.SetActive(Value: Boolean); begin if value and not assigned(DatabaseAdapter) then - raise EBold.CreateFmt(sCannotActivateWithoutDBAdapter, [classname]); + raise EBold.CreateFmt('%s.SetActive: Can not set persistence handle to active since it is not connected to a database adapter', [classname]); inherited; end; @@ -129,7 +141,6 @@ procedure TBoldPersistenceHandleDB._ReceiveComponentEvents( begin if active and not (csDestroying in ComponentState) then begin - // what to do? end; fDatabaseAdapter := nil; end; @@ -137,7 +148,6 @@ procedure TBoldPersistenceHandleDB._ReceiveComponentEvents( begin if active and not (csDestroying in ComponentState) then begin - // what to do? end; end; end; diff --git a/Source/Persistence/DB/BoldPersistenceHandleDB.res b/Source/Persistence/DB/BoldPersistenceHandleDB.res new file mode 100644 index 00000000..af85a448 Binary files /dev/null and b/Source/Persistence/DB/BoldPersistenceHandleDB.res differ diff --git a/Source/Persistence/DB/BoldPersistenceHandleDB_deprecated.pas b/Source/Persistence/DB/BoldPersistenceHandleDB_deprecated.pas deleted file mode 100644 index 93ababf1..00000000 --- a/Source/Persistence/DB/BoldPersistenceHandleDB_deprecated.pas +++ /dev/null @@ -1,175 +0,0 @@ -unit BoldPersistenceHandleDB_deprecated; - -interface - -uses - Classes, - Dialogs, - Controls, - BoldPersistenceHandleDb, - BoldSQLDatabaseConfig, - BoldAbstractPersistenceHandleDB; - - -type - { forward declarations } - TBoldDBPersistenceHandle = class; - - { TBoldDBPersistenceHandle } - TBoldDBPersistenceHandle = class(TBoldAbstractPersistenceHandleDB) - private - fUserName: String; - fPassword: String; - fSQLDataBaseConfig: TBoldSQLDataBaseConfig; - fDatabaseEngine: TBoldDataBaseEngine; - procedure SQLDatabaseConfigChanged(Sender: TObject); - procedure SetSQLDataBaseConfig(const Value: TBoldSQLDataBaseConfig); - procedure ReadEmptyStringMarker(Reader: TReader); - procedure ReadSystemTablePrefix(Reader: TReader); - function GetNewPersistenceHandle: TBoldPersistenceHandleDB; - procedure TransferPropertiesToNewPersistenceHandle(const Value: TBoldPersistenceHandleDB); - protected - procedure SetDataBaseEngine(const Value: TBoldDataBaseEngine); virtual; - procedure SetPassword(const Value: string); virtual; - procedure SetUserName(const Value: string); virtual; - function GetSQLDatabaseConfig: TBoldSQLDataBaseConfig; override; - {$IFDEF T2H} // properties is removed, but should still be in doc - property EmptyStringMarker; // String - property SystemTablesPrefix; // String - {$ELSE} - procedure InternalTransferproperties(const target: TBoldPersistenceHandleDB); virtual; - function GetNewComponentName(Comp: Tcomponent; BaseName: string): String; - {$ENDIF} - procedure DefineProperties(Filer: TFiler); override; - public - constructor Create(Owner: TComponent); override; - destructor Destroy; override; - published - property Username: string read fusername write SetUserName; - property Password: string read fPassword write SetPassword; - property SQLDataBaseConfig: TBoldSQLDataBaseConfig read GetSQLDataBaseConfig write SetSQLDataBaseConfig; - property DatabaseEngine: TBoldDataBaseEngine read fDatabaseEngine write SetDataBaseEngine; - property __TransferPropertiesToNewPersistenceHandle: TBoldPersistenceHandleDB read GetNewPersistenceHandle write TransferPropertiesToNewPersistenceHandle; - end; - -implementation - -uses - SysUtils, - BoldPersistenceControllerDefault, - BoldPersistenceHandle; - -{ TBoldDBPersistenceHandle } - -constructor TBoldDBPersistenceHandle.create(Owner: TComponent); -begin - inherited; - fSQLDatabaseConfig := TBoldSQlDatabaseConfig.Create; -end; - -procedure TBoldDBPersistenceHandle.SetPassword(const Value: string); -begin - fPassword := Value; -end; - -procedure TBoldDBPersistenceHandle.SetUserName(const Value: string); -begin - fusername := Value; -end; - -destructor TBoldDBPersistenceHandle.destroy; -begin - FreeAndNil(fSQLDataBaseConfig); - inherited; -end; - -procedure TBoldDBPersistenceHandle.SQLDatabaseConfigChanged(Sender: TObject); -begin - if HasPersistenceController then - PersistenceControllerDefault.SQLDataBaseConfig.AssignConfig(SQLDataBaseConfig); -end; - -procedure TBoldDBPersistenceHandle.SetSQLDataBaseConfig(const Value: TBoldSQLDataBaseConfig); -begin - SQLDataBaseConfig.AssignConfig(Value); -end; - -procedure TBoldDBPersistenceHandle.SetDataBaseEngine(const Value: TBoldDataBaseEngine); -begin - if value <> fDatabaseEngine then - begin - if not (csLoading in ComponentState) then - SQLDatabaseConfig.InitializeDbEngineSettings(Value); - fDatabaseEngine := Value; - SQLDataBaseConfig.Engine := DatabaseEngine; - end; -end; - -function TBoldDBPersistenceHandle.GetSQLDataBaseConfig: TBoldSQLDataBaseConfig; -begin - if not assigned(fSQLDataBaseConfig) then - begin - fSQLDataBaseConfig := TBoldSQLDataBaseConfig.Create; - fSQLDataBaseConfig.OnChange := SQLDatabaseConfigChanged; - end; - result := fSQLDataBaseConfig; -end; - -procedure TBoldDBPersistenceHandle.DefineProperties(Filer: TFiler); -begin - inherited DefineProperties(Filer); - // EmptyStringMarker and SystemtablePrefix moved to SQLDatabaseConfig in v 4.0 - Filer.DefineProperty('EmptyStringMarker', ReadEmptyStringMarker, nil, True); - Filer.DefineProperty('SystemTablesPrefix', ReadSystemTablePrefix, nil, True); -end; - -procedure TBoldDBPersistenceHandle.ReadEmptyStringMarker(Reader: TReader); -begin - SQLDataBaseConfig.EmptyStringMarker := Reader.ReadString; -end; - -procedure TBoldDBPersistenceHandle.ReadSystemTablePrefix(Reader: TReader); -begin - SQLDataBaseConfig.SystemTablePrefix := Reader.ReadString; -end; - -function TBoldDBPersistenceHandle.GetNewPersistenceHandle: TBoldPersistenceHandleDB; -begin - result := nil; -end; - -procedure TBoldDBPersistenceHandle.TransferPropertiesToNewPersistenceHandle( - const Value: TBoldPersistenceHandleDB); -begin - if assigned(value) and - (MessageDlg(format('Do you want to transfer the settings to %s', [value.Name]), - mtConfirmation, [mbYes, mbNo], 0) = mrYes) then - begin - InternalTransferproperties(value); - Value.SQLDatabaseConfig.AssignConfig(SQLDataBaseConfig); - Value.ClockLogGranularity := ClockLogGranularity; - Value.EvolutionSupport := EvolutionSupport; - Value.UpgraderHandle := UpgraderHandle; - Value.OnGetCurrentTime := OnGetCurrentTime; - Value.BoldModel := BoldModel; - showmessage('All settings have been transferred to ' + value.Name); - end; -end; - -procedure TBoldDBPersistenceHandle.InternalTransferproperties(const target: TBoldPersistenceHandleDB); -begin - // do nothing -end; - -function TBoldDBPersistenceHandle.GetNewComponentName(Comp: Tcomponent; - BaseName: string): String; -var - i: integer; -begin - i := 1; - while assigned(comp.Owner.FindComponent(BaseName+IntToStr(i))) do - inc(i); - result := BaseName + inttostr(i); -end; - -end. diff --git a/Source/Persistence/DB/BoldPersistenceHandleDBreg.pas b/Source/Persistence/DB/BoldPersistenceHandleDBreg.pas index 63a297c8..5778908d 100644 --- a/Source/Persistence/DB/BoldPersistenceHandleDBreg.pas +++ b/Source/Persistence/DB/BoldPersistenceHandleDBreg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleDBreg; interface @@ -6,7 +9,7 @@ procedure Register; implementation -{.$R BoldPersistenceHandleDB.res} +{$R BoldPersistenceHandleDB.res} uses Classes, @@ -15,11 +18,14 @@ implementation BoldDbActions, DesignEditors, DesignIntf, - actnlist, +{$IFDEF BOLD_DELPHI17_OR_LATER} + Actions, +{$ELSE} + ActnList, +{$ENDIF} SysUtils, BoldPersistenceHandleDB, - BoldIDEConsts, - BoldPMConsts; + BoldIDEConsts; type { TBoldPersistenceHandleDBEditor } @@ -36,8 +42,11 @@ TBoldPersistenceHandleDBEditor = class(TComponentEditor) procedure Register; begin RegisterComponents(BOLDPAGENAME_PERSISTENCE, [TBoldPersistenceHandleDB]); -// RegisterActions(BOLDACTIONGROUPNAME, -// [TBoldGenerateSchemaAction], nil); + RegisterActions(BOLDACTIONGROUPNAME, + [TBoldGenerateSchemaAction, + TBoldValidateDBStructureAction, + TBoldValidateDBDataAction, + TBoldEvolveDBAction], nil); RegisterComponentEditor(TBoldPersistenceHandleDB, TBoldPersistenceHandleDBEditor); end; @@ -56,11 +65,11 @@ procedure TBoldPersistenceHandleDBEditor.GenerateSchema; begin try TBoldPersistenceHandleDB(Component).CreateDataBaseSchema; - showmessage(sSchemaGenerated); + showmessage('Database schema generated'); except on e: Exception do begin - Showmessage(Format(sSchemaGenerationFailed, [BOLDCRLF, BOLDCRLF, e.message])); + Showmessage('Database schema generation failed: '+BOLDCRLF+BOLDCRLF+e.message); end; end; end; @@ -69,7 +78,7 @@ procedure TBoldPersistenceHandleDBEditor.GenerateSchema; function TBoldPersistenceHandleDBEditor.GetVerb(Index: Integer): string; begin case Index of - 0: Result := sGenerateSchema; + 0: Result := 'Generate Database Schema...'; end; end; diff --git a/Source/Persistence/DBExpress/BoldDBXInterfaces.pas b/Source/Persistence/DBExpress/BoldDBXInterfaces.pas index 2afe59cf..537a0f73 100644 --- a/Source/Persistence/DBExpress/BoldDBXInterfaces.pas +++ b/Source/Persistence/DBExpress/BoldDBXInterfaces.pas @@ -1,3 +1,5 @@ +{ Global compiler directives } +{$include bold.inc} unit BoldDBXInterfaces; interface @@ -6,7 +8,7 @@ interface Classes, Db, SQlExpr, - DBXpress, + DBXCommon, BoldSQLDataBaseConfig, BoldDBInterfaces; @@ -17,7 +19,6 @@ TBoldDBXQuery = class; TBoldDBXTable = class; TBoldDBXQueryClass = class of TBoldDBXQuery; - { TBoldDBXParameter } TBoldDBXParameter = class(TBoldDbParameter) protected @@ -29,29 +30,43 @@ TBoldDBXParameter = class(TBoldDbParameter) TBoldDBXQuery = class(TBoldDataSetWrapper, IBoldQuery, IBoldExecQuery, IBoldParameterized) private fQuery: TSQLQuery; + fSQLStrings: TStringList; + fReadTransactionStarted: Boolean; + fUseReadTransactions: boolean; procedure AssignParams(SourceParams: TParams); + function GetParams: TParams; function GetParamCount: integer; - function GetParams(i: integer): IBoldParameter; + function GetParam(i: integer): IBoldParameter; function GetRequestLiveQuery: Boolean; function ParamByName(const Value: string): IBoldParameter; procedure SetRequestLiveQuery(NewValue: Boolean); function GetSQLText: String; procedure ClearParams; procedure AssignSQL(SQL: TStrings); - procedure AssignSQLText(SQL: String); + procedure AssignSQLText(const SQL: String); + function GetParamCheck: Boolean; + procedure SetParamCheck(value: Boolean); function GetRowsAffected: integer; function GetRecordCount: integer; - function Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; + function Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; override; + function GetUseReadTransactions: boolean; + procedure SetUseReadTransactions(value: boolean); + procedure BeginExecuteQuery; + procedure EndExecuteQuery; + function GetBatchQueryParamCount: integer; protected function GetDataSet: TDataSet; override; + function GetSQLStrings: TStrings; procedure StartSQLBatch; virtual; procedure EndSQLBatch; virtual; procedure FailSQLBatch; virtual; procedure ExecSQL; virtual; property Query: TSQLQuery read fQuery; procedure Open; override; + procedure Close; override; public constructor Create(Query: TSQLQuery; DatabaseWrapper: TBoldDatabaseWrapper); virtual; + destructor Destroy; override; end; { TBoldDBXTable } @@ -63,7 +78,7 @@ TBoldDBXTable = class(TBoldDataSetWrapper, IBoldTable) procedure DeleteTable; function GetTable: TSQLTable; function GetIndexDefs: TIndexDefs; - procedure SetTableName(NewName: String); + procedure SetTableName(const NewName: String); function GetTableName: String; procedure SetExclusive(NewValue: Boolean); function GetExclusive: Boolean; @@ -79,9 +94,10 @@ TBoldDBXTable = class(TBoldDataSetWrapper, IBoldTable) TBoldDBXDataBase = class(TBoldDatabaseWrapper, IBoldDataBase) private fDataBase: TSQLConnection; + fTransaction: TDBXTransaction; fCachedTable: TSQLTable; fCachedQuery: TSQLQuery; - fTransactionDesc: TTransactionDesc; + fExecuteQueryCount: integer; function GetConnected: Boolean; function GetInTransaction: Boolean; function GetIsSQLBased: Boolean; @@ -90,21 +106,26 @@ TBoldDBXDataBase = class(TBoldDatabaseWrapper, IBoldDataBase) procedure SetKeepConnection(NewValue: Boolean); function GetKeepConnection: Boolean; procedure StartTransaction; + procedure StartReadTransaction; procedure Commit; procedure RollBack; procedure Open; procedure Close; - function GetTable: IBoldTable; - procedure ReleaseTable(var Table: IBoldTable); + procedure Reconnect; function SupportsTableCreation: Boolean; procedure ReleaseCachedObjects; + function GetIsExecutingQuery: Boolean; + procedure BeginExecuteQuery; + procedure EndExecuteQuery; protected procedure AllTableNames(Pattern: String; ShowSystemTables: Boolean; TableNameList: TStrings); override; function GetQuery: IBoldQuery; override; procedure ReleaseQuery(var Query: IBoldQuery); override; + function GetTable: IBoldTable; override; + procedure ReleaseTable(var Table: IBoldTable); override; public constructor create(DataBase: TSQLConnection; SQLDataBaseConfig: TBoldSQLDataBaseConfig); - destructor Destroy; override; + destructor destroy; override; end; var @@ -119,17 +140,28 @@ implementation SqlTimSt, BoldDefs, SysUtils, - BoldUtils, - BoldCoreConsts; + BoldUtils; { TBoldDBXQuery } procedure TBoldDBXQuery.AssignParams(Sourceparams: tparams); +var + i: integer; begin if assigned(Sourceparams) then Query.Params.Assign(SourceParams) else Query.Params.Clear; + for i := 0 to Query.Params.Count - 1 do + if Query.Params[i].DataType = ftDateTime then + Query.Params[i].DataType := ftDate; // Patch since DBX does not support datetime in this version. + + +end; + +function TBoldDBXQuery.GetParamCheck: Boolean; +begin + Result := Query.ParamCheck; end; function TBoldDBXQuery.GetParamCount: integer; @@ -137,14 +169,18 @@ function TBoldDBXQuery.GetParamCount: integer; result := Query.params.count; end; -function TBoldDBXQuery.GetParams(I: integer): IBoldParameter; +function TBoldDBXQuery.GetParams: TParams; +begin + result := Query.Params; +end; + +function TBoldDBXQuery.GetParam(I: integer): IBoldParameter; begin result := TBoldDBXParameter.Create(Query.Params[i], self); end; function TBoldDBXQuery.GetREquestLiveQuery: Boolean; begin - // FIXME result := Query.RequestLive; result := false; end; @@ -159,10 +195,24 @@ function TBoldDBXQuery.ParamByName(const Value: string): IBoldParameter; result := nil; end; +procedure TBoldDBXQuery.SetParamCheck(value: Boolean); +begin + Query.ParamCheck := Value; +end; + procedure TBoldDBXQuery.SetRequestLiveQuery(NewValue: Boolean); begin - // FIXME -// Query.RequestLive := NewValue; + +end; + +procedure TBoldDBXQuery.SetUseReadTransactions(value: boolean); +begin + fUseReadTransactions := value; +end; + +function TBoldDBXQuery.GetBatchQueryParamCount: integer; +begin + result := 0; end; function TBoldDBXQuery.GetDataSet: TDataSet; @@ -171,52 +221,136 @@ function TBoldDBXQuery.GetDataSet: TDataSet; end; procedure TBoldDBXQuery.ExecSQL; +var + Retries: Integer; + Done: Boolean; begin - BoldLogSQL(Query.SQL); + BeginExecuteQuery; try - Query.ExecSQL; - except - on e: Exception do - begin - e.Message := e.Message + BOLDCRLF + 'SQL: ' + Query.SQL.text; // do not localize - raise; + +{$IFDEF BOLD_DELPHI10_OR_LATER} + {$IFDEF BOLD_UNICODE} + BoldLogSQL(Query.SQL); + {$ELSE} + BoldLogSQLWide(Query.SQL, self); + {$ENDIF} +{$ELSE} + BoldLogSQL(Query.SQL); +{$ENDIF} + + Retries := 0; + Done := false; + while not Done do + begin + try + if Query.SQLConnection.InTransaction then + fReadTransactionStarted := false + else + begin + (DatabaseWrapper as TBoldDBXDataBase).StartReadTransaction; + fReadTransactionStarted := true; + end; + + Query.ExecSQL; + if fReadTransactionStarted and (DatabaseWrapper as TBoldDBXDataBase).GetInTransaction then + begin + (DatabaseWrapper as TBoldDBXDataBase).Commit; + fReadTransactionStarted := false; + end; + Done := true; + except + on e: Exception do + begin + e.Message := e.Message + BOLDCRLF + 'SQL: ' + Query.SQL.text; + if (not fReadTransactionStarted) or (Retries > 4) then + raise; + if (DatabaseWrapper as TBoldDBXDataBase).GetInTransaction then + (DatabaseWrapper as TBoldDBXDataBase).Rollback; + fReadTransactionStarted := false; + INC(Retries); + sleep(Retries*200); + end; + end; - end + end; + finally + EndExecuteQuery; + end; end; constructor TBoldDBXQuery.Create(Query: TSQLQuery; DatabaseWrapper: TBoldDatabaseWrapper); begin inherited Create(DatabaseWrapper); fQuery := Query; + SetParamCheck(true); + fUseReadTransactions := true; + fSQLStrings := TStringList.Create; +end; + +procedure TBoldDBXQuery.BeginExecuteQuery; +begin + (DatabaseWrapper as TBoldDBXDataBase).BeginExecuteQuery; +end; + +procedure TBoldDBXQuery.EndExecuteQuery; +begin + (DatabaseWrapper as TBoldDBXDataBase).EndExecuteQuery; end; procedure TBoldDBXQuery.EndSQLBatch; begin - // intentionally left blank end; procedure TBoldDBXQuery.StartSQLBatch; begin - // intentionally left blank end; procedure TBoldDBXQuery.FailSQLBatch; begin - // intentionally left blank end; procedure TBoldDBXQuery.Open; +var + Retries: Integer; + Done: Boolean; begin +{$IFDEF BOLD_DELPHI10_OR_LATER} + {$IFDEF BOLD_UNICODE} BoldLogSQL(Query.SQL); - try - inherited; - except - on e: Exception do - begin - e.Message := e.Message + BOLDCRLF + 'SQL: ' + Query.SQL.text; // do not localize - raise; + {$ELSE} + BoldLogSQLWide(Query.SQL, self); + {$ENDIF} +{$ELSE} + BoldLogSQL(Query.SQL); +{$ENDIF} + Retries := 0; + Done := false; + while not Done do + begin + try + if (DatabaseWrapper as TBoldDBXDataBase).GetInTransaction then + fReadTransactionStarted := false + else + begin + (DatabaseWrapper as TBoldDBXDataBase).StartReadTransaction; + fReadTransactionStarted := true; + end; + inherited; + Done := true; + except + on e: Exception do + begin + e.Message := e.Message + BOLDCRLF + 'SQL: ' + Query.SQL.text; + if (not fReadTransactionStarted) or (Retries > 4) then + raise; + if (DatabaseWrapper as TBoldDBXDataBase).GetInTransaction then + (DatabaseWrapper as TBoldDBXDataBase).Rollback; + fReadTransactionStarted := false; + INC(Retries); + sleep(Retries*200); + end; end; - end + end; end; procedure TBoldDBXQuery.AssignSQL(SQL: TStrings); @@ -226,19 +360,36 @@ procedure TBoldDBXQuery.AssignSQL(SQL: TStrings); Query.SQL.EndUpdate; end; -procedure TBoldDBXQuery.AssignSQLText(SQL: String); +procedure TBoldDBXQuery.AssignSQLText(const SQL: String); begin Query.SQL.BeginUpdate; Query.SQL.Clear; +{$IFDEF BOLD_DELPHI10_OR_LATER} + Query.SQL.Append(SQL); // FIXME, this gives one long line. +{$ELSE} BoldAppendToStrings(Query.SQL, SQL, true); +{$ENDIF} + Query.SQL.EndUpdate; end; +function TBoldDBXQuery.GetSQLStrings: TStrings; +begin + result := fSQLStrings; + result.clear; + result.Add(Query.SQL.Text); +end; + function TBoldDBXQuery.GetSQLText: String; begin result := Query.SQL.text; end; +function TBoldDBXQuery.GetUseReadTransactions: boolean; +begin + result := fUseReadTransactions; +end; + function TBoldDBXQuery.GetRowsAffected: integer; begin result := Query.RowsAffected; @@ -254,6 +405,14 @@ procedure TBoldDBXQuery.ClearParams; query.params.Clear; end; +procedure TBoldDBXQuery.Close; +begin + inherited; + if (fReadTransactionStarted) and (DatabaseWrapper as TBoldDBXDataBase).GetInTransaction then + (DatabaseWrapper as TBoldDBXDataBase).Commit; + fReadTransactionStarted := false; +end; + function TBoldDBXQuery.Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; @@ -261,13 +420,20 @@ function TBoldDBXQuery.Createparam(FldType: TFieldType; result := TBoldDbParameter.Create(Query.params.CreateParam(fldType, ParamName, ParamType), self); end; +destructor TBoldDBXQuery.Destroy; +begin + if (fReadTransactionStarted) then + Close; + FreeAndNil(fSQLStrings); + inherited; +end; + { TBoldDBXTable } procedure TBoldDBXTable.AddIndex(const Name, Fields: string; Options: TIndexOptions; const DescFields: string); begin - // FIXME -// Table.AddIndex(Name, Fields, Options, DescFields); + end; constructor TBoldDBXTable.Create(Table: TSQLTable; DatabaseWrapper: TBoldDatabaseWrapper); @@ -278,12 +444,11 @@ constructor TBoldDBXTable.Create(Table: TSQLTable; DatabaseWrapper: TBoldDatabas procedure TBoldDBXTable.CreateTable; begin - raise EBold.CreateFmt(sMethodNotImplemented, [classname, 'CreateTable']); // do not localize + raise EBold.CreateFmt('%s.CreateTable: Not supported', [classname]); end; procedure TBoldDBXTable.DeleteTable; begin -// FIXME Table.DeleteTable; end; function TBoldDBXTable.GetDataSet: TDataSet; @@ -293,14 +458,23 @@ function TBoldDBXTable.GetDataSet: TDataSet; function TBoldDBXTable.GetExclusive: Boolean; begin -// FIXME result := Table.Exclusive; result := false; end; function TBoldDBXTable.GetExists: Boolean; +var + DB: IBoldDataBase; + NameList: TStringList; begin -// FIXME result := Table.Exists; - result := false; + NameList := TStringList.Create; + NameList.CaseSensitive := false; + try + DB:= DatabaseWrapper as IBoldDataBase; + DB.AllTableNames('', false, NameList); + Result := NameList.IndexOf(fTable.TableName) > -1; + finally + FreeANdNil(NameList); + end; end; function TBoldDBXTable.GetIndexDefs: TIndexDefs; @@ -322,19 +496,53 @@ function TBoldDBXTable.GetTableName: String; procedure TBoldDBXTable.SetExclusive(NewValue: Boolean); begin -// FIXME Table.Exclusive := NewValue; end; -procedure TBoldDBXTable.SetTableName(NewName: String); -begin - Table.TableName := NewName; +procedure TBoldDBXTable.SetTableName(const NewName: String); +var + DB: IBoldDataBase; + NameList: TStringList; + NameIndex: Integer; + s: string; +begin + s := NewName; + NameList := TStringList.Create; + NameList.CaseSensitive := false; + try + DB:= DatabaseWrapper as IBoldDataBase; + DB.AllTableNames('', false, NameList); + NameIndex := NameList.IndexOf(s); + if NameIndex > -1 then + s := NameList[NameIndex]; + finally + FreeANdNil(NameList); + end; + Table.TableName := s; end; { TBoldDBXDataBase } procedure TBoldDBXDataBase.AllTableNames(Pattern: String; ShowSystemTables: Boolean; TableNameList: TStrings); +var + SystemTableNames: TStringList; + TableName: string; begin - fDataBase.GetTableNames(TableNameList, ShowSystemTables); + if (Pattern <> '') and (Pattern <> '*') then + raise Exception.CreateFmt('%s.AlltableNames: This call does not allow patterns ("%s")', [ClassName, Pattern]); + fDataBase.GetTableNames(TableNameList, false); + if ShowSystemTables then + begin + SystemTableNames := TStringList.Create; + try + fDataBase.GetTableNames(SystemTableNames, true); + for TableName in SystemTableNames do + if TableNameList.IndexOf(TableName) = -1 then + TableNameList.Add(TableName); + finally + FreeAndNil(SystemTableNames); + end; + end; + end; function TBoldDBXDataBase.GetInTransaction: Boolean; @@ -342,6 +550,11 @@ function TBoldDBXDataBase.GetInTransaction: Boolean; result := fDataBase.InTransaction; end; +function TBoldDBXDataBase.GetIsExecutingQuery: Boolean; +begin + Result := fExecuteQueryCount > 0; +end; + function TBoldDBXDataBase.GetIsSQLBased: Boolean; begin result := true; @@ -378,21 +591,24 @@ function TBoldDBXDataBase.GetConnected: Boolean; result := fDataBase.Connected; end; +procedure TBoldDBXDataBase.StartReadTransaction; +begin + fTransaction := fDataBase.BeginTransaction(TDBXIsolations.ReadCommitted); +end; + procedure TBoldDBXDataBase.StartTransaction; begin -// fTransactionDesc.IsolationLevel := xilREADCOMMITTED; - fTransactionDesc.TransactionID := BOLD_DEFAULT_DBX_TRANSACTION_ID; - fDataBase.StartTransaction(fTransactionDesc); + fTransaction := fDataBase.BeginTransaction(TDBXIsolations.RepeatableRead); end; procedure TBoldDBXDataBase.Commit; begin - fDatabase.Commit(fTransactionDesc); + fDatabase.CommitFreeAndNil(fTransaction); end; procedure TBoldDBXDataBase.RollBack; begin - fDataBase.Rollback(fTransactionDesc); + fDataBase.RollbackFreeAndNil(fTransaction); end; procedure TBoldDBXDataBase.Open; @@ -400,6 +616,11 @@ procedure TBoldDBXDataBase.Open; fDataBase.Open; end; +procedure TBoldDBXDataBase.BeginExecuteQuery; +begin + inc(fExecuteQueryCount); +end; + procedure TBoldDBXDataBase.Close; begin fDataBase.Close; @@ -413,6 +634,11 @@ destructor TBoldDBXDataBase.destroy; FreeAndNil(fCachedQuery); end; +procedure TBoldDBXDataBase.EndExecuteQuery; +begin + dec(fExecuteQueryCount); +end; + function TBoldDBXDataBase.GetQuery: IBoldQuery; var Query: TSQLQuery; @@ -461,9 +687,11 @@ procedure TBoldDBXDataBase.ReleaseQuery(var Query: IBoldQuery); if fCachedQuery.Active then fCachedQuery.Close; fCachedQuery.SQL.Clear; + fCachedQuery.Params.Clear; end else DBXQuery.fQuery.free; + DBXQuery.fQuery := nil; DBXQuery.Free; end; end; @@ -489,6 +717,14 @@ function TBoldDBXDataBase.SupportsTableCreation: Boolean; result := false; end; +procedure TBoldDBXDataBase.Reconnect; +begin + if Assigned(fDataBase) then begin + fDataBase.Connected := False; + fDataBase.Connected := True; + end; +end; + procedure TBoldDBXDataBase.ReleaseCachedObjects; begin FreeAndNil(fCachedTable); @@ -499,16 +735,13 @@ procedure TBoldDBXDataBase.ReleaseCachedObjects; function TBoldDBXParameter.GetAsDateTime: TDateTime; begin - // dbexpress does not handle AsDateTime, only AsSQLTimeStamp result := SQLTimeStampToDateTime(Parameter.AsSQLTimeStamp); end; procedure TBoldDBXParameter.SetAsDateTime(const Value: TDateTime); begin - // dbexpress does not handle AsDateTime, only AsSQLTimeStamp -// Parameter.AsDateTime := value; + Parameter.AsSQLTimeStamp := DateTimetoSQLTimeStamp(value); end; end. - diff --git a/Source/Persistence/DBExpress/BoldDatabaseAdapterDBX.pas b/Source/Persistence/DBExpress/BoldDatabaseAdapterDBX.pas index 7ef867f7..fe8bc333 100644 --- a/Source/Persistence/DBExpress/BoldDatabaseAdapterDBX.pas +++ b/Source/Persistence/DBExpress/BoldDatabaseAdapterDBX.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDatabaseAdapterDBX; interface @@ -5,7 +8,6 @@ interface uses BoldAbstractDataBaseAdapter, BoldDBInterfaces, - DBXpress, SQLExpr, BoldDBXInterfaces; @@ -71,4 +73,6 @@ procedure TBoldDatabaseAdapterDBX.SetDataBase(const Value: TSQLConnection); InternalDatabase := value; end; +initialization + end. diff --git a/Source/Persistence/DBExpress/BoldPersistenceHandleDBX.pas b/Source/Persistence/DBExpress/BoldPersistenceHandleDBX.pas index fe336a3d..8174f47e 100644 --- a/Source/Persistence/DBExpress/BoldPersistenceHandleDBX.pas +++ b/Source/Persistence/DBExpress/BoldPersistenceHandleDBX.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleDBX; interface @@ -24,7 +27,7 @@ TBoldPersistenceHandleDBX = class(TBoldDBPersistenceHandle) procedure SetPassword(const Value: string); override; procedure SetUserName(const Value: string); override; public - destructor Destroy; override; + destructor destroy; override; function GetDataBaseInterface: IBoldDatabase; override; published property SQLConnection: TSQLConnection read fSQLConnection write SetSQLConnection; @@ -33,7 +36,8 @@ TBoldPersistenceHandleDBX = class(TBoldDBPersistenceHandle) implementation uses - SysUtils; + SysUtils, + BoldRev; { TBoldPersistenceHandleDBX } @@ -75,11 +79,13 @@ procedure TBoldPersistenceHandleDBX.SetSQLConnection(const Value: TSQLConnection procedure TBoldPersistenceHandleDBX.SetPassword(const Value: string); begin raise Exception.Create('Can not set password directly on PersistenceHandleDBX, set it on the SQLConnection'); -end; +end; procedure TBoldPersistenceHandleDBX.SetUserName(const Value: string); begin raise Exception.Create('Can not set username directly on PersistenceHandleDBX, set it on the SQLConnection'); end; +initialization + end. diff --git a/Source/Persistence/DBExpress/BoldPersistenceHandleDBXReg.pas b/Source/Persistence/DBExpress/BoldPersistenceHandleDBXReg.pas index 8c692a25..e762a28b 100644 --- a/Source/Persistence/DBExpress/BoldPersistenceHandleDBXReg.pas +++ b/Source/Persistence/DBExpress/BoldPersistenceHandleDBXReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleDBXReg; interface @@ -6,16 +9,21 @@ procedure Register; implementation -{$R BoldPersistenceHandleDBX.res} - uses Classes, BoldPersistenceHandleDBX, + BoldAbstractDatabaseAdapter, + BoldIndexCollection, BoldDatabaseAdapterDBX, - BoldIDEConsts; + BoldIDEConsts, ColnEdit, DesignIntf; +type + + TBoldIndexCollectionProperty = class(TCollectionProperty) + end; procedure Register; begin + RegisterPropertyEditor(TypeInfo(TBoldIndexCollection), TBoldAbstractDatabaseAdapter, 'CustomIndexes', TBoldIndexCollectionProperty); // Should really be registered in own unit RegisterComponents(BOLDPAGENAME_DEPRECATED, [TBoldPersistenceHandleDBX]); RegisterComponents(BOLDPAGENAME_PERSISTENCE, [TBoldDatabaseAdapterDBX]); end; diff --git a/Source/Persistence/DBISAM/BoldDBISAMInterfaces.pas b/Source/Persistence/DBISAM/BoldDBISAMInterfaces.pas index fea94fbc..2d7c9761 100644 --- a/Source/Persistence/DBISAM/BoldDBISAMInterfaces.pas +++ b/Source/Persistence/DBISAM/BoldDBISAMInterfaces.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDBISAMInterfaces; interface @@ -23,7 +26,7 @@ TBoldDBISAMQuery = class(TBoldDataSetWrapper, IBoldQuery, IBoldExecQuery, IBol fQuery: TDBISAMQuery; function GetQuery: TDBISAMQuery; procedure AssignParams(SourceParams: TParams); - procedure ClearParams; + procedure ClearParams; function GetParamCount: integer; function GetParams(i: integer): IBoldParameter; function GetRequestLiveQuery: Boolean; @@ -32,6 +35,8 @@ TBoldDBISAMQuery = class(TBoldDataSetWrapper, IBoldQuery, IBoldExecQuery, IBol function GetSQLText: String; procedure AssignSQL(SQL: TStrings); procedure AssignSQLText(SQL: String); + function GetParamCheck: Boolean; + procedure SetParamCheck(value: Boolean); function GetRowsAffected: integer; function GetRecordCount: integer; function Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; @@ -86,8 +91,6 @@ TBoldDBISAMDataBase = class(TBoldDatabaseWrapper, IBoldDataBase) procedure RollBack; procedure Open; procedure Close; - function GetTable: IBoldTable; - procedure ReleaseTable(var Table: IBoldTable); function SupportsTableCreation: Boolean; procedure ReleaseCachedObjects; protected @@ -95,9 +98,11 @@ TBoldDBISAMDataBase = class(TBoldDatabaseWrapper, IBoldDataBase) procedure AllTableNames(Pattern: String; ShowSystemTables: Boolean; TableNameList: TStrings); override; function GetQuery: IBoldQuery; override; procedure ReleaseQuery(var Query: IBoldQuery); override; + function GetTable: IBoldTable; override; + procedure ReleaseTable(var Table: IBoldTable); override; public - constructor Create(DataBase: TDBISAMDataBase; SQLDataBaseConfig: TBoldSQLDatabaseConfig); - destructor Destroy; override; + constructor create(DataBase: TDBISAMDataBase; SQLDataBaseConfig: TBoldSQLDatabaseConfig); + destructor destroy; override; end; var @@ -107,7 +112,8 @@ implementation uses SysUtils, - BoldDefs; + BoldDefs, + BoldRev; { TBoldDBISAMQuery } @@ -126,6 +132,11 @@ function TBoldDBISAMQuery.GetQuery: TDBISAMQuery; result := fQuery; end; +function TBoldDBISAMQuery.GetParamCheck: Boolean; +begin + Result := Query.ParamCheck; +end; + function TBoldDBISAMQuery.GetParamCount: integer; begin result := Query.params.count; @@ -152,6 +163,11 @@ function TBoldDBISAMQuery.ParamByName(const Value: string): IBoldParameter; result := nil; end; +procedure TBoldDBISAMQuery.SetParamCheck(value: Boolean); +begin + Query.ParamCheck := Value; +end; + procedure TBoldDBISAMQuery.SetRequestLiveQuery(NewValue: Boolean); begin Query.RequestLive := NewValue; @@ -170,7 +186,7 @@ procedure TBoldDBISAMQuery.ExecSQL; except on e: Exception do begin - e.Message := e.Message + BOLDCRLF + 'SQL: ' + Query.SQL.text; // do not localize + e.Message := e.Message + BOLDCRLF + 'SQL: ' + Query.SQL.text; raise; end; end @@ -180,21 +196,19 @@ constructor TBoldDBISAMQuery.Create(Query: TDBISAMQuery; DatabaseWrapper: TBoldD begin inherited Create(DatabaseWrapper); fQuery := Query; + SetParamCheck(true); end; procedure TBoldDBISAMQuery.EndSQLBatch; begin - // intentionally left blank end; procedure TBoldDBISAMQuery.StartSQLBatch; begin - // intentionally left blank end; procedure TBoldDBISAMQuery.FailSQLBatch; begin - // intentionally left blank end; procedure TBoldDBISAMQuery.Open; @@ -205,7 +219,7 @@ procedure TBoldDBISAMQuery.Open; except on e: Exception do begin - e.Message := e.Message + BOLDCRLF + 'SQL: ' + Query.SQL.text; // do not localize + e.Message := e.Message + BOLDCRLF + 'SQL: ' + Query.SQL.text; raise; end; end @@ -333,7 +347,7 @@ function TBoldDBISAMDataBase.GetInTransaction: Boolean; function TBoldDBISAMDataBase.GetIsSQLBased: Boolean; begin - result := true; // CHECKME: fDataBase.IsSQLBased; + result := true; end; function TBoldDBISAMDataBase.GetKeepConnection: Boolean; @@ -343,7 +357,7 @@ function TBoldDBISAMDataBase.GetKeepConnection: Boolean; function TBoldDBISAMDataBase.GetLogInPrompt: Boolean; begin - result := false; // CHECKME: fDataBase.LoginPrompt; + result := false; end; procedure TBoldDBISAMDataBase.SetKeepConnection(NewValue: Boolean); @@ -353,7 +367,6 @@ procedure TBoldDBISAMDataBase.SetKeepConnection(NewValue: Boolean); procedure TBoldDBISAMDataBase.SetlogInPrompt(NewValue: Boolean); begin - // DO NOTHING; // CHECKME: fDataBase.LoginPrompt := NewValue; end; constructor TBoldDBISAMDataBase.create(DataBase: TDBISAMDataBase; SQLDataBaseConfig: TBoldSQLDatabaseConfig); @@ -490,6 +503,3 @@ function TBoldDBISAMDataBase.SupportsDefaultColumnValues: Boolean; end; end. - - - diff --git a/Source/Persistence/DBISAM/BoldDatabaseAdapterDBIsam.pas b/Source/Persistence/DBISAM/BoldDatabaseAdapterDBIsam.pas index 5a51b7d9..f2c1b4bc 100644 --- a/Source/Persistence/DBISAM/BoldDatabaseAdapterDBIsam.pas +++ b/Source/Persistence/DBISAM/BoldDatabaseAdapterDBIsam.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDatabaseAdapterDBISAM; interface @@ -24,8 +27,8 @@ TBoldDatabaseAdapterDBISAM = class(TBoldAbstractDatabaseAdapter) procedure ReleaseBoldDatabase; override; function GetDataBaseInterface: IBoldDatabase; override; public - constructor Create(aOwner: TComponent); override; - destructor Destroy; override; + constructor create(aOwner: TComponent); override; + destructor destroy; override; published property DataBase: TDBISAMDataBase read GetDataBase write SetDataBase; {$IFNDEF T2H} @@ -37,10 +40,9 @@ implementation uses SysUtils, - BoldDefs, - DBISAMConsts; + BoldDefs; -{ TBoldDatabaseAdapterDBISAM } +{ TBoldDatabaseAdapterDBISAM } constructor TBoldDatabaseAdapterDBISAM.create(aOwner: TComponent); begin @@ -53,7 +55,7 @@ destructor TBoldDatabaseAdapterDBISAM.destroy; Changed; FreePublisher; FreeAndNil(fBoldDatabase); - inherited; + inherited; end; function TBoldDatabaseAdapterDBISAM.GetDataBase: TDBISAMDataBase; @@ -64,7 +66,7 @@ function TBoldDatabaseAdapterDBISAM.GetDataBase: TDBISAMDataBase; function TBoldDatabaseAdapterDBISAM.GetDataBaseInterface: IBoldDatabase; begin if not assigned(Database) then - raise EBold.CreateFmt(sAdapterNotConnected, [classname]); + raise EBold.CreateFmt('%s.GetDatabaseInterface: The adapter is not connected to a database', [classname]); if not assigned(fBoldDatabase) then fBoldDatabase := TBoldDBISAMDataBase.create(Database, SQLDataBaseConfig); result := fBoldDatabase; @@ -80,4 +82,6 @@ procedure TBoldDatabaseAdapterDBISAM.SetDataBase(const Value: TDBISAMDataBase); InternalDatabase := value; end; +initialization + end. diff --git a/Source/Persistence/DBISAM/BoldPersistenceHandleDBISAM.pas b/Source/Persistence/DBISAM/BoldPersistenceHandleDBISAM.pas index 1c55b11b..92e2b5c4 100644 --- a/Source/Persistence/DBISAM/BoldPersistenceHandleDBISAM.pas +++ b/Source/Persistence/DBISAM/BoldPersistenceHandleDBISAM.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleDBISAM; interface @@ -28,8 +31,8 @@ TBoldPersistenceHandleDBISAM = class(TBoldDBPersistenceHandle) procedure InternalTransferproperties(const target: TBoldPersistenceHandleDB); override; {$ENDIF} public - constructor Create(Owner: TComponent); override; - destructor Destroy; override; + constructor create(Owner: TComponent); override; + destructor destroy; override; function GetDataBaseInterface: IBoldDatabase; override; published property DataBase: TDBISAMDatabase read fDataBase write SetDataBase; @@ -79,7 +82,7 @@ procedure TBoldPersistenceHandleDBISAM.SetDataBase(const Value: TDBISAMDatabase) begin if fDataBase <> Value then begin - CheckInactive('SetDataBase'); // do not localize + CheckInactive('SetDataBase'); fDataBase := Value; if assigned(fDataBase) then fDataBase.FreeNotification(self); @@ -97,14 +100,14 @@ procedure TBoldPersistenceHandleDBISAM.InternalTransferproperties( if not assigned(Target.DatabaseAdapter) then begin Target.DatabaseAdapter := TBoldDatabaseAdapterDBISAM.Create(Target.Owner); - Target.DatabaseAdapter.Name := GetNewComponentName(Target.DatabaseAdapter, 'BoldDatabaseAdapterDBISAM'); // do not localize - LongRec(DesInfo).Lo := LongRec(DesInfo).lo+16; //set Left - LongRec(DesInfo).Hi := LongRec(DesInfo).hi+16; //Set Top; + Target.DatabaseAdapter.Name := GetNewComponentName(Target.DatabaseAdapter, 'BoldDatabaseAdapterDBISAM'); + LongRec(DesInfo).Lo := LongRec(DesInfo).lo+16; + LongRec(DesInfo).Hi := LongRec(DesInfo).hi+16; Target.DatabaseAdapter.DesignInfo := DesInfo; - showmessage(sCreatedNewAdapter); + showmessage('Created a new DatabaseAdapterDBISAM'); end else if not (target.DatabaseAdapter is tBoldDatabaseAdapterDBISAM) then - raise Exception.CreateFmt(sCannotTransferProperties, [target.DatabaseAdapter.ClassName] ); + raise Exception.CreateFmt('The persistencehandle is connected to a %s, properties can only be transfered to a TBoldDatabaseAdapterDBISAM', [target.DatabaseAdapter.ClassName] ); Adapter := target.DatabaseAdapter as tBoldDatabaseAdapterDBISAM; if assigned(fDatabase) then @@ -113,14 +116,13 @@ procedure TBoldPersistenceHandleDBISAM.InternalTransferproperties( if not assigned(Adapter.Database) then begin Adapter.DataBase := TDBISAMDatabase.Create(Target.owner); - Adapter.DataBase.Name := GetNewComponentName(Adapter.DataBase, 'Database'); // do not localize - showmessage(sCreatedDB); - LongRec(DesInfo).Lo := LongRec(DesInfo).lo+16; //set Left - LongRec(DesInfo).Hi := LongRec(DesInfo).hi+16; //Set Top; + Adapter.DataBase.Name := GetNewComponentName(Adapter.DataBase, 'Database'); + showmessage('Created a new Database'); + LongRec(DesInfo).Lo := LongRec(DesInfo).lo+16; + LongRec(DesInfo).Hi := LongRec(DesInfo).hi+16; Adapter.DataBase.DesignInfo := DesInfo; end; end; -end. - +end. diff --git a/Source/Persistence/DBISAM/BoldPersistenceHandleDBISAMReg.pas b/Source/Persistence/DBISAM/BoldPersistenceHandleDBISAMReg.pas index 603ce8de..35848067 100644 --- a/Source/Persistence/DBISAM/BoldPersistenceHandleDBISAMReg.pas +++ b/Source/Persistence/DBISAM/BoldPersistenceHandleDBISAMReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleDBISAMReg; interface @@ -11,16 +14,22 @@ implementation uses SysUtils, Classes, + BoldIDESupport, + BoldVersionInfo, BoldDatabaseAdapterDBIsam, BoldPersistenceHandleDBISAM, - BoldIDESupport, - BoldIDEConsts; + BoldIDEConsts; procedure Register; begin - RemovePackageFromDisabledPackagesRegistry(format('BoldDBISAM%s', [LIBSUFFIX])); // do not localize + RemovePackageFromDisabledPackagesRegistry(format('Bold%d%d%sDOA', [ + BoldBuildVersionNumberMajor, + BoldBuildVersionNumberMinor, + BoldBuildTarget])); RegisterComponents(BOLDPAGENAME_DEPRECATED, [TBoldPersistenceHandleDBISAM]); RegisterComponents(BOLDPAGENAME_PERSISTENCE, [TBoldDatabaseAdapterDBISAM]); end; +initialization + end. diff --git a/Source/Persistence/DBISAM/DBISAMConsts.pas b/Source/Persistence/DBISAM/DBISAMConsts.pas index c94a822e..c60b1458 100644 --- a/Source/Persistence/DBISAM/DBISAMConsts.pas +++ b/Source/Persistence/DBISAM/DBISAMConsts.pas @@ -12,4 +12,4 @@ interface implementation -end. \ No newline at end of file +end. diff --git a/Source/Persistence/DOA/BoldDOAInterfaces.pas b/Source/Persistence/DOA/BoldDOAInterfaces.pas index cd3931f2..2a0d57c2 100644 --- a/Source/Persistence/DOA/BoldDOAInterfaces.pas +++ b/Source/Persistence/DOA/BoldDOAInterfaces.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDOAInterfaces; interface @@ -5,7 +8,6 @@ interface uses Classes, Db, - Contnrs, Oracle, OracleTypes, OracleData, @@ -17,22 +19,12 @@ interface { forward declarations } TBoldDOADataBase = class; TBoldDOAQuery = class; - TLobValues = class - private - FLOB:TLoblocator; - FValue:TBlobData; - public - constructor Create(aLOB:TLOBLocator;const aValue:TBlobData); - destructor Destroy; override; - end; -// TBoldDOATable = class; { TBoldDOAQuery } TBoldDOAQuery = class(TBoldDataSetWrapper, IBoldQuery, IBoldParameterized) private fQuery: TOracleDataSet; - fLOBList:TObjectList; function GetQuery: TOracleDataSet; procedure AssignParams(SourceParams: TParams); function GetParamCount: integer; @@ -42,7 +34,9 @@ TBoldDOAQuery = class(TBoldDataSetWrapper, IBoldQuery, IBoldParameterized) procedure SetRequestLiveQuery(NewValue: Boolean); function GetSQLText: String; procedure AssignSQL(SQL: TStrings); - procedure AssignSQLText(SQL: String); + procedure AssignSQLText(const SQL: String); + function GetParamCheck: Boolean; + procedure SetParamCheck(value: Boolean); function GetRecordCount: integer; function Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; protected @@ -50,26 +44,24 @@ TBoldDOAQuery = class(TBoldDataSetWrapper, IBoldQuery, IBoldParameterized) procedure ClearParams; property Query: TOracleDataSet read GetQuery; procedure Open; override; - procedure BuildVariables; - procedure Clear; public constructor Create(Query: TOracleDataSet; DatabaseWrapper: TBoldDatabaseWrapper); virtual; - destructor Destroy; override; end; TBoldDOAExecQuery = class(TBoldNonRefCountedObject, IBoldExecQuery, IBoldParameterized) private fQuery: TOracleQuery; fDatabase: TBoldDOADatabase; - fLOBList:TObjectList; procedure ClearParams; procedure AssignParams(SourceParams: TParams); function ParamByName(const Value: string): IBoldParameter; function GetParamCount: integer; function GetSQLText: String; function GetParams(i:integer): IBoldParameter; - procedure AssignSQL(SQL: TStrings); + procedure AssignSQL(const SQL: TStrings); procedure AssignSQLText(SQL: String); + function GetParamCheck: Boolean; + procedure SetParamCheck(value: Boolean); procedure StartSQLBatch; procedure EndSQLBatch; procedure FailSQLBatch; @@ -78,12 +70,8 @@ TBoldDOAExecQuery = class(TBoldNonRefCountedObject, IBoldExecQuery, IBoldParam function GetRowsAffected: integer; function GetImplementor: TObject; property Query: TOracleQuery read fQuery; - protected - procedure BuildVariables; - procedure Clear; public constructor Create(Query: TOracleQuery; Database: TBoldDOADatabase); - destructor Destroy; override; end; { TBoldADOParameter } @@ -129,6 +117,8 @@ TBoldDOAParameter = class(TBoldRefCountedObject, IBoldParameter) constructor create(Query: TBoldDOAQuery; ExecQuery: TBoldDOAExecQuery; ParamIndex: integer; ParamName: String); end; + + { TBoldDOADataBase } TBoldDOADataBase = class(TBoldDatabaseWrapper, IBoldDataBase) private @@ -147,8 +137,6 @@ TBoldDOADataBase = class(TBoldDatabaseWrapper, IBoldDataBase) procedure RollBack; procedure Open; procedure Close; - function GetTable: IBoldTable; - procedure ReleaseTable(var Table: IBoldTable); function SupportsTableCreation: Boolean; procedure ReleaseCachedObjects; protected @@ -157,9 +145,11 @@ TBoldDOADataBase = class(TBoldDatabaseWrapper, IBoldDataBase) procedure ReleaseQuery(var Query: IBoldQuery); override; function GetExecQuery: IBoldExecQuery; override; procedure ReleaseExecQuery(var Query: IBoldExecQuery); override; + function GetTable: IBoldTable; override; + procedure ReleaseTable(var Table: IBoldTable); override; public - constructor Create(DataBase: TOracleSession; SQLDataBaseConfig: TBoldSQLDatabaseConfig); - destructor Destroy; override; + constructor create(DataBase: TOracleSession; SQLDataBaseConfig: TBoldSQLDatabaseConfig); + destructor destroy; override; end; implementation @@ -168,9 +158,7 @@ implementation Variants, BoldDefs, SysUtils, - OracleCI, - BoldUtils, - DOAConsts; + BoldUtils; function FieldTypeToOracleType(FieldType: TFieldType): integer; begin @@ -234,6 +222,9 @@ function OracleTypeToFieldType(OracleType: Integer): TFieldType; end; end; + + + { TBoldDOAQuery } procedure TBoldDOAQuery.AssignParams(Sourceparams: tparams); @@ -251,6 +242,11 @@ function TBoldDOAQuery.GetQuery: TOracleDataSet; result := fQuery; end; +function TBoldDOAQuery.GetParamCheck: Boolean; +begin + Result := Query.ParamCheck; +end; + function TBoldDOAQuery.GetParamCount: integer; begin result := Query.Variables.count; @@ -263,7 +259,6 @@ function TBoldDOAQuery.GetParams(I: integer): IBoldParameter; function TBoldDOAQuery.GetREquestLiveQuery: Boolean; begin - // FIXME: Query.RequestLive; result := true; end; @@ -272,17 +267,16 @@ function TBoldDOAQuery.ParamByName(const Value: string): IBoldParameter; i: integer; begin i := Query.VariableIndex(value); - if i = -1 then - begin - BuildVariables; - i := Query.VariableIndex(value); - end; result := TBoldDOAParameter.Create(self, nil, i, value) end; +procedure TBoldDOAQuery.SetParamCheck(value: Boolean); +begin + Query.ParamCheck := Value; +end; + procedure TBoldDOAQuery.SetRequestLiveQuery(NewValue: Boolean); begin - //FIXME: Query.RequestLive := NewValue; ; end; @@ -295,6 +289,7 @@ constructor TBoldDOAQuery.Create(Query: TOracleDataSet; DatabaseWrapper: TBoldDa begin inherited Create(DatabaseWrapper); fQuery := Query; + SetParamCheck(true); end; procedure TBoldDOAQuery.Open; @@ -305,7 +300,7 @@ procedure TBoldDOAQuery.Open; except on e: Exception do begin - e.Message := e.Message + BOLDCRLF + 'SQL: ' + Query.SQL.text; // do not localize + e.Message := e.Message + BOLDCRLF + 'SQL: ' + Query.SQL.text; raise; end; end @@ -318,7 +313,7 @@ procedure TBoldDOAQuery.AssignSQL(SQL: TStrings); Query.SQL.EndUpdate; end; -procedure TBoldDOAQuery.AssignSQLText(SQL: String); +procedure TBoldDOAQuery.AssignSQLText(const SQL: String); begin Query.SQL.BeginUpdate; Query.SQL.Clear; @@ -347,25 +342,6 @@ procedure TBoldDOAQuery.ClearParams; query.DeleteVariables; end; -procedure TBoldDOAQuery.BuildVariables; -var - VarList: TStringList; - i : integer; -begin - VarList := Oracle.FindVariables(Query.SQL.Text, False); - for i := 0 to VarList.Count - 1 do Query.DeclareVariable(VarList[i], otString); -end; - -procedure TBoldDOAQuery.Clear; -begin - Query.DeleteVariables; - FLoblist.Clear; -end; -destructor TBoldDOAQuery.Destroy; -begin - FLobList.Free; - inherited; -end; { TBoldDOADataBase } procedure TBoldDOADataBase.AllTableNames(Pattern: String; ShowSystemTables: Boolean; TableNameList: TStrings); @@ -376,14 +352,14 @@ procedure TBoldDOADataBase.AllTableNames(Pattern: String; ShowSystemTables: Bool aQuery := TOracleDataset.Create(nil); aQuery.Session := fDataBase; SQL := - 'select owner, table_name, tablespace_name '+ // do not localize - 'from all_tables '; // do not localize + 'select owner, table_name, tablespace_name '+ + 'from all_tables '; if not ShowSystemTables then SQL := SQL + - 'where owner <> ''SYSTEM'' and owner <> ''DBSNMP'' and owner <> ''ORDSYS'' and '+ // do not localize - 'owner <> ''OUTLN'' and owner <> ''SYS'' and owner <> ''MDSYS'' and owner <> ''MTSSYS'' '; // do not localize - SQL := SQL + 'order by owner, table_name, tablespace_name'; // do not localize + 'where owner <> ''SYSTEM'' and owner <> ''DBSNMP'' and owner <> ''ORDSYS'' and '+ + 'owner <> ''OUTLN'' and owner <> ''SYS'' and owner <> ''MDSYS'' and owner <> ''MTSSYS'' '; + SQL := SQL + 'order by owner, table_name, tablespace_name'; aQuery.SQL.Text := SQL; aQuery.Open; while not aQuery.Eof do @@ -407,24 +383,20 @@ function TBoldDOADataBase.GetIsSQLBased: Boolean; function TBoldDOADataBase.GetKeepConnection: Boolean; begin - // FIXME: result := fDataBase.KeepConnection; result := true end; function TBoldDOADataBase.GetLogInPrompt: Boolean; begin - //FIXME: result := fDataBase.LoginPrompt; result := true; end; procedure TBoldDOADataBase.SetKeepConnection(NewValue: Boolean); begin - // FIXME: fDataBase.KeepConnection := NewValue; end; procedure TBoldDOADataBase.SetlogInPrompt(NewValue: Boolean); begin - // FIXME: fDataBase.LoginPrompt := NewValue; end; constructor TBoldDOADataBase.create(DataBase: TOracleSession; SQLDataBaseConfig: TBoldSQLDatabaseConfig); @@ -477,7 +449,6 @@ destructor TBoldDOADataBase.destroy; begin inherited; fDatabase := nil; -// FreeAndNil(fCachedTable); FreeAndNil(fCachedQuery); FreeAndNil(fCachedExecQuery); end; @@ -501,7 +472,7 @@ function TBoldDOADataBase.GetQuery: IBoldQuery; function TBoldDOADataBase.GetTable: IBoldTable; begin - raise EBold.CreateFmt(sIBoldTablesNotSupported, [classname, 'GetTable']); // do not localize + raise EBold.CreateFmt('%s.GetTable: DOA-Implementation does not support IBoldTables', [classname]); end; { var @@ -545,7 +516,7 @@ procedure TBoldDOADataBase.ReleaseQuery(var Query: IBoldQuery); procedure TBoldDOADataBase.ReleaseTable(var Table: IBoldTable); begin - raise EBold.CreateFmt(sIBoldTablesNotSupported, [classname, 'ReleaseTable']); // do not localize + raise EBold.CreateFmt('%s.ReleaseTable: DOA-Implementation does not support IBoldTables', [classname]); end; { var @@ -571,7 +542,6 @@ function TBoldDOADataBase.SupportsTableCreation: Boolean; procedure TBoldDOADataBase.ReleaseCachedObjects; begin -// FreeAndNil(fCachedTable); FreeAndNil(fCachedQuery); FreeAndNil(fCachedExecQuery); end; @@ -610,8 +580,10 @@ procedure TBoldDOADataBase.ReleaseExecQuery(var Query: IBoldExecQuery); DOAExecQuery.fQuery.free; DOAExecQuery.Free; end; + end; + { TBoldDOAParameter } procedure TBoldDOAParameter.AssignFieldValue(source: IBoldField); @@ -637,17 +609,15 @@ constructor TBoldDOAParameter.create(Query: TBoldDOAQuery; ExecQuery: TBoldDOAEx procedure TBoldDOAParameter.EnsureParameter(fieldType: TFieldType); begin - if fieldType <> ftUnknown then + if fParamIndex = -1 then begin if assigned(fQuery) then begin - FQuery.Query.DeleteVariable(fParamName); fQuery.Query.DeclareVariable(fParamName, FieldTypeToOracleType(FieldType)); fParamIndex := fQuery.Query.VariableIndex(fParamName); end else begin - fExecQuery.Query.DeleteVariable(fParamName); fExecQuery.Query.DeclareVariable(fParamName, FieldTypeToOracleType(FieldType)); fParamIndex := fExecQuery.Query.VariableIndex(fParamName); end; @@ -744,22 +714,12 @@ procedure TBoldDOAParameter.SetAsBCD(const Value: Currency); end; procedure TBoldDOAParameter.SetAsBlob(const Value: TBlobData); -var - LOB:TLOBLocator; begin EnsureParameter(ftBlob); - if assigned(fQuery) then - begin - LOB := TLOBLocator.Create(fQuery.Query.Session,otBlob); - FQuery.Query.SetComplexVariable(fQuery.Query.VariableName(fParamIndex),LOB); - end + if value = '' then + SetAsVariant(GetDatabaseWrapper.SQLDatabaseConfig.EmptyStringMarker) else - begin - LOB := TLOBLocator.CreateTemporary(fExecQuery.Query.Session,otBlob,True); - LOB.Write(Value[1],Length(Value)); - fExecQuery.Query.SetComplexVariable(fExecQuery.Query.VariableName(fParamIndex),LOB); - FExecQuery.fLOBList.Add(TLobValues.Create(LOB,value)) - end; + SetAsVariant(Value); end; procedure TBoldDOAParameter.SetAsBoolean(Value: Boolean); @@ -777,18 +737,13 @@ procedure TBoldDOAParameter.SetAsCurrency(const Value: Currency); procedure TBoldDOAParameter.SetAsDate(const Value: TDateTime); begin EnsureParameter(ftDate); - SetAsDateTime(Value); + SetAsVariant(Value); end; procedure TBoldDOAParameter.SetAsDateTime(const Value: TDateTime); begin EnsureParameter(ftDateTime); - if assigned(fQuery) then - fQuery.Query.SetVariable(fParamIndex, Value) - else - fExecQuery.Query.SetVariable(fParamIndex, Value) - -// SetAsVariant(Value); + SetAsVariant(Value); end; procedure TBoldDOAParameter.SetAsFloat(const Value: Double); @@ -827,7 +782,7 @@ procedure TBoldDOAParameter.SetAsString(const Value: string); procedure TBoldDOAParameter.SetAsTime(const Value: TDateTime); begin EnsureParameter(ftTime); - SetAsDateTime(Value); + SetAsVariant(Value); end; procedure TBoldDOAParameter.SetAsVariant(const NewValue: Variant); @@ -862,7 +817,7 @@ procedure TBoldDOAParameter.SetText(const Value: string); { TBoldDOAExecQuery } -procedure TBoldDOAExecQuery.AssignSQL(SQL: TStrings); +procedure TBoldDOAExecQuery.AssignSQL(const SQL: TStrings); begin Query.SQL.Assign(SQL); end; @@ -875,14 +830,13 @@ procedure TBoldDOAExecQuery.AssignSQLText(SQL: String); procedure TBoldDOAExecQuery.ClearParams; begin query.DeleteVariables; - FLobList.Clear; end; constructor TBoldDOAExecQuery.Create(Query: TOracleQuery; Database: TBoldDOADatabase); begin fQuery := Query; fDatabase := Database; - FLobList := TObjectList.Create; + SetParamCheck(true); end; function TBoldDOAExecQuery.Createparam(FldType: TFieldType; @@ -895,12 +849,10 @@ function TBoldDOAExecQuery.Createparam(FldType: TFieldType; procedure TBoldDOAExecQuery.EndSQLBatch; begin - // Do nothing end; procedure TBoldDOAExecQuery.FailSQLBatch; begin - // Do nothing end; function TBoldDOAExecQuery.GetImplementor: TObject; @@ -908,6 +860,11 @@ function TBoldDOAExecQuery.GetImplementor: TObject; result := Query; end; +function TBoldDOAExecQuery.GetParamCheck: Boolean; +begin + Query.ParamCheck := Value; +end; + function TBoldDOAExecQuery.GetParamCount: integer; begin result := Query.VariableCount; @@ -934,11 +891,6 @@ function TBoldDOAExecQuery.ParamByName( i: integer; begin i := Query.VariableIndex(value); - if i = -1 then - begin - BuildVariables; - i := Query.VariableIndex(value); - end; result := TBoldDOAParameter.Create(nil, self, i, Value) end; @@ -947,19 +899,22 @@ procedure TBoldDOAExecQuery.ExecSQL; BoldLogSQL(fQuery.SQL); try fQuery.Execute; - fQuery.Close; except on e: Exception do begin - e.Message := e.Message + BOLDCRLF + 'SQL: ' + fQuery.SQL.text; // do not localize + e.Message := e.Message + BOLDCRLF + 'SQL: ' + fQuery.SQL.text; raise; end; end end; +procedure TBoldDOAExecQuery.SetParamCheck(value: Boolean); +begin + Query.ParamCheck := Value; +end; + procedure TBoldDOAExecQuery.StartSQLBatch; begin - // do nothing end; procedure TBoldDOAExecQuery.AssignParams(SourceParams: TParams); @@ -970,41 +925,4 @@ procedure TBoldDOAExecQuery.AssignParams(SourceParams: TParams); Query.Variables.list.Clear; end; -procedure TBoldDOAExecQuery.BuildVariables; -var - VarList: TStringList; - i : integer; -begin - VarList := Oracle.FindVariables(Query.SQL.Text, False); - for i := 0 to VarList.Count - 1 do Query.DeclareVariable(VarList[i], otString); -end; - -procedure TBoldDOAExecQuery.Clear; -begin - Query.DeleteVariables; - FLoblist.Clear; -end; - -destructor TBoldDOAExecQuery.Destroy; -begin - FLobList.Free; - inherited; -end; - -{ TLobValues } - -constructor TLobValues.Create(aLOB: TLOBLocator;const aValue: TBlobData); -begin - inherited Create; - FLOB := aLOB; - FValue := aValue; -end; - -destructor TLobValues.Destroy; -begin - FLOB.Free; - inherited Destroy; -end; - -initialization end. diff --git a/Source/Persistence/DOA/BoldDatabaseAdapterDOA.pas b/Source/Persistence/DOA/BoldDatabaseAdapterDOA.pas index 3b23dc6e..f9e50427 100644 --- a/Source/Persistence/DOA/BoldDatabaseAdapterDOA.pas +++ b/Source/Persistence/DOA/BoldDatabaseAdapterDOA.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDatabaseAdapterDOA; interface @@ -22,7 +25,7 @@ TBoldDatabaseAdapterDOA = class(TBoldAbstractDatabaseAdapter) procedure ReleaseBoldDatabase; override; function GetDataBaseInterface: IBoldDatabase; override; public - destructor Destroy; override; + destructor destroy; override; published property DataBase: TOracleSession read GetDataBase write SetDataBase; {$IFNDEF T2H} @@ -34,17 +37,16 @@ implementation uses SysUtils, - BoldDefs, - DOAConsts; + BoldDefs; -{ TBoldDatabaseAdapterDOA } +{ TBoldDatabaseAdapterDOA } destructor TBoldDatabaseAdapterDOA.destroy; begin Changed; FreePublisher; FreeAndNil(fBoldDatabase); - inherited; + inherited; end; function TBoldDatabaseAdapterDOA.GetDataBase: TOracleSession; @@ -55,7 +57,7 @@ function TBoldDatabaseAdapterDOA.GetDataBase: TOracleSession; function TBoldDatabaseAdapterDOA.GetDataBaseInterface: IBoldDatabase; begin if not assigned(Database) then - raise EBold.CreateFmt(sAdapterNotConnected, [classname]); + raise EBold.CreateFmt('%s.GetDatabaseInterface: The adapter is not connected to an OracleSession', [classname]); if not assigned(fBoldDatabase) then fBoldDatabase := TBoldDOADataBase.create(Database, SQLDataBaseConfig); result := fBoldDatabase; @@ -71,4 +73,6 @@ procedure TBoldDatabaseAdapterDOA.SetDataBase(const Value: TOracleSession); InternalDatabase := value; end; +initialization + end. diff --git a/Source/Persistence/DOA/BoldPersistenceHandleDOA.pas b/Source/Persistence/DOA/BoldPersistenceHandleDOA.pas index f3fbfefe..fef9518e 100644 --- a/Source/Persistence/DOA/BoldPersistenceHandleDOA.pas +++ b/Source/Persistence/DOA/BoldPersistenceHandleDOA.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleDOA; interface @@ -24,7 +27,7 @@ TBoldPersistenceHandleDOA = class(TBoldDBPersistenceHandle) procedure SetPassword(const Value: string); override; procedure SetUserName(const Value: string); override; public - destructor Destroy; override; + destructor destroy; override; function GetDataBaseInterface: IBoldDatabase; override; published property OracleSession: TOracleSession read fOracleSession write SetOracleSession; @@ -33,7 +36,8 @@ TBoldPersistenceHandleDOA = class(TBoldDBPersistenceHandle) implementation uses - SysUtils; + SysUtils, + BoldRev; { TBoldPersistenceHandleDOA } @@ -49,12 +53,13 @@ function TBoldPersistenceHandleDOA.GetDataBaseInterface: IBoldDatabase; if not assigned(fDataBaseAdapter) then begin if not assigned(fOracleSession) then - raise Exception.CreateFmt(sNoOracleSession, [classname]); + raise Exception.CreateFmt('%s.GetDatabaseInterface: There is no OracleSession, can''t create a database interface', [classname]); fDataBaseAdapter := TBoldDOADataBase.create(fOracleSession, SQLDataBaseConfig); end; result := fDataBaseAdapter; end; + procedure TBoldPersistenceHandleDOA.Notification(AComponent: TComponent; Operation: TOperation); begin @@ -71,7 +76,7 @@ procedure TBoldPersistenceHandleDOA.SetOracleSession(const NewValue: TOracleSess begin if fOracleSession <> NewValue then begin - CheckInactive('SetDataBase'); // do not localize + CheckInactive('SetDataBase'); fOracleSession := NewValue; if assigned(fOracleSession) then fOracleSession.FreeNotification(self); @@ -80,12 +85,14 @@ procedure TBoldPersistenceHandleDOA.SetOracleSession(const NewValue: TOracleSess procedure TBoldPersistenceHandleDOA.SetPassword(const Value: string); begin - raise Exception.CreateFmt(sSetOnOracleSession, [classname, 'SetPassword']); // do not localize + raise Exception.CreateFmt('%s.SetPassword: Not supported, set the password directly on your OracleSession-object', [classname]); end; procedure TBoldPersistenceHandleDOA.SetUserName(const Value: string); begin - raise Exception.CreateFmt(sSetOnOracleSession, [classname, 'SetUserName']); // do not localize + raise Exception.CreateFmt('%s.SetUserName: Not supported, set the Username directly on your OracleSession-object', [classname]); end; +initialization + end. diff --git a/Source/Persistence/DOA/BoldPersistenceHandleDOAReg.pas b/Source/Persistence/DOA/BoldPersistenceHandleDOAReg.pas index 32c855c3..39114478 100644 --- a/Source/Persistence/DOA/BoldPersistenceHandleDOAReg.pas +++ b/Source/Persistence/DOA/BoldPersistenceHandleDOAReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleDOAReg; interface @@ -11,16 +14,22 @@ implementation uses Classes, SysUtils, - BoldDatabaseAdapterDOA, BoldPersistenceHandleDOA, BoldIDESupport, + BoldVersionInfo, + BoldDatabaseAdapterDOA, BoldIDEConsts; procedure Register; begin - RemovePackageFromDisabledPackagesRegistry(format('BoldDOA%s', [LIBSUFFIX])); // do not localize + RemovePackageFromDisabledPackagesRegistry(format('Bold%d%d%sDOA', [ + BoldBuildVersionNumberMajor, + BoldBuildVersionNumberMinor, + BoldBuildTarget])); RegisterComponents(BOLDPAGENAME_DEPRECATED, [TBoldPersistenceHandleDOA]); RegisterComponents(BOLDPAGENAME_PERSISTENCE, [TBoldDatabaseAdapterDOA]); end; +initialization + end. diff --git a/Source/Persistence/DOA/DOAConsts.pas b/Source/Persistence/DOA/DOAConsts.pas index 7e3e4496..3a6216e9 100644 --- a/Source/Persistence/DOA/DOAConsts.pas +++ b/Source/Persistence/DOA/DOAConsts.pas @@ -17,4 +17,4 @@ interface implementation -end. \ No newline at end of file +end. diff --git a/Source/Persistence/ExternalPersistence/BoldAbstractExternalPersistenceController.pas b/Source/Persistence/ExternalPersistence/BoldAbstractExternalPersistenceController.pas index c7c5f217..ad5eacf1 100644 --- a/Source/Persistence/ExternalPersistence/BoldAbstractExternalPersistenceController.pas +++ b/Source/Persistence/ExternalPersistence/BoldAbstractExternalPersistenceController.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAbstractExternalPersistenceController; interface @@ -21,7 +24,7 @@ TBoldAbstractExternalPersistenceController = class(TBoldPersistenceControllerP FOnStartUpdates: TNotifyEvent; FOnEndUpdates: TNotifyEvent; fOnFailUpdates: TNotifyEvent; - + fUpdateBoldDatabaseFirst: boolean; procedure SplitObjects(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; ObjectsToPassAlong, ObjectsToHandle: TBoldObjectIdList; var CommonClass: TMoldClass); protected procedure PrepareFetch(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MoldClass: TMoldClass; MemberIdList: TBoldMemberIdList; var FetchContext: TObject); virtual; @@ -45,14 +48,14 @@ TBoldAbstractExternalPersistenceController = class(TBoldPersistenceControllerP property MaxFetchBlockSize: integer read GetMaxFetchBlockSize; public - constructor Create(MoldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; OnStartUpdates, OnEndUpdates, OnFailUpdates: TNotifyEvent); - procedure PMExactifyIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; + constructor Create(MoldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; OnStartUpdates, OnEndUpdates, OnFailUpdates: TNotifyEvent; AUpdateBoldDatabaseFirst: boolean); + procedure PMExactifyIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; HandleNonExisting: Boolean); override; procedure PMFetch(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; BoldClientID: TBoldClientID); override; procedure PMFetchIDListWithCondition(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; FetchMode: Integer; Condition: TBoldCondition; BoldClientID: TBoldClientID); override; - procedure PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; BoldClientID: TBoldClientID); override; + procedure PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; var TimeOfLatestUpdate: TDateTime; BoldClientID: TBoldClientID); override; function KeyForObject(ObjectContents: IBoldObjectContents): IBoldValue; function ValueForObject(ObjectContents: IBoldObjectContents; MemberExpressionName: string): IBoldValue; - + property UpdateBoldDatabaseFirst: boolean read fUpdateBoldDatabaseFirst; end; @@ -66,7 +69,7 @@ implementation { TBoldAbstractExternalPersistenceController } -constructor TBoldAbstractExternalPersistenceController.Create(MoldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; OnStartUpdates, OnEndUpdates, OnFailUpdates: TNotifyEvent); +constructor TBoldAbstractExternalPersistenceController.Create(MoldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; OnStartUpdates, OnEndUpdates, OnFailUpdates: TNotifyEvent; AUpdateBoldDatabaseFirst: boolean); begin inherited Create; fMoldModel := MoldModel; @@ -75,11 +78,12 @@ constructor TBoldAbstractExternalPersistenceController.Create(MoldModel: TMoldMo FOnStartUpdates := OnStartUpdates; fOnFailUpdates := OnFailUpdates; FOnEndUpdates := OnEndUpdates; + FUpdateBoldDatabaseFirst := AUpdateBoldDatabaseFirst; end; procedure TBoldAbstractExternalPersistenceController.PMExactifyIds( ObjectIdList: TBoldObjectIdList; - TranslationList: TBoldIdTranslationList); + TranslationList: TBoldIdTranslationList; HandleNonExisting: Boolean); begin inherited; end; @@ -117,12 +121,13 @@ procedure TBoldAbstractExternalPersistenceController.PMFetch( if MembersToHandle.Count = 0 then ObjectsToHandle.Clear; end; - - // only call inherited fetch if there is anything to fetch from the internal database if (ObjectsToPassAlong.Count > 0) and (not assigned(MembersToPAssAlong) or (MembersToPassAlong.Count > 0)) then inherited PMFetch(ObjectsToPassAlong, Valuespace, MembersToPassAlong, FetchMode, BoldClientId); - EnsureObjectsforFetch(ObjectsToHandle, ValueSpace, MembersToHandle); - FetchObjects(ObjectsToHandle, ValueSpace, MembersToHandle); + if ObjectsToHandle.count > 0 then + begin + EnsureObjectsforFetch(ObjectsToHandle, ValueSpace, MembersToHandle); + FetchObjects(ObjectsToHandle, ValueSpace, MembersToHandle); + end; end; procedure TBoldAbstractExternalPersistenceController.PMFetchIDListWithCondition( @@ -148,7 +153,7 @@ procedure TBoldAbstractExternalPersistenceController.PMUpdate( ObjectIdList: TBoldObjectIdList; ValueSpace, Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; - var TimeStamp: TBoldTimeStampType; BoldClientID: TBoldClientID); + var TimeStamp: TBoldTimeStampType; var TimeOfLatestUpdate: TDateTime; BoldClientID: TBoldClientID); var i: integer; ObjectsToHandle, @@ -157,7 +162,7 @@ procedure TBoldAbstractExternalPersistenceController.PMUpdate( SuperClass: TMoldClass; ObjectsToCreate, ObjectsToDelete, ObjectsToUpdate: TBoldObjectidList; ObjectContents: IBoldObjectContents; - + lNeedsExternalTransaction: boolean; begin Guard := TBoldGuard.Create( ObjectsToHandle, ObjectsToPassAlong, @@ -183,16 +188,38 @@ procedure TBoldAbstractExternalPersistenceController.PMUpdate( end else ObjectsToUpdate.Add(ObjectsTohandle[i]); end; - StartUpdates; + lNeedsExternalTransaction := ((ObjectsToCreate.Count + ObjectsToDelete.count + ObjectsToUpdate.count) > 0); + if lNeedsExternalTransaction then + begin + StartUpdates; + StartTransaction; + end; try + if UpdateBoldDatabaseFirst then + begin + inherited PMUpdate(ObjectsToPassAlong, ValueSpace, Old_Values, Precondition, TranslationList, TimeStamp, TimeOfLatestUpdate, BoldClientId); + ObjectsToCreate.ApplyTranslationList(TranslationList); + end; CreateObjects(ObjectsToCreate, ValueSpace); DeleteObjects(ObjectsToDelete, ValueSpace); UpdateObjects(ObjectsToUpdate, ValueSpace); - - inherited PMUpdate(ObjectsToPassAlong, ValueSpace, Old_Values, Precondition, TranslationList, TimeStamp, BoldClientId); - EndUpdates; + if not UpdateBoldDatabaseFirst then + begin + inherited PMUpdate(ObjectsToPassAlong, ValueSpace, Old_Values, Precondition, TranslationList, TimeStamp, TimeOfLatestUpdate, BoldClientId); + end; + if lNeedsExternalTransaction then + begin + EndUpdates; + CommitTransaction; + end; except - FailUpdates; + if lNeedsExternalTransaction then + try + FailUpdates; + finally + RollbackTransaction; + end; + raise; end; end; @@ -352,7 +379,7 @@ procedure TBoldAbstractExternalPersistenceController.FetchObjects( ActionList: TBoldObjectIdList; FetchContext: TObject; MoldClass: TMoldClass; - + procedure AddToActionList(index: integer); begin ActionList.Add(IdList[index]); @@ -363,7 +390,7 @@ procedure TBoldAbstractExternalPersistenceController.FetchObjects( ActionList := TBoldObjectIdList.Create; TranslationList := TBoldIdTranslationList.Create; - PMExactifyIds(ObjectIdList, TranslationList); + PMExactifyIds(ObjectIdList, TranslationList, false); IdList := ObjectIdList.Clone; IdList.ApplyTranslationList(TranslationList); @@ -392,12 +419,10 @@ procedure TBoldAbstractExternalPersistenceController.FetchObjects( procedure TBoldAbstractExternalPersistenceController.PostFetch( FetchContext: TObject; MoldClass: TMoldClass); begin - // intentionally left blank end; procedure TBoldAbstractExternalPersistenceController.PrepareFetch(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MoldClass: TMoldClass; MemberIdList: TBoldMemberIdList; var FetchContext: TObject); begin - // intentionally left blank end; function TBoldAbstractExternalPersistenceController.GetMaxFetchBlockSize: integer; @@ -411,4 +436,6 @@ procedure TBoldAbstractExternalPersistenceController.FailUpdates; fOnFailUpdates(self); end; +initialization + end. diff --git a/Source/Persistence/ExternalPersistence/BoldAbstractExternalPersistenceHandle.pas b/Source/Persistence/ExternalPersistence/BoldAbstractExternalPersistenceHandle.pas index 5f602b0f..80945dc0 100644 --- a/Source/Persistence/ExternalPersistence/BoldAbstractExternalPersistenceHandle.pas +++ b/Source/Persistence/ExternalPersistence/BoldAbstractExternalPersistenceHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAbstractExternalPersistenceHandle; interface @@ -9,6 +12,7 @@ interface BoldPersistenceHandlePTWithModel, BoldAbstractExternalPersistenceController; + type TBoldAbstractExternalPersistenceHandle = class(TBoldPersistenceHandlePassthroughWithModel) private @@ -17,6 +21,7 @@ TBoldAbstractExternalPersistenceHandle = class(TBoldPersistenceHandlePassthrou fOnFailUpdates: TNotifyEvent; FOnActivate: TNotifyEvent; FOnDeActivate: TNotifyEvent; + FUpdateBoldDatabaseFirst: boolean; function GetPersistenceController: TBoldAbstractExternalPersistenceController; protected procedure SetActive(Value: Boolean); override; @@ -36,13 +41,16 @@ TBoldAbstractExternalPersistenceHandle = class(TBoldPersistenceHandlePassthrou function IntValueForObject(ObjectContents: IBoldObjectContents; MemberExpressionName: string): Integer; function GetReferredObject(ObjectContents: IBoldObjectContents; MemberExpressionName: string; ValueSpace: IBoldValueSpace): IBoldObjectContents; property PersistenceController: TBoldAbstractExternalPersistenceController read GetPersistenceController; + property UpdateBoldDatabaseFirst: boolean read FUpdateBoldDatabaseFirst write FUpdateBoldDatabaseFirst default false; end; + + implementation uses - BoldDefs, - ExPeConsts; + BoldDefs; + { TBoldAbstractExternalPersistenceHandle } @@ -57,7 +65,7 @@ function TBoldAbstractExternalPersistenceHandle.CurrencyValueForObject( if Value.QueryInterface(IBoldCurrencyContent, Currvalue) = S_OK then result := Currvalue.asCurrency else - raise EBold.createFmt(sValueNotCurrency, [classname, MemberExpressionName]); + raise EBold.createFmt('%s.CurrencyValueForObject: The value (%s) is not a currency', [classname, MemberExpressionName]); end; function TBoldAbstractExternalPersistenceHandle.DateValueForObject( @@ -71,7 +79,7 @@ function TBoldAbstractExternalPersistenceHandle.DateValueForObject( if Value.QueryInterface(IBoldDateContent, Datevalue) = S_OK then result := Datevalue.asDate else - raise EBold.createFmt(sValueNotDate, [classname, MemberExpressionName]); + raise EBold.createFmt('%s.DateValueForObject: The value (%s) is not a date', [classname, MemberExpressionName]); end; function TBoldAbstractExternalPersistenceHandle.GetPersistenceController: TBoldAbstractExternalPersistenceController; @@ -107,7 +115,7 @@ function TBoldAbstractExternalPersistenceHandle.IntValueForObject( if Value.QueryInterface(IBoldIntegerContent, Intvalue) = S_OK then result := Intvalue.asInteger else - raise EBold.createFmt(sValueNotInteger, [classname, MemberExpressionName]); + raise EBold.createFmt('%s.IntValueForObject: The value (%s) is not an integer', [classname, MemberExpressionName]); end; function TBoldAbstractExternalPersistenceHandle.KeyForObject(ObjectContents: IBoldObjectContents): IBoldValue; @@ -125,7 +133,7 @@ function TBoldAbstractExternalPersistenceHandle.KeyIntForObject( if Value.QueryInterface(IBoldIntegerContent, Intvalue) = S_OK then result := Intvalue.asInteger else - raise EBold.createFmt(sKeyNotInteger, [classname]); + raise EBold.createFmt('%s.KeyIntForObject: The key is not an integer', [classname]); end; function TBoldAbstractExternalPersistenceHandle.KeyStringForObject( @@ -138,7 +146,7 @@ function TBoldAbstractExternalPersistenceHandle.KeyStringForObject( if Value.QueryInterface(IBoldStringContent, Strvalue) = S_OK then result := (Value as IBoldStringContent).asString else - raise EBold.createFmt(sKeyNotString, [classname]); + raise EBold.createFmt('%s.KeyStringForObject: The key is not a string', [classname]); end; function TBoldAbstractExternalPersistenceHandle.StringValueForObject( @@ -153,7 +161,7 @@ function TBoldAbstractExternalPersistenceHandle.StringValueForObject( if Value.QueryInterface(IBoldStringContent, StrValue) = S_OK then result := StrValue.asString else - raise EBold.createFmt(sValueNotString, [classname, MemberExpressionName]); + raise EBold.createFmt('%s.StringValueForObject: The value (%s) is not is not a string', [classname, MemberExpressionName]); end; function TBoldAbstractExternalPersistenceHandle.ValueForObject( @@ -179,4 +187,7 @@ procedure TBoldAbstractExternalPersistenceHandle.SetActive(Value: Boolean); end; end; + +initialization + end. diff --git a/Source/Persistence/ExternalPersistence/BoldAbstractPartiallyExternalPC.pas b/Source/Persistence/ExternalPersistence/BoldAbstractPartiallyExternalPC.pas index 0b416ae1..c6a37666 100644 --- a/Source/Persistence/ExternalPersistence/BoldAbstractPartiallyExternalPC.pas +++ b/Source/Persistence/ExternalPersistence/BoldAbstractPartiallyExternalPC.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAbstractPartiallyExternalPC; interface @@ -18,6 +21,7 @@ TBoldAbstractPartiallyExternalPC = class(TBoldAbstractExternalPersistenceContr fDeletedExternalObjects: TBoldObjectIdList; fNewExternalObjects: TBoldObjectIdList; protected + function FetchAllMembersWhenFetchingKey(MoldClass: TMoldClass): boolean; virtual; function ExternalKeyExistsInExternalStorage(MoldClass: TMoldClass; ExternalKey: TBoldObjectId): Boolean; virtual; procedure PrepareFetchExternal(ExternalKeys: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MoldClass: TMoldClass; MemberIdList: TBoldMemberIdList; var FetchContext: TObject); virtual; procedure PrepareFetch(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MoldClass: TMoldClass; MemberIdList: TBoldMemberIdList; var FetchContext: TObject); override; @@ -30,10 +34,11 @@ TBoldAbstractPartiallyExternalPC = class(TBoldAbstractExternalPersistenceContr procedure TranslateInternalIdsToExternal(InternalIds, ExternalKeys: TBoldObjectIdList; ValueSpace: IBoldValueSpace); function ExternalKeysToInternalSQL(MoldClass: TMoldClass; ExternalKeys: TBoldObjectIdList): String; virtual; procedure CreateInternalObject(MoldClass: TMoldClass; ExternalKey: TBoldObjectid; ValueSpace: IBoldValueSpace; Ids: TBoldObjectidList); + procedure CreateInternalObjects(MoldClass: TMoldClass; ExternalIDlist: TBoldObjectIdList; const ValueSpace: IBoldValueSpace; Ids: TBoldObjectidList); procedure FindMoldRoleByName(ObjectContents: IBoldObjectContents; ExpressionName: String; var MoldRole: TMoldRole; var Index: integer); public - constructor Create(MoldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; OnStartUpdates, OnEndUpdates, OnFailUpdates: TNotifyEvent); - destructor Destroy; override; + constructor Create(MoldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; OnStartUpdates, OnEndUpdates, OnFailUpdates: TNotifyEvent; AUpdateBoldDatabaseFirst: boolean); + destructor destroy; override; procedure SetMultiLink(MultiLink: IBoldObjectIdListref; ExternalKeys: TBoldObjectIdList; MoldClassOfOtherEnd: TMoldClass); procedure SetSingleLink(SingleLink: IBoldObjectIdRef; ExternalKey: TBoldObjectId; MoldClassOfOtherEnd: TMoldClass); procedure TranslateExternalKeysToInternalIds(MoldClass: TMoldClass; ExternalKeys, InternalIds: TBoldObjectIdList); @@ -42,7 +47,6 @@ TBoldAbstractPartiallyExternalPC = class(TBoldAbstractExternalPersistenceContr end; implementation - uses BoldGuard, SysUtils, @@ -51,12 +55,11 @@ implementation BoldDefs, BoldTaggedValueSupport, BoldFreeStandingValues, - BoldUtils, - ExPeConsts; - + BoldUtils; + { TBoldAbstractPartiallyExternalPC } -constructor TBoldAbstractPartiallyExternalPC.Create(MoldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; OnStartUpdates, OnEndUpdates, OnFailUpdates: TNotifyEvent); +constructor TBoldAbstractPartiallyExternalPC.Create(MoldModel: TMoldModel; TypeNameDictionary: TBoldTypeNameDictionary; OnStartUpdates, OnEndUpdates, OnFailUpdates: TNotifyEvent; AUpdateBoldDatabaseFirst: boolean); begin inherited; fDeletedExternalObjects := TBoldObjectIdList.Create; @@ -76,14 +79,13 @@ procedure TBoldAbstractPartiallyExternalPC.CreateInternalObject( Guard: IBoldGuard; UpdateIdList: TBoldObjectIdList; TimeStamp: Integer; + TimeOfTimeStamp: TDateTime; begin Guard := TBoldguard.Create(TranslationList, NewId, UpdateIdlist); TranslationList := TBoldIDTranslationList.Create; UpdateIdList := TBoldObjectIdList.Create; TopSortedIndex := MoldClass.TopSortedIndex; - - // FIXME: how can we be sure that the object is actually of the type MoldClass? NewId := TBoldInternalObjectId.CreateWithClassID(TopSortedIndex, MoldClass.SubClasses.Count = 0); NewObject := ValueSpace.GetEnsuredObjectContentsByObjectId(NewId); @@ -97,22 +99,66 @@ procedure TBoldAbstractPartiallyExternalPC.CreateInternalObject( end; NewObject.BoldPersistenceState := bvpsModified; NewObject.BoldExistenceState := besExisting; - - // insert the external key to the new object so that it can be saved to the internal database AssignKeyToObject(MoldClass, NewObject, ExternalKey, ValueSpace); NewObject := nil; UpdateIdList.Add(NewId); - NextPersistenceController.PMUpdate(UpdateIdList, ValueSpace, nil, nil, TranslationList, TimeStamp, -1); - - // return the translated ID! + NextPersistenceController.PMUpdate(UpdateIdList, ValueSpace, nil, nil, TranslationList, TimeStamp, TimeOfTimeStamp, -1); Id := TranslationList.TranslateToNewId[NewId].Clone; Ids.Add(Id); - - // indicate that this is a newly created object if anyone wants to initialize any internal-attributes. NewExternalObjects.Add(Id); end; +procedure TBoldAbstractPartiallyExternalPC.CreateInternalObjects( + MoldClass: TMoldClass; ExternalIDlist: TBoldObjectIdList; + const ValueSpace: IBoldValueSpace; Ids: TBoldObjectidList); +var + i: integer; + j: integer; + TopSortedIndex: integer; + NewId: TBoldObjectId; + TranslationList: TBoldIDTranslationList; + NewObject: IBoldObjectContents; + Id: TBoldObjectId; + Guard: IBoldGuard; + UpdateIdList: TBoldObjectIdList; + TimeStamp: Integer; + TimeOfTimeStamp: TDateTime; +begin + Guard := TBoldguard.Create(TranslationList, NewId, UpdateIdlist); + TranslationList := TBoldIDTranslationList.Create; + UpdateIdList := TBoldObjectIdList.Create; + + TopSortedIndex := MoldClass.TopSortedIndex; + for i := 0 to ExternalIDlist.Count - 1 do + begin + NewId := TBoldInternalObjectId.CreateWithClassID(TopSortedIndex, MoldClass.SubClasses.Count = 0); + NewObject := ValueSpace.GetEnsuredObjectContentsByObjectId(NewId); + for j := 0 to MoldClass.AllBoldMembers.Count-1 do + begin + if MoldClass.AllBoldMembers[j].Storage in [bsInternal, bsExternalKey] then + begin + EnsureMember(NewObject, MoldClass.AllBoldMembers[j], j); + NewObject.ValueByIndex[j].BoldPersistenceState := bvpsModified; + end; + end; + NewObject.BoldPersistenceState := bvpsModified; + NewObject.BoldExistenceState := besExisting; + AssignKeyToObject(MoldClass, NewObject, ExternalIDlist[i], ValueSpace); + NewObject := nil; + UpdateIdList.Add(NewId); + end; + + NextPersistenceController.PMUpdate(UpdateIdList, ValueSpace, nil, nil, TranslationList, TimeStamp, TimeOfTimeStamp, -1); + + for i := 0 to ExternalIDlist.Count - 1 do + begin + Id := TranslationList.TranslateToNewId[NewId].Clone; + Ids.Add(Id); + NewExternalObjects.Add(Id); + end; +end; + destructor TBoldAbstractPartiallyExternalPC.destroy; begin FreeAndNil(fDeletedExternalObjects); @@ -133,14 +179,14 @@ function TBoldAbstractPartiallyExternalPC.ExternalKeysToInternalSQL( if (MoldClass.AllBoldMembers[i] is TMoldAttribute) and (MoldClass.AllBoldMembers[i].Storage = bsExternalKey) then begin if assigned(ExternalKey) then - raise EBold.CreateFmt(sNotSupportedWithMultipleKeys, [classname, MoldClass.ExpandedExpressionName]) + raise EBold.CreateFmt('%s.ExternalKeysToInternalSQL: Automatic SQL-generation only supported for classes with 1 (one) external key (class %s has multiple)', [classname, MoldClass.ExpandedExpressionName]) else ExternalKey := MoldClass.AllBoldMembers[i] as TMoldAttribute; end; if not assigned(ExternalKey) then - raise EBold.CreateFmt(sNotSupportedWithNoKeys, [classname, MoldClass.ExpandedExpressionName]); + raise EBold.CreateFmt('%s.ExternalKeysToInternalSQL: Automatic SQL-generation only supported for classes with 1 (one) external key (class %s has none!)', [classname, MoldClass.ExpandedExpressionName]); - result := format('%s.%s in (', [ // do not localize + result := format('%s.%s in (', [ BoldExpandName(ExternalKey.MoldClass.Tablename, ExternalKey.MoldClass.Name, xtSQL, -1, nccFalse), BoldExpandName(ExternalKey.ColumnName, ExternalKey.name, xtSQL, -1, nccFalse)]); Mapping := TypeNameDictionary.MappingForModelName[ExternalKey.BoldType]; @@ -157,6 +203,11 @@ function TBoldAbstractPartiallyExternalPC.ExternalKeysToInternalSQL( result := result + ')'; end; +function TBoldAbstractPartiallyExternalPC.FetchAllMembersWhenFetchingKey(MoldClass: TMoldClass): boolean; +begin + result := false; +end; + procedure TBoldAbstractPartiallyExternalPC.FetchExternalKeysForIDs( InternalObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MoldClass: TMoldClass); @@ -166,11 +217,19 @@ procedure TBoldAbstractPartiallyExternalPC.FetchExternalKeysForIDs( guard: IBoldGuard; begin Guard := TBoldGuard.Create(MemberIdList); - MemberIdList := tBoldMemberIdList.Create; - for i := 0 to MoldClass.AllBoldMembers.count-1 do - if MoldClass.AllBoldMembers[i].Storage = bsExternalKey then - MemberIdList.Add(TBoldMemberId.Create(i)); - NextPersistenceController.PMFetch(InternalObjectIdList, ValueSpace, MemberIdList, fmNormal, -1); + if FetchAllMembersWhenFetchingKey(MoldClass) then + begin + NextPersistenceController.PMFetch(InternalObjectIdList, ValueSpace, nil, fmNormal, -1); + end + else + begin + MemberIdList := TBoldMemberIdList.Create; + for i := 0 to MoldClass.AllBoldMembers.count-1 do + if MoldClass.AllBoldMembers[i].Storage = bsExternalKey then + MemberIdList.Add(TBoldMemberId.Create(i)); + if MemberIdList.count > 0 then + NextPersistenceController.PMFetch(InternalObjectIdList, ValueSpace, MemberIdList, fmNormal, -1); + end; end; procedure TBoldAbstractPartiallyExternalPC.FindMoldRoleByName(ObjectContents: IBoldObjectContents; @@ -191,7 +250,7 @@ procedure TBoldAbstractPartiallyExternalPC.FindMoldRoleByName(ObjectContents: IB end; end; if index = -1 then - raise EBold.CreateFmt(sNoSuchRole, [ClassNAme, ExpressionName, MoldClass.ExpandedExpressionName]); + raise EBold.CreateFmt('%s.FindMoldRoleByName: There is no role called %s in class %s', [ClassNAme, ExpressionName, MoldClass.ExpandedExpressionName]); end; procedure TBoldAbstractPartiallyExternalPC.HandleAllInstances( @@ -209,13 +268,8 @@ procedure TBoldAbstractPartiallyExternalPC.HandleAllInstances( TempvalueSpace := TBoldFreeStandingvalueSpace.Create; InternalObjectIdList := TBoldObjectidList.create; ExternalKeys := TBoldObjectIdList.create; - - // send the condition query to the internal database and fetch the objects to a local valuespace NextPersistenceController.PMFetchIDListWithCondition(InternalObjectIdList, TempValueSpace, fmNormal, Condition, -1); - // Get the external keys GetExternalKeys(MoldClass, ExternalKeys); - - // match the external keys and the internal objects. MatchObjectsByKeys(MoldClass, TempValueSpace, InternalObjectIdList, ExternalKeys, ObjectIdList); end; @@ -227,19 +281,18 @@ procedure TBoldAbstractPartiallyExternalPC.MatchObjectsByKeys(MoldClass: TMoldCl TranslationList: TBoldIdTranslationList; ObjectContents: IBoldObjectContents; Guard: IBoldGuard; + lNotFoundObjects: TBoldObjectIdList; begin - // The Internal ids and External keys should be expected to contain references to the same objects. - - Guard := TBoldguard.Create(TranslationList); + Guard := TBoldguard.Create(TranslationList, lNotFoundObjects); + lNotFoundObjects:= TBoldObjectIdList.Create; FetchExternalKeysForIDs(InternalIds, ValueSpace, MoldClass); TranslationList := TBoldIdTranslationList.Create; for i := 0 to InternalIds.Count-1 do begin - ObjectContents := ValueSpace.ObjectContentsByObjectId[InternalIds[i]]; + ObjectContents := ValueSpace.EnsuredObjectContentsByObjectId[InternalIds[i]]; ExternalKey := GetExternalKeyFromObject(ObjectContents, ValueSpace); TranslationList.AddTranslation(ExternalKey, InternalIds[i]); - // Objects that have been deleted in external database are just logged... if not ExternalKeys.IdInList[ExternalKey] then DeletedExternalObjects.Add(InternalIds[i]); ExternalKey.Free; @@ -250,15 +303,15 @@ procedure TBoldAbstractPartiallyExternalPC.MatchObjectsByKeys(MoldClass: TMoldCl InternalId := TranslationList.TranslateToNewId[ExternalKeys[i]]; if assigned(InternalId) and (ExternalKeys[i] <> InternalId) then begin - // the objects that already exist in the internal database can be returned directly FoundObjects.Add(InternalId) end else begin - // the missing objects has to be created in the internal database - CreateInternalObject(MoldClass, ExternalKeys[i], ValueSpace, FoundObjects) + lNotFoundObjects.Add(ExternalKeys[i]); end; end; + if lNotFoundObjects.count > 0 then + CreateInternalObjects(MoldClass, lNotFoundObjects, ValueSpace, FoundObjects) end; function TBoldAbstractPartiallyExternalPC.ExternalKeyExistsInExternalStorage(MoldClass: TMoldClass; ExternalKey: TBoldObjectId): Boolean; @@ -281,12 +334,12 @@ procedure TBoldAbstractPartiallyExternalPC.PrepareFetch(ObjectIdList: TBoldObjec begin ObjectContents := ValueSpace.ObjectContentsByObjectId[ObjectIdList[i]]; ExternalKey := GetExternalKeyFromObject(ObjectContents, ValueSpace); - // only perform the existencetest if this is the default-fetch of an object - // when fetching custommembers we assume this test has already been performed + if not assigned(MemberIdList) or ExternalKeyExistsInExternalStorage(MoldClass, ExternalKey) then ExternalKeys.Add(ExternalKey) else DeletedExternalObjects.Add(ObjectIdList[i]); + ExternalKey.free; end; PrepareFetchExternal(ExternalKeys, ValueSpace, MoldClass, MemberIdList, FetchContext); end; @@ -296,7 +349,6 @@ procedure TBoldAbstractPartiallyExternalPC.PrepareFetchExternal( MoldClass: TMoldClass; MemberIdList: TBoldMemberIdList; var FetchContext: TObject); begin - // intentionally left blank end; procedure TBoldAbstractPartiallyExternalPC.SetMultiLink( @@ -316,7 +368,6 @@ procedure TBoldAbstractPartiallyExternalPC.SetSingleLink( ExternalKeys: TBoldObjectIdList; InternalIds: TBoldObjectIdList; begin - // set the member to point to the ID if assigned(ExternalKey) then begin ExternalKeys := TBoldObjectIdList.Create; @@ -324,12 +375,12 @@ procedure TBoldAbstractPartiallyExternalPC.SetSingleLink( InternalIds := TBoldObjectidList.Create; TranslateExternalKeysToInternalIds(MoldClassOfOtherEnd, ExternalKeys, InternalIds); if InternalIds.Count = 1 then - SingleLink.SetFromId(InternalIds[0]); + SingleLink.SetFromId(InternalIds[0], false); InternalIds.Free; ExternalKeys.Free; end else - SingleLink.SetFromId(nil); + SingleLink.SetFromId(nil, false); end; procedure TBoldAbstractPartiallyExternalPC.TranslateExternalKeysToInternalIds( @@ -386,4 +437,3 @@ procedure TBoldAbstractPartiallyExternalPC.TranslateInternalIdsToExternal( end; end. - diff --git a/Source/Persistence/ExternalPersistence/BoldAbstractPartiallyExternalPH.pas b/Source/Persistence/ExternalPersistence/BoldAbstractPartiallyExternalPH.pas index 931240fd..814186d6 100644 --- a/Source/Persistence/ExternalPersistence/BoldAbstractPartiallyExternalPH.pas +++ b/Source/Persistence/ExternalPersistence/BoldAbstractPartiallyExternalPH.pas @@ -1,7 +1,9 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAbstractPartiallyExternalPH; interface - uses BoldId, BoldMeta, @@ -36,9 +38,7 @@ implementation BoldStringId, BoldDefaultId, BoldDefs, - BoldGuard, - BoldPersistenceHandlePTWithModel, - ExPeConsts; + BoldGuard; { TBoldAbstractpartiallyExternalPH } @@ -78,7 +78,7 @@ function TBoldAbstractpartiallyExternalPH.GetObjectIdByExternalKey( Guard := TBoldGuard.Create(ExternalKeys, InternalIds); MoldClass := BoldModel.MoldModel.Classes.ItemsByExpressionName[ExpressionName]; if not assigned(MoldClass) then - raise EBold.CreateFmt(sInvalidClassName, [classname, expressionname]); + raise EBold.CreateFmt('%s.GetObjectIdByExternalKey: Invalid class name (%s)', [classname, expressionname]); ExternalKeys := TBoldObjectIdLIst.Create; InternalIds := TBoldObjectIdLIst.Create; ExternalKeys.Add(ExternalKey); diff --git a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceConfigItemDataSet.pas b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceConfigItemDataSet.pas index e36704cd..6f7ed502 100644 --- a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceConfigItemDataSet.pas +++ b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceConfigItemDataSet.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldExternalPersistenceConfigItemDataSet; interface @@ -37,6 +40,10 @@ TBoldExternalPersistenceConfigDataSetItems = class(TBoldCollectionWithUniquely implementation +uses + BoldRev; + + constructor TBoldExternalPersistenceConfigDataSetItem.Create(AOwner: TCollection); begin inherited Create(AOwner); @@ -87,4 +94,6 @@ function TBoldExternalPersistenceConfigDataSetItems.GetItem( result := inherited GetItem(Index) as TBoldExternalPersistenceConfigDataSetItem; end; +initialization + end. diff --git a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceControllerConfig.pas b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceControllerConfig.pas index 284b8d2c..a945c95b 100644 --- a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceControllerConfig.pas +++ b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceControllerConfig.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldExternalPersistenceControllerConfig; interface @@ -32,6 +35,7 @@ TBoldExternalPersistenceConfigItems = class; TBoldExternalPersistenceConfigItem = class(TBoldUniquelyNamedCollectionItemWithNameStorage) private + FFetchAllMembersWhenFetchingKey: boolean; FOnCreateObject: TBoldExternalPersistenceCreateEvent; FOnReadObject: TBoldExternalPersistenceFetchEvent; FOnUpdateObject: TBoldExternalPersistenceUpdateEvent; @@ -51,6 +55,7 @@ TBoldExternalPersistenceConfigItem = class(TBoldUniquelyNamedCollectionItemWit public published property ExpressionName: String read GetExpressionName write SetExpressionName; + property FetchAllMembersWhenFetchingKey: boolean read FFetchAllMembersWhenFetchingKey write FFetchAllMembersWhenFetchingKey default false; property OnCreateObject: TBoldExternalPersistenceCreateEvent read FOnCreateObject write FOnCreateObject; property OnReadObject: TBoldExternalPersistenceFetchEvent read FOnReadObject write FOnReadObject; property OnUpdateObject: TBoldExternalPersistenceUpdateEvent read FOnUpdateObject write FOnUpdateObject; @@ -78,6 +83,7 @@ TBoldExternalPersistenceConfigItems = class(TBoldCollectionWithUniquelyNamedIt implementation + { TBoldExternalPersistenceConfigItem } procedure TBoldExternalPersistenceConfigItem.SetExpressionName(const Value: String); diff --git a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceControllerDataSet.pas b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceControllerDataSet.pas index 176d4850..9a3d000a 100644 --- a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceControllerDataSet.pas +++ b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceControllerDataSet.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldExternalPersistenceControllerDataSet; interface @@ -20,6 +23,10 @@ TBoldExternalPersistenceControllerDataSet = class(TBoldAbstractPartiallyExtern fMaxFetchBlockSize: integer; protected function LocateInDB(MoldClass: TMoldClass; ObjectContents: IBoldObjectContents): TDataSet; + procedure PrepareFetchExternal(ExternalKeys: TBoldObjectIdList; + ValueSpace: IBoldValueSpace; MoldClass: TMoldClass; + MemberIdList: TBoldMemberIdList; var FetchContext: TObject); override; + procedure PostFetch(FetchContext: TObject; MoldClass: TMoldClass); override; function ConfigItemByObjectContents(ObjectContents: IBoldObjectContents): TBoldExternalPersistenceConfigDataSetItem; procedure FetchObject(ObjectContents: IBoldObjectContents; MemberIdList: TBoldMemberIdList; FetchContext: TObject; @@ -48,9 +55,11 @@ TBoldExternalPersistenceControllerDataSet = class(TBoldAbstractPartiallyExtern Config: TBoldExternalPersistenceConfigDataSetItems; TypeNameDictionary: TBoldTypeNameDictionary; OnStartUpdates, OnEndUpdates, OnFailUpdates: TNotifyEvent; MaxFetchBlockSize: integer); + procedure SubscribeToPeristenceEvents(Subscriber: TBoldSubscriber); override; property Config: TBoldExternalPersistenceConfigDataSetItems read fConfig; end; + implementation uses @@ -60,8 +69,7 @@ implementation BoldNameExpander, BoldValueInterfaces, BoldStringId, - BoldDefaultId, - ExPeConsts; + BoldDefaultId; function MemberIndexByName(MoldClass: TMoldClass; MemberName: String): Integer; begin @@ -195,7 +203,7 @@ function BoldValueToVariant(B: IBoldValue): Variant; Result := DT.asDateTime else if B.QueryInterface(IBoldBlobContent, BL) = S_OK then Result := BL.asBlob - else raise Exception.Create(sUnknownDataType); + else raise Exception.Create('Unknown data type'); end; procedure VariantToBoldValue(B: IBoldValue; Value: Variant); @@ -232,7 +240,7 @@ procedure VariantToBoldValue(B: IBoldValue; Value: Variant); DT.asDateTime := Value else if B.QueryInterface(IBoldBlobContent, BL) = S_OK then BL.asBlob := Value - else raise Exception.Create(sUnknownDataType); + else raise Exception.Create('Unknown data type'); end; procedure SetBoldValueToNull(B: IBoldValue); @@ -268,7 +276,7 @@ procedure SetBoldValueToNull(B: IBoldValue); DT.asDateTime := 0 else if B.QueryInterface(IBoldBlobContent, BL) = S_OK then BL.asBlob := '' - else raise Exception.Create(sUnknownDataType); + else raise Exception.Create('Unknown data type'); end; function GetKeyCount(MoldClass: TMoldClass): Integer; @@ -315,7 +323,7 @@ function GetObjectKeys(MoldClass: TMoldClass; ObjectContents: IBoldObjectContent constructor TBoldExternalPersistenceControllerDataSet.Create(MoldModel: TMoldModel; Config: TBoldExternalPersistenceConfigDataSetItems; TypeNameDictionary: TBoldTypeNameDictionary; OnStartUpdates, OnEndUpdates, OnFailUpdates: TNotifyEvent; MaxFetchBlockSize: integer); begin - inherited Create(MoldModel, TypeNameDictionary, OnStartUpdates, OnEndUpdates, OnFailUpdates); + inherited Create(MoldModel, TypeNameDictionary, OnStartUpdates, OnEndUpdates, OnFailUpdates, UpdateBoldDatabaseFirst); FConfig := Config; FMaxFetchBlockSize := MaxFetchBlockSize; end; @@ -421,7 +429,7 @@ procedure TBoldExternalPersistenceControllerDataSet.FetchObject( MultiLinkConfigItem := Config.FindExpressionName(MultiLinkClass.ExpandedExpressionName); if not Assigned(MultiLinkConfigItem) then - raise Exception.CreateFmt(sLinkToUnconfiguredTable, [MultiLinkClass.ExpandedExpressionName]); + raise Exception.CreateFmt('External link to unconfigured table %s', [MultiLinkClass.ExpandedExpressionName]); MultiLinkDataSet := MultiLinkConfigItem.DataSet; MultiLinkKeyName := RemovePreAt(MoldRole.OtherEnd); @@ -433,7 +441,7 @@ procedure TBoldExternalPersistenceControllerDataSet.FetchObject( for i := 0 to GetCharCount(';', MultiLinkKeyName) do begin if S <> '' then - S := S + ' and '; // do not localize + S := S + ' and '; S := S + '(' + GetNextWord(B, ';') + ' = ' + ConfigItem.DataSet.FieldByName(GetNextWord(A, ';')).AsString + ')'; end; @@ -451,7 +459,6 @@ procedure TBoldExternalPersistenceControllerDataSet.FetchObject( if not VarIsNull(DBValue) then begin ExternalKey := nil; - // the type of the field MUST match the type of the internal ID if VarType(DBValue) in [varInteger, varSmallint, varSingle, varDouble] then begin ExternalKey := TBoldDefaultId.Create; @@ -463,7 +470,7 @@ procedure TBoldExternalPersistenceControllerDataSet.FetchObject( TBoldStringId(ExternalKey).AsString := DBValue; end else - raise Exception.CreateFmt(sUnknownVarTypeLoadingID, [MoldClass.name, MoldRole.name]); + raise Exception.CreateFmt('Unknown vartype when loading an external ID for multilink %s.%s', [MoldClass.name, MoldRole.name]); MultiLinkList.Add(ExternalKey); ExternalKey.Free; @@ -496,7 +503,7 @@ procedure TBoldExternalPersistenceControllerDataSet.FetchObject( TBoldStringId(ExternalKey).AsString := DBValue; end else - raise Exception.CreateFmt(sUnknownVarTypeLoadingSingleID, [MoldClass.name, MoldRole.name]); + raise Exception.CreateFmt('Unknown vartype when loading an external ID for Singlelink %s.%s', [MoldClass.name, MoldRole.name]); if Value.QueryInterface(IBoldObjectIdRef, IDRef) = S_OK then SetSingleLink(IDRef, ExternalKey, MoldRole.OtherEnd.MoldClass); @@ -578,7 +585,7 @@ procedure TBoldExternalPersistenceControllerDataSet.GetExternalKeys(MoldClass: T TBoldStringId(ExternalId).AsString := DBValue; end else - raise Exception.CreateFmt(sUnknownVarTypeLoadingObject, [MoldClass.name]); + raise Exception.CreateFmt('Unknown vartype when loading an external ID for %s', [MoldClass.name]); ExternalKeys.Add(ExternalId); ExternalId.Free; ConfigItem.DataSet.Next; @@ -608,6 +615,11 @@ function TBoldExternalPersistenceControllerDataSet.ConfigItemByObjectContents( result := Config.FindExpressionName(MoldClass.ExpandedExpressionName); end; +procedure TBoldExternalPersistenceControllerDataSet.SubscribeToPeristenceEvents(Subscriber: TBoldSubscriber); +begin + inherited; +end; + procedure TBoldExternalPersistenceControllerDataSet.UpdateObjects( ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace); var @@ -672,7 +684,19 @@ function TBoldExternalPersistenceControllerDataSet.GetExternalKeyFromObject( TBoldStringId(Result).AsString := DBValue; end else - raise Exception.CreateFmt(sUnknownVarTypeLoadingObject, [MoldClass.name]); + raise Exception.CreateFmt('Unknown vartype when loading an external ID for %s', [MoldClass.name]); +end; + + +procedure TBoldExternalPersistenceControllerDataSet.PostFetch( + FetchContext: TObject; MoldClass: TMoldClass); +begin + inherited; +end; + +procedure TBoldExternalPersistenceControllerDataSet.PrepareFetchExternal(ExternalKeys: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MoldClass: TMoldClass; MemberIdList: TBoldMemberIdList; var FetchContext: TObject); +begin + inherited; end; function TBoldExternalPersistenceControllerDataSet.GetMaxFetchBlockSize: integer; @@ -712,13 +736,13 @@ function TBoldExternalPersistenceControllerDataSet.ExternalKeysToInternalSQL(Mol Val(T, v, c); if c <> 0 then T := '''' + T + ''''; - SQL := SQL + '(' + GetNextWord(S, ';') + ' = ' + T + ') AND '; // do not localize + SQL := SQL + '(' + GetNextWord(S, ';') + ' = ' + T + ') AND '; end; if Length(SQL) > 1 then SetLength(SQL, Length(SQL)-5); SQL := SQL + ')'; - Result := Result + SQL + ' OR '; // do not localize + Result := Result + SQL + ' OR '; end; if Length(Result) > 0 then @@ -748,7 +772,7 @@ procedure TBoldExternalPersistenceControllerDataSet.AssignKeyToObject( else if KeyValue.QueryInterface(IBoldIntegerContent, IntContent) = S_OK then IntContent.AsInteger := StrToInt(GetNextWord(S, ';')) else - raise EBold.createFmt(sKeyTypeNotAutoHandled, [MoldClass.Name, MoldClass.AllBoldMembers[i].Name]); + raise EBold.createFmt('Keytype not handled automatically: %s.%s', [MoldClass.Name, MoldClass.AllBoldMembers[i].Name]); end; end; end; @@ -772,4 +796,6 @@ function TBoldExternalPersistenceControllerDataSet.LocateInDB( end; end; +initialization + end. diff --git a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceControllerEventDriven.pas b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceControllerEventDriven.pas index d4149ee9..3a32988b 100644 --- a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceControllerEventDriven.pas +++ b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceControllerEventDriven.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldExternalPersistenceControllerEventDriven; interface @@ -18,8 +21,9 @@ TBoldExternalPersistenceControllerEventDriven = class(TBoldAbstractPartiallyEx private FConfig: TBoldExternalPersistenceConfigItems; fMaxFetchBlockSize: integer; - function PersistentObjectFromObjectContents(Obj: IBoldObjectContents; ValueSpace: IBoldValueSpace; MoldClass: TMoldClass): IPersistentBoldObject; + function PersistentObjectFromObjectContents(const Obj: IBoldObjectContents; const ValueSpace: IBoldValueSpace; MoldClass: TMoldClass): IPersistentBoldObject; protected + function FetchAllMembersWhenFetchingKey(MoldClass: TMoldClass): boolean; override; procedure PrepareFetchExternal(ExternalKeys: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MoldClass: TMoldClass; MemberIdList: TBoldMemberIdList; var FetchContext: TObject); override; procedure PostFetch(FetchContext: TObject; MoldClass: TMoldClass); override; function ConfigItemByObjectContents(ObjectContents: IBoldObjectContents): TBoldExternalPersistenceConfigItem; @@ -35,7 +39,7 @@ TBoldExternalPersistenceControllerEventDriven = class(TBoldAbstractPartiallyEx procedure UpdateObjects(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace); override; function GetMaxFetchBlockSize: integer; override; public - constructor Create(MoldModel: TMoldModel; Config: TBoldExternalPersistenceConfigItems; TypeNameDictionary: TBoldTypeNameDictionary; OnStartUpdates, OnEndUpdates, OnFailUpdates: TNotifyEvent; MaxFetchBlockSize: integer); + constructor Create(MoldModel: TMoldModel; Config: TBoldExternalPersistenceConfigItems; TypeNameDictionary: TBoldTypeNameDictionary; OnStartUpdates, OnEndUpdates, OnFailUpdates: TNotifyEvent; MaxFetchBlockSize: integer; UpdateBoldDatabaseFirst: boolean); procedure SubscribeToPeristenceEvents(Subscriber: TBoldSubscriber); override; property Config: TBoldExternalPersistenceConfigItems read fConfig; end; @@ -48,8 +52,7 @@ implementation BoldDefs, BoldValueInterfaces, BoldStringId, - BoldDefaultId, - ExPeConsts; + BoldDefaultId; { TBoldExternalPersistenceControllerEventDriven } @@ -61,7 +64,6 @@ procedure TBoldExternalPersistenceControllerEventDriven.AssignKeyToObject(MoldCl IntContent: IBoldIntegerContent; ConfigItem: TBoldExternalPersistenceConfigItem; begin - // Make sure that the object contains the data of the external key ConfigItem := Config.FindExpressionName(MoldClass.ExpandedExpressionName); if assigned(ConfigItem.OnAssignKeyToObject) then ConfigItem.OnAssignKeyToObject(PersistentObjectFromObjectContents(ObjectContents, ValueSpace, MoldClass), ExternalKey) @@ -73,7 +75,7 @@ procedure TBoldExternalPersistenceControllerEventDriven.AssignKeyToObject(MoldCl if MoldClass.AllBoldMembers[i].Storage = bsExternalKey then begin if assigned(Keyvalue) then - raise EBold.createFmt(sAssignKeyValueRequiresOneKey, [MoldClass.Name]); + raise EBold.createFmt('AssignKeyValue only supported automatically for classes with one external key: %s', [MoldClass.Name]); KeyValue := ObjectContents.ValueByIndex[i]; if KeyValue.QueryInterface(IBoldStringContent, StrContent) = S_OK then @@ -81,15 +83,15 @@ procedure TBoldExternalPersistenceControllerEventDriven.AssignKeyToObject(MoldCl else if KeyValue.QueryInterface(IBoldIntegerContent, IntContent) = S_OK then IntContent.AsInteger := StrToInt(ExternalKey.AsString) else - raise EBold.createFmt(sKeyTypeNotAutoHandled, [MoldClass.Name, MoldClass.AllBoldMembers[i].Name]); + raise EBold.createFmt('Keytype not handled automatically: %s.%s', [MoldClass.Name, MoldClass.AllBoldMembers[i].Name]); end; end; end; end; -constructor TBoldExternalPersistenceControllerEventDriven.Create(MoldModel: TMoldModel; Config: TBoldExternalPersistenceConfigItems; TypeNameDictionary: TBoldTypeNameDictionary; OnStartUpdates, OnEndUpdates, OnFailUpdates: TNotifyEvent; MaxFetchBlockSize: integer); +constructor TBoldExternalPersistenceControllerEventDriven.Create(MoldModel: TMoldModel; Config: TBoldExternalPersistenceConfigItems; TypeNameDictionary: TBoldTypeNameDictionary; OnStartUpdates, OnEndUpdates, OnFailUpdates: TNotifyEvent; MaxFetchBlockSize: integer; UpdateBoldDatabaseFirst: boolean); begin - inherited Create(MoldModel, TypeNameDictionary, OnStartUpdates, OnEndUpdates, OnFailUpdates); + inherited Create(MoldModel, TypeNameDictionary, OnStartUpdates, OnEndUpdates, OnFailUpdates, UpdateBoldDatabaseFirst); fConfig := Config; fMaxFetchBlockSize := MaxFetchBlockSize; end; @@ -111,12 +113,13 @@ procedure TBoldExternalPersistenceControllerEventDriven.CreateObjects( if assigned(ConfigItem) then begin if not assigned(ConfigItem.OnCreateObject) then - raise EBold.CreateFmt(sCreateObjectsNotAllowed, [ConfigItem.ExpressionName]); + raise EBold.CreateFmt('Creating new objects of type %s not supported/allowed', [ConfigItem.ExpressionName]); ExternalKey := GetExternalKeyFromObject(ObjectContents, ValueSpace); ConfigItem.OnCreateObject(PersistentObjectFromObjectContents(ObjectContents, ValueSpace, MoldClass), ExternalKey, ValueSpace); ExternalKey.Free; end; end; + end; procedure TBoldExternalPersistenceControllerEventDriven.DeleteObjects( @@ -136,7 +139,7 @@ procedure TBoldExternalPersistenceControllerEventDriven.DeleteObjects( if assigned(ConfigItem) then begin if not assigned(ConfigItem.OnDeleteObject) then - raise EBold.CreateFmt(sDeleteObjectsNotAllowed, [ConfigItem.ExpressionName]); + raise EBold.CreateFmt('Deleting objects of type %s not supported/allowed', [ConfigItem.ExpressionName]); ExternalKey := GetExternalKeyFromObject(ObjectContents, valueSpace); ConfigItem.OnDeleteObject(PersistentObjectFromObjectContents(ObjectContents, ValueSpace, MoldClass), ExternalKey); ExternalKey.Free; @@ -144,6 +147,15 @@ procedure TBoldExternalPersistenceControllerEventDriven.DeleteObjects( end; end; +function TBoldExternalPersistenceControllerEventDriven.FetchAllMembersWhenFetchingKey( + MoldClass: TMoldClass): boolean; +var + lConfigItem: TBoldExternalPersistenceConfigItem; +begin + lConfigItem := Config.FindExpressionName(MoldClass.ExpandedExpressionName); + result := lConfigItem.FetchAllMembersWhenFetchingKey; +end; + procedure TBoldExternalPersistenceControllerEventDriven.FetchObject( ObjectContents: IBoldObjectContents; MemberIdList: TBoldMemberIdList; FetchContext: TObject; ValueSpace: IBoldValueSpace); @@ -157,21 +169,25 @@ procedure TBoldExternalPersistenceControllerEventDriven.FetchObject( ConfigItem := ConfigItemByObjectContents(ObjectContents); MoldClass := MoldModel.Classes[ObjectContents.ObjectId.TopSortedIndex]; PersistentObject := PersistentObjectFromObjectContents(ObjectContents, valueSpace, MoldClass); - ExternalKey :=GetExternalKeyFromObject(ObjectContents, valueSpace); - if assigned(MemberidList) and assigned(ConfigItem.OnReadMember) then - begin - for i := 0 to MemberIdList.Count-1 do - ConfigItem.OnReadMember(PersistentObject, ExternalKey, MoldClass.AllBoldMembers[MemberIdList[i].MemberIndex], FetchContext); - end - else - begin - if Assigned(ConfigItem.OnReadObject) then - ConfigItem.OnReadObject(PersistentObject, ExternalKey, FetchContext) + ExternalKey := GetExternalKeyFromObject(ObjectContents, valueSpace); + try + if assigned(MemberidList) and assigned(ConfigItem.OnReadMember) then + begin + for i := 0 to MemberIdList.Count-1 do + ConfigItem.OnReadMember(PersistentObject, ExternalKey, MoldClass.AllBoldMembers[MemberIdList[i].MemberIndex], FetchContext); + end else - raise EBold.CreateFmt(sReadObjectNotImplementedForClass, [MoldClass.Name]); + begin + if Assigned(ConfigItem.OnReadObject) then + ConfigItem.OnReadObject(PersistentObject, ExternalKey, FetchContext) + else + raise EBold.CreateFmt('Event ReadObject is not implemented for class %s', [MoldClass.Name]); + end; + finally + ExternalKey.free; end; if not assigned(ConfigItem.OnUpdateObject) and not assigned(ConfigItem.OnDeleteObject) then - ObjectContents.IsReadOnly := true; + ObjectContents.IsReadOnly := true; end; procedure TBoldExternalPersistenceControllerEventDriven.GetExternalKeys(MoldClass: TMoldClass; ExternalKeys: TBoldObjectIdList); @@ -182,7 +198,7 @@ procedure TBoldExternalPersistenceControllerEventDriven.GetExternalKeys(MoldClas if assigned(ConfigItem) and assigned(ConfigItem.OngetKeyList) then ConfigItem.OnGetKeyList(ExternalKeys) else - raise EBold.CreateFmt(sGetExternalKeyNotImplementedForClass, [MoldClass.Name]); + raise EBold.CreateFmt('Getting external keys for class %s not implemented', [MoldClass.Name]); end; function TBoldExternalPersistenceControllerEventDriven.HandlesClass(MoldClass: TMoldClass): Boolean; @@ -232,7 +248,7 @@ procedure TBoldExternalPersistenceControllerEventDriven.UpdateObjects( if assigned(ConfigItem) then begin if not assigned(ConfigItem.OnUpdateObject) then - raise EBold.CreateFmt(sModifyObjectsNotAllowed, [ConfigItem.ExpressionName]); + raise EBold.CreateFmt('Modifying objects of type %s not supported/allowed', [ConfigItem.ExpressionName]); ExternalKey := GetExternalKeyFromObject(ObjectContents, ValueSpace); ConfigItem.OnUpdateObject(PersistentObjectFromObjectContents(ObjectContents, valueSpace, MoldClass), ExternalKey, ValueSpace); ExternalKey.Free; @@ -266,7 +282,7 @@ function TBoldExternalPersistenceControllerEventDriven.GetExternalKeyFromObject( if MoldClass.AllBoldMembers[i].Storage = bsExternalKey then begin if assigned(Result) then - raise EBold.createFmt(sAssignKeyValueRequiresOneKey, [MoldClass.Name]); + raise EBold.createFmt('AssignKeyValue only supported automatically for classes with one external key: %s', [MoldClass.Name]); KeyValue := ObjectContents.ValueByIndex[i]; if not assigned(KeyValue) then @@ -284,12 +300,13 @@ function TBoldExternalPersistenceControllerEventDriven.GetExternalKeyFromObject( result := DefId; end else - raise EBold.createFmt(sKeyTypeNotAutoHandled, [MoldClass.Name, MoldClass.AllBoldMembers[i].Name]); + raise EBold.createFmt('Keytype not handled automatically: %s.%s', [MoldClass.Name, MoldClass.AllBoldMembers[i].Name]); end; end; end; end; + procedure TBoldExternalPersistenceControllerEventDriven.PostFetch( FetchContext: TObject; MoldClass: TMoldClass); var @@ -317,7 +334,7 @@ function TBoldExternalPersistenceControllerEventDriven.GetMaxFetchBlockSize: int end; function TBoldExternalPersistenceControllerEventDriven.PersistentObjectFromObjectContents( - Obj: IBoldObjectContents; ValueSpace: IBoldValueSpace; MoldClass: TMoldClass): IPersistentBoldObject; + const Obj: IBoldObjectContents; const ValueSpace: IBoldValueSpace; MoldClass: TMoldClass): IPersistentBoldObject; var adapterClass: TBoldObjectPersistenceAdapterClass; begin diff --git a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceControllerSQL.pas b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceControllerSQL.pas index 1745d867..0053a6df 100644 --- a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceControllerSQL.pas +++ b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceControllerSQL.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldExternalPersistenceControllerSQL; interface @@ -5,7 +8,9 @@ interface uses DB, Classes, + {$IFDEF BOLD_DELPHI6_OR_LATER} Variants, + {$ENDIF} BoldSubscription, BoldPersistenceController, BoldNameExpander, @@ -88,7 +93,7 @@ TBoldExternalPersistenceControllerSQL = class(TBoldAbstractPartiallyExternalPC public constructor Create(MoldModel: TMoldModel; ADatabaseAdapter: TBoldAbstractDatabaseAdapter; TypeNameDictionary: TBoldTypeNameDictionary; OnStartUpdates, OnEndUpdates, OnFailUpdates: TNotifyEvent; - AClassesToHandle: TStrings); reintroduce; + AClassesToHandle: TStrings; AUpdateBoldDatabaseFirst: boolean); reintroduce; destructor Destroy; override; procedure SubscribeToPeristenceEvents(Subscriber: TBoldSubscriber); override; end; @@ -193,12 +198,12 @@ implementation uses SysUtils, + BoldUtils, BoldDefs, BoldTaggedValueSupport, BoldStringId, BoldDefaultId, - Math, - ExPeConsts; + Math; function _GetTableName(MoldClass: TMoldClass): String; begin @@ -229,7 +234,7 @@ function FindExternalKey(MoldClass: TMoldClass): Integer; function RemovePreAt(Member: TMoldMember): String; begin result := BoldExpandName(Member.ColumnName, Member.name, xtSQL, -1, Member.MoldClass.Model.NationalCharConversion); - if (Length(result) > 0) and {(result[1] = '@')} (result[1] in ['@', '_']) then {!!} + if (Length(result) > 0) and {(result[1] = '@')} CharInSet(result[1], ['@', '_']) then {!!} Result := Copy(result, 2, Length(result)) end; @@ -342,7 +347,7 @@ function BoldValueToVariant(B: IBoldValue): Variant; Result := DT.asDateTime else if B.QueryInterface(IBoldBlobContent, BL) = S_OK then Result := BL.asBlob - else raise Exception.Create(sUnknownDataType); + else raise Exception.Create('Unknown data type'); end; procedure VariantToBoldValue(B: IBoldValue; Value: Variant); @@ -379,7 +384,7 @@ procedure VariantToBoldValue(B: IBoldValue; Value: Variant); DT.asDateTime := Value else if B.QueryInterface(IBoldBlobContent, BL) = S_OK then BL.asBlob := Value - else raise Exception.Create(sUnknownDataType); + else raise Exception.Create('Unknown data type'); end; procedure SetBoldValueToNull(B: IBoldValue); @@ -395,7 +400,6 @@ procedure SetBoldValueToNull(B: IBoldValue); DT: IBoldDateTimeContent; BL: IBoldBlobContent; begin - // all the below types support IBoldNullableValue if B.QueryInterface(IBoldNullableValue, Nullable) = S_OK then Nullable.SetContentToNull else if B.QueryInterface(IBoldStringContent, S) = S_OK then @@ -416,7 +420,7 @@ procedure SetBoldValueToNull(B: IBoldValue); DT.asDateTime := 0 else if B.QueryInterface(IBoldBlobContent, BL) = S_OK then BL.asBlob := '' - else raise Exception.Create(sUnknownDataType); + else raise Exception.Create('Unknown data type'); end; function GetKeyCount(MoldClass: TMoldClass): Integer; @@ -486,9 +490,9 @@ function QuoteStringIfNeeded(const S: String): String; constructor TBoldExternalPersistenceControllerSQL.Create( MoldModel: TMoldModel; ADatabaseAdapter: TBoldAbstractDatabaseAdapter; TypeNameDictionary: TBoldTypeNameDictionary; - OnStartUpdates, OnEndUpdates, OnFailUpdates: TNotifyEvent; AClassesToHandle: TStrings); + OnStartUpdates, OnEndUpdates, OnFailUpdates: TNotifyEvent; AClassesToHandle: TStrings; AUpdateBoldDatabaseFirst: boolean); begin - inherited Create(MoldModel, TypeNameDictionary, OnStartUpdates, OnEndUpdates, OnFailUpdates); + inherited Create(MoldModel, TypeNameDictionary, OnStartUpdates, OnEndUpdates, OnFailUpdates, AUpdateBoldDatabaseFirst); FDatabaseAdapter := ADatabaseAdapter; FClassesToHandle := TStringList.Create; FClassesToHandle.Assign(AClassesToHandle); @@ -536,6 +540,7 @@ procedure TBoldExternalPersistenceControllerSQL.PrepareFetchExternal( var FetchMembers: TBoldMemberIdList; i: integer; + lMember: TMoldMember; begin if Assigned(MemberIdList) and (MemberIdList.Count > 0) then FetchMembers := MemberIdList @@ -543,17 +548,20 @@ procedure TBoldExternalPersistenceControllerSQL.PrepareFetchExternal( begin FetchMembers := TBoldMemberIdList.Create; for i := 0 to MoldClass.AllBoldMembers.Count-1 do - if (MoldClass.AllBoldMembers[i].Storage in [bsExternal, bsExternalKey]) and - not MoldClass.AllBoldMembers[i].Derived and - not ((MoldClass.AllBoldMembers[i] is TMoldRole) and - (TMoldRole(MoldClass.AllBoldMembers[i]).Multi)) and - not (SameText(MoldClass.AllBoldMembers[i].TVByName['DelayedFetch'], 'True')) then // do not localize + begin + lMember := MoldClass.AllBoldMembers[i]; + if (lMember.Storage in [bsExternal, bsExternalKey]) and + not lMember.Derived and + not ((lMember is TMoldRole) and + (TMoldRole(lMember).Multi)) and + not (SameText(lMember.TVByName['DelayedFetch'], 'True')) then FetchMembers.Add(TBoldMemberId.Create(i)); + end; end; FetchContext := TFetchContext.Create(Self, ExternalKeys, ValueSpace, MoldClass, FetchMembers); - + if FetchMembers <> MemberIdList then FetchMembers.Free; end; @@ -565,8 +573,8 @@ procedure TBoldExternalPersistenceControllerSQL.PostFetch( begin TFetchContext(FetchContext).PostFetch; FetchContext.Free; - end; - inherited; + end; + inherited; end; procedure TBoldExternalPersistenceControllerSQL.FetchObject( @@ -586,7 +594,7 @@ procedure TBoldExternalPersistenceControllerSQL.GetExternalKeys(MoldClass: TMold DBFieldName := FindExternalKeyColumns(MoldClass); BoldQuery := DatabaseAdapter.DatabaseInterface.GetQuery; - BoldQuery.AssignSQLText(Format('SELECT %S FROM %S', [ // do not localize + BoldQuery.AssignSQLText(Format('SELECT %S FROM %S', [ StringReplace(DBFieldName, ';', ', ', [rfReplaceAll]), _GetTableName(MoldClass)])); BoldQuery.Open; @@ -604,7 +612,7 @@ procedure TBoldExternalPersistenceControllerSQL.GetExternalKeys(MoldClass: TMold TBoldStringId(ExternalId).AsString := DBValue; end else - raise Exception.CreateFmt(sUnknownVarTypeLoadingObject, [MoldClass.name]); + raise Exception.CreateFmt('Unknown vartype when loading an external ID for %s', [MoldClass.name]); ExternalKeys.Add(ExternalId); ExternalId.Free; BoldQuery.Next; @@ -632,7 +640,7 @@ function TBoldExternalPersistenceControllerSQL.ExternalKeyExistsInExternalStorag ExternalKeys := TBoldObjectIdList.Create; try ExternalKeys.Add(ExternalKey); - AssignSQLText(Format('SELECT %S FROM %S WHERE %S', [ // do not localize + AssignSQLText(Format('SELECT %S FROM %S WHERE %S', [ StringReplace(DBFieldName, ';', ', ', [rfReplaceAll]), _GetTableName(MoldClass), ExternalKeysToInternalSQL(MoldClass, ExternalKeys)])); finally @@ -684,7 +692,7 @@ function TBoldExternalPersistenceControllerSQL.GetExternalKeyFromObject( TBoldStringId(Result).AsString := DBValue; end else - raise Exception.CreateFmt(sUnknownVarTypeLoadingObject, [MoldClass.name]); + raise Exception.CreateFmt('Unknown vartype when loading an external ID for %s', [MoldClass.name]); end; function TBoldExternalPersistenceControllerSQL.GetMaxFetchBlockSize: integer; @@ -724,13 +732,13 @@ function TBoldExternalPersistenceControllerSQL.ExternalKeysToInternalSQL(MoldCla Val(T, v, c); if c <> 0 then T := '''' + T + ''''; - SQL := SQL + '(' + GetNextWord(S, ';') + ' = ' + T + ') AND '; // do not localize + SQL := SQL + '(' + GetNextWord(S, ';') + ' = ' + T + ') AND '; end; if Length(SQL) > 1 then SetLength(SQL, Length(SQL)-5); SQL := SQL + ')'; - Result := Result + SQL + ' OR '; // do not localize + Result := Result + SQL + ' OR '; end; if Length(Result) > 0 then @@ -760,7 +768,7 @@ procedure TBoldExternalPersistenceControllerSQL.AssignKeyToObject( else if KeyValue.QueryInterface(IBoldIntegerContent, IntContent) = S_OK then IntContent.AsInteger := StrToInt(GetNextWord(S, ';')) else - raise EBold.createFmt(sKeyTypeNotAutoHandled, [MoldClass.Name, MoldClass.AllBoldMembers[i].Name]); + raise EBold.createFmt('Keytype not handled automatically: %s.%s', [MoldClass.Name, MoldClass.AllBoldMembers[i].Name]); end; end; end; @@ -796,7 +804,6 @@ procedure TBoldExternalPersistenceControllerSQL.AssignParametersWithMemberIdlist ParamName := _GetColumnName(MoldClass.AllBoldMembers[MemberIdList[i].MemberIndex]); Query.ParamByName(ParamName).asVariant := BoldValueToVariant(BoldValue); -// Createparam(ftunknown, ParamName, ptInput, 0).asVariant := BoldValueToVariant(BoldValue); end; end; @@ -850,11 +857,11 @@ function TBoldExternalPersistenceControllerSQL.GenerateInsertSQL( begin SetLength(FieldNames, Length(FieldNames)-2); SetLength(Params, Length(Params)-2); - Result := Format('INSERT INTO %s (%s) VALUES (%s)', [_GetTableName(MoldClass), FieldNames, // do not localize + Result := Format('INSERT INTO %s (%s) VALUES (%s)', [_GetTableName(MoldClass), FieldNames, Params]); end else - Result := Format('INSERT INTO %s', [_GetTableName(MoldClass)]); // do not localize + Result := Format('INSERT INTO %s', [_GetTableName(MoldClass)]); end; @@ -876,7 +883,7 @@ procedure TBoldExternalPersistenceControllerSQL.InternalDeleteObject( function TBoldExternalPersistenceControllerSQL.GenerateDeleteSQL( MoldClass: TMoldClass; ObjectContents: IBoldObjectContents): String; begin - Result := Format('DELETE FROM %S WHERE %S', [_GetTableName(MoldClass), // do not localize + Result := Format('DELETE FROM %S WHERE %S', [_GetTableName(MoldClass), ObjectContentsToInternalSQL(MoldClass, ObjectContents)]); end; @@ -918,6 +925,7 @@ function TBoldExternalPersistenceControllerSQL.GenerateUpdateSQL( var i: integer; FieldNames: String; + lMember: TMoldMember; begin FieldNames := ''; @@ -925,17 +933,18 @@ function TBoldExternalPersistenceControllerSQL.GenerateUpdateSQL( if (MoldClass.AllBoldMembers[i].Storage in [bsExternal, bsExternalKey]) and not MoldClass.AllBoldMembers[i].Derived then begin + lMember := MoldClass.AllBoldMembers[i]; { Do not store multi links and non-embedded single links } - if (MoldClass.AllBoldMembers[i] is TMoldRole) and - (TMoldRole(MoldClass.AllBoldMembers[i]).Multi or - not TMoldRole(MoldClass.AllBoldMembers[i]).Embed) then + if (lMember is TMoldRole) and + (TMoldRole(lMember).Multi or + not TMoldRole(lMember).Embed) then Continue; { Only update the record if the member has been modified } if ObjectContents.ValueByIndex[i].BoldPersistenceState = bvpsModified then begin - FieldNames := FieldNames + _GetColumnName(MoldClass.AllBoldMembers[i]) + ' = :' + - _GetColumnName(MoldClass.AllBoldMembers[i]) + ', '; + FieldNames := FieldNames + _GetColumnName(lMember) + ' = :' + + _GetColumnName(lMember) + ', '; end; end; @@ -943,8 +952,8 @@ function TBoldExternalPersistenceControllerSQL.GenerateUpdateSQL( if Length(FieldNames) > 0 then begin SetLength(FieldNames, Length(FieldNames)-2); - Result := Format('UPDATE %S SET %S', [_GetTableName(MoldClass), FieldNames]); // do not localize - Result := Result + ' WHERE ' + ObjectContentsToInternalSQL(MoldClass, ObjectContents); // do not localize + Result := Format('UPDATE %S SET %S', [_GetTableName(MoldClass), FieldNames]); + Result := Result + ' WHERE ' + ObjectContentsToInternalSQL(MoldClass, ObjectContents); end else Result := ''; @@ -956,15 +965,17 @@ procedure TBoldExternalPersistenceControllerSQL.GetExternalDirtyMembers( var i: integer; BoldValue: IBoldValue; + lMember: TMoldMember; begin for i := 0 to MoldClass.AllBoldMembers.Count-1 do if (MoldClass.AllBoldMembers[i].Storage in [bsExternal, bsExternalKey]) and not MoldClass.AllBoldMembers[i].Derived then begin + lMember := MoldClass.AllBoldMembers[i]; { Do not store multi links and non-embedded single links } - if (MoldClass.AllBoldMembers[i] is TMoldRole) and - (TMoldRole(MoldClass.AllBoldMembers[i]).Multi or - not TMoldRole(MoldClass.AllBoldMembers[i]).Embed) then + if (lMember is TMoldRole) and + (TMoldRole(lMember).Multi or + not TMoldRole(lMember).Embed) then Continue; { Only add members that has been modified } @@ -1053,22 +1064,22 @@ function TAbstractRoleFetchObject.PrepareSQL: String; {!!} { Sanity check } - Assert((W1 <> '') and (W2 <> ''), Format(sRoleHasNoColumnNames, [ + Assert((W1 <> '') and (W2 <> ''), Format('Role %s does not have any column names!', [ Role.Association.name])); Assert(GetCharCount(';', W1) = GetCharCount(';', W2), - Format(sRoleEndCountMismatch, [ + Format('Role %s does not have an equal amount of columns on both ends!', [ Role.Association.name])); {!!} { Parse SQL } SQL := ''; for i := 0 to GetCharCount(';', W1) do - SQL := SQL + '(' + GetNextWord(W1, ';') + ' = :' + GetNextWord(W2, ';') + ') AND'; // do not localize + SQL := SQL + '(' + GetNextWord(W1, ';') + ' = :' + GetNextWord(W2, ';') + ') AND'; { Remove last ' AND' } SetLength(SQL, Length(SQL)-4); - SQL := Format('SELECT %S FROM %S WHERE (%S)', [ // do not localize + SQL := Format('SELECT %S FROM %S WHERE (%S)', [ StringReplace(FindExternalKeyColumns(Role.OtherEnd.MoldClass), ';', ', ', [rfReplaceAll]), _GetTableName(Role.OtherEnd.MoldClass), SQL]); @@ -1134,7 +1145,7 @@ procedure TSingleRoleFetchObject.Fetch(Source: IBoldQuery; end else raise Exception.CreateFmt( - sUnknownVarTypeLoadingSingleID, + 'Unknown vartype when loading an external ID for singlelink %s.%s', [MoldClass.name, Role.name]); if Value.QueryInterface(IBoldObjectIdRef, IdRef) = S_OK then PersistenceController.SetSingleLink(IdRef, ExternalId, @@ -1149,7 +1160,7 @@ procedure TMultiRoleFetchObject.Fetch(Source: IBoldQuery; var Value: IBoldValue; OtherEndQuery: IBoldQuery; - IdRefList: IBoldObjectIdListRef; + IdRefList: IBoldObjectIdListRef; KeyNames: String; DBValue: Variant; ExternalId: TBoldObjectId; @@ -1180,7 +1191,7 @@ procedure TMultiRoleFetchObject.Fetch(Source: IBoldQuery; end else raise Exception.CreateFmt( - sUnknownVarTypeLoadingSingleID, + 'Unknown vartype when loading an external ID for singlelink %s.%s', [MoldClass.name, Role.name]); OtherEndQuery.Next; end; @@ -1296,7 +1307,7 @@ constructor TFetchContext.Create( SQL := SQL + S[i] + ', '; SetLength(SQL, Length(SQL)-2); - SQL := Format('SELECT %S FROM %S WHERE %S', [ // do not localize + SQL := Format('SELECT %S FROM %S WHERE %S', [ SQL, _GetTableName(MoldClass), PersistenceController.ExternalKeysToInternalSQL(MoldClass, ExternalKeys)]); finally S.Free; @@ -1322,7 +1333,7 @@ procedure TFetchContext.FetchObject(ObjectContents: IBoldObjectContents); FetchObjectList.MoldClass, ObjectContents, Source) then FetchObjectList[i].Fetch(Source, ObjectContents) else - raise Exception.Create(sObjectNoLongerInDB); + raise Exception.Create('Object no longer exists in database'); end; end; @@ -1331,6 +1342,7 @@ procedure TFetchContext.PostFetch; { Do nothing } end; + function TBoldExternalPersistenceControllerSQL.ObjectContentsToInternalSQL( MoldClass: TMoldClass; ObjectContents: IBoldObjectContents): String; var diff --git a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandleDataSet.pas b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandleDataSet.pas index 99df201d..9a67b82f 100644 --- a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandleDataSet.pas +++ b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandleDataSet.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldExternalPersistenceHandleDataSet; interface @@ -10,6 +13,7 @@ interface BoldExternalPersistenceControllerDataSet; type + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldExternalPersistenceHandleDataSet = class(TBoldAbstractPartiallyExternalPH) private FConfig: TBoldExternalPersistenceConfigDataSetItems; @@ -79,4 +83,6 @@ procedure TBoldExternalPersistenceHandleDataSet.SetConfig( Config.Assign(Value); end; +initialization + end. diff --git a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandleEventDriven.pas b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandleEventDriven.pas index 7c678655..12d97cce 100644 --- a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandleEventDriven.pas +++ b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandleEventDriven.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldExternalPersistenceHandleEventDriven; interface @@ -14,6 +17,7 @@ interface TBoldExternalPersistenceHandleEventDriven = class; + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldExternalPersistenceHandleEventDriven = class(TBoldAbstractpartiallyExternalPH) private FConfig: TBoldExternalPersistenceConfigItems; @@ -29,6 +33,7 @@ TBoldExternalPersistenceHandleEventDriven = class(TBoldAbstractpartiallyExtern published property Config: TBoldExternalPersistenceConfigItems read fConfig write SetConfig; property MaxFetchBlockSize: integer read fMaxFetchBlockSize write fMaxFetchBlockSize default 250; + property UpdateBoldDatabaseFirst; {$IFNDEF T2H} property NextPersistenceHandle; property BoldModel; @@ -52,7 +57,7 @@ constructor TBoldExternalPersistenceHandleEventDriven.Create(Owner: TComponent); begin inherited; FConfig := TBoldExternalPersistenceConfigItems.Create(self); - fMaxFetchBlockSize := 250; + fMaxFetchBlockSize := 250; end; destructor TBoldExternalPersistenceHandleEventDriven.Destroy; @@ -65,7 +70,7 @@ function TBoldExternalPersistenceHandleEventDriven.CreatePersistenceController: var Controller: TBoldExternalPersistenceControllerEventDriven; begin - Controller := TBoldExternalPersistenceControllerEventDriven.Create(BoldModel.MoldModel, Config, BoldModel.TypeNameDictionary, OnStartUpdates, OnEndUpdates, OnFailUpdates, MaxFetchBlockSize); + Controller := TBoldExternalPersistenceControllerEventDriven.Create(BoldModel.MoldModel, Config, BoldModel.TypeNameDictionary, OnStartUpdates, OnEndUpdates, OnFailUpdates, MaxFetchBlockSize, UpdateBoldDatabaseFirst); ChainPersistenceController(Controller); Result := Controller; end; @@ -83,4 +88,5 @@ function TBoldExternalPersistenceHandleEventDriven.GetPersistenceController: TBo result := inherited PersistenceController as TBoldExternalPersistenceControllerEventDriven; end; + end. diff --git a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandleSQL.pas b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandleSQL.pas index 8b3d6d54..eba354b8 100644 --- a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandleSQL.pas +++ b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandleSQL.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldExternalPersistenceHandleSQL; interface @@ -16,6 +19,7 @@ interface BoldPersistenceController; type + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldExternalPersistenceHandleSQL = class(TBoldAbstractPartiallyExternalPH) private FDatabaseAdapter: TBoldAbstractDatabaseAdapter; @@ -30,6 +34,7 @@ TBoldExternalPersistenceHandleSQL = class(TBoldAbstractPartiallyExternalPH) destructor Destroy; override; property PersistenceController: TBoldExternalPersistenceControllerSQL read GetPersistenceController; published + property UpdateBoldDatabaseFirst; property ClassesToHandle: TStrings read GetClassesToHandle write SetClassesToHandle; property DatabaseAdapter: TBoldAbstractDatabaseAdapter read FDatabaseAdapter write FDatabaseAdapter; {$IFNDEF T2H} @@ -45,6 +50,7 @@ TBoldExternalPersistenceHandleSQL = class(TBoldAbstractPartiallyExternalPH) implementation + { TBoldExternalPersistenceHandleSQL } constructor TBoldExternalPersistenceHandleSQL.Create(Owner: TComponent); @@ -65,7 +71,7 @@ function TBoldExternalPersistenceHandleSQL.CreatePersistenceController: TBoldPer begin Controller := TBoldExternalPersistenceControllerSQL.Create( BoldModel.MoldModel, FDatabaseAdapter, BoldModel.TypeNameDictionary, - OnStartUpdates, OnEndUpdates, OnFailUpdates, ClassesToHandle); + OnStartUpdates, OnEndUpdates, OnFailUpdates, ClassesToHandle, UpdateBoldDatabaseFirst); ChainPersistenceController(Controller); Result := Controller; end; @@ -86,4 +92,6 @@ function TBoldExternalPersistenceHandleSQL.GetPersistenceController: TBoldExtern result := inherited PersistenceController as TBoldExternalPersistenceControllerSQL; end; +initialization + end. diff --git a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandleSQLPropEditor.pas b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandleSQLPropEditor.pas index ddf89511..70f5b2dd 100644 --- a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandleSQLPropEditor.pas +++ b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandleSQLPropEditor.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldExternalPersistenceHandleSQLPropEditor; interface diff --git a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandles.res b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandles.res new file mode 100644 index 00000000..d7547a41 Binary files /dev/null and b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandles.res differ diff --git a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandlesReg.pas b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandlesReg.pas index fb25de70..1d290dd3 100644 --- a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandlesReg.pas +++ b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceHandlesReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldExternalPersistenceHandlesReg; interface @@ -26,8 +29,7 @@ implementation BoldExternalPersistenceHandleSQL, BoldAbstractPropertyEditors, - BoldIDEConsts, - ExPeConsts; + BoldIDEConsts; type { forward declarations } @@ -86,7 +88,7 @@ procedure RegisterPropertyEditors; RegisterPropertyEditor(TypeInfo(TBoldExternalPersistenceGetExistsEvent), nil, '', TBoldExternalPersistenceHandleEventProperty); RegisterPropertyEditor(TypeInfo(TBoldExternalPersistenceAssignKeyToObjectEvent), nil, '', TBoldExternalPersistenceHandleEventProperty); RegisterPropertyEditor(TypeInfo(TBoldExternalPersistenceGetKeyFromObject), nil, '', TBoldExternalPersistenceHandleEventProperty); - RegisterPropertyEditor(TypeInfo(TStrings), TBoldExternalPersistenceHandleSQL, 'ClassesToHandle', TBoldExternalPersistenceHandleSQLPropEdit); // do not localize + RegisterPropertyEditor(TypeInfo(TStrings), TBoldExternalPersistenceHandleSQL, 'ClassesToHandle', TBoldExternalPersistenceHandleSQLPropEdit); end; procedure Register; @@ -105,7 +107,7 @@ function TBoldExternalPersistenceHandleEventProperty.GetFormMethodName: string; if GetComponent(0) = Designer.GetRoot then begin Result := Designer.GetRootClassName; - if (Result <> '') and (Result[1] = 'T') then // do not localize + if (Result <> '') and (Result[1] = 'T') then Delete(Result, 1, 1); end else @@ -115,11 +117,11 @@ function TBoldExternalPersistenceHandleEventProperty.GetFormMethodName: string; else Result := Designer.GetObjectName(GetComponent(0)); for I := Length(Result) downto 1 do - if Result[I] in ['.', '[', ']', '-', '>'] then + if CharInSet(Result[I], ['.', '[', ']', '-', '>']) then Delete(Result, I, 1); end; if Result = '' then - raise Exception.Create(sCannotCreateNameNow); + raise Exception.Create('Can not create name for eventhandler. Assign an expressionname for the config-item first'); Result := Result + GetTrimmedEventName; end; @@ -144,7 +146,7 @@ procedure TBoldExternalPersistenceHandleEditor.Edit; procedure TBoldExternalPersistenceHandleEditor.EditConfig(const PropertyEditor: IProperty); begin - if SameText(PropertyEditor.GetName, 'Config') then // do not localize + if SameText(PropertyEditor.GetName, 'Config') then PropertyEditor.Edit; end; @@ -158,7 +160,7 @@ procedure TBoldExternalPersistenceHandleEditor.ExecuteVerb(Index: Integer); function TBoldExternalPersistenceHandleEditor.GetVerb(Index: Integer): string; begin case Index of - 0: result := sEditConfiguration; + 0: result := 'Edit configuration'; end; end; @@ -179,7 +181,7 @@ procedure TBoldExternalPersistenceHandleSQLPropEdit.Edit; Handle := GetComponent(0) as TBoldExternalPersistenceHandleSQL; if not Assigned(Handle.BoldModel) then - raise Exception.Create(sBoldModelNotAssigned); + raise Exception.Create('BoldModel is not assigned!'); Form := TBoldExternalPersistenceHandleSQLPropEditorForm.Create(nil); Form.Initialize(Handle.BoldModel.MoldModel, Handle.ClassesToHandle); @@ -222,12 +224,12 @@ function TBoldExternalPersistenceHandleSQLPropEdit.GetValue: string; All := False; end; if All then - Result := '(All)' // do not localize + Result := '(All)' else if Result <> '' then SetLength(Result, Length(Result)-2) else - Result := '(None)'; // do not localize + Result := '(None)'; end; var @@ -235,7 +237,7 @@ function TBoldExternalPersistenceHandleSQLPropEdit.GetValue: string; begin Result := ''; if PropCount <> 1 then - Result := '(Multi)' // do not localize + Result := '(Multi)' else with (GetComponent(0) as TBoldExternalPersistenceHandleSQL) do begin @@ -248,11 +250,9 @@ function TBoldExternalPersistenceHandleSQLPropEdit.GetValue: string; if Result <> '' then SetLength(Result, Length(Result)-2) else - Result := '(None)'; // do not localize + Result := '(None)'; end; end; end; end. - - diff --git a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceSupport.pas b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceSupport.pas index 37a44d84..ecae7b98 100644 --- a/Source/Persistence/ExternalPersistence/BoldExternalPersistenceSupport.pas +++ b/Source/Persistence/ExternalPersistence/BoldExternalPersistenceSupport.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldExternalPersistenceSupport; interface diff --git a/Source/Persistence/ExternalPersistence/ExPeConsts.pas b/Source/Persistence/ExternalPersistence/ExPeConsts.pas index daf96156..f57af51a 100644 --- a/Source/Persistence/ExternalPersistence/ExPeConsts.pas +++ b/Source/Persistence/ExternalPersistence/ExPeConsts.pas @@ -48,4 +48,4 @@ interface implementation -end. \ No newline at end of file +end. diff --git a/Source/Persistence/File/BoldPersistenceHandleFile.pas b/Source/Persistence/File/BoldPersistenceHandleFile.pas index 009cec42..b2ba9c60 100644 --- a/Source/Persistence/File/BoldPersistenceHandleFile.pas +++ b/Source/Persistence/File/BoldPersistenceHandleFile.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleFile; interface @@ -12,7 +15,8 @@ interface BoldUpdatePrecondition, BoldCondition, BoldFreeStandingValues, - BoldValueSpaceInterfaces; + BoldValueSpaceInterfaces, + BoldElements; type { forward declarations } @@ -20,7 +24,6 @@ TBoldAbstractPersistenceHandleFile = class; TBoldPersistenceControllerFile = class; { TBoldAbstractPersistenceHandleFile } - {$MESSAGE WARN 'BoldModel should have FreeNotification!'} TBoldAbstractPersistenceHandleFile = class(TBoldPersistenceHandle) private FFileName: String; @@ -50,18 +53,19 @@ TBoldPersistenceControllerFile = class(TBoldPersistenceController) procedure WriteValueSpace; virtual; abstract; procedure ReadValueSpace; virtual; abstract; public - constructor Create(filename: string; CacheData: Boolean; MoldModel: TMoldModel); - destructor Destroy; override; - procedure PMExactifyIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; + constructor create(filename: string; CacheData: Boolean; MoldModel: TMoldModel); + destructor destroy; override; + procedure PMExactifyIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; HandleNonExisting: Boolean); override; procedure PMFetch(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; BoldClientID: TBoldClientID); override; procedure PMFetchIDListWithCondition(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; FetchMode: Integer; Condition: TBoldCondition; BoldClientID: TBoldClientID); override; - procedure PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; BoldClientID: TBoldClientID); override; + procedure PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; var TimeOfLatestUpdate: TDateTime; BoldClientID: TBoldClientID); override; procedure PMTranslateToGlobalIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; procedure PMTranslateToLocalIds(GlobalIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; - procedure PMSetReadOnlyness(ReadOnlyList, WriteableList: TBoldObjectIdList); override; + procedure PMSetReadonlyness(ReadOnlyList, WriteableList: TBoldObjectIdList); override; function MultilinksAreStoredInObject: Boolean; override; procedure ReserveNewIds(ValueSpace: IBoldValueSpace; ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; + function CanEvaluateInPS(sOCL: string; aSystem: TBoldElement; aContext: TBoldElementTypeInfo = nil; const aVariableList: TBoldExternalVariableList = nil): Boolean; override; property FileName: String read fFileName; property LocalValueSpace: IBoldValueSpace read GetValueSpace; property CacheData: Boolean read fCacheData; @@ -73,12 +77,19 @@ implementation uses Dialogs, SysUtils, - BoldDefaultId, - PersistenceConsts, - BoldCoreConsts; + BoldDefaultId; { TBoldPersistenceControllerFile } +function TBoldPersistenceControllerFile.CanEvaluateInPS(sOCL: string; + aSystem: TBoldElement; aContext: TBoldElementTypeInfo; + const aVariableList: TBoldExternalVariableList): Boolean; +const + sMethodNotImplemented = '%s.%s: not supported/implemented'; +begin + raise EBold.CreateFmt(sMethodNotImplemented, [ClassName, 'CanEvaluateInPS']); // do not localize +end; + constructor TBoldPersistenceControllerFile.create(filename: string; CacheData: Boolean; MoldModel: TMoldModel); begin Inherited Create; @@ -94,9 +105,8 @@ function TBoldPersistenceControllerFile.GetValueSpace: IBoldValueSpace; end; procedure TBoldPersistenceControllerFile.EnsureValueSpace; - procedure FixupValueSpace; // make sure that valuspaces in old formats can be handled + procedure FixupValueSpace; begin - // Make sure persistacestate is current for everything fFreeStandingValueSpace.MarkAllObjectsAndMembersCurrent; end; begin @@ -116,22 +126,17 @@ procedure TBoldPersistenceControllerFile.EnsureValueSpace; procedure TBoldPersistenceControllerFile.PMExactifyIds( ObjectIdList: TBoldObjectIdList; - TranslationList: TBoldIdTranslationList); + TranslationList: TBoldIdTranslationList; HandleNonExisting: Boolean); begin - raise EBold.Create(sNotImplemented); + raise EBold.Create('NotImplemented'); end; procedure TBoldPersistenceControllerFile.PMFetch( ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; BoldClientID: TBoldClientID); -var - i: integer; begin EnsureValueSpace; - for i := 0 to ObjectIdList.Count - 1 do - if not LocalValueSpace.HasContentsForId[ObjectIdList[i]] then - raise EBold.CreateFmt(sObjectNotInFile, [ClassName, ObjectIdList[i].AsString]); BoldApplyPartialValueSpace(ValueSpace, LocalValueSpace, ObjectIdList, MemberIdList, false); if not cacheData then @@ -167,55 +172,55 @@ procedure TBoldPersistenceControllerFile.PMFetchIDListWithCondition( end else if Condition is TBoldSQLCondition then begin - ShowMessage(sSQLNotSpokenHere); + ShowMessage('This filehandler does not understand SQL, ignoring condition and orderby...'); NewCondition := TBoldConditionWithClass.Create; NewCondition.TopSortedIndex := TBoldSQLCondition(Condition).TopSortedIndex; PMFetchIDListWithCondition(ObjectIdList, ValueSpace, FetchMode, NewCondition, NOTVALIDCLIENTID); NewCondition.free; end else - raise EBold.CreateFmt(sUnknownConditionType, [Condition.Classname]); + raise EBold.Create('unknown conditiontype: ' + Condition.Classname); end; procedure TBoldPersistenceControllerFile.PMSetReadonlyness(ReadOnlyList, WriteableList: TBoldObjectIdList); begin - raise EBold.Create(sNotImplemented); + raise EBold.Create('Not Implemented'); end; procedure TBoldPersistenceControllerFile.PMTranslateToGlobalIds( ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); begin - raise EBold.Create(sNotImplemented); + raise EBold.Create('Not Implemented'); end; procedure TBoldPersistenceControllerFile.PMTranslateToLocalIds( GlobalIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); begin - raise EBold.Create(sNotImplemented); + raise EBold.Create('Not Implemented'); end; procedure TBoldPersistenceControllerFile.PMUpdate( ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; - Precondition: TBoldUpdatePrecondition; - TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; BoldClientID: TBoldClientID); + Precondition: TBoldUpdatePrecondition; + TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; var TimeOfLatestUpdate: TDateTime; BoldClientID: TBoldClientID); var NewTimeStamp: TDateTime; LocalTranslationList: TBoldIdTranslationList; begin if assigned(Precondition) then - raise EBold.CreateFmt(sPreconditionsNotSupported, [Classname, Precondition.Classname]); - + raise EBold.CreateFmt('%s.PMUpdate: Preconditions (%s) not supported in this component', [Classname, Precondition.Classname]); + EnsureValueSpace; if fileexists(Filename) then NewTimeStamp := FileDateToDateTime(FileAge(FileName)) else NewTimeStamp := 0; - + TimeOfLatestUpdate := now; if (NewTimeStamp <> fFileTimeStamp) then begin { if MessageDlg('The datafile has been written since you last accessed it... Go ahead?', @@ -242,13 +247,12 @@ procedure TBoldPersistenceControllerFile.PMUpdate( LocalTranslationList.Free; WriteValueSpace; - + fFileTimestamp := FileDateToDateTime(FileAge(FileName)); end; procedure TBoldPersistenceControllerFile.UnloadLocalValueSpace; begin - // does not work. { fFreeStandingValueSpace.Free; fFreeStandingValueSpace := nil; } @@ -284,11 +288,12 @@ procedure TBoldPersistenceControllerFile.ReserveNewIds(ValueSpace: IBoldValueSpa destructor TBoldPersistenceControllerFile.destroy; begin FreeAndNil(fFreeStandingValueSpace); - inherited; + inherited; end; { TBoldAbstractPersistenceHandleFile } + procedure TBoldAbstractPersistenceHandleFile.SetBoldModel(const Value: TBoldAbstractModel); begin FBoldModel := Value; @@ -304,4 +309,7 @@ procedure TBoldAbstractPersistenceHandleFile.SetFileName(const Value: String); FFileName := Value; end; + +initialization + end. diff --git a/Source/Persistence/File/BoldPersistenceHandleFileXML.pas b/Source/Persistence/File/BoldPersistenceHandleFileXML.pas index 4122ff5e..6879f529 100644 --- a/Source/Persistence/File/BoldPersistenceHandleFileXML.pas +++ b/Source/Persistence/File/BoldPersistenceHandleFileXML.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleFileXML; interface @@ -12,6 +15,7 @@ TBoldPersistenceHandleFileXML = class; TBoldPersistenceControllerFileXML = class; { TBoldPersistenceHandleFileXML } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldPersistenceHandleFileXML = class(TBoldAbstractPersistenceHandleFile) protected function CreatePersistenceController: TBoldPersistenceController; override; @@ -34,25 +38,47 @@ implementation classes, SysUtils, BoldDefs, - MSXML_TLB, + {$IFDEF OXML}OXmlPDOM, OTextReadWrite{$ELSE}Bold_MSXML_TLB{$ENDIF}, BoldId, BoldXMLStreaming, BoldDefaultXMLStreaming, - BoldGuard, - PersistenceConsts; + BoldGuard; { TBoldPersistenceHandleFileXML } function TBoldPersistenceHandleFileXML.CreatePersistenceController: TBoldPersistenceController; begin if not assigned(BoldModel) then - Raise EBold.CreateFmt(sModelRequired, [ClassName]); + Raise EBold.CreateFmt('%s.CreatePersistenceController: Unable to create, model is missing.', [ClassName]); Result := TBoldPersistenceControllerFileXML.Create(FileName, CacheData, BoldModel.MoldModel); end; { TBoldPersistenceControllerFileXML } procedure TBoldPersistenceControllerFileXML.ReadValueSpace; +{$IFDEF OXML} +var + anXMLDoc: TXMLDocument; + ParseError: IOTextParseError; + aMgr: TBoldDefaultXMLStreamManager; + aNode: TBoldXMLNode; + BoldGuard: IBoldGuard; +begin + BoldGuard := TBoldGuard.Create(aMgr, aNode); + anXMLDoc := TXMLDocument.Create; + aMgr := TBoldDefaultXMLStreamManager.Create( + TBoldDefaultXMLStreamerRegistry.MainStreamerRegistry, MoldModel); + aMgr.IgnorePersistenceState := True; + aMgr.PersistenceStatesToOverwrite := [bvpsInvalid, bvpsCurrent]; + aMgr.PersistenceStatesToBeStreamed := [bvpsInvalid, bvpsModified, bvpsCurrent]; + anXMLDoc.LoadFromFile(FileName); + ParseError := anXMLDoc.parseError; + if Assigned(ParseError) and (ParseError.ErrorCode <> 0) then + raise EBold.Create('Error reading/parsing XML file'); + aNode := aMgr.GetRootNode(anXMLDoc, 'ValueSpace'); //do not localize + aMgr.ReadValueSpace(LocalValueSpace, aNode); +end; +{$ELSE} var aStringList: TStringList; anXMLDoc: TDomDocument; @@ -74,12 +100,33 @@ procedure TBoldPersistenceControllerFileXML.ReadValueSpace; ParseError := anXMLDoc.parseError; if Assigned(ParseError) and (ParseError.errorCode <> 0) then - raise EBold.Create(sXMLParseError); - aNode := aMgr.GetRootNode(anXMLDoc, 'ValueSpace'); //do not localize + raise EBold.Create('Error reading/parsing XML file'); + aNode := aMgr.GetRootNode(anXMLDoc, 'ValueSpace'); aMgr.ReadValueSpace(LocalValueSpace, aNode); end; +{$ENDIF} procedure TBoldPersistenceControllerFileXML.WriteValueSpace; +{$IFDEF OXML} +var + aXML: TXMLDocument; + aMgr: TBoldDefaultXMLStreamManager; + aNode: TBoldXMLNode; + anIdList: TBoldObjectIdList; + BoldGuard: IBoldGuard; +begin + BoldGuard := TBoldGuard.Create(aNode, aMgr, anIDList); + aXML := TXMLDocument.Create; + aMgr := TBoldDefaultXMLStreamManager.Create(TBoldDefaultXMLStreamerRegistry.MainStreamerRegistry, MoldModel); + aMgr.IgnorePersistenceState := True; + aMgr.PersistenceStatesToBeStreamed := [bvpsInvalid, bvpsModified, bvpsCurrent]; + aNode := aMgr.NewRootNode(aXML, 'ValueSpace'); //do not localize + anIdList := TBoldObjectIdList.Create; + LocalValueSpace.AllObjectIds(anIdList, True); + aMgr.WriteValueSpace(LocalValueSpace, anIdList, nil, aNode); + aXML.SaveToFile(FileName); +end; +{$ELSE} var aStringList: TStringList; anXMLDoc: TDomDocument; @@ -94,12 +141,15 @@ procedure TBoldPersistenceControllerFileXML.WriteValueSpace; aMgr := TBoldDefaultXMLStreamManager.Create(TBoldDefaultXMLStreamerRegistry.MainStreamerRegistry, MoldModel); aMgr.IgnorePersistenceState := True; aMgr.PersistenceStatesToBeStreamed := [bvpsInvalid, bvpsModified, bvpsCurrent]; - aNode := aMgr.NewRootNode(anXMLDoc, 'ValueSpace'); //do not localize + aNode := aMgr.NewRootNode(anXMLDoc, 'ValueSpace'); anIdList := TBoldObjectIdList.Create; LocalValueSpace.AllObjectIds(anIdList, True); aMgr.WriteValueSpace(LocalValueSpace, anIdList, nil, aNode); aStringList.Text := anXMLDoc.documentElement.xml; aStringList.SaveToFile(FileName); end; +{$ENDIF} + +initialization end. diff --git a/Source/Persistence/FireDAC/BoldDatabaseAdapterFireDAC.pas b/Source/Persistence/FireDAC/BoldDatabaseAdapterFireDAC.pas new file mode 100644 index 00000000..2c600a20 --- /dev/null +++ b/Source/Persistence/FireDAC/BoldDatabaseAdapterFireDAC.pas @@ -0,0 +1,102 @@ +{ Global compiler directives } +{$include bold.inc} +unit BoldDatabaseAdapterFireDAC; + +interface + +uses + Classes, + BoldAbstractDataBaseAdapter, + BoldDBInterfaces, + BoldFireDACInterfaces, + FireDAC.Comp.Client; + +type + { forward declarations } + TBoldDatabaseAdapterFireDAC = class; + + { TBoldDatabaseAdapterFireDAC } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] + TBoldDatabaseAdapterFireDAC = class(TBoldAbstractDatabaseAdapter) + private + fBoldFireDACConnection: TBoldFireDACConnection; + procedure SetConnection(const Value: TFDConnection); + function GetConnection: TFDConnection; + protected + procedure ReleaseBoldDatabase; override; + function GetDataBaseInterface: IBoldDatabase; override; + public + destructor Destroy; override; + procedure CreateDatabase(DropExisting: boolean = true); override; + procedure DropDatabase; override; + function DatabaseExists: boolean; override; + published + property Connection: TFDConnection read GetConnection write SetConnection; + {$IFNDEF T2H} + property DatabaseEngine; + {$ENDIF} + end; + +implementation + +uses + BoldSQLDatabaseConfig, + SysUtils, + BoldDefs, + BoldFireDACConsts; + +{ TBoldDatabaseAdapterFireDAC } + +function TBoldDatabaseAdapterFireDAC.DatabaseExists: boolean; +begin + result := DatabaseInterface.DatabaseExists; +end; + +destructor TBoldDatabaseAdapterFireDAC.Destroy; +begin + Changed; + FreePublisher; + FreeAndNil(fBoldFireDACConnection); + inherited; +end; + +procedure TBoldDatabaseAdapterFireDAC.DropDatabase; +begin + DatabaseInterface.DropDatabase; +end; + +procedure TBoldDatabaseAdapterFireDAC.CreateDatabase(DropExisting: boolean = true); +begin + DatabaseInterface.CreateDatabase(DropExisting); +end; + +function TBoldDatabaseAdapterFireDAC.GetConnection: TFDConnection; +begin + Result := InternalDatabase as TFDConnection; +end; + +function TBoldDatabaseAdapterFireDAC.GetDataBaseInterface: IBoldDatabase; +begin + if not Assigned(Connection) then + begin + raise EBold.CreateFmt(sAdapterNotConnected, [ClassName]); + end; + if not Assigned(fBoldFireDACConnection) then + begin + fBoldFireDACConnection := TBoldFireDACConnection.Create(Connection, SQLDataBaseConfig); + end; + Result := fBoldFireDACConnection; +end; + +procedure TBoldDatabaseAdapterFireDAC.ReleaseBoldDatabase; +begin + FreeAndNil(fBoldFireDACConnection); +end; + +procedure TBoldDatabaseAdapterFireDAC.SetConnection(const Value: TFDConnection); +begin + InternalDatabase := Value; +end; + +end. + diff --git a/Source/Persistence/FireDAC/BoldFireDACConsts.pas b/Source/Persistence/FireDAC/BoldFireDACConsts.pas new file mode 100644 index 00000000..d7c84d58 --- /dev/null +++ b/Source/Persistence/FireDAC/BoldFireDACConsts.pas @@ -0,0 +1,18 @@ +{ Global compiler directives } +{$include bold.inc} +unit BoldFireDACConsts; + +interface + +resourcestring +//BoldDatabaseAdapterFireDAC + sAdapterNotConnected = '%s.GetDatabaseInterface: The adapter is not connected to an FireDAC connection'; + sCreatedNewAdapter = 'Created a new DatabaseAdapterFireDAC'; + sCanOnlyTransferToFireDACAdapter = 'The persistencehandle is connected to a %s, properties can only be transfered to a TBoldDatabaseAdapterFireDAC'; + sCreatedNewDB = 'Created a new FireDACDatabase'; + sCouldNotTransferConnectionString = 'Connection string settings could not be transferred to the new FireDAC connection: '; + sTransferManually = 'Please transfer these manually!'; + +implementation + +end. diff --git a/Source/Persistence/FireDAC/BoldFireDACInterfaces.pas b/Source/Persistence/FireDAC/BoldFireDACInterfaces.pas new file mode 100644 index 00000000..14d88c1f --- /dev/null +++ b/Source/Persistence/FireDAC/BoldFireDACInterfaces.pas @@ -0,0 +1,1705 @@ + +{ Global compiler directives } +{$include bold.inc} +unit BoldFireDACInterfaces; + +interface + +uses + Classes, + Db, + SysUtils, + + FireDAC.Comp.Client, + FireDAC.Stan.Param, + + BoldSQLDatabaseConfig, + BoldDBInterfaces, + BoldDefs; + +type + { forward declarations } + TBoldFireDACParameter = class; + TBoldFireDACQuery = class; + TBoldFireDACTable = class; + TBoldFireDACConnection = class; + + TFireDacParam = TFDParam; + + TBoldFireDACQueryClass = class of TBoldFireDACQuery; + TBoldFireDACExecQueryClass = class of TBoldFireDACExecQuery; + + { TBoldFireDACParameter } + TBoldFireDACParameter = class(TBoldParameterWrapper, IBoldParameter) + private + fFDParam: TFireDacParam; + function GetAsVariant: Variant; + procedure SetAsVariant(const NewValue: Variant); + function GetName: string; + procedure Clear; + function GetDataType: TFieldType; + procedure SetDataType(Value: TFieldType); + function GetAsBCD: Currency; + function GetAsblob: TBoldBlobData; + function GetAsBoolean: Boolean; + function GetAsDateTime: TDateTime; + function GetAsCurrency: Currency; + function GetAsFloat: Double; + function GetAsInteger: Longint; + function GetAsInt64: Int64; + function GetAsMemo: string; + function GetAsString: string; + function GetIsNull: Boolean; + function GetAsWideString: WideString; + procedure SetAsBCD(const Value: Currency); + procedure SetAsBlob(const Value: TBoldBlobData); + procedure SetAsBoolean(Value: Boolean); + procedure SetAsCurrency(const Value: Currency); + procedure SetAsDate(const Value: TDateTime); + procedure SetAsDateTime(const Value: TDateTime); + procedure SetAsFloat(const Value: Double); + procedure SetAsInteger(Value: Longint); + procedure SetAsInt64(const Value: Int64); + procedure SetAsMemo(const Value: string); + procedure SetAsString(const Value: string); + procedure SetAsSmallInt(Value: Longint); + procedure SetAsTime(const Value: TDateTime); + procedure SetAsWord(Value: Longint); + procedure SetText(const Value: string); + procedure SetAsWideString(const Value: Widestring); + function GetAsAnsiString: TBoldAnsiString; + procedure SetAsAnsiString(const Value: TBoldAnsiString); + function GetFDParam: TFireDacParam; + procedure AssignFieldValue(const source: IBoldField); + procedure Assign(const source: IBoldParameter); + property FDParam: TFireDacParam read GetFDParam; + public + constructor Create(FireDACParameter: TFireDacParam; DatasetWrapper: TBoldAbstractQueryWrapper); + end; + + { TBoldFireDACQuery } + TBoldFireDACQuery = class(TBoldBatchDataSetWrapper, IBoldQuery, IBoldExecQuery, IBoldParameterized) + private + fQuery: TFDQuery; + fReadTransactionStarted: Boolean; + fUseReadTransactions: boolean; + function GetQuery: TFDQuery; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure AssignParams(Sourceparams: TParams); + function GetParamCount: Integer; + function GetParam(i: Integer): IBoldParameter; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetParamCheck: Boolean; + procedure SetParamCheck(value: Boolean); + function GetRequestLiveQuery: Boolean; + function ParamByName(const Value: string): IBoldParameter; override; + function FindParam(const Value: string): IBoldParameter; override; + function Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; override; + procedure SetRequestLiveQuery(NewValue: Boolean); + procedure AssignSQL(SQL: TStrings); virtual; + function GetSQLStrings: TStrings; override; + function GetRecordCount: Integer; + function GetUseReadTransactions: boolean; + procedure SetUseReadTransactions(value: boolean); + procedure BeginExecuteQuery; + procedure EndExecuteQuery; + protected + function GetParams: TParams; override; + function GetSqlText: string; override; + procedure AssignSQLText(const SQL: string); override; + function GetRowsAffected: Integer; + function GetDataSet: TDataSet; override; + procedure ClearParams; + procedure Open; override; + procedure Close; override; + procedure ExecSQL; override; + function GetRecNo: integer; override; + property Query: TFDQuery read GetQuery; + public + constructor Create(BoldFireDACConnection: TBoldFireDACConnection); reintroduce; + destructor Destroy; override; + procedure Clear; override; + end; + + { TBoldFireDACQuery } + TBoldFireDACExecQuery = class(TBoldAbstractQueryWrapper, IBoldExecQuery, IBoldParameterized) + private + fExecQuery: TFDQuery; + fReadTransactionStarted: Boolean; + fUseReadTransactions: boolean; + function GetExecQuery: TFDQuery; + function GetParams: TParams; + procedure AssignParams(Sourceparams: TParams); + function GetParamCount: Integer; + function GetParam(i: Integer): IBoldParameter; + function GetParamCheck: Boolean; + procedure SetParamCheck(value: Boolean); + function ParamByName(const Value: string): IBoldParameter; + function FindParam(const Value: string): IBoldParameter; + function Createparam(FldType: TFieldType; const ParamName: string): IBoldParameter; overload; + function CreateParam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; overload; + function EnsureParamByName(const Value: string): IBoldParameter; + function GetSQLText: string; + function GetSQLStrings: TStrings; + procedure AssignSQL(SQL: TStrings); virtual; + procedure AssignSQLText(const SQL: string); + function GetRowsAffected: Integer; + function GetUseReadTransactions: boolean; + procedure SetUseReadTransactions(value: boolean); + procedure BeginExecuteQuery; + procedure EndExecuteQuery; + function GetBatchQueryParamCount: integer; +// procedure Prepare; + protected + procedure StartSQLBatch; virtual; + procedure EndSQLBatch; virtual; + procedure FailSQLBatch; virtual; + procedure ClearParams; + procedure ExecSQL; virtual; + property ExecQuery: TFDQuery read GetExecQuery; + public + constructor Create(BoldFireDACConnection: TBoldFireDACConnection); reintroduce; + destructor Destroy; override; + procedure Clear; override; + end; + + { TBoldFireDACTable } + TBoldFireDACTable = class(TBoldDatasetWrapper, IBoldTable) + private + fFDTable: TFDTable; + function GetFDTable: TFDTable; + property FDTable: TFDTable read GetFDTable; + procedure AddIndex(const Name, Fields: string; Options: TIndexOptions; const DescFields: string = ''); + procedure CreateTable; + procedure DeleteTable; + function GetIndexDefs: TIndexDefs; + procedure SetTableName(const NewName: string); + function GetTableName: string; + procedure SetExclusive(NewValue: Boolean); + function GetExclusive: Boolean; + function GetExists: Boolean; +// function GetCommaListOfIndexesForColumn(const aColumnName: string): string; +// function GetPrimaryIndex: string; + protected + function GetDefaultConstraintNameForColumn(const aColumnName: string): string; {override;} + function GetDataSet: TDataSet; override; + function ParamByName(const Value: string): IBoldParameter; override; + function FindParam(const Value: string): IBoldParameter; override; + public + constructor Create(aFDTable: TFDTable; BoldFireDACConnection: TBoldFireDACConnection); reintroduce; + end; + + { TBoldFireDACConnection } + TBoldFireDACConnection = class(TBoldDatabaseWrapper, IBoldDataBase) + fFDConnection: TFDConnection; + fCachedTable: TBoldFireDACTable; + fCachedQuery1: TBoldFireDACQuery; + fCachedQuery2: TBoldFireDACQuery; + fCachedExecQuery1: TBoldFireDACQuery; + fExecuteQueryCount: integer; + function GetFDConnection: TFDConnection; + property FDConnection: TFDConnection read GetFDConnection; + function GetConnected: Boolean; + function GetInTransaction: Boolean; + function GetIsSQLBased: Boolean; + procedure SetlogInPrompt(NewValue: Boolean); + function GetLogInPrompt: Boolean; + procedure SetKeepConnection(NewValue: Boolean); + function GetKeepConnection: Boolean; + procedure StartTransaction; + procedure StartReadTransaction; + procedure Commit; + procedure RollBack; + procedure Open; + procedure Close; + procedure Reconnect; + function SupportsTableCreation: Boolean; + procedure ReleaseCachedObjects; + function GetIsExecutingQuery: Boolean; + procedure BeginExecuteQuery; + procedure EndExecuteQuery; + private + function GetTransaction: TFDTransaction; + function GetUpdateTransaction: TFDTransaction; + procedure SetTransaction(const Value: TFDTransaction); + procedure SetUpdateTransaction(const Value: TFDTransaction); + protected + procedure AllTableNames(Pattern: string; ShowSystemTables: Boolean; TableNameList: TStrings); override; + function GetTable: IBoldTable; override; + function GetQuery: IBoldQuery; override; + function GetExecQuery: IBoldExecQuery; override; + procedure ReleaseTable(var Table: IBoldTable); override; + procedure ReleaseQuery(var Query: IBoldQuery); override; + procedure ReleaseExecQuery(var Query: IBoldExecQuery); override; + property Transaction: TFDTransaction read GetTransaction write SetTransaction; + property UpdateTransaction: TFDTransaction read GetUpdateTransaction write SetUpdateTransaction; + public + constructor Create(aFDConnection: TFDConnection; SQLDataBaseConfig: TBoldSQLDatabaseConfig); + destructor Destroy; override; + procedure CreateDatabase(DropExisting: boolean = true); override; + procedure DropDatabase; override; + function DatabaseExists: boolean; override; + function GetDatabaseError(const E: Exception; const sSQL: string = ''): + EBoldDatabaseError; + property ExecuteQueryCount: integer read fExecuteQueryCount; + end; + +var + BoldFireDACQueryClass: TBoldFireDACQueryClass = TBoldFireDACQuery; + BoldFireDACExecQueryClass: TBoldFireDACExecQueryClass = TBoldFireDACExecQuery; + +implementation + +uses + Variants, + Masks, + + FireDAC.Stan.Option, + FireDAC.Comp.Script, + FireDAC.Comp.ScriptCommands, + FireDAC.Phys.Intf, + FireDAC.Phys.PGWrapper, + FireDAC.Stan.Intf, + + BoldUtils, + BoldGuard, + BoldCoreConsts; + +{ TBoldFireDACQuery } + +function TBoldFireDACQuery.GetQuery: TFDQuery; +begin + if not Assigned(fQuery) then + begin + fQuery := TFDQuery.Create(nil); + fQuery.Connection := (DatabaseWrapper as TBoldFireDACConnection).FDConnection; + end; + Result := fQuery; +end; + +function TBoldFireDACQuery.GetDataSet: TDataSet; +begin + Result := Query; +end; + +function TBoldFireDACQuery.GetParamCheck: Boolean; +begin + result := true; // ? +end; + +function TBoldFireDACQuery.GetParamCount: Integer; +begin + Result := Query.Params.Count; +end; + +type TFDAdaptedDataSetAccess = class(TFDAdaptedDataSet); + +function TBoldFireDACQuery.GetParams: TParams; +begin + result := TFDAdaptedDataSetAccess(Query).PSGetParams; +end; + +function TBoldFireDACQuery.GetParam(i: Integer): IBoldParameter; +begin + Result := TBoldFireDACParameter.Create(Query.Params[i], Self); +end; + +function TBoldFireDACQuery.GetRecNo: integer; +begin + result := Query.RecNo - 1; +end; + +function TBoldFireDACQuery.GetRecordCount: Integer; +begin + Result := Query.RecordCount; +end; + +function TBoldFireDACQuery.GetRequestLiveQuery: Boolean; +begin + Result := False; +end; + +function TBoldFireDACQuery.GetRowsAffected: Integer; +begin + result := Query.RowsAffected; +end; + +function TBoldFireDACQuery.GetSQLStrings: TStrings; +begin + result := Query.SQL; +end; + +function TBoldFireDACQuery.GetSQLText: string; +begin + Result := Query.SQL.Text; +end; + +function TBoldFireDACQuery.GetUseReadTransactions: boolean; +begin + result := fUseReadTransactions; +end; + +procedure TBoldFireDACQuery.AssignParams(Sourceparams: TParams); +var + lIndexSourceParams: Integer; + lFDParam: TFireDacParam; +begin + Query.Params.Clear; + if Assigned(Sourceparams) and (Sourceparams.Count > 0) then + begin + for lIndexSourceParams := 0 to Sourceparams.Count - 1 do + begin + lFDParam := Query.Params.CreateParam(Sourceparams[lIndexSourceParams].DataType, Sourceparams[lIndexSourceParams].Name, Sourceparams[lIndexSourceParams].ParamType) as TFireDacParam; + lFDParam.Value := Sourceparams[lIndexSourceParams].Value; + end; + end; +end; + +procedure TBoldFireDACQuery.AssignSQL(SQL: TStrings); +begin + Query.SQL.Assign(SQL); + //function ParseSQL(SQL: WideString; DoCreate: Boolean): WideString; + //DoCreate indicates whether to clear all existing parameter definitions before parsing the SQL statement. +end; + +procedure TBoldFireDACQuery.AssignSQLText(const SQL: string); +begin + Query.SQL.Text := Sql; +{ if SQL = '' then + Query.Params.clear + else + Query.Params.ParseSQL(SQL, False);} +end; + +procedure TBoldFireDACQuery.BeginExecuteQuery; +begin + (DatabaseWrapper as TBoldFireDACConnection).BeginExecuteQuery; +end; + +procedure TBoldFireDACQuery.Clear; +begin + AssignSQLText(''); + ClearParams; +end; + +procedure TBoldFireDACQuery.ClearParams; +begin + Query.Params.Clear; +end; + +procedure TBoldFireDACQuery.Close; +begin + inherited; + if (fReadTransactionStarted) and (DatabaseWrapper as TBoldFireDACConnection).GetInTransaction then + (DatabaseWrapper as TBoldFireDACConnection).Commit; + fReadTransactionStarted := false; +end; + +constructor TBoldFireDACQuery.Create(BoldFireDACConnection: TBoldFireDACConnection); +begin + inherited Create(BoldFireDACConnection); + fUseReadTransactions := true; + fQuery := TFDQuery.Create(nil); + fQuery.Connection := (DatabaseWrapper as TBoldFireDACConnection).FDConnection; +end; + +function TBoldFireDACQuery.CreateParam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; +var + lFDParam: TFireDacParam; +begin + lFDParam := Query.Params.CreateParam(FldType, ParamName, ptUnknown) as TFireDacParam; +// lFDParam.Size := Size; + lFDParam.Value := NULL; + Result := TBoldFireDACParameter.Create(lFDParam, Self); +end; + +destructor TBoldFireDACQuery.Destroy; +begin + if (fReadTransactionStarted) then + Close; + FreeAndNil(fQuery); + inherited; +end; + +procedure TBoldFireDACQuery.EndExecuteQuery; +begin + (DatabaseWrapper as TBoldFireDACConnection).EndExecuteQuery; +end; + +type TStringsAccess = class(TStrings); + +procedure TBoldFireDACQuery.ExecSQL; +var + Retries: Integer; + Done: Boolean; +begin + if InBatch then + begin + BatchExecSQL; + exit; + end; + BeginExecuteQuery; + try + BoldLogSQLWithParams(Query.SQL, self); + Retries := 0; + Done := false; + while not Done do + begin + try + if (DatabaseWrapper as TBoldFireDACConnection).GetInTransaction then + fReadTransactionStarted := false + else + begin + if fUseReadTransactions then + (DatabaseWrapper as TBoldFireDACConnection).StartReadTransaction; + fReadTransactionStarted := fUseReadTransactions; + end; + Query.Execute; + if fReadTransactionStarted and (DatabaseWrapper as TBoldFireDACConnection).GetInTransaction then + begin + (DatabaseWrapper as TBoldFireDACConnection).Commit; + fReadTransactionStarted := false; + end; + Done := true; + except + on e: Exception do + begin + if (DatabaseWrapper as TBoldFireDACConnection).GetInTransaction then + (DatabaseWrapper as TBoldFireDACConnection).Rollback; + if (not fReadTransactionStarted) or (Retries > 4) then + raise TBoldFireDACConnection(DatabaseWrapper).GetDatabaseError(E, Query.SQL.Text); + fReadTransactionStarted := false; + INC(Retries); + sleep(Retries*200); + end; + end; + end; + finally + EndExecuteQuery; + end; +end; + +function TBoldFireDACQuery.FindParam(const Value: string): IBoldParameter; +var + Param: TFireDacParam; +begin + result := nil; + Param := Query.FindParam(Value); + if Assigned(Param) then + Result := TBoldFireDACParameter.Create(Param, Self); +end; + +procedure TBoldFireDACQuery.Open; +var + Retries: Integer; + Done: Boolean; + EDatabase: EBoldDatabaseError; +begin + BeginExecuteQuery; + try + BoldLogSQLWithParams(Query.SQL, self); + Retries := 0; + Done := false; + while not Done do + begin + try + if (DatabaseWrapper as TBoldFireDACConnection).GetInTransaction then + fReadTransactionStarted := false + else + begin + if fUseReadTransactions then + (DatabaseWrapper as TBoldFireDACConnection).StartReadTransaction; + fReadTransactionStarted := fUseReadTransactions; + end; + Query.UpdateOptions.ReadOnly := true; + inherited; + Done := true; + except + on e: Exception do + begin + EDatabase := TBoldFireDACConnection(DatabaseWrapper). + GetDatabaseError(E, Query.SQL.Text); + if (EDatabase is EBoldDatabaseConnectionError) {and + (not Assigned(ReconnectAppExists) or ReconnectAppExists)} then + begin + EDatabase.free; +// ReconnectDatabase(Query.SQL.Text); + Reconnect; + end else + begin + if (DatabaseWrapper as TBoldFireDACConnection).GetInTransaction then + (DatabaseWrapper as TBoldFireDACConnection).Rollback; + if (not fReadTransactionStarted) or (Retries > 4) then + raise EDatabase + else + EDatabase.free; + fReadTransactionStarted := false; + INC(Retries); + sleep(Retries*200); + end; + end; + end; + end; + finally + EndExecuteQuery; + end; +end; + +function TBoldFireDACQuery.ParamByName(const Value: string): IBoldParameter; +var + lFDParam: TFireDacParam; +begin + lFDParam := Query.Params.ParamByName(Value); + Result := TBoldFireDACParameter.Create(lFDParam, Self) +end; + +procedure TBoldFireDACQuery.SetParamCheck(value: Boolean); +begin +// if Query.ParamCheck <> Value then +// Query.ParamCheck := Value; +end; + +procedure TBoldFireDACQuery.SetRequestLiveQuery(NewValue: Boolean); +begin + // ignore +end; + +procedure TBoldFireDACQuery.SetUseReadTransactions(value: boolean); +begin + fUseReadTransactions := value; +end; + +{ TBoldFireDACTable } + +constructor TBoldFireDACTable.Create(aFDTable: TFDTable; BoldFireDACConnection: TBoldFireDACConnection); +begin + inherited Create(BoldFireDACConnection); + fFDTable := aFDTable; +end; + +procedure TBoldFireDACTable.CreateTable; +begin + FDTable.CreateTable(true); +end; + +procedure TBoldFireDACTable.DeleteTable; +begin + FDTable.ExecSQL('Drop Table ' + FDTable.TableName); +end; + +function TBoldFireDACTable.FindParam(const Value: string): IBoldParameter; +var + Param: TFireDacParam; +begin + result := nil; + Param := FDTable.FindParam(Value); + if Assigned(Param) then + Result := TBoldFireDACParameter.Create(Param, Self); +end; + +procedure TBoldFireDACTable.AddIndex(const Name, Fields: string; + Options: TIndexOptions; const DescFields: string); +var + SortOption: TFDSortOptions; +begin +// ixPrimary, ixUnique, ixDescending, ixCaseInsensitive, ixExpression, ixNonMaintained); +// soNoCase, soNullFirst, soDescNullLast, soDescending, soUnique, soPrimary, soNoSymbols); + SortOption := []; + if ixCaseInsensitive in Options then + Include(SortOption, soNoCase); + if ixUnique in Options then + Include(SortOption, soUnique); + if ixPrimary in Options then + Include(SortOption, soPrimary); + if ixDescending in Options then + Include(SortOption, soDescending); + FDTable.AddIndex(Name, Fields, '', SortOption, DescFields); +end; +(* +function TBoldFireDACTable.GetCommaListOfIndexesForColumn( + const aColumnName: string): string; +var + lUniMetaData: TUniMetaData; + lIndexList: TStringList; + lIndexedColumn: string; + lIndexName: string; + lBoldGuard: IBoldGuard; +const + cTableName = 'Table_Name'; + cIndexName = 'Index_Name'; + cColumnName = 'Column_Name'; +begin +// TODO possibly slow comment +// to improve performance move metadata to the Connection and store it there + + lBoldGuard := TBoldGuard.Create(lUniMetaData, lIndexList); + lUniMetaData := TUniMetaData.Create(nil); + lIndexList := TStringList.Create; + + Assert(Assigned(UniTable)); + Assert(Assigned(UniTable.Connection)); + lUniMetaData.Connection := UniTable.Connection; +// lUniMetaData.DatabaseName := UniTable.Connection.Database; + lUniMetaData.MetaDataKind := 'Indexes'; +{ lUniMetaData.TableName := GetTableName; + lUniMetaData.Open; + lUniMetaData.First; + while not lUniMetaData.Eof do + begin + lIndexedColumn := lUniMetaData.FieldByName(cColumnName).AsString; + if aColumnName = lIndexedColumn then + begin + lIndexName := lUniMetaData.FieldByName(cIndexName).AsString; + lIndexList.Add(lIndexName); + end; + lUniMetaData.Next; + end; + Result := lIndexList.CommaText; + lUniMetaData.Close; +} +end; + +function TBoldFireDACTable.GetPrimaryIndex: string; +var + lUniMetaData: TUniMetaData; + lIndexName: string; +const + cTableName = 'Table_Name'; + cIndexName = 'Index_Name'; + cColumnName = 'Column_Name'; + cPrimaryKey = 'Primary_Key'; +// COLUMN_NAME +begin +// TODO possibly slow comment +// to improve performance move metadata to the Connection and store it there + + lUniMetaData := TUniMetaData.Create(nil); + try + Assert(Assigned(UniTable)); + Assert(Assigned(UniTable.Connection)); + lUniMetaData.Connection := UniTable.Connection; +// lUniMetaData.DatabaseName := UniTable.Connection.Database; +{ lUniMetaData.MetaDataKind := otPrimaryKeys; + lUniMetaData.Open; + lUniMetaData.Filter := Format('(%s = ''%s'')', [cTableName, GetTableName]); + lUniMetaData.Filtered := True; + if lUniMetaData.RecordCount = 1 then + begin + lIndexName := lUniMetaData.FieldByName(cColumnName).AsString; + Result := lIndexName; + end + else + begin + Result := ''; + end; + lUniMetaData.Close; +} + finally + lUniMetaData.free; + end; +end; +*) +function TBoldFireDACTable.GetDataSet: TDataSet; +begin + Result := fFDTable; +end; + +function TBoldFireDACTable.GetDefaultConstraintNameForColumn( + const aColumnName: string): string; +var + lFDMetaData: TFDMetaInfoQuery; + lDefaultConstraintName: string; + lBoldGuard: IBoldGuard; +const + cConstraintName = 'CONSTRAINT_NAME'; +begin + Assert(Assigned(FDTable)); + Assert(Assigned(FDTable.Connection)); + + lBoldGuard := TBoldGuard.Create(lFDMetaData); + lFDMetaData := TFDMetaInfoQuery.Create(nil); + lFDMetaData.Connection := FDTable.Connection; +{ lUniMetaData.DatabaseName := UniTable.Connection.Database; + lUniMetaData.TableName := GetTableName; + lUniMetaData.ColumnName := aColumnName; + lUniMetaData.ObjectType := otConstraintColumnUsage; + lUniMetaData.Open; + lUniMetaData.First; + if not lUniMetaData.Eof then + begin + lDefaultConstraintName := lUniMetaData.FieldByName(cConstraintName).AsString; + end; + lUniMetaData.Close; +} + Result := lDefaultConstraintName; +end; + +function TBoldFireDACTable.GetExclusive: Boolean; +begin + Result := False; +end; + +function TBoldFireDACTable.GetExists: Boolean; +var + lAllTables: TStringList; + lGuard: IBoldGuard; +begin + lGuard := TBoldGuard.Create(lAllTables); + Result := False; + + // First we make sure we have a table component and that it is connected to a database + if Assigned(FDTable) and Assigned(FDTable.Connection) then + begin + // We now create a list that will hold all the table names in the database + lAllTables := TStringList.Create; + FDTable.Connection.GetTableNames('', '', '', lAllTables); // ? + Result := lAllTables.IndexOf(GetTableName) <> -1; + end; +end; + +function TBoldFireDACTable.GetIndexDefs: TIndexDefs; +begin + Result := FDTable.IndexDefs; +end; + +function TBoldFireDACTable.GetFDTable: TFDTable; +begin + Result := fFDTable; +end; + +type TFDTableAccess = class(TFDTable); + +function TBoldFireDACTable.ParamByName(const Value: string): IBoldParameter; +var + lFDParam: TFireDacParam; +begin + lFDParam := TFDTableAccess(FDTable).Params.ParamByName(Value); + Result := TBoldFireDACParameter.Create(lFDParam, Self); +end; + +function TBoldFireDACTable.GetTableName: string; +begin + Result := FDTable.TableName; +end; + +procedure TBoldFireDACTable.SetExclusive(NewValue: Boolean); +begin +end; + +procedure TBoldFireDACTable.SetTableName(const NewName: string); +begin + FDTable.TableName := NewName; +end; + +{ TBoldFireDACConnection } + +// Populate the "TableNameList" with tablenames from the database that maches "pattern" + +procedure TBoldFireDACConnection.AllTableNames(Pattern: string; ShowSystemTables: Boolean; TableNameList: TStrings); +var + lTempList: TStringList; + lIndexTempList: Integer; + lGuard: IBoldGuard; + i: integer; +begin + lGuard := TBoldGuard.Create(lTempList); + lTempList := TStringList.Create; + if ShowSystemTables then + FDConnection.GetTableNames(FDConnection.Params.Database,'','',lTempList, [osMy, osSystem, osOther], [tkTable]) + else + FDConnection.GetTableNames(FDConnection.Params.Database,'','',lTempList, [osMy], [tkTable]); + + // convert from fully qualified names in format: database.catalogue.table to just table name + for i := 0 to lTempList.Count - 1 do + while pos('.', lTempList[i]) > 0 do + lTempList[i] := Copy(lTempList[i], pos('.', lTempList[i])+1, maxInt); + + if Pattern = '' then + TableNameList.Assign(lTempList) + else + // MatchesMask is used to compare filenames with wildcards, suits us here + // but there should be some care taken, when using tablenames with period + // signes, as that might be interpreted as filename extensions + for lIndexTempList := 0 to lTempList.Count - 1 do + begin + if MatchesMask(lTempList[lIndexTempList], Pattern) then + begin + TableNameList.Add(lTempList[lIndexTempList]); + end; + end; +end; + +procedure TBoldFireDACConnection.Commit; +begin + FDConnection.Commit; +end; + +function TBoldFireDACConnection.GetInTransaction: Boolean; +begin + Result := FDConnection.InTransaction; +end; + +function TBoldFireDACConnection.GetIsExecutingQuery: Boolean; +begin + Result := fExecuteQueryCount > 0; +end; + +function TBoldFireDACConnection.GetIsSQLBased: Boolean; +begin + Result := True; +end; + +function TBoldFireDACConnection.GetKeepConnection: Boolean; +begin + //CheckMe; + Result := True; +end; + +function TBoldFireDACConnection.GetLogInPrompt: Boolean; +begin + Result := FDConnection.LoginPrompt; +end; + +procedure TBoldFireDACConnection.RollBack; +begin + FDConnection.RollBack; +end; + +procedure TBoldFireDACConnection.SetKeepConnection(NewValue: Boolean); +begin + //CheckMe; +end; + +procedure TBoldFireDACConnection.SetlogInPrompt(NewValue: Boolean); +begin + FDConnection.LoginPrompt := NewValue; +end; + +procedure TBoldFireDACConnection.SetTransaction(const Value: TFDTransaction); +begin + FDConnection.Transaction := Value; +end; + +procedure TBoldFireDACConnection.SetUpdateTransaction( + const Value: TFDTransaction); +begin + FDConnection.UpdateTransaction := value; +end; + +procedure TBoldFireDACConnection.StartReadTransaction; +begin + Transaction.Options.Isolation := xiReadCommitted; + FDConnection.StartTransaction; +end; + +procedure TBoldFireDACConnection.StartTransaction; +begin + Transaction.Options.Isolation := xiRepeatableRead; + FDConnection.StartTransaction; +end; + +function TBoldFireDACConnection.DatabaseExists: boolean; +var + vQuery: IBoldQuery; + vDatabaseName: string; +begin + vDatabaseName := LowerCase(FDConnection.Params.Database); + FDConnection.Params.Database := ''; // need to clear this to connect succesfully + vQuery := GetQuery; + try + vQuery.SQLText := SQLDataBaseConfig.GetDatabaseExistsQuery(vDatabaseName); + vQuery.Open; + result := vQuery.Fields[0].AsBoolean; + finally + ReleaseQuery(vQuery); + FDConnection.Params.Database := vDatabaseName; + end; +end; + +destructor TBoldFireDACConnection.Destroy; +begin + ReleaseCachedObjects; + inherited; +end; + +procedure TBoldFireDACConnection.DropDatabase; +var + vDatabaseName: string; + vScript: TFDScript; + sl: TStringList; +begin + vDatabaseName := LowerCase(FDConnection.Params.Database); + FDConnection.Params.Database := ''; // need to clear this to connect succesfully + vScript := TFDScript.Create(nil); + sl := TStringList.Create; + try + sl.Text := SQLDataBaseConfig.GetDropDatabaseQuery(vDatabaseName); + vScript.Connection := FDConnection; + vScript.ExecuteScript(sl); + FDConnection.Close; + finally + FDConnection.Params.Database := vDatabaseName; + vScript.free; + sl.free; + end; +end; + +procedure TBoldFireDACConnection.EndExecuteQuery; +begin + dec(fExecuteQueryCount); +end; + +constructor TBoldFireDACConnection.Create(aFDConnection: TFDConnection; SQLDataBaseConfig: TBoldSQLDatabaseConfig); +begin + inherited Create(SQLDataBaseConfig); + fFDConnection := aFDConnection; +end; + +procedure TBoldFireDACConnection.BeginExecuteQuery; +begin + inc(fExecuteQueryCount); +end; + +procedure TBoldFireDACConnection.Close; +begin + FDConnection.Close; +end; + +procedure TBoldFireDACConnection.CreateDatabase(DropExisting: boolean = true); +var + vDatabaseName: string; + vScript: TFDScript; + sl: TStringList; +begin + vDatabaseName := LowerCase(FDConnection.Params.Database); + if DropExisting and DatabaseExists then + DropDatabase; + FDConnection.Params.Database := ''; // need to clear this to connect succesfully + vScript := TFDScript.Create(nil); + sl := TStringList.Create; + try + sl.Text := SQLDataBaseConfig.GetCreateDatabaseQuery(vDatabaseName); + vScript.Connection := FDConnection; + vScript.ExecuteScript(sl); + FDConnection.Close; + finally + FDConnection.Params.Database := vDatabaseName; + vScript.free; + sl.free; + end; +end; + +function TBoldFireDACConnection.GetConnected: Boolean; +begin + Result := FDConnection.Connected; +end; + +function TBoldFireDACConnection.GetDatabaseError(const E: Exception; + const sSQL: string): EBoldDatabaseError; +const + SQLERRORCODE = 'SQL Error Code: '; +var + iErrorCode: Integer; + sMsg: string; + iPos: Integer; + aErrorType: TBoldDatabaseErrorType; + sServer, + sDatabase, + sUsername: string; + bUseWindowsAuth: Boolean; + vConnectionString: string; +const + // Provider names copied here to avoid dependancy + cMSSQLProvider = 'SQL Server'; // TSQLServerFDProvider.GetProviderName + cPostgreSQLProvider = 'PostgreSQL'; // TPostgreSQLFDProvider.GetProviderName + cOracleSQLProvider = 'Oracle'; // TOracleFDProvider.GetProviderName + cInterBaseProvider = 'InterBase'; + cMSSQLDeadLock = 1205; +begin + sMsg := E.Message; + aErrorType := bdetError; + vConnectionString := FDConnection.ConnectionString; + Result := InternalGetDatabaseError(aErrorType, E, vConnectionString, '', '', '', false); + +{ + bUseWindowsAuth := Pos('Authentication=Windows', FDConnection.ConnectString) > 0; + if (E is EFDError) then + begin + if FDConnection.ProviderName = cMSSQLProvider then + case EFDError(E).ErrorCode of + -2147467259, 2, 233: aErrorType := bdetConnection; // only set bdetConnection for cases where retry might work. + 208, 4145: aErrorType := bdetSQL; + 4060: aErrorType := bdetLogin; // SQLServer Error: 4060, Cannot open database "SessionStateService" requested by the login. The login failed. [SQLSTATE 42000] + 18456: aErrorType := bdetLogin; // SQLServer Error: 18456, Login failed for user 'domain\user'. [SQLSTATE 28000] + cMSSQLDeadLock: aErrorType := bdetDeadlock; + //Deadlock und weitere ErrorCodes? + end + else + if FDConnection.ProviderName = cInterBaseProvider then + case EFDError(E).ErrorCode of + -803: aErrorType := bdetUpdate; // attempt to store duplicate value (visible to active transactions) in FDque index + end + else + if FDConnection.ProviderName = cPostgreSQLProvider then + case EFDError(E).ErrorCode of + 0: aErrorType := bdetLogin; + end + else + raise Exception.Create('Error codes not implemented for ' + FDConnection.ProviderName); + end; + Result := InternalGetDatabaseError(aErrorType, E, sSQL, sServer, sDatabase, + sUsername, bUseWindowsAuth); +} +end; + +function TBoldFireDACConnection.GetExecQuery: IBoldExecQuery; +begin + if Assigned(fCachedExecQuery1) then + begin + result := fCachedExecQuery1; + fCachedExecQuery1 := nil; + end else + begin + Result := BoldFireDACQueryClass.Create(Self); + end; +end; + +function TBoldFireDACConnection.GetFDConnection: TFDConnection; +begin + Result := fFDConnection; +end; + +function TBoldFireDACConnection.GetQuery: IBoldQuery; +begin + if Assigned(fCachedQuery1) then + begin + result := fCachedQuery1; + fCachedQuery1 := nil; + end else + if Assigned(fCachedQuery2) then + begin + result := fCachedQuery2; + fCachedQuery2 := nil; + end else + begin + Result := BoldFireDACQueryClass.Create(Self); + end; +end; + +function TBoldFireDACConnection.GetTable: IBoldTable; +var + lFDTable: TFDTable; +begin + if Assigned(fCachedTable) then + begin + result := fCachedTable; + fCachedTable := nil; + end + else + begin + lFDTable := TFDTable.Create(nil); + lFDTable.Connection := FDConnection; + Result := TBoldFireDACTable.Create(lFDTable, Self); + end; +end; + +function TBoldFireDACConnection.GetTransaction: TFDTransaction; +begin + if not Assigned(FDConnection.Transaction) then + FDConnection.Transaction := TFDTransaction.Create(FDConnection); + result := FDConnection.Transaction as TFDTransaction; +end; + +function TBoldFireDACConnection.GetUpdateTransaction: TFDTransaction; +begin + if not Assigned(FDConnection.UpdateTransaction) then + FDConnection.UpdateTransaction := TFDTransaction.Create(FDConnection); + result := FDConnection.UpdateTransaction as TFDTransaction; +end; + +procedure TBoldFireDACConnection.Open; +begin + try + FDConnection.Params.Database := LowerCase(FDConnection.Params.Database); + FDConnection.Open; + except + on E: Exception do begin + raise GetDatabaseError(E); + end; + end; +end; + +procedure TBoldFireDACConnection.Reconnect; +begin + if Assigned(fFDConnection) then begin + fFDConnection.Connected := False; + fFDConnection.Connected := True; + end; +end; + +procedure TBoldFireDACConnection.ReleaseQuery(var Query: IBoldQuery); +var + lBoldFireDACQuery: TBoldFireDACQuery; +begin + if (Query.Implementor is TBoldFireDACQuery) then + begin + lBoldFireDACQuery := Query.Implementor as TBoldFireDACQuery; + lBoldFireDACQuery.clear; + Query := nil; + if not Assigned(fCachedQuery1) then + fCachedQuery1 := lBoldFireDACQuery + else + if not Assigned(fCachedQuery2) then + fCachedQuery2 := lBoldFireDACQuery + else + lBoldFireDACQuery.free; + end +end; + +procedure TBoldFireDACConnection.ReleaseExecQuery(var Query: IBoldExecQuery); +var + lBoldFireDACQuery: TBoldFireDACQuery; + lBoldFireDACExecQuery: TBoldFireDACExecQuery; +begin + if (Query.Implementor is TBoldFireDACQuery) then + begin + lBoldFireDACQuery := Query.Implementor as TBoldFireDACQuery; + if lBoldFireDACQuery.GetSQLStrings.Count <> 0 then + begin + lBoldFireDACQuery.GetSQLStrings.BeginUpdate; + lBoldFireDACQuery.clear; + end; + while TStringsAccess(lBoldFireDACQuery.GetSQLStrings).UpdateCount > 0 do + lBoldFireDACQuery.GetSQLStrings.EndUpdate; + Query := nil; + if not Assigned(fCachedExecQuery1) then + fCachedExecQuery1 := lBoldFireDACQuery + else + lBoldFireDACQuery.free; + end +{ else + if (Query.Implementor is TBoldFireDACExecQuery) then + begin + lBoldFireDACExecQuery := Query.Implementor as TBoldFireDACExecQuery; + lBoldFireDACExecQuery.clear; + Query := nil; + if not Assigned(fCachedExecQuery1) then + fCachedExecQuery1 := lBoldFireDACExecQuery + else + lBoldFireDACExecQuery.free; + end +} +end; + +procedure TBoldFireDACConnection.ReleaseTable(var Table: IBoldTable); +var + lBoldFireDACTable: TBoldFireDACTable; +begin + if Table.Implementor is TBoldFireDACTable then + begin + lBoldFireDACTable := Table.Implementor as TBoldFireDACTable; + Table := nil; + if not Assigned(fCachedTable) then + fCachedTable := lBoldFireDACTable + else + lBoldFireDACTable.free; + end; +end; + +function TBoldFireDACConnection.SupportsTableCreation: Boolean; +begin + Result := False; +end; + +{ TBoldFireDACParameter } + +procedure TBoldFireDACParameter.Clear; +begin + FDParam.Clear; +end; + +constructor TBoldFireDACParameter.Create(FireDACParameter: TFireDacParam; DatasetWrapper: TBoldAbstractQueryWrapper); +begin + inherited Create(DatasetWrapper); + fFDParam := FireDACParameter; +end; + +function TBoldFireDACParameter.GetAsAnsiString: TBoldAnsiString; +begin + Result := FDParam.AsAnsiString; +end; + +function TBoldFireDACParameter.GetAsBCD: Currency; +begin + Result := FDParam.AsBCD; +end; + +function TBoldFireDACParameter.GetAsblob: TBoldBlobData; +begin + Result := AnsiString(FDParam.Value); +end; + +function TBoldFireDACParameter.GetAsBoolean: Boolean; +begin + Result := FDParam.AsBoolean; +end; + +function TBoldFireDACParameter.GetAsCurrency: Currency; +begin + Result := FDParam.AsCurrency; +end; + +function TBoldFireDACParameter.GetAsDateTime: TDateTime; +begin + Result := FDParam.AsDateTime; +end; + +function TBoldFireDACParameter.GetAsFloat: Double; +begin + Result := FDParam.AsFloat; +end; + +function TBoldFireDACParameter.GetAsInt64: Int64; +begin + result := FDParam.AsLargeInt; +end; + +function TBoldFireDACParameter.GetAsInteger: Longint; +begin + Result := FDParam.AsInteger; +end; + +function TBoldFireDACParameter.GetAsMemo: string; +begin + Result := FDParam.AsMemo; +end; + +function TBoldFireDACParameter.GetAsString: string; +begin + Result := FDParam.AsString; + if Result = DatasetWrapper.DatabaseWrapper.SQLDataBaseConfig.EmptyStringMarker then + begin + Result := ''; + end; +end; + +function TBoldFireDACParameter.GetAsVariant: Variant; +begin + Result := FDParam.Value; +end; + +function TBoldFireDACParameter.GetAsWideString: WideString; +begin + Result := FDParam.AsWideString; + if Result = DatasetWrapper.DatabaseWrapper.SQLDataBaseConfig.EmptyStringMarker then + begin + Result := ''; + end; +end; + +function TBoldFireDACParameter.GetDataType: TFieldType; +begin + Result := FDParam.DataType; +end; + +function TBoldFireDACParameter.GetIsNull: Boolean; +begin + Result := VarIsNull(FDParam.Value) +end; + +function TBoldFireDACParameter.GetName: string; +begin + Result := FDParam.Name; +end; + +function TBoldFireDACParameter.GetFDParam: TFireDacParam; +begin + Result := fFDParam; +end; + +procedure TBoldFireDACParameter.SetAsAnsiString(const Value: TBoldAnsiString); +begin + FDParam.AsAnsiString := Value; +end; + +procedure TBoldFireDACParameter.SetAsBCD(const Value: Currency); +begin + FDParam.Value := Value; +end; + +procedure TBoldFireDACParameter.SetAsBlob(const Value: TBoldBlobData); +begin + if FDParam.DataType = ftUnknown then + begin + FDParam.DataType := ftBlob; + end; + if Value = '' then + begin +// FDParam.Value := DatasetWrapper.DatabaseWrapper.SQLDataBaseConfig.EmptyStringMarker; + FDParam.Value := Null; + end else + begin + FDParam.Value := TBoldBlobData(AnsiString(Value)); + end; +end; + +procedure TBoldFireDACParameter.SetAsBoolean(Value: Boolean); +begin + FDParam.AsBoolean := Value; +end; + +procedure TBoldFireDACParameter.SetAsCurrency(const Value: Currency); +begin + FDParam.AsCurrency := Value; +end; + +procedure TBoldFireDACParameter.SetAsDate(const Value: TDateTime); +begin + FDParam.AsDate := Value; +end; + +procedure TBoldFireDACParameter.SetAsDateTime(const Value: TDateTime); +begin + FDParam.AsDateTime := Value; +end; + +procedure TBoldFireDACParameter.SetAsFloat(const Value: Double); +begin + FDParam.AsFloat := Value; +end; + +procedure TBoldFireDACParameter.SetAsInt64(const Value: Int64); +begin + FDParam.AsLargeInt := Value; +end; + +procedure TBoldFireDACParameter.SetAsInteger(Value: Integer); +begin + FDParam.AsInteger := Value; +end; + +procedure TBoldFireDACParameter.SetAsMemo(const Value: string); +begin + FDParam.AsMemo := Value; +end; + +procedure TBoldFireDACParameter.SetAsSmallInt(Value: Integer); +begin + FDParam.AsSmallInt := Value; +end; + +procedure TBoldFireDACParameter.SetAsString(const Value: string); +begin + if Value = '' then + begin + FDParam.AsString := DatasetWrapper.DatabaseWrapper.SQLDataBaseConfig.EmptyStringMarker; + end else + begin + FDParam.AsString := Value; + end; +end; + +procedure TBoldFireDACParameter.SetAsTime(const Value: TDateTime); +begin + FDParam.AsTime := Value; +end; + +procedure TBoldFireDACParameter.SetAsVariant(const NewValue: Variant); +begin + FDParam.Value := NewValue; +end; + +procedure TBoldFireDACParameter.SetAsWideString(const Value: Widestring); +begin + if Value = '' then + begin + FDParam.AsString := DatasetWrapper.DatabaseWrapper.SQLDataBaseConfig.EmptyStringMarker; + end else + begin + FDParam.AsWideString := Value; + end; +end; + +procedure TBoldFireDACParameter.SetAsWord(Value: Integer); +begin + FDParam.AsWord := Value; +end; + +procedure TBoldFireDACParameter.SetDataType(Value: TFieldType); +begin + FDParam.DataType := Value; +end; + +procedure TBoldFireDACParameter.SetText(const Value: string); +begin + FDParam.Value := Value; +end; + +procedure TBoldFireDACParameter.Assign(const source: IBoldParameter); +begin + FDParam.Value := Source.AsVariant; +end; + +procedure TBoldFireDACParameter.AssignFieldValue(const source: IBoldField); +begin + FDParam.Assign(source.Field); +end; + +procedure TBoldFireDACConnection.ReleaseCachedObjects; +begin + FreeAndNil(fCachedTable); + FreeAndNil(fCachedQuery1); + FreeAndNil(fCachedQuery2); + FreeAndNil(fCachedExecQuery1); +end; + +{ TBoldFireDACExecQuery } + +procedure TBoldFireDACExecQuery.AssignParams(Sourceparams: TParams); +var + lIndexSourceParams: Integer; + lFDParam: TFireDacParam; +begin + ExecQuery.Params.Clear; + if Assigned(Sourceparams) and (Sourceparams.Count > 0) then + begin + for lIndexSourceParams := 0 to Sourceparams.Count - 1 do + begin + lFDParam := ExecQuery.Params.CreateParam(Sourceparams[lIndexSourceParams].DataType, Sourceparams[lIndexSourceParams].Name, Sourceparams[lIndexSourceParams].ParamType) as TFireDacParam; + lFDParam.Value := Sourceparams[lIndexSourceParams].Value; + end; + end; +end; + +procedure TBoldFireDACExecQuery.AssignSQL(SQL: TStrings); +begin + ExecQuery.SQL.BeginUpdate; + ExecQuery.SQL.Assign(SQL); + ExecQuery.SQL.EndUpdate; +end; + +procedure TBoldFireDACExecQuery.AssignSQLText(const SQL: string); +var + lStringList: TStringList; + lGuard: IBoldGuard; +begin + lGuard := TBoldGuard.Create(lStringList); + lStringList := TStringList.Create; + lStringList.Add(SQL); + AssignSQL(lStringList); +end; + +procedure TBoldFireDACExecQuery.BeginExecuteQuery; +begin + (DatabaseWrapper as TBoldFireDACConnection).BeginExecuteQuery; +end; + +procedure TBoldFireDACExecQuery.Clear; +begin + inherited; + AssignSQLText(''); + ClearParams; +end; + +procedure TBoldFireDACExecQuery.ClearParams; +begin + ExecQuery.Params.Clear; +end; + +constructor TBoldFireDACExecQuery.Create(BoldFireDACConnection: TBoldFireDACConnection); +begin + inherited Create(BoldFireDACConnection); + fUseReadTransactions := true; +end; + +function TBoldFireDACExecQuery.Createparam(FldType: TFieldType; + const ParamName: string): IBoldParameter; +begin + result := CreateParam(FldType, ParamName, ptUnknown, 0); +end; + +function TBoldFireDACExecQuery.CreateParam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; +var + lFDParam: TFireDacParam; +begin + lFDParam := ExecQuery.Params.CreateParam(FldType, ParamName, ptUnknown) as TFireDacParam; + lFDParam.Size := Size; + lFDParam.Value := NULL; + Result := TBoldFireDACParameter.Create(lFDParam, Self); +end; + +destructor TBoldFireDACExecQuery.Destroy; +begin + FreeAndNil(fExecQuery); + inherited; +end; + +procedure TBoldFireDACExecQuery.EndExecuteQuery; +begin + (DatabaseWrapper as TBoldFireDACConnection).EndExecuteQuery; +end; + +function TBoldFireDACExecQuery.EnsureParamByName( + const Value: string): IBoldParameter; +var + lFDParam: TFireDacParam; +begin + lFDParam := ExecQuery.Params.FindParam(Value); + if not Assigned(lFDParam) then + lFDParam := ExecQuery.Params.CreateParam(ftUnknown, Value, ptUnknown) as TFireDacParam; + Result := TBoldFireDACParameter.Create(lFDParam, Self) +end; + +procedure TBoldFireDACExecQuery.ExecSQL; +var + Retries: Integer; + Done: Boolean; +begin + BeginExecuteQuery; + try + BoldLogSQLWithParams(ExecQuery.SQL, self); + Retries := 0; + Done := false; + while not Done do + begin + try + if (DatabaseWrapper as TBoldFireDACConnection).GetInTransaction then + fReadTransactionStarted := false + else + begin + if fUseReadTransactions then + (DatabaseWrapper as TBoldFireDACConnection).StartReadTransaction; + fReadTransactionStarted := fUseReadTransactions; + end; + ExecQuery.Execute; + if fReadTransactionStarted and (DatabaseWrapper as TBoldFireDACConnection).GetInTransaction then + begin + (DatabaseWrapper as TBoldFireDACConnection).Commit; + fReadTransactionStarted := false; + end; + Done := true; + except + on e: Exception do + begin + if (not fReadTransactionStarted) or (Retries > 4) then + raise TBoldFireDACConnection(DatabaseWrapper).GetDatabaseError(E, ExecQuery.SQL.Text); + if (DatabaseWrapper as TBoldFireDACConnection).GetInTransaction then + (DatabaseWrapper as TBoldFireDACConnection).Rollback; + fReadTransactionStarted := false; + INC(Retries); + sleep(Retries*200); + end; + end; + end; + finally + EndExecuteQuery; + end; +end; + +procedure TBoldFireDACExecQuery.StartSQLBatch; +begin + raise EBold.CreateFmt('MethodNotImplemented', [ClassName, 'StartSQLBatch']); // do not localize +end; + +procedure TBoldFireDACExecQuery.EndSQLBatch; +begin + raise EBold.CreateFmt('MethodNotImplemented', [ClassName, 'EndSQLBatch']); // do not localize +end; + +procedure TBoldFireDACExecQuery.FailSQLBatch; +begin + raise EBold.CreateFmt('MethodNotImplemented', [ClassName, 'FailSQLBatch']); // do not localize +end; + +function TBoldFireDACExecQuery.FindParam(const Value: string): IBoldParameter; +var + Param: TFDParam; +begin + Param := ExecQuery.FindParam(Value); + if not Assigned(Param) then + result := CreateParam(ftUnknown, Value); +end; + +function TBoldFireDACExecQuery.GetBatchQueryParamCount: integer; +begin + result := 0; // update when batch support is implemented +end; + +function TBoldFireDACExecQuery.GetExecQuery: TFDQuery; +begin + if not Assigned(fExecQuery) then + begin + fExecQuery := TFDQuery.Create(nil); + fExecQuery.Connection := (DatabaseWrapper as TBoldFireDACConnection).FDConnection; + end; + Result := fExecQuery; +end; + +function TBoldFireDACExecQuery.GetParamCheck: Boolean; +begin + result := true; +end; + +function TBoldFireDACExecQuery.GetParamCount: Integer; +begin + result := ExecQuery.Params.Count; +end; + +function TBoldFireDACExecQuery.GetParams: TParams; +begin + result := TFDAdaptedDataSetAccess(ExecQuery).fVclParams; +end; + +function TBoldFireDACExecQuery.GetParam(i: Integer): IBoldParameter; +begin + Result := TBoldFireDACParameter.Create(ExecQuery.Params[i], Self); +end; + +function TBoldFireDACExecQuery.GetRowsAffected: Integer; +begin + Result := ExecQuery.RowsAffected; +end; + +function TBoldFireDACExecQuery.GetSQLStrings: TStrings; +begin + result := ExecQuery.SQL; +end; + +function TBoldFireDACExecQuery.GetSQLText: string; +begin + Result := ExecQuery.SQL.Text; +end; + +function TBoldFireDACExecQuery.GetUseReadTransactions: boolean; +begin + result := fUseReadTransactions; +end; + +function TBoldFireDACExecQuery.ParamByName(const Value: string): IBoldParameter; +var + lFDParam: TFireDacParam; +begin + lFDParam := ExecQuery.Params.ParamByName(Value); + if Assigned(lFDParam) then + begin + Result := TBoldFireDACParameter.Create(lFDParam, Self) + end else + begin + Result := nil; + end; +end; + +{procedure TBoldFireDACExecQuery.Prepare; +begin + ExecQuery.Prepare; +end;} + +procedure TBoldFireDACExecQuery.SetParamCheck(value: Boolean); +begin +// ExecQuery.ParamCheck := Value; +end; + +procedure TBoldFireDACExecQuery.SetUseReadTransactions(value: boolean); +begin + fUseReadTransactions := value; +end; + +end. diff --git a/Source/Persistence/FireDAC/BoldPersistenceHandleFireDACReg.pas b/Source/Persistence/FireDAC/BoldPersistenceHandleFireDACReg.pas new file mode 100644 index 00000000..21bac5cc --- /dev/null +++ b/Source/Persistence/FireDAC/BoldPersistenceHandleFireDACReg.pas @@ -0,0 +1,25 @@ +{ Global compiler directives } +{$include bold.inc} +unit BoldPersistenceHandleFireDACReg; + +interface + +procedure Register; + +implementation + +//{$R BoldPersistenceHandleFireDAC.res} + +uses + SysUtils, + Classes, + BoldDatabaseAdapterFireDAC, + BoldIDEConsts; + +procedure Register; +begin + + RegisterComponents(BOLDPAGENAME_PERSISTENCE, [TBoldDatabaseAdapterFireDAC]); +end; + +end. diff --git a/Source/Persistence/HTTP/BoldHTTPClientPersistenceHandle.pas b/Source/Persistence/HTTP/BoldHTTPClientPersistenceHandle.pas index dc7dacb6..b292f2e6 100644 --- a/Source/Persistence/HTTP/BoldHTTPClientPersistenceHandle.pas +++ b/Source/Persistence/HTTP/BoldHTTPClientPersistenceHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldHTTPClientPersistenceHandle; interface @@ -8,13 +11,15 @@ interface BoldHTTPPersistenceControllerClient, BoldAbstractModel, BoldWebConnection, - classes; + classes + ; type { forward declarations } TBoldHTTPClientPersistenceHandle = class; { TBoldHTTPClientPersistenceHandle } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldHTTPClientPersistenceHandle = class(TBoldPersistenceHandle) private FModel: TBoldAbstractModel; @@ -34,15 +39,15 @@ implementation uses SysUtils, BoldUtils, - BoldDefs, - BoldComConst; + BoldDefs + ; { TBoldHTTPClientPersistenceHandle } function TBoldHTTPClientPersistenceHandle.CreatePersistenceController: TBoldPersistenceController; begin if not assigned(BoldModel) then - raise EBold.createfmt(sModelRequired, [ClassName]); + raise EBold.createfmt('%s.CreatePersistenceController: Can not get a PersistenceController without a Model', [ClassName]); FPersistenceController := TBoldHTTPPersistenceControllerClient.Create(fModel.MoldModel); (FPersistenceController as TBoldHTTPPersistenceControllerClient).WebConnection := WebConnection; result := FPersistenceController; @@ -72,4 +77,6 @@ procedure TBoldHTTPClientPersistenceHandle.setWebConnection( end; end; +initialization + end. diff --git a/Source/Persistence/HTTP/BoldHTTPPersistenceControllerClient.pas b/Source/Persistence/HTTP/BoldHTTPPersistenceControllerClient.pas index 49179d29..c940d09b 100644 --- a/Source/Persistence/HTTP/BoldHTTPPersistenceControllerClient.pas +++ b/Source/Persistence/HTTP/BoldHTTPPersistenceControllerClient.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldHTTPPersistenceControllerClient; interface @@ -8,7 +11,8 @@ interface BoldMeta, BoldSOAP_TLB, ComObj, - ActiveX; + ActiveX + ; type {forward declarations} @@ -46,8 +50,8 @@ implementation BoldDataBlock, BoldDefs, Classes, - windows, - BoldComConst; + windows + ; { TBoldHTTPSOAPService } @@ -58,7 +62,7 @@ constructor TBoldHTTPSOAPService.Create; if (LoadRegTypeLib(LIBID_BoldSOAP, 1, 0, 0, typelib) = S_OK) then inherited Create(typelib, IBoldSOAPService) else - raise EBold.CreateFmt(sUnableToLoadTypeLibBoldSoap, [ClassName]); + raise EBold.CreateFmt('%s.Create: Unable to load type library LIBID_BoldSOAP', [ClassName]); end; procedure TBoldHTTPSOAPService.Get(const request: WideString; @@ -92,6 +96,7 @@ procedure TBoldHTTPSOAPService.Get(const request: WideString; end; end; + { TBoldHTTPPersistenceControllerClient } constructor TBoldHTTPPersistenceControllerClient.Create(Model: TMoldModel); @@ -109,7 +114,6 @@ destructor TBoldHTTPPersistenceControllerClient.Destroy; procedure TBoldHTTPPersistenceControllerClient.Disconnect; begin - //do nothing end; function TBoldHTTPPersistenceControllerClient.getWebConnection: TBoldWebConnection; @@ -123,4 +127,6 @@ procedure TBoldHTTPPersistenceControllerClient.setWebConnection( fhttpSoapService.WebConnection := Value; end; +initialization + end. diff --git a/Source/Persistence/HTTP/BoldHTTPServerPersistenceHandlePassthrough.pas b/Source/Persistence/HTTP/BoldHTTPServerPersistenceHandlePassthrough.pas index 2398d4fc..a3a8fd31 100644 --- a/Source/Persistence/HTTP/BoldHTTPServerPersistenceHandlePassthrough.pas +++ b/Source/Persistence/HTTP/BoldHTTPServerPersistenceHandlePassthrough.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldHTTPServerPersistenceHandlePassthrough; interface @@ -8,13 +11,15 @@ interface BoldPersistenceHandle, BoldAbstractModel, BoldSubscription, - Classes; + Classes + ; type { forward declarations} TBoldHTTPServerPersistenceHandlePassthrough = class; { TBoldHTTPServerPersistenceHandlePassthrough } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldHTTPServerPersistenceHandlePassthrough = class(TBoldSubscribableComponent) private FPersistenceHandle: TBoldPersistenceHandle; @@ -38,8 +43,7 @@ implementation uses SysUtils, BoldUtils, - BoldDefs, - BoldComConst; + BoldDefs; { TBoldHTTPServerPersistenceHandlePassthrough } @@ -50,7 +54,7 @@ procedure TBoldHTTPServerPersistenceHandlePassthrough.Get(const request: WideStr if Assigned(PersistenceController) then AdapterCore.Get(request, reply, PersistenceController) else - raise EBold.CreateFmt(sPersistenceHandleNotAssigned, [ClassName, 'Get']); // do not localize + raise EBold.CreateFmt('%s.%s: PersistenceHandle not assigned', [ClassName, 'Get']); except on E: Exception do Reply := E.Message + ' ' + request; end; @@ -83,4 +87,6 @@ procedure TBoldHTTPServerPersistenceHandlePassthrough.Notification( end; end; +initialization + end. diff --git a/Source/Persistence/IBX/BoldDatabaseAdapterIB.pas b/Source/Persistence/IBX/BoldDatabaseAdapterIB.pas index f58939a0..5a309cf3 100644 --- a/Source/Persistence/IBX/BoldDatabaseAdapterIB.pas +++ b/Source/Persistence/IBX/BoldDatabaseAdapterIB.pas @@ -1,10 +1,14 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDatabaseAdapterIB; interface uses Classes, - IBDataBase, + Windows, + IBX.IBDatabase, BoldSQLDatabaseConfig, BoldAbstractDataBaseAdapter, BoldDBInterfaces, @@ -29,6 +33,8 @@ TBoldDatabaseAdapterIB = class(TBoldAbstractDatabaseAdapter) destructor Destroy; override; procedure CreateInterbaseDatabase(PageSize: integer = 4096); procedure EnsureInterbaseDatabase(PageSize: integer = 4096); + procedure CreateDatabase(DropExisting: boolean = true); override; + procedure DropDatabase; override; published property DataBase: TIBDataBase read GetDataBase write SetDataBase; {$IFNDEF T2H} @@ -40,46 +46,23 @@ implementation uses SysUtils, - BoldDefs; + BoldDefs, + BoldRev; { TBoldDatabaseAdapterIB } -constructor TBoldDatabaseAdapterIB.create(aOwner: TComponent); +constructor TBoldDatabaseAdapterIB.Create(aOwner: TComponent); begin inherited; DatabaseEngine := dbeInterbaseSQLDialect3; end; procedure TBoldDatabaseAdapterIB.CreateInterbaseDatabase(PageSize: integer = 4096); -var - db: TIBDatabase; - username: String; - pwd: String; begin - if not assigned(Database) then - raise EBold.CreateFmt('%s.CreateInterbaseDatbase: Unable to complete operation without an IBDatabase', [classname]); - - username := Database.Params.Values['user_name']; // do not localize - pwd := Database.Params.Values['password']; // do not localize - - if (username = '') or (pwd = '') then - raise EBold.CreateFmt('%s.CreateInterbaseDatabase: username or password missing', [classname]); - if FileExists(Database.DatabaseName) then - if not DeleteFile(Database.DatabaseName) then - raise EBold.CreateFmt('%s.CreateInterbaseDatbase: Unable to remove old database file (%s)', [classname, DataBase.DatabaseName]); - db := TIBDatabase.Create(nil); - try - db.DatabaseName := Database.DatabaseName; - db.Params.add(format('USER "%s" PASSWORD "%s" PAGE_SIZE %d', [ // do not localize - username, pwd, PageSize])); - db.SQLDialect := Database.SQLDialect; - db.CreateDatabase; - finally - db.free; - end; + DatabaseInterface.CreateDatabase; end; -destructor TBoldDatabaseAdapterIB.destroy; +destructor TBoldDatabaseAdapterIB.Destroy; begin Changed; FreePublisher; @@ -87,6 +70,11 @@ destructor TBoldDatabaseAdapterIB.destroy; inherited; end; +procedure TBoldDatabaseAdapterIB.DropDatabase; +begin + DatabaseInterface.DropDatabase; +end; + procedure TBoldDatabaseAdapterIB.EnsureInterbaseDatabase( PageSize: integer); begin @@ -97,6 +85,11 @@ procedure TBoldDatabaseAdapterIB.EnsureInterbaseDatabase( CreateInterbaseDatabase(PageSize); end; +procedure TBoldDatabaseAdapterIB.CreateDatabase(DropExisting: boolean); +begin + CreateInterbaseDatabase(); +end; + function TBoldDatabaseAdapterIB.GetDataBase: TIBDataBase; begin result := InternalDatabase as TIBDataBase; @@ -132,5 +125,6 @@ procedure TBoldDatabaseAdapterIB.SetDataBaseEngine( 'dbeUnknown, dbeInterbaseSQLDialect1, dbeInterbaseSQLDialect3', [classname]); end; -end. +initialization +end. diff --git a/Source/Persistence/IBX/BoldIBDatabaseAction.pas b/Source/Persistence/IBX/BoldIBDatabaseAction.pas index bd9569d1..2d2d47ca 100644 --- a/Source/Persistence/IBX/BoldIBDatabaseAction.pas +++ b/Source/Persistence/IBX/BoldIBDatabaseAction.pas @@ -1,10 +1,13 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldIBDatabaseAction; interface uses Classes, - IBDatabase, + IBX.IBDatabase, BoldActions, BoldSQLDatabaseConfig, BoldPersistenceHandle, @@ -53,10 +56,11 @@ TBoldIBDatabaseAction = class(TBoldSystemHandleAction) implementation uses BoldDefs, - Controls, // crHourGlass - Forms, // screen + Controls, + Forms, BoldActionDefs, - SysUtils; + SysUtils, + BoldRev; { TBoldIBDatabaseAction } @@ -108,7 +112,7 @@ function TBoldIBDatabaseAction.GetDatabaseAdapterIB: TBoldDatabaseAdapterIB; function TBoldIBDatabaseAction.GetEffectiveDatabaseName: String; begin - result := ChangeFileExt(ParamStr(0), '.gdb'); // do not localize + result := ChangeFileExt(ParamStr(0), '.gdb'); end; function TBoldIBDatabaseAction.GetIBDatabase: TIBDatabase; @@ -154,11 +158,11 @@ procedure TBoldIBDatabaseAction.Loaded; if IBDatabase.SQLDialect = 3 then DatabaseAdapterIB.DatabaseEngine := dbeInterbaseSQLDialect3; end; - if IBDatabase.Params.Values['user_name'] = '' then // do not localize - IBDatabase.Params.Values['user_name'] := Username; // do not localize - if IBDatabase.Params.Values['password'] = '' then // do not localize - IBDatabase.Params.Values['password'] := Password; // do not localize - if IBDatabase.Params.Values['password'] <> '' then // do not localize + if IBDatabase.Params.Values['user_name'] = '' then + IBDatabase.Params.Values['user_name'] := Username; + if IBDatabase.Params.Values['password'] = '' then + IBDatabase.Params.Values['password'] := Password; + if IBDatabase.Params.Values['password'] <> '' then IBDatabase.LoginPrompt := false; if IBDatabase.DatabaseName = '' then diff --git a/Source/Persistence/IBX/BoldIBInterfaces.pas b/Source/Persistence/IBX/BoldIBInterfaces.pas index 2fbc7496..f5a81982 100644 --- a/Source/Persistence/IBX/BoldIBInterfaces.pas +++ b/Source/Persistence/IBX/BoldIBInterfaces.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldIBInterfaces; interface @@ -5,12 +8,11 @@ interface classes, Dialogs, Db, - IB, - IBQuery, - IBTable, - IBXConst, + IBX.IB, + IBX.IBQuery, + IBX.IBTable, + IBX.IBDataBase, BoldSQLDataBaseConfig, - IBDataBase, BoldBase, BoldDefs, BoldDBInterfaces, @@ -22,33 +24,38 @@ TBoldIBDataBase = class; TBoldIBQuery = class; TBoldIBTable = class; - TBoldIBTransactionMode = (tmUnknown, tmStarted, tmNotStarted); + TBoldIBTransactionMode = (tmUnknown, tmStarted, tmNotStarted); { TBoldIBQuery } - TBoldIBQuery = class(TBoldDataSetWrapper, IBoldQuery, IBoldExecQuery, IBoldParameterized) + TBoldIBQuery = class(TBoldBatchDataSetWrapper, IBoldQuery, IBoldExecQuery, IBoldParameterized) private fQuery: TIBQuery; fOpeningTransactionMode: TBoldIBTransactionMode; function GetQuery: TIBQuery; procedure EnsureTransaction; - // methods that implement IBoldQuery procedure AssignParams(Sourceparams: TParams); function GetParamCount: integer; - function GetParams(i: integer): IBoldParameter; + function GetParamCheck: Boolean; + procedure SetParamCheck(value: Boolean); + function GetParam(i: integer): IBoldParameter; + function GetParams: TParams; function GetRequestLiveQuery: Boolean; - function ParamByName(const Value: string): IBoldParameter; + function ParamByName(const Value: string): IBoldParameter; override; + function FindParam(const Value: string): IBoldParameter; override; procedure SetRequestLiveQuery(NewValue: Boolean); function GetSQLText: String; + function GetSQLStrings: TStrings; procedure AssignSQL(SQL: TStrings); - procedure AssignSQLText(SQL: String); - function Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; + procedure AssignSQLText(const SQL: String); + function Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; override; function GetRowsAffected: integer; function GetRecordCount: integer; + function GetUseReadTransactions: boolean; + procedure SetUseReadTransactions(value: boolean); + procedure BeginExecuteQuery; + procedure EndExecuteQuery; protected function GetDataSet: TDataSet; override; - procedure StartSQLBatch; virtual; - procedure EndSQLBatch; virtual; - procedure FailSQLBatch; virtual; procedure ClearParams; procedure Open; override; procedure Close; override; @@ -70,7 +77,7 @@ TBoldIBTable = class(TBoldDataSetWrapper, IBoldTable) procedure CreateTable; procedure DeleteTable; function GetIndexDefs: TIndexDefs; - procedure SetTableName(NewName: String); + procedure SetTableName(const NewName: String); function GetTableName: String; procedure SetExclusive(NewValue: Boolean); function GetExclusive: Boolean; @@ -88,6 +95,7 @@ TBoldIBDataBase = class(TBolddatabaseWrapper, IBoldDataBase) fDataBase: TIBDataBase; fCachedTable: TIBTable; fCachedQuery: TIBQuery; + fExecuteQueryCount: integer; function GetDataBase: TIBDataBase; property DataBase: TIBDataBase read GetDataBase; function GetConnected: Boolean; @@ -102,17 +110,22 @@ TBoldIBDataBase = class(TBolddatabaseWrapper, IBoldDataBase) procedure RollBack; procedure Open; procedure Close; - function GetTable: IBoldTable; - procedure ReleaseTable(var Table: IBoldTable); + procedure Reconnect; function SupportsTableCreation: Boolean; procedure ReleaseCachedObjects; + function GetIsExecutingQuery: Boolean; + procedure BeginExecuteQuery; + procedure EndExecuteQuery; protected procedure AllTableNames(Pattern: String; ShowSystemTables: Boolean; TableNameList: TStrings); override; function GetQuery: IBoldQuery; override; procedure ReleaseQuery(var Query: IBoldQuery); override; + function GetTable: IBoldTable; override; + procedure ReleaseTable(var Table: IBoldTable); override; public - constructor Create(DataBase: TIBDataBase; SQLDataBaseConfig: TBoldSQLDatabaseConfig); - destructor Destroy; override; + constructor create(DataBase: TIBDataBase; SQLDataBaseConfig: TBoldSQLDatabaseConfig); + destructor destroy; override; + procedure CreateDatabase(DropExisting: boolean = true); override; end; implementation @@ -121,8 +134,7 @@ implementation SysUtils, BoldUtils; -resourcestring - SLoginPromptFailure = 'Can not find default login prompt dialog. Please add DBLogDlg to the uses section of your main file or set IBDatabase.LoginPrompt to false.'; + { TBoldIBQuery } procedure TBoldIBQuery.AssignParams(Sourceparams: tparams); @@ -140,7 +152,7 @@ procedure TBoldIBQuery.AssignSQL(SQL: TStrings); Query.SQL.EndUpdate; end; -procedure TBoldIBQuery.AssignSQLText(SQL: String); +procedure TBoldIBQuery.AssignSQLText(const SQL: String); begin Query.SQL.BeginUpdate; Query.SQL.Clear; @@ -149,15 +161,21 @@ procedure TBoldIBQuery.AssignSQLText(SQL: String); end; -constructor TBoldIBQuery.Create(Query: TIBQuery; DatabaseWrapper: TBoldDatabaseWrapper); +procedure TBoldIBQuery.BeginExecuteQuery; begin - inherited Create(DatabaseWrapper); - fQuery := Query; + (DatabaseWrapper as TBoldIBDataBase).EndExecuteQuery; +end; + +procedure TBoldIBQuery.EndExecuteQuery; +begin + (DatabaseWrapper as TBoldIBDataBase).EndExecuteQuery; end; -procedure TBoldIBQuery.EndSQLBatch; +constructor TBoldIBQuery.Create(Query: TIBQuery; DatabaseWrapper: TBoldDatabaseWrapper); begin - // intentionally left blank + inherited Create(DatabaseWrapper); + fQuery := Query; + SetParamCheck(true); end; procedure TBoldIBQuery.EnsureTransaction; @@ -181,6 +199,8 @@ procedure TBoldIBQuery.EnsureTransaction; procedure TBoldIBQuery.ExecSQL; begin + BeginExecuteQuery; + try BoldLogSQL(Query.SQL); try if Query.Transaction.InTransaction then @@ -191,15 +211,23 @@ procedure TBoldIBQuery.ExecSQL; except on e: Exception do begin - e.Message := e.Message + BOLDCRLF + 'SQL: '+Query.SQL.text; // do not localize + e.Message := e.Message + BOLDCRLF + 'SQL: '+Query.SQL.text; raise; end; - end + end; + finally + EndExecuteQuery; + end; end; -procedure TBoldIBQuery.FailSQLBatch; +function TBoldIBQuery.FindParam(const Value: string): IBoldParameter; +var + Param: TParam; begin - // intentionally left blank + result := nil; + Param := Query.Params.FindParam(Value); + if Assigned(Param) then + result := TBoldDbParameter.Create(Param, self) end; function TBoldIBQuery.GetDataSet: TDataSet; @@ -207,14 +235,26 @@ function TBoldIBQuery.GetDataSet: TDataSet; result := Query; end; +function TBoldIBQuery.GetParam(i: integer): IBoldParameter; +begin + result := TBoldDBParameter.Create(Query.Params[i], self); +end; + +function TBoldIBQuery.GetParamCheck: Boolean; +begin + Result := Query.ParamCheck; +end; + function TBoldIBQuery.GetParamCount: integer; begin result := Query.Params.count; end; -function TBoldIBQuery.GetParams(i: integer): IBoldParameter; +type TTIBQueryAccess = class(TIBQuery); + +function TBoldIBQuery.GetParams: TParams; begin - result := TBoldDBParameter.Create(Query.Params[i], self); + result := TTIBQueryAccess(Query).PSGetParams end; function TBoldIBQuery.GetQuery: TIBQuery; @@ -237,13 +277,25 @@ function TBoldIBQuery.GetRowsAffected: integer; result := Query.RowsAffected; end; +function TBoldIBQuery.GetSQLStrings: TStrings; +begin + result := Query.SQL; +end; + function TBoldIBQuery.GetSQLText: String; begin result := Query.SQL.Text; end; +function TBoldIBQuery.GetUseReadTransactions: boolean; +begin + result := false; +end; + procedure TBoldIBQuery.Open; begin + BeginExecuteQuery; + try EnsureTransaction; BoldLogSQL(Query.SQL); try @@ -255,10 +307,13 @@ procedure TBoldIBQuery.Open; except on e: Exception do begin - e.Message := e.Message + BOLDCRLF + 'SQL: '+Query.SQL.text; // do not localize + e.Message := e.Message + BOLDCRLF + 'SQL: '+Query.SQL.text; raise; end; end + finally + EndExecuteQuery; + end; end; procedure TBoldIBQuery.Close; @@ -275,10 +330,7 @@ function TBoldIBQuery.ParamByName(const Value: string): IBoldParameter; Param: TParam; begin Param := Query.ParamByName(Value); - if assigned(Param) then result := TBoldDbParameter.Create(Param, self) - else - result := nil; end; @@ -288,15 +340,19 @@ function TBoldIBQuery.ParamByName(const Value: string): IBoldParameter; end; } +procedure TBoldIBQuery.SetParamCheck(value: Boolean); +begin + Query.ParamCheck := Value; +end; + procedure TBoldIBQuery.SetRequestLiveQuery(NewValue: Boolean); begin - // ignore end; -procedure TBoldIBQuery.StartSQLBatch; +procedure TBoldIBQuery.SetUseReadTransactions(value: boolean); begin - // intentionally left blank + end; function TBoldIBQuery.Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; @@ -414,11 +470,10 @@ procedure TBoldIBTable.Open; procedure TBoldIBTable.SetExclusive(NewValue: Boolean); begin -// showmessage('cant set exclusive on IBTables'); end; -procedure TBoldIBTable.SetTableName(NewName: String); +procedure TBoldIBTable.SetTableName(const NewName: String); begin Table.TableName := NewName; end; @@ -432,6 +487,11 @@ procedure TBoldIBDataBase.AllTableNames(Pattern: String; ShowSystemTables: Boole DataBase.GetTableNames(TableNameList, ShowSystemTables); end; +procedure TBoldIBDataBase.BeginExecuteQuery; +begin + inc(fExecuteQueryCount); +end; + procedure TBoldIBDataBase.Close; begin DataBase.Close; @@ -462,6 +522,42 @@ destructor TBoldIBDataBase.destroy; inherited; end; +procedure TBoldIBDataBase.EndExecuteQuery; +begin + dec(fExecuteQueryCount); +end; + +procedure TBoldIBDataBase.CreateDatabase(DropExisting: boolean = true); +var + db: TIBDatabase; + username: String; + pwd: String; +const + cPageSize = 4096; +begin + if not assigned(Database) then + raise EBold.CreateFmt('%s.CreateInterbaseDatbase: Unable to complete operation without an IBDatabase', [classname]); + + username := Database.Params.Values['user_name']; + pwd := Database.Params.Values['password']; + + if (username = '') or (pwd = '') then + raise EBold.CreateFmt('%s.CreateInterbaseDatabase: username or password missing', [classname]); + if FileExists(Database.DatabaseName) then + if not DeleteFile(Database.DatabaseName) then + raise EBold.CreateFmt('%s.CreateInterbaseDatbase: Unable to remove old database file (%s)', [classname, DataBase.DatabaseName]); + db := TIBDatabase.Create(nil); + try + db.DatabaseName := Database.DatabaseName; + db.Params.add(format('USER "%s" PASSWORD "%s" PAGE_SIZE %d', [ + username, pwd, cPageSize])); + db.SQLDialect := Database.SQLDialect; + db.CreateDatabase; + finally + db.free; + end; +end; + function TBoldIBDataBase.GetConnected: Boolean; begin result := DataBase.Connected; @@ -480,6 +576,11 @@ function TBoldIBDataBase.GetInTransaction: Boolean; result := assigned(Transaction) and Transaction.InTransaction; end; +function TBoldIBDataBase.GetIsExecutingQuery: Boolean; +begin + Result := fExecuteQueryCount > 0; +end; + function TBoldIBDataBase.GetIsSQLBased: Boolean; begin result := true; @@ -488,7 +589,6 @@ function TBoldIBDataBase.GetIsSQLBased: Boolean; function TBoldIBDataBase.GetKeepConnection: Boolean; begin result := true - // CHEKCME end; function TBoldIBDataBase.GetLogInPrompt: Boolean; @@ -508,6 +608,7 @@ function TBoldIBDataBase.GetQuery: IBoldQuery; else begin Query := TIBQuery.Create(nil); + Query.UniDirectional := True; Query.DataBase := DataBase; end; if not assigned(Query.Transaction) then @@ -536,9 +637,6 @@ procedure TBoldIBDataBase.Open; var NewTransaction: TIBTransaction; begin - if Database.LogInPrompt and - not (assigned(Database.OnLogin) or assigned(LoginDialogExProc)) then - raise EIBError.Create(SLoginPromptFailure); if not assigned(DataBAse.DefaultTransaction) then begin NewTransaction := TIBTransaction.Create(DataBase); @@ -547,6 +645,14 @@ procedure TBoldIBDataBase.Open; DataBase.Open; end; +procedure TBoldIBDataBase.Reconnect; +begin + if Assigned(fDataBase) then begin + fDataBase.Connected := False; + fDataBase.Connected := True; + end; +end; + procedure TBoldIBDataBase.ReleaseCachedObjects; begin FreeAndNil(fCachedQuery); @@ -567,6 +673,7 @@ procedure TBoldIBDataBase.ReleaseQuery(var Query: IBoldQuery); if fCachedQuery.Active then fCachedQuery.Close; fCachedQuery.SQL.Clear; + fCachedQuery.Params.Clear; end else IBQuery.fQuery.free; @@ -605,7 +712,6 @@ procedure TBoldIBDataBase.RollBack; procedure TBoldIBDataBase.SetKeepConnection(NewValue: Boolean); begin - //CHECKME end; procedure TBoldIBDataBase.SetlogInPrompt(NewValue: Boolean); @@ -630,6 +736,3 @@ function TBoldIBDataBase.SupportsTableCreation: Boolean; end; end. - - - diff --git a/Source/Persistence/IBX/BoldPersistenceHandleIB.pas b/Source/Persistence/IBX/BoldPersistenceHandleIB.pas index ff59ccef..bcc7fd3e 100644 --- a/Source/Persistence/IBX/BoldPersistenceHandleIB.pas +++ b/Source/Persistence/IBX/BoldPersistenceHandleIB.pas @@ -1,10 +1,13 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleIB; interface uses Classes, - IBDataBase, + IBX.IBDatabase, BoldDBInterfaces, BoldIBInterfaces, BoldSQLDatabaseConfig, @@ -37,8 +40,8 @@ TBoldPersistenceHandleIB = class(TBoldDBPersistenceHandle) procedure InternalTransferproperties(const target: TBoldPersistenceHandleDB); override; {$ENDIF} public - constructor Create(owner: TComponent); override; - destructor Destroy; override; + constructor create(owner: TComponent); override; + destructor destroy; override; function GetDataBaseInterface: IBoldDatabase; override; published property DatabaseName: String read fDataBaseName write SetDatabaseName; @@ -87,8 +90,8 @@ function TBoldPersistenceHandleIB.getEffectiveDataBase: TIBDataBase; begin fOwnDataBase := TIBDataBase.Create(nil); fOwnDataBase.DatabaseName := DatabaseName; - fOwnDataBase.Params.Values['USER_NAME'] := Username; // do not localize - fOwnDataBase.Params.Values['PASSWORD'] := Password; // do not localize + fOwnDataBase.Params.Values['USER_NAME'] := Username; + fOwnDataBase.Params.Values['PASSWORD'] := Password; if PassWord <> '' then fOwnDataBase.LoginPrompt := false; end; @@ -115,7 +118,7 @@ procedure TBoldPersistenceHandleIB.SetIBDatabase(const Value: TIBDataBase); begin if fIBDataBase <> Value then begin - CheckInactive('SetDataBase'); // do not localize + CheckInactive('SetDataBase'); if assigned(fOwnDataBase) then begin FreeAndNil(FOwnDataBase); @@ -140,26 +143,25 @@ procedure TBoldPersistenceHandleIB.SetPassword(const Value: string); begin inherited; if assigned(fOwnDataBase) then - fOwnDataBase.Params.Values['PASSWORD'] := Password; // do not localize + fOwnDataBase.Params.Values['PASSWORD'] := Password; end; procedure TBoldPersistenceHandleIB.SetUserName(const Value: string); begin inherited; if assigned(fOwnDataBase) then - fOwnDataBase.Params.Values['USER_NAME'] := UserName; // do not localize + fOwnDataBase.Params.Values['USER_NAME'] := UserName; end; procedure TBoldPersistenceHandleIB.DefineProperties(Filer: TFiler); begin inherited DefineProperties(Filer); - // Database changed names to DatabaseName after 2.5 - Filer.DefineProperty('Database', ReadDatabase, nil, True); // do not localize + Filer.DefineProperty('Database', ReadDatabase, nil, True); end; procedure TBoldPersistenceHandleIB.ReadDatabase(Reader: TReader); begin - DatabaseName := Reader.ReadString; + DatabaseName := Reader.ReadString; end; procedure TBoldPersistenceHandleIB.SetDataBaseEngine(const Value: TBoldDataBaseEngine); @@ -181,9 +183,9 @@ procedure TBoldPersistenceHandleIB.InternalTransferproperties( if not assigned(Target.DatabaseAdapter) then begin Target.DatabaseAdapter := tBoldDatabaseAdapterIB.Create(Target.Owner); - Target.DatabaseAdapter.Name := GetNewComponentName(Target.DatabaseAdapter, 'BoldDatabaseAdapterIB'); // do not localize - LongRec(DesInfo).Lo := LongRec(DesInfo).lo+16; //set Left - LongRec(DesInfo).Hi := LongRec(DesInfo).hi+16; //Set Top; + Target.DatabaseAdapter.Name := GetNewComponentName(Target.DatabaseAdapter, 'BoldDatabaseAdapterIB'); + LongRec(DesInfo).Lo := LongRec(DesInfo).lo+16; + LongRec(DesInfo).Hi := LongRec(DesInfo).hi+16; Target.DatabaseAdapter.DesignInfo := DesInfo; showmessage('Created a new DatabaseAdapterIB'); end @@ -197,19 +199,21 @@ procedure TBoldPersistenceHandleIB.InternalTransferproperties( if not assigned(Adapter.Database) then begin Adapter.DataBase := TIBDatabase.Create(Target.owner); - Adapter.DataBase.Name := GetNewComponentName(Adapter.DataBase, 'IBDatabase'); // do not localize + Adapter.DataBase.Name := GetNewComponentName(Adapter.DataBase, 'IBDatabase'); showmessage('Created a new IBDatabase'); - LongRec(DesInfo).Lo := LongRec(DesInfo).lo+16; //set Left - LongRec(DesInfo).Hi := LongRec(DesInfo).hi+16; //Set Top; + LongRec(DesInfo).Lo := LongRec(DesInfo).lo+16; + LongRec(DesInfo).Hi := LongRec(DesInfo).hi+16; Adapter.DataBase.DesignInfo := DesInfo; end; - Adapter.Database.Params.Values['PASSWORD'] := Password; // do not localize - Adapter.Database.Params.Values['USER_NAME'] := Username; // do not localize - if Adapter.Database.Params.Values['PASSWORD'] <> '' then // do not localize + Adapter.Database.Params.Values['PASSWORD'] := Password; + Adapter.Database.Params.Values['USER_NAME'] := Username; + if Adapter.Database.Params.Values['PASSWORD'] <> '' then Adapter.Database.LoginPrompt := false; if not assigned(IBDatabase) then Adapter.DataBase.DatabaseName := DatabaseName; end; +initialization + end. diff --git a/Source/Persistence/IBX/BoldPersistenceHandleIB.res b/Source/Persistence/IBX/BoldPersistenceHandleIB.res new file mode 100644 index 00000000..42f910a8 Binary files /dev/null and b/Source/Persistence/IBX/BoldPersistenceHandleIB.res differ diff --git a/Source/Persistence/IBX/BoldPersistenceHandleIBReg.pas b/Source/Persistence/IBX/BoldPersistenceHandleIBReg.pas index 4b478f6a..3b899120 100644 --- a/Source/Persistence/IBX/BoldPersistenceHandleIBReg.pas +++ b/Source/Persistence/IBX/BoldPersistenceHandleIBReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleIBReg; interface @@ -14,6 +17,7 @@ implementation DesignIntf, Controls, ActnList, + Actions, DesignEditors, Classes, BoldPropertyEditors, @@ -48,10 +52,8 @@ function TBoldIBDataBaseProperty.FileFilter: string; procedure Register; begin RegisterComponents(BOLDPAGENAME_PERSISTENCE, [TBoldDatabaseAdapterIB]); - {$WARNINGS OFF} RegisterComponents(BOLDPAGENAME_DEPRECATED, [TBoldPersistenceHandleIB]); - RegisterPropertyEditor(TypeInfo(string), TBoldPersistenceHandleIB, 'DataBaseName', TBoldIBDatabaseProperty); // do not localize - {$WARNINGS ON} + RegisterPropertyEditor(TypeInfo(string), TBoldPersistenceHandleIB, 'DataBaseName', TBoldIBDatabaseProperty); RegisterActions(BOLDACTIONGROUPNAME, [TBoldIBDatabaseAction], nil); RegisterComponentEditor(TBoldDatabaseAdapterIB, TBoldDatabaseAdapterIBEditor); @@ -125,6 +127,7 @@ procedure TBoldDatabaseAdapterIBEditor.ExecuteVerb(Index: Integer); end; end; + function TBoldDatabaseAdapterIBEditor.GetVerb(Index: Integer): string; begin case Index of diff --git a/Source/Persistence/IDE/BoldHandlesPropagationReg.pas b/Source/Persistence/IDE/BoldHandlesPropagationReg.pas index 91e6114c..13642661 100644 --- a/Source/Persistence/IDE/BoldHandlesPropagationReg.pas +++ b/Source/Persistence/IDE/BoldHandlesPropagationReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldHandlesPropagationReg; interface @@ -6,7 +9,7 @@ procedure Register; implementation -{.$R *.res} +{$R BoldHandlesPropagationReg.res} uses SysUtils, @@ -30,8 +33,8 @@ procedure RegisterComponentsOnPalette; procedure RegisterEditors; begin - RegisterPropertyEditor(TypeInfo(TBoldAbstractDequeuer), TBoldListenerHandle, 'Dequeuer', TBoldComponentPropertyIndicateMissing); // do not localize - RegisterPropertyEditor(TypeInfo(TBoldListenerHandle), TBoldIDAdderHandle, 'BoldListener', TBoldComponentPropertyIndicateMissing); // do not localize + RegisterPropertyEditor(TypeInfo(TBoldAbstractDequeuer), TBoldListenerHandle, 'Dequeuer', TBoldComponentPropertyIndicateMissing); + RegisterPropertyEditor(TypeInfo(TBoldListenerHandle), TBoldIDAdderHandle, 'BoldListener', TBoldComponentPropertyIndicateMissing); end; procedure Register; diff --git a/Source/Persistence/IDE/BoldHandlesPropagationReg.res b/Source/Persistence/IDE/BoldHandlesPropagationReg.res new file mode 100644 index 00000000..892ade93 Binary files /dev/null and b/Source/Persistence/IDE/BoldHandlesPropagationReg.res differ diff --git a/Source/Persistence/IDE/BoldObjectUpgraderHandleReg.pas b/Source/Persistence/IDE/BoldObjectUpgraderHandleReg.pas index 1011dd81..792b94ad 100644 --- a/Source/Persistence/IDE/BoldObjectUpgraderHandleReg.pas +++ b/Source/Persistence/IDE/BoldObjectUpgraderHandleReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldObjectUpgraderHandleReg; interface @@ -6,7 +9,7 @@ procedure Register; implementation -{.$R *.res} +{$R BoldObjectUpgraderHandleReg.res} uses classes, @@ -19,4 +22,3 @@ procedure Register; end; end. - diff --git a/Source/Persistence/IDE/BoldObjectUpgraderHandleReg.res b/Source/Persistence/IDE/BoldObjectUpgraderHandleReg.res new file mode 100644 index 00000000..13ca72d2 Binary files /dev/null and b/Source/Persistence/IDE/BoldObjectUpgraderHandleReg.res differ diff --git a/Source/Persistence/IDE/BoldPersistenceHandleFileReg.pas b/Source/Persistence/IDE/BoldPersistenceHandleFileReg.pas index d59258b9..59a34f38 100644 --- a/Source/Persistence/IDE/BoldPersistenceHandleFileReg.pas +++ b/Source/Persistence/IDE/BoldPersistenceHandleFileReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleFileReg; interface @@ -6,8 +9,6 @@ procedure Register; implementation -{.$R BoldPersistenceHandleFile.res} - uses SysUtils, Classes, @@ -28,7 +29,7 @@ TBoldXMLFileNameProperty = class(TBoldFileNameProperty) {---TBoldRose98FileNameProperty---} function TBoldXMLFileNameProperty.FileFilter: string; begin - Result := Format('%s (*.%s)|*%1:s', [XML_LINKDESC, XML_LINKEXTENSION]); // do not localize + Result := Format('%s (*.%s)|*%1:s', [XML_LINKDESC, XML_LINKEXTENSION]); end; function TBoldXMLFileNameProperty.IsValid: boolean; @@ -48,7 +49,7 @@ function TBoldXMLFileNameProperty.IsValid: boolean; procedure RegisterEditors; begin - RegisterPropertyEditor(TypeInfo(String), TBoldPersistenceHandleFileXML, 'Filename', TBoldXMLFileNameProperty); // do not localize + RegisterPropertyEditor(TypeInfo(String), TBoldPersistenceHandleFileXML, 'Filename', TBoldXMLFileNameProperty); end; procedure Register; diff --git a/Source/Persistence/IDE/BoldPersistenceHandleReg.pas b/Source/Persistence/IDE/BoldPersistenceHandleReg.pas index 9046496c..ade1a28e 100644 --- a/Source/Persistence/IDE/BoldPersistenceHandleReg.pas +++ b/Source/Persistence/IDE/BoldPersistenceHandleReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleReg; interface @@ -7,7 +10,6 @@ procedure Register; implementation uses - SysUtils, DesignIntf, BoldAbstractPropertyEditors, BoldAbstractModel, @@ -16,8 +18,8 @@ implementation procedure Register; begin - RegisterPropertyEditor(TypeInfo(TBoldAbstractModel), TBoldPersistenceHandle, 'BoldModel', TBoldComponentPropertyIndicateMissing); // do not localize - RegisterPropertyEditor(TypeInfo(TBoldPersistenceHandle), TBoldPersistenceHandlePassthrough, 'NextPersistenceHandle', TBoldComponentPropertyIndicateMissing); // do not localize + RegisterPropertyEditor(TypeInfo(TBoldAbstractModel), TBoldPersistenceHandle, 'BoldModel', TBoldComponentPropertyIndicateMissing); + RegisterPropertyEditor(TypeInfo(TBoldPersistenceHandle), TBoldPersistenceHandlePassthrough, 'NextPersistenceHandle', TBoldComponentPropertyIndicateMissing); end; end. diff --git a/Source/Persistence/IDE/BoldPersistenceHandleSystem.res b/Source/Persistence/IDE/BoldPersistenceHandleSystem.res new file mode 100644 index 00000000..4130335d Binary files /dev/null and b/Source/Persistence/IDE/BoldPersistenceHandleSystem.res differ diff --git a/Source/Persistence/IDE/BoldPersistenceHandleSystemReg.pas b/Source/Persistence/IDE/BoldPersistenceHandleSystemReg.pas index e109608d..2322a196 100644 --- a/Source/Persistence/IDE/BoldPersistenceHandleSystemReg.pas +++ b/Source/Persistence/IDE/BoldPersistenceHandleSystemReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleSystemReg; interface @@ -5,9 +8,10 @@ interface procedure Register; implementation -{.$R BoldPersistenceHandleSystem.res} + +{$R BoldPersistenceHandleSystem.res} + uses - SysUtils, Classes, BoldIdeConsts, BoldPersistenceHandleSystem; diff --git a/Source/Persistence/IDE/BoldPersistenceNotifierReg.pas b/Source/Persistence/IDE/BoldPersistenceNotifierReg.pas index cf120e03..275dba4d 100644 --- a/Source/Persistence/IDE/BoldPersistenceNotifierReg.pas +++ b/Source/Persistence/IDE/BoldPersistenceNotifierReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceNotifierReg; interface @@ -6,6 +9,8 @@ procedure Register; implementation +{$R *.res} + uses DesignIntf, Classes, @@ -14,7 +19,6 @@ implementation BoldAbstractPropertyEditors, BoldIDEConsts; -{.$R *.res} procedure RegisterComponentsOnPalette; begin @@ -27,7 +31,7 @@ procedure RegisterComponentsOnPalette; procedure RegisterEditors; begin - RegisterPropertyEditor(TypeInfo(TBoldPersistenceHandle), TBoldAbstractPersistenceNotifier, 'PersistenceHandle', TBoldComponentPropertyIndicateMissing); // do not localize + RegisterPropertyEditor(TypeInfo(TBoldPersistenceHandle), TBoldAbstractPersistenceNotifier, 'PersistenceHandle', TBoldComponentPropertyIndicateMissing); end; procedure Register; diff --git a/Source/Persistence/IDE/BoldPersistenceNotifierReg.res b/Source/Persistence/IDE/BoldPersistenceNotifierReg.res new file mode 100644 index 00000000..c99325ad Binary files /dev/null and b/Source/Persistence/IDE/BoldPersistenceNotifierReg.res differ diff --git a/Source/Persistence/IDECOM/BoldComPersistenceHandleReg.pas b/Source/Persistence/IDECOM/BoldComPersistenceHandleReg.pas index d06b2313..8a72e744 100644 --- a/Source/Persistence/IDECOM/BoldComPersistenceHandleReg.pas +++ b/Source/Persistence/IDECOM/BoldComPersistenceHandleReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComPersistenceHandleReg; interface @@ -22,7 +25,7 @@ procedure Register; RegisterComponents(BOLDPAGENAME_PERSISTENCE,[ TBoldSOAPClientPersistenceHandle, TBoldSOAPServerPersistenceHandle]); - RegisterPropertyEditor(TypeInfo(String), TBoldSOAPClientPersistenceHandle, 'Objectname', TBoldObjectNameProperty); // do not localize + RegisterPropertyEditor(TypeInfo(String), TBoldSOAPClientPersistenceHandle, 'Objectname', TBoldObjectNameProperty); end; end. diff --git a/Source/Persistence/IDECOM/BoldComPersistenceHandleReg.res b/Source/Persistence/IDECOM/BoldComPersistenceHandleReg.res new file mode 100644 index 00000000..9ef6c635 Binary files /dev/null and b/Source/Persistence/IDECOM/BoldComPersistenceHandleReg.res differ diff --git a/Source/Persistence/IDECOM/BoldHTTPClientPersistenceHandleReg.pas b/Source/Persistence/IDECOM/BoldHTTPClientPersistenceHandleReg.pas index d78a7a3a..d1536d1f 100644 --- a/Source/Persistence/IDECOM/BoldHTTPClientPersistenceHandleReg.pas +++ b/Source/Persistence/IDECOM/BoldHTTPClientPersistenceHandleReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldHTTPClientPersistenceHandleReg; interface @@ -6,10 +9,11 @@ procedure Register; implementation -{$R *.res} +{$R BoldHTTPClientPersistenceHandleReg.res} uses BoldIDEConsts, + BoldGuard, BoldHTTPClientPersistenceHandle, Classes; diff --git a/Source/Persistence/IDECOM/BoldHTTPClientPersistenceHandleReg.res b/Source/Persistence/IDECOM/BoldHTTPClientPersistenceHandleReg.res new file mode 100644 index 00000000..9386e9d7 Binary files /dev/null and b/Source/Persistence/IDECOM/BoldHTTPClientPersistenceHandleReg.res differ diff --git a/Source/Persistence/IDECOM/BoldHTTPServerPersistenceHandlePassthroughReg.pas b/Source/Persistence/IDECOM/BoldHTTPServerPersistenceHandlePassthroughReg.pas index 51f6dcfb..59673822 100644 --- a/Source/Persistence/IDECOM/BoldHTTPServerPersistenceHandlePassthroughReg.pas +++ b/Source/Persistence/IDECOM/BoldHTTPServerPersistenceHandlePassthroughReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldHTTPServerPersistenceHandlePassthroughReg; interface @@ -6,10 +9,11 @@ procedure Register; implementation -{$R *.res} +{$R BoldHTTPServerPersistenceHandlePassthroughReg.res} uses BoldIDEConsts, + BoldGuard, BoldHTTPServerPersistenceHandlePassthrough, Classes; diff --git a/Source/Persistence/IDECOM/BoldHTTPServerPersistenceHandlePassthroughReg.res b/Source/Persistence/IDECOM/BoldHTTPServerPersistenceHandlePassthroughReg.res new file mode 100644 index 00000000..d4c666b8 Binary files /dev/null and b/Source/Persistence/IDECOM/BoldHTTPServerPersistenceHandlePassthroughReg.res differ diff --git a/Source/Persistence/IDEUDP/BoldUDPBroadcasterReg.pas b/Source/Persistence/IDEUDP/BoldUDPBroadcasterReg.pas index 86c43b83..2d06bc51 100644 --- a/Source/Persistence/IDEUDP/BoldUDPBroadcasterReg.pas +++ b/Source/Persistence/IDEUDP/BoldUDPBroadcasterReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUDPBroadcasterReg; interface @@ -11,12 +14,9 @@ implementation BoldIDEConsts, BoldUDPModificationBroadCaster; -{$R BoldUDPBroadCaster.res} - procedure Register; begin RegisterComponents(BOLDPAGENAME_OSS_CMS, [TBoldUDPModificationBroadcaster]); end; end. - diff --git a/Source/Persistence/ObjectUpgrading/BoldAbstractObjectUpgraderHandle.pas b/Source/Persistence/ObjectUpgrading/BoldAbstractObjectUpgraderHandle.pas index 246032b4..b5de81eb 100644 --- a/Source/Persistence/ObjectUpgrading/BoldAbstractObjectUpgraderHandle.pas +++ b/Source/Persistence/ObjectUpgrading/BoldAbstractObjectUpgraderHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAbstractObjectUpgraderHandle; interface @@ -19,7 +22,7 @@ TBoldAbstractObjectUpgraderHandle = class(TBoldHandle) function CreateObjectUpgrader: TBoldAbstractObjectUpgrader; virtual; abstract; function GetHandledObject: TObject; override; public - destructor Destroy; override; + destructor destroy; override; property ObjectUpgrader: TBoldAbstractObjectUpgrader read GetObjectUpgrader; published property Config: TBoldObjectUpgraderConfiguration read GetConfig write SetConfig; @@ -74,4 +77,3 @@ procedure TBoldAbstractObjectUpgraderHandle.SetConfig(const Value: TBoldObjectUp end; end. - diff --git a/Source/Persistence/ObjectUpgrading/BoldBatchUpgrader.pas b/Source/Persistence/ObjectUpgrading/BoldBatchUpgrader.pas index 08f50128..3ef65895 100644 --- a/Source/Persistence/ObjectUpgrading/BoldBatchUpgrader.pas +++ b/Source/Persistence/ObjectUpgrading/BoldBatchUpgrader.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldBatchUpgrader; interface @@ -49,8 +52,7 @@ implementation BoldCondition, BoldDbInterfaces, BoldPMappers, - BoldUtils, - PersistenceConsts; + BoldUtils; procedure TBoldBatchUpgrader.AutoUpgradeObjects; var @@ -78,7 +80,7 @@ constructor TBoldBatchUpgrader.Create(SystemMapper: TBoldSystemDefaultMapper; Up begin inherited create; if not SystemMapper.SupportsObjectUpgrading then - raise EBold.CreateFmt(sUpgradeNotSupported, [ClassName]); + raise EBold.CreateFmt('%s.Create: The SystemPersistenceMapper does not support object upgrading!', [ClassName]); fSystemMapper := SystemMapper; fUpgrader := Upgrader; fBatchSize := 100; @@ -99,8 +101,7 @@ procedure TBoldBatchUpgrader.UpgradeClass(TopSortedIndex: integer); TranslationList := TBoldIdTranslationList.Create; try Condition.TopSortedIndex := TopSortedIndex; - // exact type and not the current version. - Condition.WhereFragment := format( '%s = %d AND %s <> %d', [ // do not localize + Condition.WhereFragment := format( '%s = %d AND %s <> %d', [ TYPECOLUMN_NAME, SystemMapper.BoldDbTypeForTopSortedIndex(TopSortedIndex), SystemMapper.RootClassObjectPersistenceMapper.ModelVersionMember.ColumnDescriptions[0].SQLName, @@ -147,30 +148,28 @@ procedure TBoldBatchUpgrader.UpgradeObjectIdList(ObjectIdList: TBoldObjectIdList for i := 0 to ObjectIdList.Count - 1 do begin if not ObjectIdList[i].TopSortedIndexExact then - raise EBold.createFmt(sObjectIDListNotExact, [Classname]); + raise EBold.createFmt('%s.UpgradeObjectIdList: ObjectIdlist not Exact', [Classname]); if ObjectIdList[i].topSortedIndex <> ObjectMapper.TopSortedIndex then - raise EBold.createFmt(sObjectIDListNotHomogenous, [Classname]); + raise EBold.createFmt('%s.UpgradeObjectIdList: ObjectIdlist not homogenous', [Classname]); TempLIst.Append(ObjectIdList[i].asString); end; if (MemberPMList.Count > 0) and (TempList.Count > 0) then begin - BoldAppendToStrings(SQL, Format('in (%s)',[BoldSeparateStringList(TempList, ', ', '', '')]), False); // do not localize + BoldAppendToStrings(SQL, Format('in (%s)',[BoldSeparateStringList(TempList, ', ', '', '')]), False); if Objectmapper.versioned then - Objectmapper.RetrieveTimeStampCondition(SQL, BOLDMAXTIMESTAMP, true, 'AND', false); // do not localize + Objectmapper.RetrieveTimeStampCondition(SQL, BOLDMAXTIMESTAMP, true, 'AND', false); aQuery.AssignSQL(SQL); aQuery.Open; while not aQuery.EOF do begin - tempId := SystemMapper.NewIdFromQuery(aQuery, 1, 0, BOLDMAXTIMESTAMP); + // ClassId param -1 was added due to changes in signature of NewIdFromQuery, + // check if we can replace -1 with known ClassId if possible in order to get ExactId right away - Daniel + tempId := SystemMapper.NewIdFromQuery(aQuery, -1, 1, 0, BOLDMAXTIMESTAMP); NewId := ObjectIdList.IDByID[TempId]; TempId.Free; - // is this safe? perhaps the object was guardupgraded while we were doing other things... -// if not ObjectMapper.IsOldVersion(aQuery) then -// raise EBold.CreateFmt('%s.UpgradeObjectIdList: Was fed an object that does not need upgrading!', [ClassName]); - Upgrader.UpgradeObjectById(NewId, aQuery); inc(fUpgradedObjects); aQuery.Next; @@ -204,7 +203,7 @@ procedure TBoldBatchUpgrader.UpgradeObjects; if IsUpgrading then exit; if not assigned(SystemMapper.DataBase) then - raise EBold.CreateFmt(sDBMustBeOpened, [classname]); + raise EBold.CreateFmt('%s.UpgradeObjects: The database must be opened first', [classname]); fIsUpgrading := true; try fStartTime := now; @@ -217,4 +216,6 @@ procedure TBoldBatchUpgrader.UpgradeObjects; end; end; +initialization + end. diff --git a/Source/Persistence/ObjectUpgrading/BoldObjectUpgrader.pas b/Source/Persistence/ObjectUpgrading/BoldObjectUpgrader.pas index d2dfa6a5..c09e2112 100644 --- a/Source/Persistence/ObjectUpgrading/BoldObjectUpgrader.pas +++ b/Source/Persistence/ObjectUpgrading/BoldObjectUpgrader.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldObjectUpgrader; interface @@ -80,8 +83,7 @@ implementation BoldPMappersSQL, BoldUtils, BoldGuard, - BoldDomainElement, - BoldCoreConsts; + BoldDomainElement; { TBoldObjectUpgrader } @@ -132,21 +134,19 @@ procedure TBoldObjectUpgrader.FetchObjectForId(ObjectId: TBoldObjectId; Query: I ObjectList: TBoldObjectlist; begin Guard := TBoldGuard.Create(Objectlist, IdList, MemberPMList); - + MemberPMList := TBoldMemberPersistenceMapperList.Create; MemberPMList.OwnsEntries := false; IdList := TBoldObjectIdList.Create; Objectlist := TBoldObjectList.Create; - // this procedure loads an object into the local objectlayer using the external persistencemapper, - // but bypassing the code for using the ObjectUpgrader IdList.Add(ObjectId); ObjectMapper := ObjectMapperForId(ObjectId); ObjectMapper.BuildMemberFetchLists(nil, MemberPMList, nil, fmNormal); ObjectMapper.HandleFetchData(ObjectId, ValueSpacePmIn, nil, query, MemberPMList, fmNormal, nil); Objectlist.Add(BoldSystem.EnsuredLocatorByID[ObjectId].BoldObject); - + TBoldExposedSystem(BoldSystem).SystemPersistenceHandler.EndFetchForAll(ObjectList, nil); end; @@ -175,7 +175,7 @@ procedure TBoldObjectUpgrader.GenerateAutoUpgradeScript(Script: TStrings); UpgradeWholeClass.Add(IntToStr(ObjectMapper.BoldDbType)) else if ConfigItem.UpgradeOlderThanVersion < CurrentVersion then begin - Script.Add(format('UPDATE %s SET %s = %d WHERE (%s = %d) AND (%s >= %d) AND (%s <> %d)', [ // do not localize + Script.Add(format('UPDATE %s SET %s = %d WHERE (%s = %d) AND (%s >= %d) AND (%s <> %d)', [ RootTable, VersionColumn, CurrentVersion, TYPECOLUMN_NAME, ObjectMapper.BoldDbType, @@ -185,7 +185,7 @@ procedure TBoldObjectUpgrader.GenerateAutoUpgradeScript(Script: TStrings); end; end; if UpgradeWholeClass.Count <> 0 then - Script.Add(format('UPDATE %s SET %s = %d WHERE %s IN (%s) AND (%s <> %d)', [ // do not localize + Script.Add(format('UPDATE %s SET %s = %d WHERE %s IN (%s) AND (%s <> %d)', [ RootTable, VersionColumn, CurrentVersion, TYPECOLUMN_NAME, BoldSeparateStringList(UpgradeWholeClass, ', ', '', ''), @@ -203,9 +203,9 @@ function TBoldObjectUpgrader.GetBoldSystem: TBoldSystem; aSystemTypeInfo := SystemTypeInfo; aPController := PersistenceController; if not assigned(aSystemTypeInfo) then - raise EBold.CreateFmt(sMissingTypeInfo, [classname]); + raise EBold.CreateFmt('%s.GetBoldSystem: Missing System Type Info', [classname]); if not assigned(aPController) then - raise EBold.CreateFmt(sMissingPersistenceController, [classname]); + raise EBold.CreateFmt('%s.GetBoldSystem: Missing Persistence Controller', [classname]); fBoldSystem := TBoldSystem.CreateWithTypeInfo(nil, aSystemTypeInfo, aPController) end; result := fBoldSystem; @@ -234,7 +234,7 @@ function TBoldObjectUpgrader.ObjectMapperForId(ObjectId: TBoldObjectId): TBoldOb procedure TBoldObjectUpgrader.ReleaseBoldSystem; begin if (fNestingLevel <> 0) then - raise EBold.CreateFmt(sCannotReleaseInOperation, [classname]); + raise EBold.CreateFmt('%s.ReleaseBoldSystem: can not release the system while in an upgrade operation', [classname]); FreeAndNil(fBoldSystem); end; @@ -248,13 +248,16 @@ procedure TBoldObjectUpgrader.UpgradeObject(Obj: TBoldObject); ConfigItem: TBoldObjectUpgraderConfigurationItemWithEvent; begin ConfigItem := Config.ItemByName[Obj.BoldClassTypeInfo.Expressionname] as TBoldObjectUpgraderConfigurationItemWithEvent; +{$IFNDEF CompareToOldValues} Obj.MarkObjectDirty; +{$ENDIF} if assigned(ConfigItem) and assigned(ConfigItem.OnUpgradeObject) then ConfigItem.OnUpgradeObject(Obj) else if assigned(OnUpgradeObject) then OnUpgradeObject(Obj); - // in case some user decides to call discard on the object, we better dirtify it again. +{$IFNDEF CompareToOldValues} Obj.MarkObjectDirty; +{$ENDIF} end; procedure TBoldObjectUpgrader.UpgradeObjectById(ObjectId: TBoldObjectId; Query: IBoldQuery); @@ -297,4 +300,3 @@ function TBoldObjectUpgraderConfigurationItemWithEvent.GetNamePath: String; end; end. - diff --git a/Source/Persistence/ObjectUpgrading/BoldObjectUpgraderHandle.pas b/Source/Persistence/ObjectUpgrading/BoldObjectUpgraderHandle.pas index dad82ff9..a408f5ea 100644 --- a/Source/Persistence/ObjectUpgrading/BoldObjectUpgraderHandle.pas +++ b/Source/Persistence/ObjectUpgrading/BoldObjectUpgraderHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldObjectUpgraderHandle; interface @@ -14,6 +17,7 @@ interface BoldAbstractObjectUpgraderHandle; type + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldObjectUpgraderHandle = class(TBoldAbstractObjectUpgraderHandle) private FPersistenceHandle: TBoldAbstractPersistenceHandleDB; @@ -32,8 +36,8 @@ TBoldObjectUpgraderHandle = class(TBoldAbstractObjectUpgraderHandle) function CreateObjectUpgrader: TBoldAbstractObjectUpgrader; override; function ConfigClass: TBoldObjectUpgraderConfigClass; override; public - constructor Create(owner: TComponent); override; - destructor Destroy; override; + constructor create(owner: TComponent); override; + destructor destroy; override; property ObjectUpgrader: TBoldObjectUpgrader read GetObjectUpgrader; published property PersistenceHandle: TBoldAbstractPersistenceHandleDB read FPersistenceHandle write SetPersistenceHandle; @@ -44,7 +48,8 @@ TBoldObjectUpgraderHandle = class(TBoldAbstractObjectUpgraderHandle) implementation uses - SysUtils; + SysUtils, + BoldRev; const breSystemTypeInfoHandleDestroying = 100; @@ -73,7 +78,7 @@ function TBoldObjectUpgraderHandle.CreateObjectUpgrader: TBoldAbstractObjectUpgr destructor TBoldObjectUpgraderHandle.destroy; begin FreeAndNil(fComponentSubscriber); - inherited; + inherited; end; function TBoldObjectUpgraderHandle.GetObjectUpgrader: TBoldObjectUpgrader; @@ -148,4 +153,5 @@ procedure TBoldObjectUpgraderHandle._ReceiveComponentEvents(Originator: TObject; ObjectUpgrader.ReleaseBoldSystem; end; + end. diff --git a/Source/Persistence/Propagation/BoldIDAdder.pas b/Source/Persistence/Propagation/BoldIDAdder.pas index fc37f68d..1456ec43 100644 --- a/Source/Persistence/Propagation/BoldIDAdder.pas +++ b/Source/Persistence/Propagation/BoldIDAdder.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldIDAdder; interface @@ -5,7 +8,7 @@ interface uses BoldPersistenceControllerPassthrough, BoldID, - BoldUpdatePrecondition, + BoldUpdatePrecondition, BoldCondition, BoldValueSpaceInterfaces, BoldListenerThread, @@ -24,13 +27,16 @@ TBoldIDAdder = class(TBoldPersistenceControllerPassthrough) constructor Create; procedure PMFetch(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; BoldClientID: TBoldClientID); override; procedure PMFetchIDListWithCondition(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; FetchMode: Integer; Condition: TBoldCondition; BoldClientID: TBoldClientID); override; - procedure PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; BoldClientID: TBoldClientID); override; + procedure PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; var TimeOfLatestUpdate: TDateTime; BoldClientID: TBoldClientID); override; property BoldClientID: TBoldClientID read GetClientID; property Listener: TBoldListenerThread read fListener write fListener; end; implementation +uses + BoldRev; + { TBoldIDAdder } constructor TBoldIDAdder.Create; @@ -45,7 +51,7 @@ function TBoldIDAdder.GetClientID: TBoldClientID; procedure TBoldIDAdder.PMFetch(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; - FetchMode: Integer; + FetchMode: Integer; BoldClientID: TBoldClientID); begin if Listener.Suspended then @@ -67,8 +73,8 @@ procedure TBoldIDAdder.PMFetchIDListWithCondition( procedure TBoldIDAdder.PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; - Precondition: TBoldUpdatePrecondition; - TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; + Precondition: TBoldUpdatePrecondition; + TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; var TimeOfLatestUpdate: TDateTime; BoldClientID: TBoldClientID); begin if Listener.Suspended then @@ -77,4 +83,6 @@ procedure TBoldIDAdder.PMUpdate(ObjectIdList: TBoldObjectIdList; inherited; end; +initialization + end. diff --git a/Source/Persistence/Propagation/BoldIDAdderHandle.pas b/Source/Persistence/Propagation/BoldIDAdderHandle.pas index cc5511bb..59f4151d 100644 --- a/Source/Persistence/Propagation/BoldIDAdderHandle.pas +++ b/Source/Persistence/Propagation/BoldIDAdderHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldIDAdderHandle; interface @@ -18,6 +21,7 @@ interface TBoldIdAdderHandle = class; { TBoldIDAdderHandle } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldIDAdderHandle = class(TBoldPersistenceHandlePassthrough) private fBoldListenerHandle: TBoldListenerHandle; @@ -50,8 +54,7 @@ implementation SysUtils, BoldUtils, BoldIDAdder, - dialogs, - BoldPMConsts; + dialogs; { TBoldIDAdderHandle } @@ -75,18 +78,12 @@ function TBoldIDAdderHandle.CreatePersistenceController: TBoldPersistenceControl procedure TBoldIDAdderHandle.DefineProperties(Filer: TFiler); begin inherited; - // property AutoStart moved to TBoldListenerHandle - Filer.DefineProperty('AutoStart', ReadObsoleteAutoStartProperty, nil, True); // do not localize - // property AutoExtendLease moved to TBoldListenerHandle - Filer.DefineProperty('AutoExtendLease', ReadObsoleteAutoExtendLeaseProperty, nil, True); // do not localize - // property LeaseDuration moved to TBoldListenerHandle - Filer.DefineProperty('LeaseDuration', ReadObsoleteLeaseDurationProperty, nil, True); // do not localize - // property Polling interval moved to TBoldListenerHandle - Filer.DefineProperty('PollingInterval', ReadObsoletePollingIntervalProperty, nil, True); // do not localize - // property MachineName moved to TBoldPropagatorHandleCOM - Filer.DefineProperty('MachineName', ReadObsoleteMachineNameProperty, nil, True); // do not localize - // event handler OnRegistrationFailed moved to TBoldListenerHandle - Filer.DefineProperty('OnRegistrationFailed', ReadObsoleteOnRegistrationFailedEventHandler, nil, True); // do not localize + Filer.DefineProperty('AutoStart', ReadObsoleteAutoStartProperty, nil, True); + Filer.DefineProperty('AutoExtendLease', ReadObsoleteAutoExtendLeaseProperty, nil, True); + Filer.DefineProperty('LeaseDuration', ReadObsoleteLeaseDurationProperty, nil, True); + Filer.DefineProperty('PollingInterval', ReadObsoletePollingIntervalProperty, nil, True); + Filer.DefineProperty('MachineName', ReadObsoleteMachineNameProperty, nil, True); + Filer.DefineProperty('OnRegistrationFailed', ReadObsoleteOnRegistrationFailedEventHandler, nil, True); end; destructor TBoldIDAdderHandle.Destroy; @@ -102,10 +99,10 @@ procedure TBoldIDAdderHandle.ReadObsoleteAutoExtendLeaseProperty(Reader: TReader begin OldPropertyValue := Reader.ReadBoolean; if OldPropertyValue then - ValueAsString := 'True' // do not localize + ValueAsString := 'True' else - ValueAsString := 'False'; // do not localize - ReadObsoleteProperty(Reader, 'AutoExtendLease', 'AutoExtendLease', ValueAsString, 'TBoldListenerHandle'); // do not localize + ValueAsString := 'False'; + ReadObsoleteProperty(Reader, 'AutoExtendLease', 'AutoExtendLease', ValueAsString, 'TBoldListenerHandle'); end; procedure TBoldIDAdderHandle.ReadObsoleteAutoStartProperty(Reader: TReader); @@ -115,10 +112,10 @@ procedure TBoldIDAdderHandle.ReadObsoleteAutoStartProperty(Reader: TReader); begin OldPropertyValue := Reader.ReadBoolean; if OldPropertyValue then - ValueAsString := 'True' // do not localize + ValueAsString := 'True' else - ValueAsString := 'False'; // do not localize - ReadObsoleteProperty(Reader, 'AutoStart', 'AutoStart', ValueAsString, 'TBoldListenerHandle'); // do not localize + ValueAsString := 'False'; + ReadObsoleteProperty(Reader, 'AutoStart', 'AutoStart', ValueAsString, 'TBoldListenerHandle'); end; procedure TBoldIDAdderHandle.ReadObsoleteLeaseDurationProperty(Reader: TReader); @@ -128,7 +125,7 @@ procedure TBoldIDAdderHandle.ReadObsoleteLeaseDurationProperty(Reader: TReader); begin OldPropertyValue := Reader.ReadInteger; ValueAsString := IntToStr(OldPropertyValue); - ReadObsoleteProperty(Reader, 'LeaseDuration', 'LeaseDuration', ValueAsString, 'TBoldListenerHandle'); // do not localize + ReadObsoleteProperty(Reader, 'LeaseDuration', 'LeaseDuration', ValueAsString, 'TBoldListenerHandle'); end; procedure TBoldIDAdderHandle.ReadObsoleteMachineNameProperty(Reader: TReader); @@ -136,7 +133,7 @@ procedure TBoldIDAdderHandle.ReadObsoleteMachineNameProperty(Reader: TReader); OldPropertyValue: string; begin OldPropertyValue := Reader.ReadString; - ReadObsoleteProperty(Reader, 'MachineName', 'ServerHost', OldPropertyValue, 'TBoldPropagatorHandleCom'); // do not localize + ReadObsoleteProperty(Reader, 'MachineName', 'ServerHost', OldPropertyValue, 'TBoldPropagatorHandleCom'); end; procedure TBoldIDAdderHandle.ReadObsoleteOnRegistrationFailedEventHandler( @@ -145,7 +142,7 @@ procedure TBoldIDAdderHandle.ReadObsoleteOnRegistrationFailedEventHandler( OldPropertyValue: string; begin OldPropertyValue := Reader.ReadString; - ReadObsoleteProperty(Reader, 'OnRegistrationFailed', 'OnRegistrationFailed', OldPropertyValue, 'TBoldListenerHandle'); // do not localize + ReadObsoleteProperty(Reader, 'OnRegistrationFailed', 'OnRegistrationFailed', OldPropertyValue, 'TBoldListenerHandle'); end; procedure TBoldIDAdderHandle.ReadObsoletePollingIntervalProperty(Reader: TReader); @@ -155,14 +152,14 @@ procedure TBoldIDAdderHandle.ReadObsoletePollingIntervalProperty(Reader: TReader begin OldPropertyValue := Reader.ReadInteger; ValueAsString := IntToStr(OldPropertyValue); - ReadObsoleteProperty(Reader, 'PollingInterval', 'PollingInterval', ValueAsString, 'TBoldListenerHandle'); // do not localize + ReadObsoleteProperty(Reader, 'PollingInterval', 'PollingInterval', ValueAsString, 'TBoldListenerHandle'); end; procedure TBoldIDAdderHandle.ReadObsoleteProperty(Reader: TReader; const PropertyName, NewPropertyName, OldPropertyValue, ComponentName: string); begin if (csDesigning in ComponentState) then - MessageDlg(Format(sPropertyHasMoved, + MessageDlg(Format('%s.%s has been moved to component (%s.%s). Old value was "%s"', [ClassName, PropertyName, ComponentName, NewPropertyName, OldPropertyValue]), mtWarning, [mbOK], 0); end; @@ -204,4 +201,6 @@ procedure TBoldIDAdderHandle.Subscribe(const DoSubscribe: Boolean); fPTSubscriber.CancelAllSubscriptions; end; +initialization + end. diff --git a/Source/Persistence/Propagation/BoldListenerCOM.pas b/Source/Persistence/Propagation/BoldListenerCOM.pas index b4feda28..fbd86fa2 100644 --- a/Source/Persistence/Propagation/BoldListenerCOM.pas +++ b/Source/Persistence/Propagation/BoldListenerCOM.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldListenerCOM; interface @@ -24,7 +27,7 @@ EBoldPropagatorTypeLib = class(EBold); TBoldExtendLeaseResult = (elrExtended, elrFailed, elrFailedExpired, elrDenied, elrNotRegistered); TBoldExtendLeaseFailureEvent = procedure(res: TBoldExtendLeaseResult; const Msg: string) of object; - TBoldMessageEvent = function(aMessage: string): Boolean of object; + TBoldMessageEvent = function(const aMessage: string): Boolean of object; { TBoldListenerCOM } TBoldListenerCOM = class(TComObject, IBoldListener, IBoldListenerAdmin) @@ -99,8 +102,9 @@ implementation SysUtils, Variants, BoldPersistenceController, - Activex, - Windows; + Activex, + Windows, + BoldRev; { TBoldListenerCOM } @@ -116,7 +120,6 @@ constructor TBoldListenerCOM.Create( aQueue: TBoldThreadSafeStringQueue; self.fPollingInterval := PollingInterval; self.fLeaseDuration := LeaseDuration; Self.fExtendLeaseAfter := ExtendLeaseAfter; - // It is important that the leaseduration and extendLeaseAfter is set up before the AutoExtendLease to get the correct interval self.AutoExtendLease := AutoExtendLease; self.fClientIdentifierString := ClientIdentifierString; Registered := false; @@ -236,12 +239,9 @@ procedure TBoldListenerCOM.OnTimer(Sender: TObject); fTimer.Interval := DefaultExtendLeaseInterval; end; elrFailed: begin - // wait 20% of the remaining time fTimer.Interval := round(LeaseTimeLeft * 0.2); - // but no more than half the usual time if fTimer.Interval > DefaultExtendLeaseInterval div 2 then fTimer.Interval := DefaultExtendLeaseInterval div 2; - // and no less than one second if fTimer.Interval < 1000 then fTimer.Interval := 1000; end; @@ -263,7 +263,7 @@ function TBoldListenerCOM.ExtendLease: TBoldExtendLeaseResult; if extended then result := elrExtended else - result := elrDenied; + result := elrDenied; except on E: Exception do begin @@ -277,7 +277,6 @@ function TBoldListenerCOM.ExtendLease: TBoldExtendLeaseResult; if result in [elrDenied, elrFailedExpired] then begin - // in the future, when the propagator allows reconnect after timeout, this code should go away... if Assigned(fPropagator) then fPropagator._Release; Registered := false; @@ -355,7 +354,7 @@ procedure TBoldListenerCOM.DisconnectClient(const aMessage: WideString; RemainDi MSecs := TimeStampToMSecs(DateTimeToTimeStamp(now)); MSecs := MSecs + RemainDisconnected; fConnectAllowed := TimeStampToDateTime(MSecsToTimeStamp(MSecs)); - Queue.Enqueue(format('DISCONNECT:%d:%s', [RemainDisconnected, aMessage])); //do not localize + Queue.Enqueue(format('DISCONNECT:%d:%s', [RemainDisconnected, aMessage])); if Assigned(QueueNotEmptyNotifyEvent) then QueueNotEmptyNotifyEvent(Self); end; @@ -369,7 +368,7 @@ function TBoldListenerCOM.Ping: Integer; constructor TBoldListenerCOMFactory.Create(ComServer: TComServerObject); begin - inherited Create(ComServer, TBoldListenerCOM, CLASS_BoldListener, 'TBoldListenerCOM', 'BoldListenerCOM', ciInternal); //do not localize + inherited Create(ComServer, TBoldListenerCOM, CLASS_BoldListener, 'TBoldListenerCOM', 'BoldListenerCOM', ciInternal); end; end. diff --git a/Source/Persistence/Propagation/BoldListenerHandle.pas b/Source/Persistence/Propagation/BoldListenerHandle.pas index 2628066a..0b10fb5a 100644 --- a/Source/Persistence/Propagation/BoldListenerHandle.pas +++ b/Source/Persistence/Propagation/BoldListenerHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldListenerHandle; interface @@ -18,11 +21,12 @@ interface {forward declarations} TBoldListenerHandle= class; + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldListenerHandle = class(TBoldHandle) private fActive: Boolean; fBoldListenerThread: TBoldListenerThread; - fDequeuer: TBoldAbstractDequeuer; + fDequeuer: TBoldStringDequeuer; fPTSubscriber: TBoldPassThroughSubscriber; fAutoStart: Boolean; fLeaseDuration: integer; @@ -35,10 +39,10 @@ TBoldListenerHandle = class(TBoldHandle) fPropagatorHandle: TBoldAbstractPropagatorHandle; fOnThreadError: TBoldMessageEvent; fExtendLeaseAfter: integer; - procedure _Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); + procedure _Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); function GetListenerThread: TBoldListenerThread; function GetConnected: Boolean; - procedure SetDequeuer(aDequeuer: TBoldAbstractDequeuer); + procedure SetDequeuer(aDequeuer: TBoldStringDequeuer); procedure NotifyDequeuer(Sender: TObject); procedure setLeaseDuration(Value: integer); procedure setPollingInterval(Value: integer); @@ -50,11 +54,11 @@ TBoldListenerHandle = class(TBoldHandle) function GetIsLoaded: Boolean; procedure StopAndFreeListenerThread; procedure SetExtendLeaseAfter(const Value: integer); - procedure Subscribe(const DoSubscribe: Boolean); + procedure Subscribe(const DoSubscribe: Boolean); protected function GetHandledObject: TObject; override; function GetBoldClientID: TBoldClientID; - procedure Notification(AComponent: TComponent; Operation: TOperation); override; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; property IsLoaded: Boolean read GetIsLoaded; public constructor Create(Owner: TComponent); override; @@ -73,7 +77,7 @@ TBoldListenerHandle = class(TBoldHandle) property ExtendLeaseAfter: integer read fExtendLeaseAfter write SetExtendLeaseAfter; property PollingInterval: integer read fPollingInterval write setPollingInterval; property AutoExtendLease: Boolean read fAutoExtendLease write setAutoExtendLease; - property Dequeuer: TBoldAbstractDequeuer read fDequeuer write SetDequeuer; + property Dequeuer: TBoldStringDequeuer read fDequeuer write SetDequeuer; property ClientIdentifierString: string read fClientIdentifierString write setClientIdentifierString; property PropagatorHandle: TBoldAbstractPropagatorHandle read fPropagatorHandle write SetPropagatorHandle; property OnRegistrationFailed: TNotifyEvent read FOnRegistrationFailed write FOnRegistrationFailed; @@ -89,7 +93,6 @@ implementation BoldEnvironment, Windows, Messages, - BoldPMConsts, BoldThreadSafeQueue; { TBoldListenerHandle } @@ -98,7 +101,7 @@ constructor TBoldListenerHandle.Create(Owner: TComponent); begin inherited; FClientIdentifierString := ''; - fPTSubscriber := TBoldPassthroughSubscriber.Create(_Receive); + fPTSubscriber := TBoldPassthroughSubscriber.Create(_Receive); fPropagatorHandleSubscriber := TBoldPassThroughSubscriber.Create(_ReceivePropagatorHandleEvents); fAutoStart := True; fLeaseDuration := DEFAULT_LEASE_DURATION; @@ -128,7 +131,7 @@ procedure TBoldListenerHandle._Receive(Originator: TObject; destructor TBoldListenerHandle.Destroy; begin StopAndFreeListenerThread; - FreeAndNil(fPTSubscriber); + FreeAndNil(fPTSubscriber); FreeAndNil(fPropagatorHandleSubscriber); inherited; end; @@ -143,13 +146,13 @@ function TBoldListenerHandle.GetConnected: Boolean; Result := ListenerThread.Registered; end; -procedure TBoldListenerHandle.SetDequeuer(aDequeuer: TBoldAbstractDequeuer); +procedure TBoldListenerHandle.SetDequeuer(aDequeuer: TBoldStringDequeuer); begin if aDequeuer <> fDequeuer then begin fDequeuer := aDequeuer; if Assigned(fDequeuer) then - fDequeuer.Queue := ListenerThread.Queue; + fDequeuer.Queue := ListenerThread.InQueue; end; end; @@ -182,13 +185,13 @@ procedure TBoldListenerHandle.StopAndFreeListenerThread; procedure TBoldListenerHandle.StartListenerThread; begin if not Assigned(fPropagatorHandle) then - raise EBold.CreateFmt(sPropagatorHandleNotAssigned, [ClassName]); + raise EBold.CreateFmt('%s.StartListenerThread: PropagatorHandle not assigned', [ClassName]); if not ListenerThread.Registered then begin ListenerThread.Resume; ListenerThread.WaitUntilInitialized; if not (fPropagatorHandle.Connected) then - raise EBold.CreateFmt(sPropagatorHandleNotConnected, [ClassName]); + raise EBold.CreateFmt('%s.StartListenerThread: PropagatorHandle not connected', [ClassName]); ListenerThread.Propagator := fPropagatorHandle.ClientHandler; ListenerThread.OnPropagatorFailure := fPropagatorHandle.DoPropagatorCallFailed; ListenerThread.OnThreadError := OnThreadError; @@ -291,7 +294,7 @@ procedure TBoldListenerHandle.SetPropagatorHandle(Value: TBoldAbstractPropagator if Value <> fPropagatorHandle then begin if fActive then - raise EBold.CreateFmt(sCannotChangeHandleWhenActive, [ClassName]); + raise EBold.Create('TBoldListenerHandle.SetPropagatorHandle: Can''t change handle on active listener'); fPropagatorHandleSubscriber.CancelAllSubscriptions; Subscribe(False); fPropagatorHandle := Value; @@ -323,7 +326,7 @@ function TBoldListenerHandle.GetIsLoaded: Boolean; procedure TBoldListenerHandle.SetExtendLeaseAfter(const Value: integer); begin if (value < 10) or (value > 90) then - raise EBold.CreateFmt(sValueOutOfRange, [ClassName]); + raise EBold.CreateFmt('%s.SetExtendLeaseAfter: Value must be between 10 and 90', [ClassName]); fExtendLeaseAfter := Value; ListenerThread.ExtendLeaseAfter := Value; end; @@ -358,4 +361,5 @@ procedure TBoldListenerHandle.Subscribe(const DoSubscribe: Boolean); fPTSubscriber.CancelAllSubscriptions; end; + end. diff --git a/Source/Persistence/Propagation/BoldListenerThread.pas b/Source/Persistence/Propagation/BoldListenerThread.pas index 64eb03ed..2c0f3d76 100644 --- a/Source/Persistence/Propagation/BoldListenerThread.pas +++ b/Source/Persistence/Propagation/BoldListenerThread.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldListenerThread; interface @@ -9,7 +12,8 @@ interface Messages, BoldThreadSafeQueue, BoldPropagatorInterfaces_TLB, - BoldDefs; + BoldDefs + ; type {forward declarations} @@ -62,7 +66,6 @@ TBoldListenerThread = class(TThread) protected procedure WaitUntilInterfaceUnmarshaled; procedure UnMarshalInterface; - procedure RaiseSysErrorMessage(const CausedIn: string); public constructor Create(CreateSuspended: Boolean); destructor Destroy; override; @@ -80,7 +83,7 @@ TBoldListenerThread = class(TThread) property BoldClientID: TBoldClientID read getBoldClientID; property Registered: Boolean read GetRegistered; property Initialized: Boolean read GetInitialized; - property Queue: TBoldThreadSafeStringQueue read GetQueue; + property InQueue: TBoldThreadSafeStringQueue read GetQueue; property LeaseDuration: integer read fLeaseDuration write setLeaseDuration; property ExtendLeaseAfter: integer read fExtendLeaseAfter write SetExtendLeaseAfter; property PollingInterval: integer read fPollingInterval write setPollingInterval; @@ -97,13 +100,9 @@ implementation uses SysUtils, - BoldPMConsts, BoldPropagatorConstants, ActiveX; -const - GenericSysErrorMessage = '%s.%s: %s'; - constructor TBoldListenerThread.Create(CreateSuspended: Boolean); begin inherited Create(true); @@ -150,12 +149,11 @@ procedure TBoldListenerThread.Execute; while not Terminated do begin res := Integer(GetMessage(rMsg, 0, 0, 0)); - // if not terminating thread if ((res <> -1) and (res <> 0)) then if not Assigned(fBoldListenerCOM) then begin try - fBoldListenerCOM := TBoldListenerCOM.Create(Queue, PollingInterval, + fBoldListenerCOM := TBoldListenerCOM.Create(InQueue, PollingInterval, LeaseDuration, ExtendLeaseAfter, AutoExtendLease, ClientIdentifierString); @@ -164,28 +162,28 @@ procedure TBoldListenerThread.Execute; FBoldListenerCOM.OnExtendLeaseFailed := DoExtendLeaseFailedSynchronized; except on E: Exception do begin - fErrorMessage := Format(sInitializationLineMissing, [E.Message]); + fErrorMessage := Format('%s. You must add the following line to the initialization section of the application: TBoldListenerCOMFactory.Create(ComServer)', [E.Message]); DoThreadErrorSynchronized(fErrorMessage); - end; + end; end; end; try - if res = -1 then // error occured + if res = -1 then Terminate - else if res = 0 then // terminate signaled + else if res = 0 then Terminate else case rMsg.message of - BM_THRD_UNREGISTER: // unregister with propagator + BM_THRD_UNREGISTER: UnRegisterWithPropagator; - BM_THRD_REGISTER: // unregister with propagator + BM_THRD_REGISTER: RegisterWithPropagator; - BM_UNMARSHAL_INTERFACE: //unmarshal interface + BM_UNMARSHAL_INTERFACE: UnMarshalInterface; - BM_EXTEND_LEASE: //extend lease + BM_EXTEND_LEASE: InternalExtendLease; else DispatchMessage(rMsg); - end; //case + end; except on e: Exception do begin @@ -193,7 +191,7 @@ procedure TBoldListenerThread.Execute; raise; end; end; - end;//while + end; finally if Assigned(fBoldListenerCOM) then InterfaceForRefCounting := nil; @@ -208,7 +206,7 @@ function TBoldListenerThread.ExtendLease: Boolean; if Result then try if PostThreadMessage(ThreadID, BM_EXTEND_LEASE, 0, 0) = false then - RaiseSysErrorMessage('ExtendLease'); // do not localize + Raise EBold.CreateFmt('%s.ExtendLease: %s', [ClassName, SysErrorMessage(GetLastError)]); WaitForSingleObject(fDoneExtendLease, 3 * TIMEOUT); Result := (WaitForSingleObject(fExtendLeaseSucceeded, 0) = WAIT_OBJECT_0); finally @@ -220,7 +218,7 @@ function TBoldListenerThread.ExtendLease: Boolean; function TBoldListenerThread.GetQueue: TBoldThreadSafeStringQueue; begin if not Assigned(fQueue) then - fQueue := TBoldThreadSafeStringQueue.Create('Listener InQueue'); // do not localize + fQueue := TBoldThreadSafeStringQueue.Create('Listener InQueue'); Result := fQueue; end; @@ -275,7 +273,7 @@ procedure TBoldListenerThread.Quit(Wait: Boolean); end; UnRegister; if PostThreadMessage(ThreadID, WM_QUIT, 0, 0) = false then - RaiseSysErrorMessage('Quit'); // do not localize + Raise EBold.CreateFmt('%s.TerminateThread: %s', [ClassName, SysErrorMessage(GetLastError)]); if wait then begin @@ -291,7 +289,7 @@ procedure TBoldListenerThread.UnRegister; if Initialized and Registered and not (Suspended)then begin if PostThreadMessage(self.ThreadID, BM_THRD_UNREGISTER, 0, 0) = false then - RaiseSysErrorMessage('UnRegister'); // do not localize + raise EBold.CreateFmt('%s.TerminateThread: %s', [ClassName, SysErrorMessage(GetLastError)]); WaitUntilUnregistered; end; end; @@ -324,7 +322,7 @@ procedure TBoldListenerThread.EnsureMessageQueue; var rMsg: TMsg; begin - PeekMessage (rMsg, 0, 0, 0, PM_NOREMOVE); // force thread message queue! + PeekMessage (rMsg, 0, 0, 0, PM_NOREMOVE); end; function TBoldListenerThread.getBoldClientID: TBoldClientID; @@ -362,7 +360,7 @@ procedure TBoldListenerThread.SetPropagator(const Value: IBoldClientHandler); begin CoMarshalInterThreadInterfaceInStream(IID_IBoldClientHandler,Value,IStream(FInterfaceStream)); if PostThreadMessage(ThreadID, BM_UNMARSHAL_INTERFACE, 0, 0) = False then - RaiseSysErrorMessage('SetPropagator'); // do not localize + raise EBold.CreateFmt('%s.SetPropagator: %s', [ClassName, SysErrorMessage(GetLastError)]); WaitUntilInterfaceUnmarshaled; end else if Assigned(fBoldListenerCOM) then @@ -469,9 +467,4 @@ procedure TBoldListenerThread.SetExtendLeaseAfter(const Value: integer); fBoldListenerCOM.ExtendLeaseAfter := fExtendLeaseAfter; end; -procedure TBoldListenerThread.RaiseSysErrorMessage(const CausedIn: string); -begin - raise EBold.CreateFmt(GenericSysErrorMessage, [ClassName, CausedIn, SysErrorMessage(GetLastError)]); -end; - end. diff --git a/Source/Persistence/Propagation/BoldPersistenceControllerPassthrough.pas b/Source/Persistence/Propagation/BoldPersistenceControllerPassthrough.pas index c45a66a5..916b2d6a 100644 --- a/Source/Persistence/Propagation/BoldPersistenceControllerPassthrough.pas +++ b/Source/Persistence/Propagation/BoldPersistenceControllerPassthrough.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceControllerPassthrough; interface @@ -9,7 +12,9 @@ interface BoldSubscription, BoldValueSpaceInterfaces, BoldUpdatePrecondition, - BoldDefs; + BoldDefs, + BoldElements, + BoldDbInterfaces; type {forward declarations} @@ -19,13 +24,13 @@ TBoldPersistenceControllerPassthrough = class; TBoldPersistenceControllerPassthrough = class(TBoldPersistenceController) private fNextPersistenceController: TBoldPersistenceController; - function getNextPersistenceController: TBoldPersistenceController; + function GetNextPersistenceController: TBoldPersistenceController; {$IFDEF BOLD_INLINE}inline;{$ENDIF} public constructor Create; - procedure PMExactifyIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; + procedure PMExactifyIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; HandleNonExisting: Boolean); override; procedure PMFetch(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; BoldClientID: TBoldClientID); override; procedure PMFetchIDListWithCondition(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; FetchMode: Integer; Condition: TBoldCondition; BoldClientID: TBoldClientID); override; - procedure PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; BoldClientID: TBoldClientID); override; + procedure PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; var TimeOfLatestUpdate: TDateTime; BoldClientID: TBoldClientID); override; procedure PMTranslateToGlobalIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; procedure PMTranslateToLocalIds(GlobalIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; procedure PMSetReadOnlyness(ReadOnlyList, WriteableList: TBoldObjectIdList); override; @@ -34,6 +39,11 @@ TBoldPersistenceControllerPassthrough = class(TBoldPersistenceController) TranslationList: TBoldIdTranslationList); override; procedure PMTimestampForTime(ClockTime: TDateTime; var Timestamp: TBoldTimestampType); override; procedure PMTimeForTimestamp(Timestamp: TBoldTimestampType; var ClockTime: TDateTime); override; + function CanEvaluateInPS(sOCL: string; aSystem: TBoldElement; aContext: TBoldElementTypeInfo = nil; const aVariableList: TBoldExternalVariableList = nil): Boolean; override; + procedure StartTransaction; override; + procedure CommitTransaction; override; + procedure RollbackTransaction; override; + function DatabaseInterface: IBoldDatabase; override; property NextPersistenceController: TBoldPersistenceController read getNextPersistenceController write fNextPersistenceController; end; @@ -42,28 +52,58 @@ implementation uses SysUtils, - BoldPMConsts; + BoldRev; { TBoldPersistenceControllerPassthrough } +function TBoldPersistenceControllerPassthrough.CanEvaluateInPS(sOCL: string; + aSystem: TBoldElement; aContext: TBoldElementTypeInfo; + const aVariableList: TBoldExternalVariableList): Boolean; +begin + Result := NextPersistenceController.CanEvaluateInPS(sOCL, aSystem, aContext, aVariableList); +end; + +procedure TBoldPersistenceControllerPassthrough.StartTransaction; +begin + NextPersistenceController.StartTransaction; +end; + +procedure TBoldPersistenceControllerPassthrough.CommitTransaction; +begin + NextPersistenceController.CommitTransaction; +end; + +procedure TBoldPersistenceControllerPassthrough.RollbackTransaction; +begin + NextPersistenceController.RollbackTransaction; +end; + constructor TBoldPersistenceControllerPassthrough.Create; begin inherited; end; +function TBoldPersistenceControllerPassthrough.DatabaseInterface: IBoldDatabase; +begin + if Assigned(fNextPersistenceController) then + Result := fNextPersistenceController.DatabaseInterface + else + result := nil; +end; + function TBoldPersistenceControllerPassthrough.getNextPersistenceController: TBoldPersistenceController; begin if Assigned(fNextPersistenceController) then Result := fNextPersistenceController else - raise EBold.CreateFmt(sNextControllerMissing, [ClassName]); + raise EBold.CreateFmt('%s.getNextPersistenceController: NextPersistenceController not assigned', [ClassName]); end; procedure TBoldPersistenceControllerPassthrough.PMExactifyIds( ObjectIdList: TBoldObjectIdList; - TranslationList: TBoldIdTranslationList); + TranslationList: TBoldIdTranslationList; HandleNonExisting: Boolean); begin - NextPersistenceController.PMExactifyIds(ObjectIdList, TranslationList); + NextPersistenceController.PMExactifyIds(ObjectIdList, TranslationList, HandleNonExisting); end; procedure TBoldPersistenceControllerPassthrough.PMFetch( @@ -107,11 +147,11 @@ procedure TBoldPersistenceControllerPassthrough.PMUpdate( Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; - var TimeStamp: TBoldTimeStampType; BoldClientID: TBoldClientID); + var TimeStamp: TBoldTimeStampType; var TimeOfLatestUpdate: TDateTime; BoldClientID: TBoldClientID); begin NextPersistenceController.PMUpdate(ObjectIdList, ValueSpace, Old_Values, Precondition, - TranslationList, TimeStamp, BoldClientID); + TranslationList, TimeStamp, TimeOfLatestUpdate, BoldClientID); end; procedure TBoldPersistenceControllerPassthrough.SubscribeToPeristenceEvents( @@ -138,4 +178,6 @@ procedure TBoldPersistenceControllerPassthrough.PMTimestampForTime( NextPersistenceController.PMTimestampForTime(ClockTime, Timestamp); end; +initialization + end. diff --git a/Source/Persistence/Propagation/BoldPropagatorUtils.pas b/Source/Persistence/Propagation/BoldPropagatorUtils.pas index a833c3c2..0bf6f820 100644 --- a/Source/Persistence/Propagation/BoldPropagatorUtils.pas +++ b/Source/Persistence/Propagation/BoldPropagatorUtils.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPropagatorUtils; interface @@ -35,9 +38,7 @@ procedure GetActiveObjectSubscriptions(Obj: TBoldObject; Subscriptions: TStringL if Obj.BoldPersistent then begin Id := Obj.BoldObjectLocator.BoldObjectId; - // Add a subscription for the embedded state changes Subscriptions.Add(TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsEmbeddedStateOfObjectChanged, '', '', '', Id)); - // and one subscription for each nonembedded member that is current/modified in memory for i := 0 to obj.BoldMemberCount - 1 do begin MemberRTInfo := obj.BoldClassTypeInfo.AllMembers[i]; @@ -65,14 +66,11 @@ procedure GetActiveSubscriptions(System: TBoldSystem; Subscriptions: TStringList begin Guard := TBoldGuard.Create(Traverser); Traverser := system.Locators.CreateTraverser; - // add subscriptions for all objects in memory - while not Traverser.EndOfList do + while Traverser.MoveNext do begin if assigned(Traverser.locator.BoldObject) then GetActiveObjectSubscriptions(Traverser.locator.BoldObject, Subscriptions); - Traverser.Next; end; - // Add subscriptions to classes (Why is the classlist transient?) TopSortedClasses := system.BoldSystemTypeInfo.TopSortedClasses; for i := 0 to TopSortedClasses.Count-1 do if system.Classes[i].BoldPersistenceState in [bvpsTransient, bvpsCurrent, bvpsmodified] then @@ -101,7 +99,6 @@ function ReConnectToPropagator( begin result := false; Guard := TBoldGuard.Create(Subscriptions); - // disconnect and reconnect the COM-interface ComConnectionHandle.Connected := false; ComConnectionHandle.Connected := true; if ComConnectionHandle.Connected then @@ -118,4 +115,5 @@ function ReConnectToPropagator( end; end; + end. diff --git a/Source/Persistence/Propagation/BoldSnooper.pas b/Source/Persistence/Propagation/BoldSnooper.pas index 4904b6f6..ce3a6e79 100644 --- a/Source/Persistence/Propagation/BoldSnooper.pas +++ b/Source/Persistence/Propagation/BoldSnooper.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSnooper; interface @@ -13,8 +16,6 @@ interface {forward declarations} TBoldSnooper = class; -// TBoldSnooperEventType = (bsetEvent, bsetSubscription); -// TBoldSnooperEventTypeSet = set of TBoldSnooperEventType; { TBoldSnooper } TBoldSnooper = class(TBoldAbstractSnooper) @@ -44,8 +45,7 @@ implementation BoldLockingDefs, BoldUtils, BoldSnooperHandle, - ComObj, - PersistenceConsts; + ComObj; function DatabaseLock_AsOLEVariant: OleVariant; begin @@ -61,15 +61,15 @@ procedure TBoldSnooper.TransmitEvents(const ClientID: TBoldClientID); if res <> S_OK then begin if Res = E_ENQUEUER_NOT_ENABLED then - s := sEnqueuerNotEnabled + s := 'Call to %s failed. Propagator Enqueuer not enabled' else if res = E_CLIENT_NOT_REGISTERED then - s := sClientNotRegistered + s := 'Call to %s failed. Client not registered with propagator' else if res = E_INVALID_PARAMETER then - s := sInvalidParameter + s := 'Call to %s failed. Invalid parameter' else if res = W_CLIENT_NOT_RECEIVING then - s := sClientNotReceivingEvents + s := 'Call to %s OK, but client is currently not receiving events' else - s := Format(sCallFailed, [SysErrorMessage(Res)]); + s := 'Call to %s failed. Error: ' + SysErrorMessage(Res); DoPropagatorFailure(self, format(s, [Action])); end; end; @@ -79,11 +79,11 @@ procedure TBoldSnooper.TransmitEvents(const ClientID: TBoldClientID); begin try if (Events.Count <> 0) then - CheckError(Propagator.SendEvents(ClientID, StringListToVarArray(Events)), 'SendEvents'); // do not localize + CheckError(Propagator.SendEvents(ClientID, StringListToVarArray(Events)), 'SendEvents'); if (Subscriptions.Count <> 0) then - CheckError(Propagator.AddSubscriptions(ClientID, StringListToVarArray(Subscriptions)), 'AddSubscriptions'); // do not localize + CheckError(Propagator.AddSubscriptions(ClientID, StringListToVarArray(Subscriptions)), 'AddSubscriptions'); if (CancelledSubscriptions.Count <> 0) then - CheckError(Propagator.CancelSubscriptions(ClientID, StringListToVarArray(CancelledSubscriptions)), 'CancelSubscriptions'); // do not localize + CheckError(Propagator.CancelSubscriptions(ClientID, StringListToVarArray(CancelledSubscriptions)), 'CancelSubscriptions'); except on E: EOleSysError do DoPropagatorFailure(self, E.Message); end; @@ -102,7 +102,7 @@ procedure TBoldSnooper.EnsureDataBaseLock(const ClientId: TBoldClientID); Exit; res := LockManager.EnsureLocks(ClientID, DatabaseLock_AsOLEVariant, null); if not res then - raise EBoldEnsureDatabaseLockError.CreateFmt(sCannotAcquireLock, [ClassName, 'EnsureDatabaseLock']); // do not localize + raise EBoldEnsureDatabaseLockError.CreateFmt('%s.EnsureDatabaseLock Cannot acquire Database Lock', [ClassName]); end; procedure TBoldSnooper.ReleaseDataBaseLock(const ClientID: TBoldClientID); @@ -115,8 +115,8 @@ procedure TBoldSnooper.ReleaseDataBaseLock(const ClientID: TBoldClientID); try LockManager.ReleaseLocks(ClientID, DatabaseLock_AsOLEVariant) except - raise EBoldLockManagerError.CreateFmt(sCannotAcquireLock, [ClassName, 'ReleaseDataBaseLock']); // do not localize - end; + raise EBoldLockManagerError.CreateFmt('%s.ReleaseDatabaseLock Cannot acquire Database Lock', [ClassName]); + end; end; constructor TBoldSnooper.Create(MoldModel: TMoldModel; aOwner: TObject); @@ -131,7 +131,7 @@ function TBoldSnooper.GetLockManager: IBoldLockManager; if Assigned((fOwner as TBoldSnooperHandle).LockManagerHandle) then Result := (fOwner as TBoldSnooperHandle).LockManagerHandle.LockManager else - raise EBoldLockManagerError.CreateFmt(sLockManagerNotAssigned, [ClassName]); + raise EBoldLockManagerError.CreateFmt('%s.GetLockManager: LockManager not assigned', [ClassName]); end; function TBoldSnooper.GetPropagator: IBoldEventPropagator; @@ -146,6 +146,6 @@ function TBoldSnooper.GetCheckDatabaseLock: Boolean; Result := (fOwner as TBoldSnooperHandle).CheckDatabaseLock; end; -end. - +initialization +end. diff --git a/Source/Persistence/Propagation/BoldSnooperHandle.pas b/Source/Persistence/Propagation/BoldSnooperHandle.pas index e2e01050..9ad9511a 100644 --- a/Source/Persistence/Propagation/BoldSnooperHandle.pas +++ b/Source/Persistence/Propagation/BoldSnooperHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSnooperHandle; interface @@ -14,12 +17,17 @@ interface type {forward declarations} TBoldSnooperHandle = class; + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldSnooperHandle = class(TBoldPersistenceHandlePassthroughWithModel) private fPTSubscriber: TBoldPassThroughSubscriber; fLockManagerHandle: TBoldAbstractLockManagerHandle; FCheckDatabaseLock: Boolean; fPropagatorHandle: TBoldAbstractPropagatorHandle; + fClassesToIgnore: string; + fUseSubscriptions: boolean; + fUseClassEvents: boolean; + fUseMemberLevelOSS: boolean; procedure SetLockManagerHandle(Value: TBoldAbstractLockManagerHandle); procedure _Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); procedure SetPropagatorHandle(Value: TBoldAbstractPropagatorHandle); @@ -44,6 +52,10 @@ TBoldSnooperHandle = class(TBoldPersistenceHandlePassthroughWithModel) property LockManagerHandle: TBoldAbstractLockManagerHandle read fLockManagerHandle write SetLockManagerHandle; property CheckDatabaseLock: Boolean read fCheckDatabaseLock write fCheckDatabaseLock; property PropagatorHandle: TBoldAbstractPropagatorHandle read fPropagatorHandle write SetPropagatorHandle; + property UseClassEvents: boolean read fUseClassEvents write fUseClassEvents; + property UseMemberLevelOSS: boolean read fUseMemberLevelOSS write fUseMemberLevelOSS; + property UseSubscriptions: boolean read fUseSubscriptions write fUseSubscriptions; + property ClassesToIgnore: string read fClassesToIgnore write fClassesToIgnore; end; implementation @@ -53,20 +65,20 @@ implementation BoldDefs, BoldPersistenceHandlePassThrough, dialogs, - PersistenceConsts; + BoldRev; function TBoldSnooperHandle.CreatePersistenceController: TBoldPersistenceController; var Snooper: TBoldSnooper; begin if not Assigned(BoldModel) then - raise EBold.CreateFmt(sBoldModelNotAssigned, [ClassName]); + raise EBold.CreateFmt('%s.CreatePersistenceController: cannot find a BoldModel', [ClassName]); Snooper := TBoldSnooper.Create(BoldModel.MoldModel, self); ChainPersistenceController(Snooper); if Assigned(PropagatorHandle) then Snooper.OnPropagatorFailure := PropagatorHandle.DoPropagatorCallFailed else - raise EBold.CreateFmt(sPropagatorHandleNotAssigned, [ClassName]); + raise EBold.CreateFmt('%s.PropagatorHandle not assigned', [ClassName]); result := Snooper; end; @@ -116,6 +128,13 @@ procedure TBoldSnooperHandle.SetPropagatorHandle( Snooper.OnPropagatorFailure := fPropagatorHandle.DoPropagatorCallFailed else if not (csDestroying in ComponentState) then Snooper.OnPropagatorFailure := nil; + if Assigned(Value) then + begin + Snooper.UseClassEvents := UseClassEvents; + Snooper.UseMemberLevelOSS := UseMemberLevelOSS; + Snooper.UseSubscriptions := UseSubscriptions; + Snooper.ClassesToIgnore := ClassesToIgnore; + end; end; Subscribe(True); end; @@ -131,8 +150,7 @@ function TBoldSnooperHandle.GetConnected: Boolean; procedure TBoldSnooperHandle.DefineProperties(Filer: TFiler); begin inherited; - // property MachineName moved to TBoldPropagatorHandleCOM - Filer.DefineProperty('MachineName', ReadObsoleteMachineNameProperty, nil, True); // do not localize + Filer.DefineProperty('MachineName', ReadObsoleteMachineNameProperty, nil, True); end; procedure TBoldSnooperHandle.ReadObsoleteMachineNameProperty( @@ -141,14 +159,14 @@ procedure TBoldSnooperHandle.ReadObsoleteMachineNameProperty( OldPropertyValue: string; begin OldPropertyValue := Reader.ReadString; - ReadObsoleteProperty(Reader, 'MachineName', 'ServerHost', OldPropertyValue, 'TBoldPropagatorHandleCom'); // do not localize + ReadObsoleteProperty(Reader, 'MachineName', 'ServerHost', OldPropertyValue, 'TBoldPropagatorHandleCom'); end; procedure TBoldSnooperHandle.ReadObsoleteProperty(Reader: TReader; const PropertyName, NewPropertyName, OldPropertyValue, ComponentName: string); begin if (csDesigning in ComponentState) then - MessageDlg(Format(sPropertyMoved, + MessageDlg(Format('%s.%s has been moved to component (%s.%s). Old value was "%s"', [ClassName, PropertyName, ComponentName, NewPropertyName, OldPropertyValue]), mtWarning, [mbOK], 0); end; diff --git a/Source/Persistence/SOAP/BoldPersistenceControllerSOAPAdapterCore.pas b/Source/Persistence/SOAP/BoldPersistenceControllerSOAPAdapterCore.pas index 81a626ed..df45497b 100644 --- a/Source/Persistence/SOAP/BoldPersistenceControllerSOAPAdapterCore.pas +++ b/Source/Persistence/SOAP/BoldPersistenceControllerSOAPAdapterCore.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceControllerSOAPAdapterCore; interface @@ -6,10 +9,11 @@ interface BoldPersistenceController, BoldMeta, BoldDefaultXMLStreaming, - BoldPersistenceOperationXMLStreaming; + BoldPersistenceOperationXMLStreaming + ; type - { TBoldPersistenceControllerSOAPAdapterCore } + TBoldPersistenceControllerSOAPAdapterCore = class private fStreamManager: TBoldDefaultXMLStreamManager; @@ -23,11 +27,11 @@ implementation uses SysUtils, - MSXML_TLB, + {$IFDEF OXML}OXmlPDOM{$ELSE}Bold_MSXML_TLB{$ENDIF}, BoldDefs, BoldXMLStreaming, - BoldComConst; - + BoldRev + ; { TBoldPersistenceControllerSOAPAdapterCore } constructor TBoldPersistenceControllerSOAPAdapterCore.Create(Model: TMoldModel); @@ -47,48 +51,59 @@ destructor TBoldPersistenceControllerSOAPAdapterCore.Destroy; procedure TBoldPersistenceControllerSOAPAdapterCore.Get(const request: WideString; out reply: WideString; PersistenceController: TBoldPersistenceController); var - RequestDoc, ReplyDoc: TDOMDocument; + RequestDoc, ReplyDoc: {$IFDEF OXML}TXMLDocument{$ELSE}TDOMDocument{$ENDIF}; RequestBodyNode, ReplyBodyNode: TBoldXMLNode; - anXMLNode: IXMLDOMNode; + anXMLNode: {$IFDEF OXML}PXMLNode{$ELSE}IXMLDOMNode{$ENDIF}; OpNode: TBoldXMLNode; OpName: string; PMOperation: TBoldPersistenceOperation; begin + {$IFDEF OXML} + RequestDoc := TXMLDocument.Create; + ReplyDoc := TXMLDocument.Create; + {$ELSE} RequestDoc := TDOMDocument.Create(nil); ReplyDoc := TDOMDocument.Create(nil); + {$ENDIF} RequestBodyNode := nil; ReplyBodyNode := nil; OpNode := nil; PMOperation := nil; try + {$IFDEF OXML} + RequestDoc.LoadFromXML(request); + RequestBodyNode := fStreamManager.GetSOAP(RequestDoc); + anXMLNode := RequestBodyNode.XMLDomElement.ChildNodes.GetFirst; + OpNode := TBoldXMLNode.Create(fStreamManager, anXMLNode, nil); + {$ELSE} RequestDoc.loadXML(request); RequestBodyNode := fStreamManager.GetSOAP(RequestDoc); anXMLNode := RequestBodyNode.XMLDomElement.childNodes.nextNode; OpNode := TBoldXMLNode.Create(fStreamManager, anXMLNode as IXMLDOMElement, nil); + {$ENDIF} OpName := OpNode.Accessor; - anXMLNode := nil; ReplyBodyNode := fStreamManager.NewSOAP(ReplyDoc); - if OpName = 'PMFetch' then // do not localize + if OpName = 'PMFetch' then PMOperation := TBoldPMFetchOperation.Create(fStreamManager) - else if OpName = 'PMFetchIDListWithCondition' then // do not localize + else if OpName = 'PMFetchIDListWithCondition' then PMOperation := TBoldPMFetchIdListOperation.Create(fStreamManager) - else if OpName = 'PMExactifyIds' then // do not localize + else if OpName = 'PMExactifyIds' then PMOperation := TBoldPMExactifyIdsOperation.Create(fStreamManager) - else if OpName = 'PMUpdate' then // do not localize + else if OpName = 'PMUpdate' then PMOperation := TBoldPMUpdateOperation.Create(fStreamManager) - else if OpName = 'ReserveNewIds' then // do not localize + else if OpName = 'ReserveNewIds' then PMOperation := TBoldPMReserveNewIdsOperation.Create(fStreamManager) - else if OpName = 'PMTimeForTimestamp' then // do not localize + else if OpName = 'PMTimeForTimestamp' then PMOperation := TBoldPMTimeForTimestampOperation.Create(fStreamManager) - else if OpName = 'PMTimestampForTime' then // do not localize + else if OpName = 'PMTimestampForTime' then PMOperation := TBoldPMTimestampForTimeOperation.Create(fStreamManager) else - raise EBold.CreateFmt(sUnknownOperation, [classname, OpName]); + raise EBold.CreateFmt('%s.Get: Unrecognized operation %s', [classname, OpName]); PMOperation.ExecuteStreamed(PersistenceController, RequestBodyNode, ReplyBodyNode); - reply := ReplyDoc.DefaultInterface.xml; + reply := {$IFDEF OXML}ReplyDoc.XML{$ELSE}ReplyDoc.DefaultInterface.xml{$ENDIF}; finally RequestBodyNode.Free; ReplyBodyNode.Free; @@ -99,4 +114,6 @@ procedure TBoldPersistenceControllerSOAPAdapterCore.Get(const request: WideStrin end; end; +initialization + end. diff --git a/Source/Persistence/SOAP/BoldPersistenceOperationXMLStreaming.pas b/Source/Persistence/SOAP/BoldPersistenceOperationXMLStreaming.pas index 53b00034..487429fa 100644 --- a/Source/Persistence/SOAP/BoldPersistenceOperationXMLStreaming.pas +++ b/Source/Persistence/SOAP/BoldPersistenceOperationXMLStreaming.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceOperationXMLStreaming; interface @@ -88,6 +91,7 @@ TBoldPMExactifyIdsOperation = class(TBoldPersistenceOperation) private fObjectIdList: TBoldObjectIdList; fTranslationList: TBoldIdTranslationList; + fHandleNonExisting: Boolean; protected function GetName: string; override; public @@ -101,6 +105,7 @@ TBoldPMExactifyIdsOperation = class(TBoldPersistenceOperation) property ObjectIdList: TBoldObjectIdList read fObjectIdList write fObjectIdList; property TranslationList: TBoldIdTranslationList read fTranslationList write fTranslationList; + property HandleNonExisting: Boolean read fHandleNonExisting write fHandleNonExisting; end; TBoldPMUpdateOperation = class(TBoldPersistenceOperation) @@ -113,6 +118,7 @@ TBoldPMUpdateOperation = class(TBoldPersistenceOperation) fFreestanding_old: TBoldFreeStandingValueSpace; fTranslationList: TBoldIdTranslationList; fTimestamp: TBoldTimestampType; + fTimeOfTimeStamp: TDateTIme; fBoldClientID: TBoldClientID; protected function GetName: string; override; @@ -191,11 +197,9 @@ TBoldPMTimeForTimestampOperation = class(TBoldPersistenceOperation) implementation uses - MSXML_TLB, + {$IFDEF OXML}OXmlPDOM{$ELSE}Bold_MSXML_TLB{$ENDIF}, SysUtils, -// BoldUtils, - BoldDefaultStreamNames, - BoldComConst; + BoldDefaultStreamNames; const BoldNodeName_ObjectIdList = 'ObjectIdList'; @@ -209,6 +213,7 @@ implementation BoldNodeName_Old_Values = 'Old_Values'; BoldNodeName_Timestamp = 'Timestamp'; BoldNodeName_ClockTime = 'ClockTime'; + BoldNodeName_HandleNonExisting = 'HandleNonExisting'; { TBoldPMFetchOperation } @@ -228,7 +233,7 @@ procedure TBoldPMFetchOperation.FreeParams; function TBoldPMFetchOperation.GetName: string; begin - result := 'PMFetch'; // do not localize + result := 'PMFetch'; end; procedure TBoldPMFetchOperation.InitParams; @@ -294,13 +299,13 @@ procedure TBoldPersistenceOperation.ExecuteStreamed( try Execute(PersistenceController); - OpNode := ReplyBodyNode.NewSubNode(Name + 'Response'); // do not localize + OpNode := ReplyBodyNode.NewSubNode(Name + 'Response'); WriteOutParams(OpNode); except on E: Exception do begin - OpNode := ReplyBodyNode.NewSubNode('SOAP-ENV:Fault'); // do not localize - OpNode := OpNode.NewSubNode('SOAP-ENV:faultstring'); // do not localize - OpNode.WriteString(E.Message); + OpNode := ReplyBodyNode.NewSubNode('SOAP-ENV:Fault'); + OpNode := OpNode.NewSubNode('SOAP-ENV:faultstring'); + OpNode.WriteString(E.Message); end; end; OpNode.Free; @@ -318,14 +323,19 @@ procedure TBoldPersistenceOperation.InitParams; procedure TBoldPersistenceOperation.RemoteExecute(Stub: IBoldSOAPService); var - RequestDoc: TDOMDocument; - ReplyDoc: TDOMDocument; + RequestDoc, + ReplyDoc: {$IFDEF OXML}TXMLDocument{$ELSE}TDOMDocument{$ENDIF}; BodyNode: TBoldXMLNode; OpNode: TBoldXMLNode; replyXML: WideString; begin + {$IFDEF OXML} + RequestDoc := TXMLDocument.Create; + ReplyDoc := TXMLDocument.Create; + {$ELSE} RequestDoc := TDOMDocument.Create(nil); ReplyDoc := TDOMDocument.Create(nil); + {$ENDIF} try BodyNode := StreamManager.NewSOAP(RequestDoc); OpNode := BodyNode.NewSubNode(Name); @@ -335,33 +345,37 @@ procedure TBoldPersistenceOperation.RemoteExecute(Stub: IBoldSOAPService); BodyNode.Free; OpNode.Free; end; - Stub.Get(RequestDoc.DefaultInterface.xml, replyXML); + Stub.Get({$IFDEF OXML}RequestDoc.XML{$ELSE} + RequestDoc.DefaultInterface.xml{$ENDIF}, replyXML); - if not ReplyDoc.loadXML(replyXML) then - raise EBoldXMLLoadError.CreateFmt('%s: %s', [Replydoc.parseError.reason, ReplyXML]) ; //Invalid XML data // do not localize + if not {$IFDEF OXML}ReplyDoc.LoadFromXML(replyXML){$ELSE} + ReplyDoc.loadXML(replyXML){$ENDIF} then + begin + raise EBoldXMLLoadError.CreateFmt('%s: %s', [Replydoc.parseError.Reason, ReplyXML]) ; + end; try BodyNode := StreamManager.GetSOAP(ReplyDoc); except - raise EBoldInvalidSOAP.CreateFmt(sInvalidSOAPData, [replyXML]); + raise EBoldInvalidSOAP.CreateFmt('Invalid SOAP data : %s', [replyXML]); end; - OpNode := BodyNode.GetSubNode(Name + 'Response'); // do not localize + OpNode := BodyNode.GetSubNode(Name + 'Response'); if not Assigned(OpNode) then begin - OpNode := BodyNode.GetSubNode('SOAP-ENV:Fault'); // do not localize + OpNode := BodyNode.GetSubNode('SOAP-ENV:Fault'); if not Assigned(OpNode) then - raise EBold.Create(sEmptySOAPData) + raise EBold.Create('Empty SOAP data.') else begin - OpNode := OpNode.GetSubNode('SOAP-ENV:faultstring'); // do not localize + OpNode := OpNode.GetSubNode('SOAP-ENV:faultstring'); if Assigned(OpNode) then - raise EBold.CreateFmt(sError, [OpNode.XMLDomElement.text]) + raise EBold.CreateFmt('Error: %s', [OpNode.XMLDomElement.text]) else - raise EBold.Create(sErrorNoMessage) ; + raise EBold.Create('Error: empty error message') ; end; end; - + try ReadOutParams(OpNode); finally @@ -397,7 +411,7 @@ procedure TBoldPMFetchIdListOperation.FreeParams; function TBoldPMFetchIdListOperation.GetName: string; begin - result := 'PMFetchIDListWithCondition'; // do not localize + result := 'PMFetchIDListWithCondition'; end; procedure TBoldPMFetchIdListOperation.InitParams; @@ -441,7 +455,7 @@ procedure TBoldPMFetchIdListOperation.WriteOutParams(XMLNode: TBoldXMLNode); procedure TBoldPMExactifyIdsOperation.Execute(PersistenceController: TBoldPersistenceController); begin - PersistenceController.PMExactifyIds(ObjectIdList, TranslationList); + PersistenceController.PMExactifyIds(ObjectIdList, TranslationList, HandleNonExisting); end; procedure TBoldPMExactifyIdsOperation.FreeParams; @@ -453,7 +467,7 @@ procedure TBoldPMExactifyIdsOperation.FreeParams; function TBoldPMExactifyIdsOperation.GetName: string; begin - result := 'PMExactifyIds'; // do not localize + result := 'PMExactifyIds'; end; procedure TBoldPMExactifyIdsOperation.InitParams; @@ -465,6 +479,7 @@ procedure TBoldPMExactifyIdsOperation.InitParams; procedure TBoldPMExactifyIdsOperation.ReadInParams(XMLNode: TBoldXMLNode); begin ObjectIdList := XMLNode.ReadSubNodeObject(BoldNodeName_ObjectIdList, BOLDOBJECTIDLISTNAME) as TBoldObjectIdList; + HandleNonExisting := XMLNode.ReadSubNodeBoolean(BoldNodeName_HandleNonExisting); end; procedure TBoldPMExactifyIdsOperation.ReadOutParams(XMLNode: TBoldXMLNode); @@ -472,7 +487,7 @@ procedure TBoldPMExactifyIdsOperation.ReadOutParams(XMLNode: TBoldXMLNode); aTranslationList: TBoldIDTranslationList; i: Integer; begin - aTranslationList := XMLNode.ReadSubNodeObject(BoldNodeName_TranslationList, BOLDIDTRANSLATIONLISTNAME) as TBoldIDTranslationList; //IMPORTANT: this returns an object(a list) which is up to the caller to free + aTranslationList := XMLNode.ReadSubNodeObject(BoldNodeName_TranslationList, BOLDIDTRANSLATIONLISTNAME) as TBoldIDTranslationList; try for i := 0 to aTranslationList.Count - 1 do TranslationList.AddTranslation(aTranslationList.OldIds[i], aTranslationList.NewIds[i]); @@ -484,6 +499,7 @@ procedure TBoldPMExactifyIdsOperation.ReadOutParams(XMLNode: TBoldXMLNode); procedure TBoldPMExactifyIdsOperation.WriteInParams(XMLNode: TBoldXMLNode); begin XMLNode.WriteSubNodeObject(BoldNodeName_ObjectIdList, BOLDOBJECTIDLISTNAME, ObjectIdList); + XMLNode.WriteSubNodeBoolean(BoldNodeName_HandleNonExisting, fHandleNonExisting); end; procedure TBoldPMExactifyIdsOperation.WriteOutParams(XMLNode: TBoldXMLNode); @@ -495,7 +511,7 @@ procedure TBoldPMExactifyIdsOperation.WriteOutParams(XMLNode: TBoldXMLNode); procedure TBoldPMUpdateOperation.Execute(PersistenceController: TBoldPersistenceController); begin - PersistenceController.PMUpdate(ObjectIdList, ValueSpace, Old_Values, Precondition, TranslationList, fTimestamp, BoldClientID); + PersistenceController.PMUpdate(ObjectIdList, ValueSpace, Old_Values, Precondition, TranslationList, fTimestamp, fTimeOfTimeStamp, BoldClientID); end; procedure TBoldPMUpdateOperation.FreeParams; @@ -516,7 +532,7 @@ procedure TBoldPMUpdateOperation.FreeTranslationList; function TBoldPMUpdateOperation.GetName: string; begin - result := 'PMUpdate'; // do not localize + result := 'PMUpdate'; end; procedure TBoldPMUpdateOperation.InitParams; @@ -612,7 +628,7 @@ procedure TBoldPMReserveNewIdsOperation.FreeParams; function TBoldPMReserveNewIdsOperation.GetName: string; begin - result := 'ReserveNewIds'; // do not localize + result := 'ReserveNewIds'; end; procedure TBoldPMReserveNewIdsOperation.InitParams; @@ -659,7 +675,7 @@ procedure TBoldPMTimestampForTimeOperation.Execute(PersistenceController: TBoldP function TBoldPMTimestampForTimeOperation.GetName: string; begin - result := 'PMTimestampForTime'; // do not localize + result := 'PMTimestampForTime'; end; procedure TBoldPMTimestampForTimeOperation.ReadInParams(XMLNode: TBoldXMLNode); @@ -691,7 +707,7 @@ procedure TBoldPMTimeForTimestampOperation.Execute(PersistenceController: TBoldP function TBoldPMTimeForTimestampOperation.GetName: string; begin - result := 'PMTimeForTimestamp'; // do not localize + result := 'PMTimeForTimestamp'; end; procedure TBoldPMTimeForTimestampOperation.ReadInParams(XMLNode: TBoldXMLNode); @@ -714,4 +730,6 @@ procedure TBoldPMTimeForTimestampOperation.WriteOutParams(XMLNode: TBoldXMLNode) XMLNode.WriteSubNodeString(BoldNodeName_ClockTime, DateTimeToStr(ClockTime)); end; +initialization + end. diff --git a/Source/Persistence/SOAP/BoldSOAPClientPersistenceHandles.pas b/Source/Persistence/SOAP/BoldSOAPClientPersistenceHandles.pas index feb5708f..9faf78d4 100644 --- a/Source/Persistence/SOAP/BoldSOAPClientPersistenceHandles.pas +++ b/Source/Persistence/SOAP/BoldSOAPClientPersistenceHandles.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSOAPClientPersistenceHandles; interface @@ -8,6 +11,7 @@ interface BoldPersistenceController; type + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldSOAPClientPersistenceHandle = class(TBoldAbstractComClientPersistenceHandle) private fModel: TBoldAbstractModel; @@ -34,4 +38,6 @@ function TBoldSOAPClientPersistenceHandle.CreatePersistenceController: TBoldPers result := Controller; end; +initialization + end. diff --git a/Source/Persistence/SOAP/BoldSOAPPersistenceControllerProxy.pas b/Source/Persistence/SOAP/BoldSOAPPersistenceControllerProxy.pas index 49be36c7..33b5e7fa 100644 --- a/Source/Persistence/SOAP/BoldSOAPPersistenceControllerProxy.pas +++ b/Source/Persistence/SOAP/BoldSOAPPersistenceControllerProxy.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSOAPPersistenceControllerProxy; interface @@ -14,7 +17,8 @@ interface BoldUpdatePrecondition, BoldPersistenceOperationXMLStreaming, BoldMeta, - BoldDefs; + BoldDefs, + BoldElements; type { forward declarations } @@ -35,7 +39,6 @@ TBoldSOAPPersistenceControllerProxy = class(TBoldAbstractComPersistenceControl protected fStub: IBoldSOAPService; function GetIsConnected: Boolean; override; - procedure CheckConnect(const Caller: string); property FetchIdListOp: TBoldPMFetchIdListOperation read GetFetchIdListOp; property FetchOp: TBoldPMFetchOperation read GetFetchOp; property ExactifyOp: TBoldPMExactifyIdsOperation read GetExactifyOp; @@ -45,8 +48,7 @@ TBoldSOAPPersistenceControllerProxy = class(TBoldAbstractComPersistenceControl destructor Destroy; override; procedure Connect(const Provider: IBoldProvider; const ObjectName: string); override; procedure Disconnect; override; - procedure PMExactifyIds(ObjectIdList: TBoldObjectidList; - TranslationList: TBoldIDTranslationList); override; + procedure PMExactifyIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; HandleNonExisting: Boolean); override; procedure PMFetch(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; BoldClientID: TBoldClientID); override; procedure PMFetchIDListWithCondition(ObjectIdList: TBoldObjectIdList; @@ -54,18 +56,19 @@ TBoldSOAPPersistenceControllerProxy = class(TBoldAbstractComPersistenceControl procedure PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; - TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; + TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; var TimeOfLatestUpdate: TDateTime; BoldClientID: TBoldClientID); override; procedure PMTranslateToGlobalIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; procedure PMTranslateToLocalIds(GlobalIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; - procedure PMSetReadOnlyness(ReadOnlyList, WriteableList: TBoldObjectIdList); override; + procedure PMSetReadonlyness(ReadOnlyList, WriteableList: TBoldObjectIdList); override; procedure ReserveNewIds(ValueSpace: IBoldValueSpace; ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; procedure PMTimestampForTime(ClockTime: TDateTime; var Timestamp: TBoldTimestampType); override; procedure PMTimeForTimestamp(Timestamp: TBoldTimestampType; var ClockTime: TDateTime); override; procedure SubscribeToPeristenceEvents(Subscriber: TBoldSubscriber); override; + function CanEvaluateInPS(sOCL: string; aSystem: TBoldElement; aContext: TBoldElementTypeInfo = nil; const aVariableList: TBoldExternalVariableList = nil): Boolean; override; end; implementation @@ -73,16 +76,17 @@ implementation uses BoldComUtils, SysUtils, - BoldCursorGuard, - BoldComConst; + BoldCursorGuard; { TBoldSOAPPersistenceControllerProxy } -procedure TBoldSOAPPersistenceControllerProxy.CheckConnect( - const Caller: string); +function TBoldSOAPPersistenceControllerProxy.CanEvaluateInPS(sOCL: string; + aSystem: TBoldElement; aContext: TBoldElementTypeInfo; + const aVariableList: TBoldExternalVariableList): Boolean; +const + sMethodNotImplemented = '%s.%s: not supported/implemented'; begin - if not Connected then - raise EBoldCom.CreateFmt(sNotConnected, [ClassName, Caller]); + raise EBold.CreateFmt(sMethodNotImplemented, [ClassName, 'CanEvaluateInPS']); // do not localize end; procedure TBoldSOAPPersistenceControllerProxy.Connect( @@ -94,9 +98,9 @@ procedure TBoldSOAPPersistenceControllerProxy.Connect( ObjectNamews := Objectname; Unk := Provider.GetObject(ObjectNameWS); if not Assigned(Unk) then - raise EBoldCom.CreateFmt(sFailedToConnect, [ObjectName]); + raise EBoldCom.CreateFmt('Failed connecting to COM object ''%s''.', [ObjectName]); if Unk.QueryInterface(IBoldSOAPService, fStub) <> 0 then - raise EBoldCom.CreateFmt(sCOMObjectNotPController, [ObjectName]); + raise EBoldCom.CreateFmt('COM object ''%s'' is not a persistence controller.', [ObjectName]); end; constructor TBoldSOAPPersistenceControllerProxy.Create(Model: TMoldModel); @@ -158,10 +162,11 @@ function TBoldSOAPPersistenceControllerProxy.GetUpdateOp: TBoldPMUpdateOperation procedure TBoldSOAPPersistenceControllerProxy.PMExactifyIds( ObjectIdList: TBoldObjectidList; - TranslationList: TBoldIDTranslationList); + TranslationList: TBoldIDTranslationList; + HandleNonExisting: Boolean); begin - CheckConnect('PMFetch'); // do not localize - + if not Connected then + raise EBoldCom.CreateFmt('%s.PMFetch: Not connected.', [ClassName]); ExactifyOp.ObjectIdList := ObjectIdList; ExactifyOp.TranslationList := TranslationList; ExactifyOp.RemoteExecute(fStub); @@ -174,7 +179,8 @@ procedure TBoldSOAPPersistenceControllerProxy.PMFetch( var CursorGuard: IBoldCursorGuard; begin - CheckConnect('PMFetch'); // do not localize + if not Connected then + raise EBoldCom.CreateFmt('%s.PMFetch: Not connected.', [ClassName]); try CursorGuard := TBoldCursorGuard.Create; @@ -200,7 +206,8 @@ procedure TBoldSOAPPersistenceControllerProxy.PMFetchIDListWithCondition( var CursorGuard: IBoldCursorGuard; begin - CheckConnect('PMFetchIDListWithCondition'); // do not localize + if not Connected then + raise EBoldCom.CreateFmt('%s.PMFetchIDListWithCondition: Not connected.', [ClassName]); CursorGuard := TBoldCursorGuard.Create; SendExtendedEvent(bpeStartFetchId, [Condition]); @@ -224,7 +231,8 @@ procedure TBoldSOAPPersistenceControllerProxy.PMTimeForTimestamp( var Op: TBoldPMTimeForTimestampOperation; begin - CheckConnect('PMUpdate'); // do not localize + if not Connected then + raise EBoldCom.CreateFmt('%s.PMUpdate: Not connected.', [ClassName]); Op := TBoldPMTimeForTimestampOperation.Create(fStreamManager); try @@ -242,7 +250,8 @@ procedure TBoldSOAPPersistenceControllerProxy.PMTimestampForTime( var Op: TBoldPMTimestampForTimeOperation; begin - CheckConnect('PMUpdate'); // do not localize + if not Connected then + raise EBoldCom.CreateFmt('%s.PMUpdate: Not connected.', [ClassName]); Op := TBoldPMTimestampForTimeOperation.Create(fStreamManager); try @@ -271,13 +280,14 @@ procedure TBoldSOAPPersistenceControllerProxy.PMTranslateToLocalIds( procedure TBoldSOAPPersistenceControllerProxy.PMUpdate( ObjectIdList: TBoldObjectIdList; ValueSpace, Old_Values: IBoldValueSpace; - Precondition: TBoldUpdatePrecondition; + Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; - var TimeStamp: TBoldTimeStampType; BoldClientID: TBoldClientID); + var TimeStamp: TBoldTimeStampType; var TimeOfLatestUpdate: TDateTime; BoldClientID: TBoldClientID); var CursorGuard: IBoldCursorGuard; begin - CheckConnect('PMUpdate'); // do not localize + if not Connected then + raise EBoldCom.CreateFmt('%s.PMUpdate: Not connected.', [ClassName]); try CursorGuard := TBoldCursorGuard.Create; @@ -295,16 +305,16 @@ procedure TBoldSOAPPersistenceControllerProxy.PMUpdate( UpdateOp.RemoteExecute(fStub); if assigned(Precondition) and Precondition.failed then - // update failed. don't get out params. else begin TimeStamp := UpdateOp.Timestamp; + TimeOfLatestUpdate := now; // TODO implement ValueSpace.ApplytranslationList(UpdateOp.TranslationList); end; finally if not Assigned(TranslationList) then UpdateOp.FreeTranslationList; - SendEvent(bpeEndUpdate); + SendEvent(bpeEndUpdate); end; end; @@ -314,7 +324,8 @@ procedure TBoldSOAPPersistenceControllerProxy.ReserveNewIds( var ReserveOp: TBoldPMReserveNewIdsOperation; begin - CheckConnect('ReserveNewIds'); // do not localize + if not Connected then + raise EBoldCom.CreateFmt('%s.ReserveNewIds: Not connected.', [ClassName]); ReserveOp := TBoldPMReserveNewIdsOperation.Create(fStreamManager); try @@ -345,4 +356,6 @@ procedure TBoldSOAPPersistenceControllerProxy.SubscribeToPeristenceEvents( AddSubscription(Subscriber, bpeDeleteObject, bpeDeleteObject); end; +initialization + end. diff --git a/Source/Persistence/SOAP/BoldSOAPPersistenceControllerStub.pas b/Source/Persistence/SOAP/BoldSOAPPersistenceControllerStub.pas index 63430f53..c7df71d0 100644 --- a/Source/Persistence/SOAP/BoldSOAPPersistenceControllerStub.pas +++ b/Source/Persistence/SOAP/BoldSOAPPersistenceControllerStub.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSOAPPersistenceControllerStub; interface @@ -31,8 +34,7 @@ implementation uses sysutils, - BoldComUtils, - BoldComConst; + BoldComUtils; { TBoldSOAPPersistenceControllerAdapter } @@ -44,7 +46,7 @@ constructor TBoldSOAPPersistenceControllerAdapter.Create(Model: TMoldModel; Adap fAdapterCore := TBoldPersistenceControllerSOAPAdapterCore.Create(Model); if Failed(LoadRegTypeLib(LIBID_BoldSOAP, BoldSOAPMajorVersion, BoldSOAPMinorVersion, 0, aTypeLibrary)) then - raise EBoldCom.CreateFmt(sUnableToLoadTypeLibBoldSoap, [classname]); + raise EBoldCom.CreateFmt('%s.Create: Cannot load type library', [classname]); inherited Create(Adaptee, Owner, aTypeLibrary, IBoldSOAPService); end; @@ -65,4 +67,6 @@ function TBoldSOAPPersistenceControllerAdapter.GetPersistenceController: TBoldPe result := Adaptee as TBoldPersistenceController; end; +initialization + end. diff --git a/Source/Persistence/SOAP/BoldSOAPServerPersistenceHandles.pas b/Source/Persistence/SOAP/BoldSOAPServerPersistenceHandles.pas index f7a2046d..d3338663 100644 --- a/Source/Persistence/SOAP/BoldSOAPServerPersistenceHandles.pas +++ b/Source/Persistence/SOAP/BoldSOAPServerPersistenceHandles.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSOAPServerPersistenceHandles; interface @@ -15,6 +18,7 @@ interface TBoldSOAPServerPersistenceHandle = class; {-- TBoldComServerElementHandle --} + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldSOAPServerPersistenceHandle = class(TBoldComExportHandle) private FBoldHandle: TBoldPersistenceHandle; @@ -33,6 +37,7 @@ TBoldSOAPServerPersistenceHandle = class(TBoldComExportHandle) implementation + {-- TBoldComServerPersistenceHandle -------------------------------------------} function TBoldSOAPServerPersistenceHandle.GetComObject: IUnknown; @@ -68,4 +73,6 @@ procedure TBoldSOAPServerPersistenceHandle.SetBoldHandle(Value: TBoldPersistence end; end; +initialization + end. diff --git a/Source/Persistence/SQLDirect/BoldDatabaseAdapterSQLDirect.pas b/Source/Persistence/SQLDirect/BoldDatabaseAdapterSQLDirect.pas index f7a94d23..91d45c40 100644 --- a/Source/Persistence/SQLDirect/BoldDatabaseAdapterSQLDirect.pas +++ b/Source/Persistence/SQLDirect/BoldDatabaseAdapterSQLDirect.pas @@ -1,9 +1,13 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDatabaseAdapterSQLDirect; interface uses SDEngine, + SDCommon, BoldAbstractDataBaseAdapter, BoldDBInterfaces, BoldSQLDirectInterfaces; @@ -23,6 +27,11 @@ TBoldDatabaseAdapterSQLDirect = class(TBoldAbstractDatabaseAdapter) function GetDataBaseInterface: IBoldDatabase; override; public destructor Destroy; override; + procedure LostConnectError(Database: TSDDatabase; + E: ESDEngineError; var Action: TSDLostConnectAction); + procedure ReconnectError(Database: TSDDatabase; + E: ESDEngineError; var Action: TSDLostConnectAction); + procedure CreateDatabase; override; published property DataBase: TSDDataBase read GetDataBase write SetDataBase; {$IFNDEF T2H} @@ -34,11 +43,17 @@ implementation uses SysUtils, - BoldDefs; + BoldDefs, + BoldRev; { TBoldDatabaseAdapterSQLDirect } -destructor TBoldDatabaseAdapterSQLDirect.destroy; +procedure TBoldDatabaseAdapterSQLDirect.CreateDatabase; +begin + DatabaseInterface.CreateDatabase; +end; + +destructor TBoldDatabaseAdapterSQLDirect.Destroy; begin Changed; FreePublisher; @@ -65,9 +80,27 @@ procedure TBoldDatabaseAdapterSQLDirect.ReleaseBoldDatabase; FreeAndNil(fBoldDatabase); end; +procedure TBoldDatabaseAdapterSQLDirect.LostConnectError( + Database: TSDDatabase; E: ESDEngineError; + var Action: TSDLostConnectAction); +begin + Action:=lcWaitReconnect; +end; + +procedure TBoldDatabaseAdapterSQLDirect.ReconnectError( + Database: TSDDatabase; E: ESDEngineError; + var Action: TSDLostConnectAction); +begin + Action:=lcWaitReconnect; +end; + procedure TBoldDatabaseAdapterSQLDirect.SetDataBase(const Value: TSDDataBase); begin + value.OnLostConnectError:=LostConnectError; + value.OnReconnectError:=ReconnectError; InternalDatabase := value; end; +initialization + end. diff --git a/Source/Persistence/SQLDirect/BoldPersistenceHandleSQLDirect.pas b/Source/Persistence/SQLDirect/BoldPersistenceHandleSQLDirect.pas index 388a50fb..1d48802f 100644 --- a/Source/Persistence/SQLDirect/BoldPersistenceHandleSQLDirect.pas +++ b/Source/Persistence/SQLDirect/BoldPersistenceHandleSQLDirect.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleSQLDirect; interface @@ -35,7 +38,7 @@ TBoldPersistenceHandleSQLDirect = class(TBoldDBPersistenceHandle) procedure InternalTransferproperties(const target: TBoldPersistenceHandleDB); override; {$ENDIF} public - destructor Destroy; override; + destructor destroy; override; function GetDataBaseInterface: IBoldDatabase; override; published property DatabaseName: string read FDatabaseName write SetDatabaseName; @@ -46,7 +49,8 @@ implementation uses Dialogs, - SysUtils; + SysUtils, + BoldRev; { TBoldPersistenceHandleSQLDirect } @@ -85,8 +89,8 @@ procedure TBoldPersistenceHandleSQLDirect.InternalTransferproperties( begin Target.DatabaseAdapter := TBoldDatabaseAdapterSQLDirect.Create(Target.Owner); Target.DatabaseAdapter.Name := GetNewComponentName(Target.DatabaseAdapter, 'BoldDatabaseAdapterSQLDirect'); - LongRec(DesInfo).Lo := LongRec(DesInfo).lo+16; //set Left - LongRec(DesInfo).Hi := LongRec(DesInfo).hi+16; //Set Top; + LongRec(DesInfo).Lo := LongRec(DesInfo).lo+16; + LongRec(DesInfo).Hi := LongRec(DesInfo).hi+16; Target.DatabaseAdapter.DesignInfo := DesInfo; showmessage('Created a new DatabaseAdapterSQLDirect'); end @@ -102,8 +106,8 @@ procedure TBoldPersistenceHandleSQLDirect.InternalTransferproperties( Adapter.DataBase := TSDDatabase.Create(Target.owner); Adapter.DataBase.Name := GetNewComponentName(Adapter.DataBase, 'SDDatabase'); showmessage('Created a new SDDatabase'); - LongRec(DesInfo).Lo := LongRec(DesInfo).lo+16; //set Left - LongRec(DesInfo).Hi := LongRec(DesInfo).hi+16; //Set Top; + LongRec(DesInfo).Lo := LongRec(DesInfo).lo+16; + LongRec(DesInfo).Hi := LongRec(DesInfo).hi+16; Adapter.DataBase.DesignInfo := DesInfo; end; end; @@ -154,4 +158,6 @@ procedure TBoldPersistenceHandleSQLDirect.SetEffectiveDataBase(const Value: TSDD FEffectiveDatabase := Value; end; +initialization + end. diff --git a/Source/Persistence/SQLDirect/BoldPersistenceHandleSQLDirectReg.pas b/Source/Persistence/SQLDirect/BoldPersistenceHandleSQLDirectReg.pas index d4b42b76..fd616c70 100644 --- a/Source/Persistence/SQLDirect/BoldPersistenceHandleSQLDirectReg.pas +++ b/Source/Persistence/SQLDirect/BoldPersistenceHandleSQLDirectReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleSQLDirectReg; interface @@ -11,16 +14,22 @@ implementation uses SysUtils, Classes, + BoldIDESupport, + BoldVersionInfo, BoldDatabaseAdapterSQLDirect, BoldPersistenceHandleSQLDirect, - BoldIDESupport, - BoldIDEConsts; + BoldIDEConsts; procedure Register; begin - RemovePackageFromDisabledPackagesRegistry(format('BoldSQLDirect%s', [LIBSUFFIX])); // do not localize + RemovePackageFromDisabledPackagesRegistry(format('Bold%d%d%sSQLDirect', [ + BoldBuildVersionNumberMajor, + BoldBuildVersionNumberMinor, + BoldBuildTarget])); RegisterComponents(BOLDPAGENAME_DEPRECATED, [TBoldPersistenceHandleSQLDirect]); RegisterComponents(BOLDPAGENAME_PERSISTENCE, [TBoldDatabaseAdapterSQLDirect]); end; +initialization + end. diff --git a/Source/Persistence/SQLDirect/BoldSQLDirectInterfaces.pas b/Source/Persistence/SQLDirect/BoldSQLDirectInterfaces.pas index 773ab544..86d7b03f 100644 --- a/Source/Persistence/SQLDirect/BoldSQLDirectInterfaces.pas +++ b/Source/Persistence/SQLDirect/BoldSQLDirectInterfaces.pas @@ -1,7 +1,11 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSQLDirectInterfaces; interface uses + Windows, Classes, Db, SDEngine, @@ -12,43 +16,78 @@ interface { forward declarations } TBoldSQLDirectDatabase = class; TBoldSQLDirectQuery = class; + TBoldSQLDirectTable = class; + TBoldSQLDirectQueryClass = class of TBoldSQLDirectQuery; + TBoldSqlDirectDbParameter = class(TBoldDbParameter, IBoldDBParam) + private + function GetParameter: TParam; + end; + { TBoldSDQuery } - TBoldSQLDirectQuery = class(TBoldDataSetWrapper, IBoldQuery, IBoldExecQuery, IBoldParameterized) + TBoldSQLDirectQuery = class(TBoldBatchDataSetWrapper, IBoldQuery, IBoldExecQuery, IBoldParameterized) private FQuery: TSDQuery; + fUseReadTransactions: boolean; function GetParamCount: integer; - function GetParams(i: integer): IBoldParameter; + function GetParams: TParams; override; + function GetParam(i: integer): IBoldParameter; function GetQuery: TSDQuery; function GetRecordCount: integer; function GetRequestLiveQuery: Boolean; procedure ClearParams; function GetRowsAffected: integer; function GetSQLText: String; - function ParamByName(const Value: string): IBoldParameter; + function GetParamCheck: Boolean; + procedure SetParamCheck(value: Boolean); + function ParamByName(const Value: string): IBoldParameter; override; + function FindParam(const Value: string): IBoldParameter; override; procedure AssignParams(Sourceparams: TParams); procedure AssignSQL(SQL: TStrings); - procedure AssignSQLText(SQL: String); + procedure AssignSQLText(const SQL: String); + function GetSQLStrings: TStrings; override; procedure SetRequestLiveQuery(NewValue: Boolean); - function Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; + function GetUseReadTransactions: boolean; + procedure SetUseReadTransactions(value: boolean); + function Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; override; + procedure ExecSQL; protected function GetDataSet: TDataSet; override; - procedure EndSQLBatch; virtual; - procedure ExecSQL; - procedure FailSQLBatch; virtual; procedure Open; override; - procedure StartSQLBatch; virtual; property Query: TSDQuery read GetQuery; public - constructor Create(Query: TSDQuery; DatabaseWrapper: TBoldDatabaseWrapper); + constructor Create(Query: TSDQuery; DatabaseWrapper: TBoldDatabaseWrapper); virtual; + end; + + { TBoldSQLDirectTable } + TBoldSQLDirectTable = class(TBoldDataSetWrapper, IBoldTable) + private + fTable: TSDTable; + procedure AddIndex(const Name, Fields: string; Options: TIndexOptions; const DescFields: string = ''); + procedure CreateTable; + procedure DeleteTable; + function GetTable: TSDTable; + function GetIndexDefs: TIndexDefs; + procedure SetTableName(const NewName: String); + function GetTableName: String; + procedure SetExclusive(NewValue: Boolean); + function GetExclusive: Boolean; + function GetExists: Boolean; + property Table: TSDTable read GetTable; + protected + function GetDataSet: TDataSet; override; + public + constructor Create(Table: TSDTable; DatabaseWrapper: TBoldDatabaseWrapper); end; { TBoldSDDataBase } TBoldSQLDirectDatabase = class(TBolddatabaseWrapper, IBoldDataBase) private FDatabase: TSDDataBase; + fCachedTable: TSDTable; FCachedQuery: TSDQuery; + fExecuteQueryCount: integer; function GetConnected: Boolean; function GetDataBase: TSDDataBase; function GetInTransaction: Boolean; @@ -59,21 +98,23 @@ TBoldSQLDirectDatabase = class(TBolddatabaseWrapper, IBoldDataBase) procedure Close; procedure Commit; procedure Open; - function GetTable: IBoldTable; - procedure ReleaseTable(var Table: IBoldTable); procedure Rollback; procedure SetKeepConnection(NewValue: Boolean); procedure SetlogInPrompt(NewValue: Boolean); procedure StartTransaction; property Database: TSDDatabase read GetDatabase; procedure ReleaseCachedObjects; + function GetIsExecutingQuery: Boolean; protected procedure AllTableNames(Pattern: String; ShowSystemTables: Boolean; TableNameList: TStrings); override; function GetQuery: IBoldQuery; override; procedure ReleaseQuery(var Query: IBoldQuery); override; + function GetTable: IBoldTable; override; + procedure ReleaseTable(var Table: IBoldTable); override; public constructor Create(Database: TSDDataBase; SQLDataBaseConfig: TBoldSQLDatabaseConfig); destructor Destroy; override; + procedure Reconnect; end; var @@ -84,7 +125,11 @@ implementation uses SysUtils, BoldUtils, - Dialogs; + BoldDefs, + Controls, + Masks, + DateUtils, + StrUtils; { TBoldSDQuery } @@ -103,7 +148,7 @@ procedure TBoldSQLDirectQuery.AssignSQL(SQL: TStrings); Query.SQL.EndUpdate; end; -procedure TBoldSQLDirectQuery.AssignSQLText(SQL: String); +procedure TBoldSQLDirectQuery.AssignSQLText(const SQL: String); begin Query.SQL.BeginUpdate; Query.SQL.Clear; @@ -120,29 +165,41 @@ constructor TBoldSQLDirectQuery.Create(Query: TSDQuery; DatabaseWrapper: TBoldDa begin inherited create(DatabaseWrapper); FQuery := Query; + SetParamCheck(true); end; function TBoldSQLDirectQuery.Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; begin - result := TBoldDbParameter.Create(Query.params.CreateParam(fldType, ParamName, ParamType), self); -end; - -procedure TBoldSQLDirectQuery.EndSQLBatch; -begin + result := TBoldSqlDirectDbParameter.Create(Query.params.CreateParam(fldType, ParamName, ParamType), self); end; procedure TBoldSQLDirectQuery.ExecSQL; begin try BoldLogSQL(Query.SQL); - Query.ExecSQL; + if InBatch then + begin + BatchExecSQL; + exit; + end; + Query.ExecSQL; except - on E: Exception do MessageDlg(E.Message + #13#10 +Query.SQL.Text, mtError, [mbOk], 0); + on e: exception do + begin + e.Message := (e.Message + #13#10 +Query.SQL.Text); + raise; end; end; +end; -procedure TBoldSQLDirectQuery.FailSQLBatch; +function TBoldSQLDirectQuery.FindParam(const Value: string): IBoldParameter; +var + Param: TParam; begin + result := nil; + Param := Query.Params.FindParam(Value); + if Assigned(Param) then + result := TBoldSqlDirectDbParameter.Create(Param, self) end; function TBoldSQLDirectQuery.GetDataSet: TDataSet; @@ -150,19 +207,31 @@ function TBoldSQLDirectQuery.GetDataSet: TDataSet; result := Query; end; +function TBoldSQLDirectQuery.GetParamCheck: Boolean; +begin + Result := Query.ParamCheck; +end; + function TBoldSQLDirectQuery.GetParamCount: integer; begin result := Query.Params.count; end; -function TBoldSQLDirectQuery.GetParams(i: integer): IBoldParameter; +function TBoldSQLDirectQuery.GetParams: TParams; begin - result := TBoldDBParameter.Create(Query.Params[i], self); + result := Query.Params; +end; + +function TBoldSQLDirectQuery.GetParam(i: integer): IBoldParameter; +begin + result := TBoldSqlDirectDbParameter.Create(Query.Params[i], self); end; function TBoldSQLDirectQuery.GetQuery: TSDQuery; begin - result := FQuery; + if not assigned(fQuery) then + fQuery := TSDQuery.Create(nil); + result := fQuery; end; function TBoldSQLDirectQuery.GetRecordCount: integer; @@ -172,7 +241,7 @@ function TBoldSQLDirectQuery.GetRecordCount: integer; function TBoldSQLDirectQuery.GetRequestLiveQuery: Boolean; begin - result := false; + result := Query.RequestLive; end; function TBoldSQLDirectQuery.GetRowsAffected: integer; @@ -180,15 +249,25 @@ function TBoldSQLDirectQuery.GetRowsAffected: integer; result := Query.RowsAffected; end; +function TBoldSQLDirectQuery.GetSQLStrings: TStrings; +begin + result := Query.SQL; +end; + function TBoldSQLDirectQuery.GetSQLText: String; begin result := Query.SQL.Text; end; +function TBoldSQLDirectQuery.GetUseReadTransactions: boolean; +begin + result := fUseReadTransactions; +end; + procedure TBoldSQLDirectQuery.Open; begin BoldLogSQL(Query.SQL); - inherited; + inherited; end; function TBoldSQLDirectQuery.ParamByName(const Value: string): IBoldParameter; @@ -196,28 +275,130 @@ function TBoldSQLDirectQuery.ParamByName(const Value: string): IBoldParameter; Param: TParam; begin Param := Query.ParamByName(Value); - if assigned(Param) then - result := TBoldDbParameter.Create(Param, self) - else - result := nil; + result := TBoldSqlDirectDbParameter.Create(Param, self); end; +procedure TBoldSQLDirectQuery.SetParamCheck(value: Boolean); +begin + Query.ParamCheck := Value; +end; + procedure TBoldSQLDirectQuery.SetRequestLiveQuery(NewValue: Boolean); begin end; -procedure TBoldSQLDirectQuery.StartSQLBatch; +procedure TBoldSQLDirectQuery.SetUseReadTransactions(value: boolean); +begin + fUseReadTransactions := value; +end; + + +{ TBoldSQLDirectTable } + +procedure TBoldSQLDirectTable.AddIndex(const Name, Fields: string; + Options: TIndexOptions; const DescFields: string); +begin + Assert(False, 'TBoldSQLDirectTable.AddIndex: Not Implemented'); + // Table.AddIndex(Name, Fields, Options, DescFields); +end; + +constructor TBoldSQLDirectTable.Create(Table: TSDTable; DatabaseWrapper: TBoldDatabaseWrapper); +begin + inherited Create(DatabaseWrapper); + fTable := Table; +end; + +procedure TBoldSQLDirectTable.CreateTable; +begin + Table.CreateTable; +end; + +procedure TBoldSQLDirectTable.DeleteTable; +begin + Table.DeleteTable; +end; + +function TBoldSQLDirectTable.GetDataSet: TDataSet; begin + result := Table; +end; + +function TBoldSQLDirectTable.GetExclusive: Boolean; +begin + result:=false; + Assert(False, 'TBoldSQLDirectTable.GetExclusive: Not Implemented'); + // result := Table.Exclusive; +end; + +function TBoldSQLDirectTable.GetExists: Boolean; +begin + result := Table.Exists; +end; + +function TBoldSQLDirectTable.GetIndexDefs: TIndexDefs; +begin + result := Table.IndexDefs; +end; + +function TBoldSQLDirectTable.GetTable: TSDTable; +begin + if not assigned(fTable) then + fTable := TSDTable.Create(nil); + result := fTable +end; + +function TBoldSQLDirectTable.GetTableName: String; +begin + result := Table.TableName; +end; + +procedure TBoldSQLDirectTable.SetExclusive(NewValue: Boolean); +begin + Assert(False, 'TBoldSQLDirectTable.DetExclusive: Not Implemented'); + // Table.Exclusive := NewValue; +end; + +procedure TBoldSQLDirectTable.SetTableName(const NewName: String); +begin + Table.TableName := NewName; end; { TBoldSDDataBase } procedure TBoldSQLDirectDatabase.AllTableNames(Pattern: String; ShowSystemTables: Boolean; TableNameList: TStrings); -begin - if (Pattern <> '') and (Pattern <> '*') then - raise Exception.CreateFmt('%s.AlltableNames: This call does not allow patterns ("%s")', [ClassName, Pattern]); - Database.Session.GetTableNames(Database.DatabaseName, Pattern, ShowSystemTables, TableNameList); +var + i, dotpos: Integer; + TableOwner: String; +begin + // when ShowSystemTables = true SQLDirect returns only System tables, no user tables, which we never want + // in other DB implementations ShowSystemTables means User tables + System tables. + ShowSystemTables := false; + fDatabase.Session.GetTableNames(fDatabase.DatabaseName, Pattern, ShowSystemTables, TableNameList); + + TableOwner:=fDatabase.Params.Values['USER NAME']+'.'; + i:=0; + while i<=TableNameList.Count-1 do begin + if fDatabase.ServerType=stOracle then begin + if not AnsiSameText(LeftStr(TableNameList[i], Length(TableOwner)), TableOwner) then begin + TableNameList.Delete(i); + Continue; + end; + end; + dotPos := pos('.', TableNameList[i]); + if dotPos > 0 then begin + TableNameList[i] := Copy(TableNameList[i], dotPos+1, maxInt); + end; + Inc(i); + end; + + if Pattern <> '' then begin + for i := TableNameList.Count - 1 downto 0 do begin + if not MatchesMask(TableNameList[i], Pattern) then begin + TableNameList.Delete(i); + end; + end; + end; end; procedure TBoldSQLDirectDatabase.Close; @@ -232,14 +413,15 @@ procedure TBoldSQLDirectDatabase.Commit; constructor TBoldSQLDirectDatabase.create(DataBase: TSDDataBase; SQLDataBaseConfig: TBoldSQLDatabaseConfig); begin - inherited create(SQLDataBaseConfig); + inherited Create(SQLDataBaseConfig); FDataBase := DataBase; end; -destructor TBoldSQLDirectDatabase.destroy; +destructor TBoldSQLDirectDatabase.Destroy; begin inherited; FDatabase := nil; + FreeAndNil(fCachedTable); FreeAndNil(fCachedQuery); end; @@ -258,19 +440,24 @@ function TBoldSQLDirectDatabase.GetInTransaction: Boolean; result := Database.InTransaction; end; +function TBoldSQLDirectDatabase.GetIsExecutingQuery: Boolean; +begin + Result := fExecuteQueryCount > 0; +end; + function TBoldSQLDirectDatabase.GetIsSQLBased: Boolean; begin - result := true; + result := DataBase.IsSQLBased; end; function TBoldSQLDirectDatabase.GetKeepConnection: Boolean; begin - result := true; + result := DataBase.KeepConnection; end; function TBoldSQLDirectDatabase.GetLogInPrompt: Boolean; begin - result := dataBase.LoginPrompt; + result := DataBase.LoginPrompt; end; function TBoldSQLDirectDatabase.GetQuery: IBoldQuery; @@ -285,15 +472,28 @@ function TBoldSQLDirectDatabase.GetQuery: IBoldQuery; else begin Query := TSDQuery.Create(nil); - Query.DatabaseName := Database.DatabaseName; Query.SessionName := Database.SessionName; + Query.DatabaseName := Database.DatabaseName; end; result := BoldSQLDirectQueryClass.Create(Query, self); end; function TBoldSQLDirectDatabase.GetTable: IBoldTable; +var + Table: TSDTable; begin - result := nil; + if assigned(fCachedTable) then + begin + Table := fCachedTable; + fCachedTable := nil; + end + else + begin + Table := TSDTable.Create(nil); + Table.SessionName := Database.SessionName; + Table.DatabaseName := DataBase.DataBaseName; + end; + result := TBoldSQLDirectTable.Create(Table, self); end; procedure TBoldSQLDirectDatabase.Open; @@ -301,9 +501,14 @@ procedure TBoldSQLDirectDatabase.Open; Database.Open; end; +procedure TBoldSQLDirectDatabase.Reconnect; +begin + Assert(False, 'TBoldSQLDirectDatabase.Reconnect: Not Implemented'); +end; + procedure TBoldSQLDirectDatabase.ReleaseCachedObjects; begin - //FreeAndNil(fCachedTable); + FreeAndNil(fCachedTable); FreeAndNil(fCachedQuery); end; @@ -327,8 +532,19 @@ procedure TBoldSQLDirectDatabase.ReleaseQuery(var Query: IBoldQuery); end; procedure TBoldSQLDirectDatabase.ReleaseTable(var Table: IBoldTable); +var + SQLDirectTable: TBoldSQLDirectTable; +begin + if Table.Implementor is TBoldSQLDirectTable then begin - raise Exception.Create('TBoldSQLDirectDatabase.ReleaseTable: Operation not supported'); + SQLDirectTable := Table.Implementor as TBoldSQLDirectTable; + Table := nil; + if not assigned(fCachedTable) then + fCachedTable := SQLDirectTable.fTable + else + SQLDirectTable.fTable.free; + SQLDIrectTable.Free; + end; end; procedure TBoldSQLDirectDatabase.Rollback; @@ -338,6 +554,7 @@ procedure TBoldSQLDirectDatabase.Rollback; procedure TBoldSQLDirectDatabase.SetKeepConnection(NewValue: Boolean); begin + Database.KeepConnection := NewValue; end; procedure TBoldSQLDirectDatabase.SetlogInPrompt(NewValue: Boolean); @@ -352,7 +569,14 @@ procedure TBoldSQLDirectDatabase.StartTransaction; function TBoldSQLDirectDatabase.SupportsTableCreation: boolean; begin - result := false; + result := true; +end; + +{ TBoldSqlDirectDbParameter } + +function TBoldSqlDirectDbParameter.GetParameter: TParam; +begin + result := self.Parameter; end; end. diff --git a/Source/Persistence/System/BoldPersistenceControllerSystem.pas b/Source/Persistence/System/BoldPersistenceControllerSystem.pas index a3dace97..c0b64f8f 100644 --- a/Source/Persistence/System/BoldPersistenceControllerSystem.pas +++ b/Source/Persistence/System/BoldPersistenceControllerSystem.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceControllerSystem; interface @@ -11,7 +14,8 @@ interface BoldSystem, BoldValueSpaceInterfaces, BoldSubscription, - BoldDefs; + BoldDefs, + BoldElements; type { forward declarations } @@ -21,25 +25,26 @@ TBoldPersistenceControllerSystem = class; TBoldPersistenceControllerSystem = class(TBoldPersistenceController) private fBoldSystem: TBoldSystem; - fLocatorSubscriber: TBoldPassthroughSubscriber; - fMapping: TBoldIndexableList; // TBoldIdLocatorMapping + fLocatorSubscriber: TBoldExtendedPassthroughSubscriber; + fMapping: TBoldIndexableList; procedure _LocatorDestroyedReceived(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const); procedure SetBoldSystem(System: TBoldSystem); function GetLocatorById(ObjectId: TBoldObjectId): TBoldObjectLocator; function GetIdByLocator(Locator: TBoldObjectLocator): TBoldObjectId; + procedure FetchMember(const ObjectContents: IBoldObjectContents; MemberIndex: Integer; BoldMember: TBoldMember); public constructor Create; destructor Destroy; override; - procedure PMExactifyIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; + procedure PMExactifyIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList; HandleNonExisting: Boolean); override; procedure PMFetch(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; MemberIdList: TBoldMemberIdList; FetchMode: Integer; BoldClientID: TBoldClientID); override; procedure PMFetchIDListWithCondition(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; FetchMode: Integer; Condition: TBoldCondition; BoldClientID: TBoldClientID); override; - procedure PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; BoldClientID: TBoldClientID); override; + procedure PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; var TimeOfLatestUpdate: TDateTime; BoldClientID: TBoldClientID); override; procedure PMTranslateToGlobalIds(ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; procedure PMTranslateToLocalIds(GlobalIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; procedure PMSetReadOnlyness(ReadOnlyList, WriteableList: TBoldObjectIdList); override; - // this info should be stored in separate Mapping model procedure ReserveNewIds(ValueSpace: IBoldValueSpace; ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); override; + function CanEvaluateInPS(sOCL: string; aSystem: TBoldElement; aContext: TBoldElementTypeInfo = nil; const aVariableList: TBoldExternalVariableList = nil): Boolean; override; property BoldSystem: TBoldSystem read fBoldSystem write SetBoldSystem; property LocatorById[ObjectId: TBoldObjectId]: TBoldObjectLocator read GetLocatorById; property IdByLocator[Locator: TBoldObjectLocator]: TBoldObjectId read GetIdByLocator; @@ -53,11 +58,8 @@ implementation BoldDomainElement, BoldDefaultId, BoldSystemRT, - BoldIndex; - -var - IX_MappingIdIndex: integer = -1; - IX_MappingLocatorIndex: integer = -1; + BoldIndex, + BoldLogHandler; type { TBoldIdLocatorPair } @@ -89,16 +91,18 @@ TBoldMappingLocatorIndex = class(TBoldHashIndex) { TBoldIdLocatorMapping } TBoldIdLocatorMapping = class(TBoldIndexableList) private + class var IX_MappingIdIndex: integer; + class var IX_MappingLocatorIndex: integer; fNextId: Integer; - function GetLocatorById(ID: TBoldObjectId): TBoldObjectLocator; - function GetIdByLocator(Locator: TBoldObjectLocator): TBoldObjectId; - function GetPairByLocator(Locator: TBoldObjectLocator): TBoldIdLocatorPair; + function GetLocatorById(ID: TBoldObjectId): TBoldObjectLocator; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetIdByLocator(Locator: TBoldObjectLocator): TBoldObjectId; {$IFDEF BOLD_INLINE}inline;{$ENDIF} + function GetPairByLocator(Locator: TBoldObjectLocator): TBoldIdLocatorPair; {$IFDEF BOLD_INLINE}inline;{$ENDIF} public constructor Create; - procedure AddPair(Id: TBoldObjectId; Locator: TBoldObjectLocator); + procedure AddPair(Id: TBoldObjectId; Locator: TBoldObjectLocator); {$IFDEF BOLD_INLINE}inline;{$ENDIF} procedure ExactifyClassForLocator(Locator: TBoldObjectLocator; ExactClassId: Integer); function EnsuredIdByLocator(Locator: TBoldObjectLocator): TBoldObjectId; - procedure RemoveByLocator(Locator: TBoldObjectLocator); + procedure RemoveByLocator(Locator: TBoldObjectLocator); {$IFDEF BOLD_INLINE}inline;{$ENDIF} property LocatorById[ID: TBoldObjectId]: TBoldObjectLocator read GetLocatorById; property IdByLocator[Locator: TBoldObjectLocator]: TBoldObjectId read GetIdByLocator; end; @@ -106,11 +110,162 @@ TBoldIdLocatorMapping = class(TBoldIndexableList) const OBJECTIDLOCATORNAME = 'ObjectIdLocator'; +{ TBoldIdLocatorMapping } + +procedure TBoldIdLocatorMapping.AddPair(Id: TBoldObjectId; Locator: TBoldObjectLocator); +begin + Add(TBoldIdLocatorPair.Create(Id, Locator)); +end; + +constructor TBoldIdLocatorMapping.Create; +begin + inherited; + IX_MappingIdIndex := -1; + IX_MappingLocatorIndex := -1; + SetIndexVariable(IX_MappingIdIndex, AddIndex(TBoldMappingIdIndex.Create)); + SetIndexVariable(IX_MappingLocatorIndex, AddIndex(TBoldMappingLocatorIndex.Create)); + fNextId := 1; +end; + +function TBoldIdLocatorMapping.GetPairByLocator( + Locator: TBoldObjectLocator): TBoldIdLocatorPair; +begin + result := TBoldIdLocatorPair(Indexes[IX_MappingLocatorIndex].Find(Locator)); +end; + +function TBoldIdLocatorMapping.GetIdByLocator(Locator: TBoldObjectLocator): TBoldObjectId; +var + aPair: TBoldIdLocatorPair; +begin + aPair := GetPairByLocator(Locator); + if assigned(aPair) then + result := aPair.fId + else + result := nil; +end; + +function TBoldIdLocatorMapping.EnsuredIdByLocator( + Locator: TBoldObjectLocator): TBoldObjectId; +var + NewId: TBoldDefaultId; +begin + if not assigned(Locator) then + result := nil + else + begin + result := IdByLocator[Locator]; + if not assigned(result) then + begin + NewId := TBoldDefaultId.CreateWithClassID(Locator.BoldObjectID.TopSortedIndex, Locator.BoldObjectID.TopSortedIndexExact); + NewId.AsInteger := fNextId; + inc(fNextId); + AddPair(NewId, Locator); + NewId.Free; + result := IdByLocator[Locator]; + end; + end; +end; + +procedure TBoldIdLocatorMapping.ExactifyClassForLocator( + Locator: TBoldObjectLocator; ExactClassId: Integer); +var + NewId: TBoldObjectId; + aPair: TBoldIdLocatorPair; +begin + aPair := GetPairByLocator(Locator); + NewId := aPair.fId.CloneWithClassId(ExactClassId, True); + aPair.fId.Free; + aPair.fId := NewId; +end; + +function TBoldIdLocatorMapping.GetLocatorById( + ID: TBoldObjectId): TBoldObjectLocator; +var + aPair: TBoldIdLocatorPair; +begin + aPair := TBoldIdLocatorPair(Indexes[IX_MappingIdIndex].Find(Id)); + if assigned(aPair) then + result := aPair.fLocator + else + result := nil; +end; + +procedure TBoldIdLocatorMapping.RemoveByLocator( + Locator: TBoldObjectLocator); +var + aPair: TBoldIdLocatorPair; +begin + aPair := GetPairByLocator(Locator); + if assigned(aPair) then + Remove(aPair); +end; + +{ TBoldMappingIdIndex } + +function TBoldMappingIdIndex.Hash(const Key): Cardinal; +begin + Assert(TObject(Key) is TBoldObjectId); + Result := TBoldObjectId(Key).Hash; +end; + +function TBoldMappingIdIndex.HashItem(Item: TObject): Cardinal; +begin + result := (Item as TBoldIdLocatorPair).fId.Hash; +end; + +function TBoldMappingIdIndex.Match(const Key; Item: TObject): Boolean; +begin + Assert(TObject(Key) is TBoldObjectId); + result := TBoldObjectId(Key).IsEqual[TBoldIdLocatorPair(Item).fId]; +end; + +{ TBoldMappingLocatorIndex } + +function TBoldMappingLocatorIndex.Hash(const Key): Cardinal; +begin + Assert(TObject(Key) is TBoldObjectLocator); + Result := TBoldObjectLocator(Key).Hash; +end; + +function TBoldMappingLocatorIndex.HashItem(Item: TObject): Cardinal; +begin + result := (Item as TBoldIdLocatorPair).fLocator.Hash; +end; + +function TBoldMappingLocatorIndex.Match(const Key; Item:TObject): Boolean; +begin + Assert(TObject(Key) is TBoldObjectLocator); + Assert(Item is TBoldIdLocatorPair); + result := TBoldObjectLocator(Key) = TBoldIdLocatorPair(Item).fLocator; +end; + +{ TBoldIdLocatorPair } + +constructor TBoldIdLocatorPair.Create(Id: TBoldObjectId; + Locator: TBoldObjectLocator); +begin + fLocator := Locator; + fId := Id.Clone; +end; + +destructor TBoldIdLocatorPair.Destroy; +begin + FreeAndNil(fId); + inherited; +end; + { TBoldPersistenceControllerSystem } +function TBoldPersistenceControllerSystem.CanEvaluateInPS(sOCL: string; + aSystem: TBoldElement; aContext: TBoldElementTypeInfo; + const aVariableList: TBoldExternalVariableList): Boolean; +begin + result := BoldSystem.CanEvaluateInPs(sOCL, aContext, aVariableList); +end; + constructor TBoldPersistenceControllerSystem.Create; begin - fLocatorSubscriber := TBoldPassthroughSubscriber.CreateWithExtendedReceive(_LocatorDestroyedReceived); + fLocatorSubscriber := TBoldExtendedPassthroughSubscriber.CreateWithExtendedReceive(_LocatorDestroyedReceived); fMapping := TBoldIdLocatorMapping.Create; end; @@ -121,6 +276,71 @@ destructor TBoldPersistenceControllerSystem.Destroy; inherited; end; +procedure TBoldPersistenceControllerSystem.FetchMember( + const ObjectContents: IBoldObjectContents; MemberIndex: Integer; + BoldMember: TBoldMember); + + function ExtractNewIdList(ObjectList: TBoldObjectList): TBoldObjectIdList; + var + i: Integer; + begin + result := TBoldObjectIdList.Create; + for i := 0 to ObjectList.Count - 1 do + result.Add(TBoldIdLocatorMapping(fMapping).EnsuredIdByLocator(ObjectList.Locators[i])); + end; + +var + aValue: IBoldValue; + aRoleRT: TBoldRoleRTInfo; + Ids1, Ids2: TBoldObjectIdList; + aMemberId: TBoldMemberId; +begin + aValue := BoldMember.AsIBoldValue[bdepContents]; + Assert(Assigned(aValue)); + aValue := ObjectContents.EnsureMemberAndGetValueByIndex(MemberIndex, aValue.ContentName); + Assert(Assigned(aValue)); + if (aValue.BoldPersistenceState = bvpsInvalid) then + begin + if BoldMember.BoldMemberRTInfo.Persistent then + begin + BoldMember.EnsureContentsCurrent; + if not (BoldMember.BoldMemberRTInfo is TBoldRoleRTInfo) then + aValue.AssignContent(BoldMember.AsIBoldValue[bdepContents]) + else + begin + aRoleRT := BoldMember.BoldMemberRTInfo as TBoldRoleRTInfo; + if aRoleRT.IsMultiRole then + begin + if aRoleRT.IsIndirect then + begin + Ids1 := ExtractNewIdList(BoldMember.OwningObject.BoldMembers[aRoleRT.IndexOfLinkObjectRole] as TBoldObjectList); + Ids2 := ExtractNewIdList(BoldMember as TBoldObjectList); + (aValue as IBoldObjectIdListRefPair).SetFromIdLists(Ids1, Ids2); + Ids1.Free; + Ids2.Free; + end else + begin + Ids1 := ExtractNewIdList(BoldMember as TBoldObjectList); + (aValue as IBoldObjectIdListRef).SetFromIdList(Ids1); + Ids1.Free; + end; + end else + begin + if aRoleRT.IsIndirect then + (aValue as IBoldObjectIdRefPair).SetFromIds( + TBoldIdLocatorMapping(fMapping).EnsuredIdByLocator((BoldMember.OwningObject.BoldMembers[aRoleRT.IndexOfLinkObjectRole] as TBoldObjectReference).Locator), + TBoldIdLocatorMapping(fMapping).EnsuredIdByLocator((BoldMember as TBoldObjectReference).Locator)) + else + (aValue as IBoldObjectIdRef).SetFromId( + TBoldIdLocatorMapping(fMapping).EnsuredIdByLocator((BoldMember as TBoldObjectReference).Locator) + , false); //? + end; + end; + end; + end; +end; + + function TBoldPersistenceControllerSystem.GetIdByLocator( Locator: TBoldObjectLocator): TBoldObjectId; begin @@ -135,7 +355,7 @@ function TBoldPersistenceControllerSystem.GetLocatorById( procedure TBoldPersistenceControllerSystem.PMExactifyIds( ObjectIdList: TBoldObjectIdList; - TranslationList: TBoldIdTranslationList); + TranslationList: TBoldIdTranslationList; HandleNonExisting: Boolean); var i: integer; anIdList: TBoldObjectIdList; @@ -152,7 +372,7 @@ procedure TBoldPersistenceControllerSystem.PMExactifyIds( if anIdList.Count > 0 then begin - BoldSystem.PersistenceController.PMExactifyIds(anIdList, aTranslationList); + BoldSystem.PersistenceController.PMExactifyIds(anIdList, aTranslationList, HandleNonExisting); BoldSystem.AsIBoldvalueSpace[bdepContents].ApplytranslationList(aTranslationList); for i := 0 to anIdList.Count - 1 do begin @@ -178,70 +398,6 @@ procedure TBoldPersistenceControllerSystem.PMFetch( MemberIdList: TBoldMemberIdList; FetchMode: Integer; BoldClientID: TBoldClientID); - procedure FetchMember(ObjectContents: IBoldObjectContents; MemberIndex: Integer; BoldMember: TBoldMember); - - function ExtractNewIdList(ObjectList: TBoldObjectList): TBoldObjectIdList; - var - i: Integer; - begin - result := TBoldObjectIdList.Create; - for i := 0 to ObjectList.Count - 1 do - result.Add(TBoldIdLocatorMapping(fMapping).EnsuredIdByLocator(ObjectList.Locators[i])); - end; - - var - aValue: IBoldValue; - aRoleRT: TBoldRoleRTInfo; - Ids1, Ids2: TBoldObjectIdList; - aMemberId: TBoldMemberId; - begin - aMemberId := TBoldMemberID.create(MemberIndex); - try - ObjectContents.EnsureMember(aMemberId, BoldMember.AsIBoldValue[bdepContents].ContentName); - finally - aMemberId.Free; - end; - aValue := ObjectContents.ValueByIndex[MemberIndex]; - if (aValue.BoldPersistenceState = bvpsInvalid) then - begin - if BoldMember.BoldMemberRTInfo.Persistent then - begin - BoldMember.EnsureContentsCurrent; - if not (BoldMember.BoldMemberRTInfo is TBoldRoleRTInfo) then - aValue.AssignContent(BoldMember.AsIBoldValue[bdepContents]) - else - begin - aRoleRT := BoldMember.BoldMemberRTInfo as TBoldRoleRTInfo; - if aRoleRT.IsMultiRole then - begin - if aRoleRT.IsIndirect then - begin - Ids1 := ExtractNewIdList(BoldMember.OwningObject.BoldMembers[aRoleRT.IndexOfLinkObjectRole] as TBoldObjectList); - Ids2 := ExtractNewIdList(BoldMember as TBoldObjectList); - (aValue as IBoldObjectIdListRefPair).SetFromIdLists(Ids1, Ids2); - Ids1.Free; - Ids2.Free; - end else - begin - Ids1 := ExtractNewIdList(BoldMember as TBoldObjectList); - (aValue as IBoldObjectIdListRef).SetFromIdList(Ids1); - Ids1.Free; - end; - end else - begin - if aRoleRT.IsIndirect then - (aValue as IBoldObjectIdRefPair).SetFromIds( - TBoldIdLocatorMapping(fMapping).EnsuredIdByLocator((BoldMember.OwningObject.BoldMembers[aRoleRT.IndexOfLinkObjectRole] as TBoldObjectReference).Locator), - TBoldIdLocatorMapping(fMapping).EnsuredIdByLocator((BoldMember as TBoldObjectReference).Locator)) - else - (aValue as IBoldObjectIdRef).SetFromId( - TBoldIdLocatorMapping(fMapping).EnsuredIdByLocator((BoldMember as TBoldObjectReference).Locator)); - end; - end; - end; - end; - end; - var i, j: Integer; aLocator: TBoldObjectLocator; @@ -249,17 +405,48 @@ procedure TBoldPersistenceControllerSystem.PMFetch( anObjectContent: IBoldObjectContents; aMember: TBoldMember; aMemberIndex: Integer; + + FetchIdList: TBoldObjectIdList; + ExactifyTranslationList: TBoldIdTranslationList; + lObjectList: TBoldObjectList; + Locator: TBoldObjectLocator; begin - for i := 0 to ObjectIdList.Count - 1 do + ExactifyTranslationList := TBoldIdTranslationList.Create; + FetchIdList := ObjectIdList.Clone; + try + PMExactifyIDs(FetchIdList, ExactifyTranslationList, false); + if ExactifyTranslationList.Count > 0 then + begin + ValueSpace.ExactifyIDs(ExactifyTranslationList); + ObjectIdList.ExactifyIds(ExactifyTranslationList); + FetchIdList.ExactifyIds(ExactifyTranslationList); + end; + + lObjectList := TBoldObjectList.Create; + try + for I := 0 to FetchIdList.Count - 1 do + begin + Locator := TBoldIdLocatorMapping(fMapping).LocatorById[FetchIdList[i]]; + if Assigned(Locator) then + lObjectList.AddLocator(Locator); + end; + if not lObjectList.Empty then + BoldSystem.FetchMembersWithObjects(lObjectList, MemberIdList); + finally + lObjectList.free; + end; + + for i := 0 to FetchIdList.Count - 1 do begin - anObjectContent := ValueSpace.EnsuredObjectContentsByObjectId[ObjectIdList[i]]; - aLocator := TBoldIdLocatorMapping(fMapping).LocatorById[ObjectIdList[i]]; + anObjectContent := ValueSpace.EnsuredObjectContentsByObjectId[FetchIdList[i]]; + aLocator := TBoldIdLocatorMapping(fMapping).LocatorById[FetchIdList[i]]; if not assigned(aLocator) then anObjectContent.BoldExistenceState := besDeleted else begin anObject := aLocator.EnsuredBoldObject; anObjectContent.BoldExistenceState := anObject.BoldExistenceState; + anObjectContent.TimeStamp := anObject.AsIBoldObjectContents[bdepContents].TimeStamp; if assigned(MemberIdList) then begin for j := 0 to MemberIdList.Count - 1 do @@ -272,12 +459,17 @@ procedure TBoldPersistenceControllerSystem.PMFetch( for j := 0 to anObject.BoldMemberCount - 1 do begin aMember := anObject.BoldMembers[j]; - if not aMember.BoldMemberRTInfo.DelayedFetch then + if (not aMember.BoldMemberRTInfo.DelayedFetch) and aMember.BoldMemberRTInfo.Persistent then FetchMember(anObjectContent, j, aMember); end; end; end; end; + + finally + ExactifyTranslationLIst.Free; + FetchIdList.Free; + end; end; procedure TBoldPersistenceControllerSystem.PMFetchIDListWithCondition( @@ -286,12 +478,31 @@ procedure TBoldPersistenceControllerSystem.PMFetchIDListWithCondition( var anObjectList: TBoldObjectList; i: Integer; + Locator: TBoldObjectLocator; + FetchIdList: TBoldObjectIdList; begin if Condition.classtype = TBoldConditionWithClass then begin anObjectList := BoldSystem.Classes[TBoldConditionWithClass(condition).TopSortedIndex]; for i := 0 to anObjectList.Count - 1 do ObjectIdList.Add(TBoldIdLocatorMapping(fMapping).EnsuredIdByLocator(anObjectList.locators[i])); + end + else + begin + FetchIdList := TBoldObjectIdList.Create; + try + BoldSystem.PersistenceController.PMFetchIDListWithCondition(FetchIdList, BoldSystem.AsIBoldvalueSpace[bdepPMIn], FetchMode, Condition, BoldClientId); + for i := 0 to FetchIdList.Count - 1 do + begin + Locator := BoldSystem.EnsuredLocatorByID[FetchIdList[i]]; + Assert(Assigned(Locator)); + ObjectIdList.Add(TBoldIdLocatorMapping(fMapping).EnsuredIdByLocator(Locator)); + ValueSpace.EnsuredObjectContentsByObjectId[ObjectIdList[i]]; + end; + Assert(FetchIdList.Count = ObjectIdList.Count); + finally + FetchIdList.free; + end; end; end; @@ -319,7 +530,7 @@ procedure TBoldPersistenceControllerSystem.PMUpdate( ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; - var TimeStamp: TBoldTimeStampType; BoldClientID: TBoldClientID); + var TimeStamp: TBoldTimeStampType; var TimeOfLatestUpdate: TDateTime; BoldClientID: TBoldClientID); procedure CopyValue(Value: IBoldValue; Member: TBoldMember); var @@ -337,7 +548,7 @@ procedure TBoldPersistenceControllerSystem.PMUpdate( TBoldObjectReference(Member).Locator := nil; end else - Member.AsIBoldValue[bdRemove].AssignContent(Value); { TODO : Check } + Member.AsIBoldValue[bdRemove].AssignContent(Value); end; var @@ -348,12 +559,23 @@ procedure TBoldPersistenceControllerSystem.PMUpdate( aClassName: string; NewId: TBoldObjectId; anObjectContents: IBoldObjectContents; + anOldObjectContents: IBoldObjectContents; aMember: TBoldMember; aValue: IBoldValue; OwnsTransList: Boolean; begin - // TODO: Support Preconditions. - + if BoldSystem.IsProcessingTransactionOrUpdatingDatabase then + raise EBold.Create('Destination BoldSystem IsProcessingTransactionOrUpdatingDatabase.'); + if BoldSystem.InTransaction then + raise EBold.Create('Destination BoldSystem InTransaction.'); + + if assigned(Precondition) then + begin // TODO: Implement + if Precondition is TBoldOptimisticLockingPrecondition then +// if not EnsurePrecondition(Precondition, translationList) then +// exit; + end; + TimeOfLatestUpdate := now; if not assigned(TranslationList) then begin TranslationList := TBoldIDTranslationList.Create; @@ -362,53 +584,68 @@ procedure TBoldPersistenceControllerSystem.PMUpdate( else OwnsTransList := False; - for i := 0 to ObjectIdList.Count - 1 do - begin - anId := ObjectIdList[i]; - if not anId.IsStorable then - begin - aClassName := BoldSystem.BoldSystemTypeInfo.TopSortedClasses[anId.TopSortedIndex].ExpressionName; - anObject := BoldSystem.CreateNewObjectByExpressionName(aClassName); - NewId := TBoldIdLocatorMapping(fMapping).EnsuredIdByLocator(anObject.BoldObjectLocator); - TranslationList.AddTranslation(anId, NewId); - end else + BoldSystem.StartTransaction(); + try + for i := 0 to ObjectIdList.Count - 1 do begin - aLocator := TBoldIdLocatorMapping(fMapping).LocatorById[anId]; - if assigned(aLocator) then - anObject := aLocator.BoldObject - else - anObject := nil; - end; + anId := ObjectIdList[i]; + if not anId.IsStorable then + begin + aClassName := BoldSystem.BoldSystemTypeInfo.TopSortedClasses[anId.TopSortedIndex].ExpressionName; + anObject := BoldSystem.CreateNewObjectByExpressionName(aClassName); + NewId := TBoldIdLocatorMapping(fMapping).EnsuredIdByLocator(anObject.BoldObjectLocator); + TranslationList.AddTranslation(anId, NewId); + end else + begin + aLocator := TBoldIdLocatorMapping(fMapping).LocatorById[anId]; + if assigned(aLocator) then + anObject := aLocator.BoldObject + else + anObject := nil; // means object is deleted in destination system + end; - if assigned(anObject) then - begin - anObjectContents := ValueSpace.EnsuredObjectContentsByObjectId[anId]; - if anObjectContents.BoldExistenceState = besDeleted then - anObject.Delete - else + if assigned(anObject) then begin - for j := 0 to anObject.BoldMemberCount - 1 do + anOldObjectContents := Old_Values.ObjectContentsByObjectId[anId]; + if Assigned(anOldObjectContents) and (anObject.AsIBoldObjectContents[bdepPMIn].TimeStamp <> anOldObjectContents.TimeStamp) then begin - aMember := anObject.BoldMembers[j]; - aValue := anObjectContents.ValueByIndex[j]; - if aMember.BoldMemberRTInfo.Persistent and aMember.BoldMemberRTInfo.IsStoredInObject and - assigned(aValue) and ((aValue.BoldPersistenceState = bvpsModified) or BoldSystem.BoldSystemTypeInfo.UpdateWholeObjects) then - CopyValue(aValue, aMember); + BoldLog.LogFmt('Optimistic Locking TimeStamp failed for %.', [ + anObject.DisplayName]); + raise EBold.CreateFmt('Optimistic Locking failed for object:%s.', [anObject.DisplayName]); + end; + anObjectContents := ValueSpace.EnsuredObjectContentsByObjectId[anId]; + if anObjectContents.BoldExistenceState = besDeleted then + anObject.Delete + else + begin + for j := 0 to anObject.BoldMemberCount - 1 do + begin + aMember := anObject.BoldMembers[j]; + aValue := anObjectContents.ValueByIndex[j]; + if Assigned(anOldObjectContents) and Assigned(anOldObjectContents.ValueByIndex[j]) and not aMember.IsEqualToValue(anOldObjectContents.ValueByIndex[j]) then + raise EBold.CreateFmt('Optimistic Locking failed for member %s.', [aMember.DisplayName]); + if aMember.BoldMemberRTInfo.Persistent and aMember.BoldMemberRTInfo.IsStoredInObject and + assigned(aValue) and ((aValue.BoldPersistenceState = bvpsModified) or BoldSystem.BoldSystemTypeInfo.UpdateWholeObjects) then + CopyValue(aValue, aMember); + end; end; end; end; - end; - ValueSpace.ApplytranslationList(TranslationList); + ValueSpace.ApplytranslationList(TranslationList); - if OwnsTransList then - TranslationList.Free; + if OwnsTransList then + TranslationList.Free; + BoldSystem.CommitTransaction(); + except + BoldSystem.RollbackTransaction(); + raise; + end; end; procedure TBoldPersistenceControllerSystem.ReserveNewIds(ValueSpace: IBoldValueSpace; ObjectIdList: TBoldObjectIdList; TranslationList: TBoldIdTranslationList); begin - // do nothing, but implementation needed, as method is abstract in superclass end; procedure TBoldPersistenceControllerSystem.SetBoldSystem(System: TBoldSystem); @@ -431,146 +668,4 @@ procedure TBoldPersistenceControllerSystem._LocatorDestroyedReceived( TBoldIdLocatorMapping(fMapping).RemoveByLocator((Args[0].VObject as TBoldObject).BoldObjectLocator); end; -{ TBoldIdLocatorMapping } - -procedure TBoldIdLocatorMapping.AddPair(Id: TBoldObjectId; Locator: TBoldObjectLocator); -begin - Add(TBoldIdLocatorPair.Create(Id, Locator)); -end; - -constructor TBoldIdLocatorMapping.Create; -begin - inherited; - SetIndexVariable(IX_MappingIdIndex, AddIndex(TBoldMappingIdIndex.Create)); - SetIndexVariable(IX_MappingLocatorIndex, AddIndex(TBoldMappingLocatorIndex.Create)); - fNextId := 1; -end; - -function TBoldIdLocatorMapping.EnsuredIdByLocator( - Locator: TBoldObjectLocator): TBoldObjectId; -var - NewId: TBoldDefaultId; -begin - if not assigned(Locator) then - result := nil - else - begin - result := IdByLocator[Locator]; - if not assigned(result) then - begin - NewId := TBoldDefaultId.CreateWithClassID(Locator.BoldObjectID.TopSortedIndex, Locator.BoldObjectID.TopSortedIndexExact); - NewId.AsInteger := fNextId; - inc(fNextId); - AddPair(NewId, Locator); - NewId.Free; - result := IdByLocator[Locator]; - end; - end; -end; - -procedure TBoldIdLocatorMapping.ExactifyClassForLocator( - Locator: TBoldObjectLocator; ExactClassId: Integer); -var - NewId: TBoldObjectId; - aPair: TBoldIdLocatorPair; -begin - aPair := GetPairByLocator(Locator); - NewId := aPair.fId.CloneWithClassId(ExactClassId, True); - aPair.fId.Free; - aPair.fId := NewId; -end; - -function TBoldIdLocatorMapping.GetIdByLocator(Locator: TBoldObjectLocator): TBoldObjectId; -var - aPair: TBoldIdLocatorPair; -begin - aPair := GetPairByLocator(Locator); - if assigned(aPair) then - result := aPair.fId - else - result := nil; -end; - -function TBoldIdLocatorMapping.GetLocatorById( - ID: TBoldObjectId): TBoldObjectLocator; -var - aPair: TBoldIdLocatorPair; -begin - aPair := TBoldIdLocatorPair(Indexes[IX_MappingIdIndex].Find(Id)); - if assigned(aPair) then - result := aPair.fLocator - else - result := nil; -end; - -function TBoldIdLocatorMapping.GetPairByLocator( - Locator: TBoldObjectLocator): TBoldIdLocatorPair; -begin - result := TBoldIdLocatorPair(Indexes[IX_MappingLocatorIndex].Find(Locator)); -end; - -procedure TBoldIdLocatorMapping.RemoveByLocator( - Locator: TBoldObjectLocator); -var - aPair: TBoldIdLocatorPair; -begin - aPair := GetPairByLocator(Locator); - if assigned(aPair) then - Remove(aPair); -end; - -{ TBoldMappingIdIndex } - -function TBoldMappingIdIndex.Hash(const Key): Cardinal; -begin - Assert(TObject(Key) is TBoldObjectId); - Result := TBoldObjectId(Key).Hash; -end; - -function TBoldMappingIdIndex.HashItem(Item: TObject): Cardinal; -begin - result := (Item as TBoldIdLocatorPair).fId.Hash; -end; - -function TBoldMappingIdIndex.Match(const Key; Item: TObject): Boolean; -begin - Assert(TObject(Key) is TBoldObjectId); - result := TBoldObjectId(Key).IsEqual[TBoldIdLocatorPair(Item).fId]; -end; - -{ TBoldMappingLocatorIndex } - -function TBoldMappingLocatorIndex.Hash(const Key): Cardinal; -begin - Assert(TObject(Key) is TBoldObjectLocator); - Result := TBoldObjectLocator(Key).Hash; -end; - -function TBoldMappingLocatorIndex.HashItem(Item: TObject): Cardinal; -begin - result := (Item as TBoldIdLocatorPair).fLocator.Hash; -end; - -function TBoldMappingLocatorIndex.Match(const Key; Item:TObject): Boolean; -begin - Assert(TObject(Key) is TBoldObjectLocator); - Assert(Item is TBoldIdLocatorPair); - result := TBoldObjectLocator(Key) = TBoldIdLocatorPair(Item).fLocator; -end; - -{ TBoldIdLocatorPair } - -constructor TBoldIdLocatorPair.Create(Id: TBoldObjectId; - Locator: TBoldObjectLocator); -begin - fLocator := Locator; - fId := Id.Clone; -end; - -destructor TBoldIdLocatorPair.Destroy; -begin - FreeAndNil(fId); - inherited; -end; - end. diff --git a/Source/Persistence/System/BoldPersistenceHandleSystem.pas b/Source/Persistence/System/BoldPersistenceHandleSystem.pas index 25db9a03..9dd65947 100644 --- a/Source/Persistence/System/BoldPersistenceHandleSystem.pas +++ b/Source/Persistence/System/BoldPersistenceHandleSystem.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPersistenceHandleSystem; interface @@ -6,24 +9,39 @@ interface BoldSystemhandle, BoldPersistenceController, BoldPersistenceControllerSystem, - BoldPersistenceHandle; + BoldPersistenceHandle, + BoldSubscription; type + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldPersistenceHandleSystem = class(TBoldPersistenceHandle) private fSystemHandle: TBoldSystemHandle; + fSystemHandleSubscriber: TBoldPassthroughSubscriber; function GetPersistenceControllerSystem: TBoldPersistenceControllerSystem; + procedure SetSystemHandle(const Value: TBoldSystemHandle); + procedure PlaceSubscriptions; + function GetSubscriber: TBoldSubscriber; + procedure ReceiveFromSystemHandle(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); protected function CreatePersistenceController: TBoldPersistenceController; override; procedure SetActive(Value: Boolean); override; + property Subscriber: TBoldSubscriber read GetSubscriber; public + destructor Destroy; override; property PersistenceControllerSystem: TBoldPersistenceControllerSystem read GetPersistenceControllerSystem; published - property SystemHandle: TBoldSystemHandle read fSystemHandle write fSystemHandle; + property SystemHandle: TBoldSystemHandle read fSystemHandle write SetSystemHandle; end; implementation +uses + SysUtils, + BoldHandles, + + BoldRev; + { TBoldPersistenceHandleSystem } function TBoldPersistenceHandleSystem.CreatePersistenceController: TBoldPersistenceController; @@ -31,11 +49,44 @@ function TBoldPersistenceHandleSystem.CreatePersistenceController: TBoldPersiste result := TBoldPersistenceControllerSystem.Create; end; +destructor TBoldPersistenceHandleSystem.Destroy; +begin + FreeAndNil(fSystemHandleSubscriber); + inherited; +end; + function TBoldPersistenceHandleSystem.GetPersistenceControllerSystem: TBoldPersistenceControllerSystem; begin result := PersistenceController as TBoldPersistenceControllerSystem; end; +function TBoldPersistenceHandleSystem.GetSubscriber: TBoldSubscriber; +begin + if not Assigned(fSystemHandleSubscriber) then + fSystemHandleSubscriber := TBoldPassthroughSubscriber.Create(ReceiveFromSystemHandle); + result := fSystemHandleSubscriber; +end; + +procedure TBoldPersistenceHandleSystem.PlaceSubscriptions; +begin + Subscriber.CancelAllSubscriptions; + if Assigned(SystemHandle) then + begin + SystemHandle.AddSmallSubscription(Subscriber, [beDestroying], beDestroying); + SystemHandle.AddSmallSubscription(Subscriber, [beValueIdentityChanged], beValueIdentityChanged); + end; +end; + +procedure TBoldPersistenceHandleSystem.ReceiveFromSystemHandle( + Originator: TObject; OriginalEvent: TBoldEvent; + RequestedEvent: TBoldRequestedEvent); +begin + case RequestedEvent of + beDestroying: SystemHandle := nil; + beValueIdentityChanged: PersistenceControllerSystem.BoldSystem := fSystemHandle.System; + end; +end; + procedure TBoldPersistenceHandleSystem.SetActive(Value: Boolean); begin if value <> Active then begin @@ -45,4 +96,19 @@ procedure TBoldPersistenceHandleSystem.SetActive(Value: Boolean); inherited; end; +procedure TBoldPersistenceHandleSystem.SetSystemHandle( + const Value: TBoldSystemHandle); +begin + if Value = fSystemHandle then + exit; + fSystemHandle := Value; + if Assigned(Value) then + PersistenceControllerSystem.BoldSystem := Value.System + else + PersistenceControllerSystem.BoldSystem := nil; + PlaceSubscriptions; +end; + +initialization + end. diff --git a/Source/Persistence/UDPPropagator/BoldAbstractModificationPropagator.pas b/Source/Persistence/UDPPropagator/BoldAbstractModificationPropagator.pas index b46aa381..a12bd589 100644 --- a/Source/Persistence/UDPPropagator/BoldAbstractModificationPropagator.pas +++ b/Source/Persistence/UDPPropagator/BoldAbstractModificationPropagator.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAbstractModificationPropagator; interface @@ -22,7 +25,7 @@ interface BoldThreadSafeQueue; type - TReceivePropagatorEvent = procedure(Sender: TObject; Event: String) of object; + TReceivePropagatorEvent = procedure(Sender: TObject; const Event: String) of object; { Forward declaration } TBoldAbstractNotificationPropagator = class; @@ -35,7 +38,7 @@ TBoldNotificationPropagatorPersistenceControllerPassthrough = class(TBoldAbstr fClientId: TBoldClientid; public constructor Create(MoldModel: TMoldModel; ClientId: TBoldClientId); - procedure PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; BoldClientID: TBoldClientID); override; + procedure PMUpdate(ObjectIdList: TBoldObjectIdList; ValueSpace: IBoldValueSpace; Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; var TimeStamp: TBoldTimeStampType; var TimeOfLatestUpdate: TDateTime; BoldClientID: TBoldClientID); override; procedure TransmitEvents(const ClientID: TBoldClientID); override; property BoldNotificationPropagator: TBoldAbstractNotificationPropagator read FBoldNotificationPropagator write FBoldNotificationPropagator; property ClientId: TBoldClientId read fClientId; @@ -54,9 +57,10 @@ TBoldAbstractNotificationPropagator = class(TBoldPersistenceHandlePassthrough) function GetController: TBoldNotificationPropagatorPersistenceControllerPassthrough; protected { Puts one event in the out-queue } - procedure EnqueEvent(Event: String); + procedure EnqueEvent(const Event: String); + procedure EnqueEventList(const aEventList: TStrings); { Decodes and enques a received event from the in-queue } - procedure ReceiveEvent(Event: String); virtual; + procedure ReceiveEvent(const Event: String); virtual; procedure OnReceiveQueueNotEmpty(Sender: TBoldThreadSafeQueue); virtual; { The following method must be overridden in the inheriting classes } @@ -91,14 +95,14 @@ constructor TBoldAbstractNotificationPropagator.Create(AOwner: TComponent); begin inherited; - FReceiveQueue := TBoldThreadSafeStringQueue.Create('NotificationPropagator/Receive'); // do not localize + FReceiveQueue := TBoldThreadSafeStringQueue.Create('NotificationPropagator/Receive'); FReceiveQueue.OnQueueNotEmpty := OnReceiveQueueNotEmpty; - FSendQueue := TBoldThreadSafeStringQueue.Create('NotificationPropagator/Send'); // do not localize + FSendQueue := TBoldThreadSafeStringQueue.Create('NotificationPropagator/Send'); FSendQueue.OnQueueNotEmpty := OnSendQueueNotEmpty; - FRefreshQueue := TBoldThreadSafeStringQueue.Create('NotificationPropagator/Refresh'); // do not localize - fClientId := 0; // Do we need unique clientIds for any reason? + FRefreshQueue := TBoldThreadSafeStringQueue.Create('NotificationPropagator/Refresh'); + fClientId := 0; end; destructor TBoldAbstractNotificationPropagator.Destroy; @@ -116,13 +120,19 @@ destructor TBoldAbstractNotificationPropagator.Destroy; end; { Put a single event in the out-queue } -procedure TBoldAbstractNotificationPropagator.EnqueEvent(Event: String); +procedure TBoldAbstractNotificationPropagator.EnqueEvent(const Event: String); begin FSendQueue.Enqueue(Event); end; +procedure TBoldAbstractNotificationPropagator.EnqueEventList( + const aEventList: TStrings); +begin + FSendQueue.EnqueueList(aEventList); +end; + { Decodes and deques a single event } -procedure TBoldAbstractNotificationPropagator.ReceiveEvent(Event: String); +procedure TBoldAbstractNotificationPropagator.ReceiveEvent(const Event: String); var AClassName, AMemberName, ALockName: String; begin @@ -135,8 +145,6 @@ procedure TBoldAbstractNotificationPropagator.ReceiveEvent(Event: String); if TBoldObjectSpaceExternalEvent.DecodeExternalEvent(Event, AClassName, AMemberName, ALockName, nil) in [bsClassChanged] then FRefreshQueue.Enqueue(AClassName); - - //FRefreshQueue.Enqueue(Event); end; if Assigned(FOnReceiveEvent) then @@ -164,6 +172,7 @@ function TBoldAbstractNotificationPropagator.CreatePersistenceController: TBoldP Result := TempController; end; + function TBoldAbstractNotificationPropagator.GetController: TBoldNotificationPropagatorPersistenceControllerPassthrough; begin result := PersistenceController as TBoldNotificationPropagatorPersistenceControllerPassthrough; @@ -181,17 +190,18 @@ procedure TBoldNotificationPropagatorPersistenceControllerPassthrough.PMUpdate( ObjectIdList: TBoldObjectIdList; ValueSpace, Old_Values: IBoldValueSpace; Precondition: TBoldUpdatePrecondition; TranslationList: TBoldIdTranslationList; - var TimeStamp: TBoldTimeStampType; BoldClientID: TBoldClientID); + var TimeStamp: TBoldTimeStampType; var TimeOfLatestUpdate: TDateTime; BoldClientID: TBoldClientID); begin - inherited PMUpdate(ObjectIdList, valueSpace, Old_Values, PreCondition, TranslationList, TimeStamp, ClientId); + inherited PMUpdate(ObjectIdList, valueSpace, Old_Values, PreCondition, TranslationList, TimeStamp, TimeOfLatestUpdate, ClientId); end; procedure TBoldNotificationPropagatorPersistenceControllerPassthrough.TransmitEvents(const ClientID: TBoldClientID); -var - i: integer; begin - for i := 0 to Events.Count-1 do - BoldNotificationPropagator.EnqueEvent(Events[i]); + try + BoldNotificationPropagator.EnqueEventList(Events); + finally + ClearEvents; + end; end; end. diff --git a/Source/Persistence/UDPPropagator/BoldUDPModificationBroadcaster.pas b/Source/Persistence/UDPPropagator/BoldUDPModificationBroadcaster.pas index 688b8591..1f6f9995 100644 --- a/Source/Persistence/UDPPropagator/BoldUDPModificationBroadcaster.pas +++ b/Source/Persistence/UDPPropagator/BoldUDPModificationBroadcaster.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUDPModificationBroadcaster; interface @@ -12,6 +15,7 @@ interface BoldAbstractModificationPropagator, { Indy } + IdGlobal, IdUDPClient, IdUDPServer, IdSocketHandle; @@ -24,6 +28,7 @@ TBoldUDPModificationBroadcaster = class; TActivationErrorEvent = procedure(Sender: TObject; E: Exception) of object; { TBoldUDPModificationBroadcaster } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldUDPModificationBroadcaster = class(TBoldAbstractNotificationPropagator) private fUDPClient: TIdUDPClient; @@ -34,14 +39,13 @@ TBoldUDPModificationBroadcaster = class(TBoldAbstractNotificationPropagator) protected procedure OnSendQueueNotEmpty(Sender: TBoldThreadSafeQueue); override; procedure SetActive(Value: Boolean); override; - procedure InternalUDPRead(Sender: TObject; AData: TStream; ABinding: TIdSocketHandle); + procedure InternalUDPRead(AThread: TIdUDPListenerThread; const AData: TIdBytes; ABinding: TIdSocketHandle); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; published property Port: Integer read GetPort write SetPort; property OnActivationError: TActivationErrorEvent read FOnActivationError write FOnActivationError; - // inherited properties {$IFNDEF T2H} property NextPersistenceHandle; property Active; @@ -69,8 +73,9 @@ constructor TBoldUDPModificationBroadcaster.Create(AOwner: TComponent); fUDPServer := TIdUDPServer.Create(Self); fUDPClient.BroadcastEnabled := True; fUDPServer.OnUDPRead := InternalUDPRead; +// procedure(AThread: TIdUDPListenerThread; const AData: TIdBytes; ABinding: TIdSocketHandle) - fUDPClient.Host := '255.255.255.255'; // do not localize + fUDPClient.Host := '255.255.255.255'; fUDPClient.Port := 4098; fUDPServer.DefaultPort := 4098; @@ -121,19 +126,13 @@ procedure TBoldUDPModificationBroadcaster.SetPort(Value: Integer); fUDPServer.Bindings.Add.Port := Value; end; -procedure TBoldUDPModificationBroadcaster.InternalUDPRead(Sender: TObject; AData: TStream; - ABinding: TIdSocketHandle); +procedure TBoldUDPModificationBroadcaster.InternalUDPRead(AThread: TIdUDPListenerThread; const AData: TIdBytes; ABinding: TIdSocketHandle); var S: String; begin - if AData.Size - AData.Position > 0 then - begin - SetLength(S, AData.Size - AData.Position); - AData.Read(S[1], Length(S)); - if Length(S) > 0 then - if SameText(Copy(S, 1, Length(SIdentification)), SIdentification) then - ReceiveEvent(Copy(S, Length(SIdentification) + 1, Length(S))); - end; + s := BytesToString(AData); + if SameText(Copy(S, 1, Length(SIdentification)), SIdentification) then + ReceiveEvent(Copy(S, Length(SIdentification) + 1, Length(S))); end; procedure TBoldUDPModificationBroadcaster.OnSendQueueNotEmpty(Sender: TBoldThreadSafeQueue); @@ -142,7 +141,7 @@ procedure TBoldUDPModificationBroadcaster.OnSendQueueNotEmpty(Sender: TBoldThrea BoldEffectiveEnvironment.ProcessMessages; while not SendQueue.Empty do - fUDPClient.Send('255.255.255.255', // do not localize + fUDPClient.Send('255.255.255.255', fUDPClient.Port, SIdentification + SendQueue.Dequeue); end; diff --git a/Source/Persistence/UniDAC/BoldDatabaseAdapterUniDAC.pas b/Source/Persistence/UniDAC/BoldDatabaseAdapterUniDAC.pas new file mode 100644 index 00000000..0237bf3a --- /dev/null +++ b/Source/Persistence/UniDAC/BoldDatabaseAdapterUniDAC.pas @@ -0,0 +1,95 @@ +{ Global compiler directives } +{$include bold.inc} +unit BoldDatabaseAdapterUniDAC; + +interface + +uses + Classes, + BoldAbstractDataBaseAdapter, + BoldDBInterfaces, + BoldUniDACInterfaces, + Uni; + +type + { forward declarations } + TBoldDatabaseAdapterUniDAC = class; + + { TBoldDatabaseAdapterUniDAC } + TBoldDatabaseAdapterUniDAC = class(TBoldAbstractDatabaseAdapter) + private + fBoldUniDACConnection: TBoldUniDACConnection; + procedure SetConnection(const Value: TUniConnection); + function GetConnection: TUniConnection; + protected + procedure ReleaseBoldDatabase; override; + function GetDataBaseInterface: IBoldDatabase; override; + public + destructor Destroy; override; + procedure CreateDatabase(DropExisting: boolean = true); override; + procedure DropDatabase; override; + published + property Connection: TUniConnection read GetConnection write SetConnection; + {$IFNDEF T2H} + property DatabaseEngine; + {$ENDIF} + end; + +implementation + +uses + BoldSQLDatabaseConfig, + SysUtils, + BoldDefs, + UniDACConsts; + +{ TBoldDatabaseAdapterUniDAC } + +destructor TBoldDatabaseAdapterUniDAC.Destroy; +begin + Changed; + FreePublisher; + FreeAndNil(fBoldUniDACConnection); + inherited; +end; + +procedure TBoldDatabaseAdapterUniDAC.DropDatabase; +begin + DatabaseInterface.DropDatabase; +end; + +procedure TBoldDatabaseAdapterUniDAC.CreateDatabase(DropExisting: boolean); +begin + DatabaseInterface.CreateDatabase(DropExisting); +end; + +function TBoldDatabaseAdapterUniDAC.GetConnection: TUniConnection; +begin + Result := InternalDatabase as TUniConnection; +end; + +function TBoldDatabaseAdapterUniDAC.GetDataBaseInterface: IBoldDatabase; +begin + if not Assigned(Connection) then + begin + raise EBold.CreateFmt(sAdapterNotConnected, [ClassName]); + end; + if not Assigned(fBoldUniDACConnection) then + begin + fBoldUniDACConnection := TBoldUniDACConnection.Create(Connection, SQLDataBaseConfig); + end; + Result := fBoldUniDACConnection; +end; + +procedure TBoldDatabaseAdapterUniDAC.ReleaseBoldDatabase; +begin + FreeAndNil(fBoldUniDACConnection); +end; + +procedure TBoldDatabaseAdapterUniDAC.SetConnection(const Value: TUniConnection); +begin + InternalDatabase := Value; +end; + +end. + diff --git a/Source/Persistence/UniDAC/BoldPersistenceHandleUniDACReg.pas b/Source/Persistence/UniDAC/BoldPersistenceHandleUniDACReg.pas new file mode 100644 index 00000000..7472df04 --- /dev/null +++ b/Source/Persistence/UniDAC/BoldPersistenceHandleUniDACReg.pas @@ -0,0 +1,24 @@ +{ Global compiler directives } +{$include bold.inc} +unit BoldPersistenceHandleUniDACReg; + +interface + +procedure Register; + +implementation + +//{$R BoldPersistenceHandleUniDAC.res} + +uses + SysUtils, + Classes, + BoldDatabaseAdapterUniDAC, + BoldIDEConsts; + +procedure Register; +begin + RegisterComponents(BOLDPAGENAME_PERSISTENCE, [TBoldDatabaseAdapterUniDAC]); +end; + +end. diff --git a/Source/Persistence/UniDAC/BoldUniDACInterfaces.pas b/Source/Persistence/UniDAC/BoldUniDACInterfaces.pas new file mode 100644 index 00000000..a4ac1518 --- /dev/null +++ b/Source/Persistence/UniDAC/BoldUniDACInterfaces.pas @@ -0,0 +1,1681 @@ + +///////////////////////////////////////////////////////// +// // +// Bold for Delphi // +// Copyright (c) 1996-2002 Boldsoft AB // +// (c) 2002-2005 Borland Software Corp // +// // +///////////////////////////////////////////////////////// + +{ Global compiler directives } +{$include bold.inc} +unit BoldUniDACInterfaces; + +interface + +uses + Classes, + Db, + SysUtils, + Uni, + UniProvider, + MemDS, + BoldSQLDatabaseConfig, + BoldDBInterfaces, + BoldDefs; + +type + { forward declarations } + TBoldUniDACParameter = class; + TBoldUniDACQuery = class; + TBoldUniDACTable = class; + TBoldUniDACConnection = class; + + TBoldUniDACQueryClass = class of TBoldUniDACQuery; + TBoldUniDACExecQueryClass = class of TBoldUniDACExecQuery; + + { TBoldUniDACParameter } + TBoldUniDACParameter = class(TBoldParameterWrapper, IBoldParameter) + private + fUniParam: TUniParam; + function GetAsVariant: Variant; + procedure SetAsVariant(const NewValue: Variant); + function GetName: string; + procedure Clear; + function GetDataType: TFieldType; + procedure SetDataType(Value: TFieldType); + function GetAsBCD: Currency; + function GetAsblob: TBoldBlobData; + function GetAsBoolean: Boolean; + function GetAsDateTime: TDateTime; + function GetAsCurrency: Currency; + function GetAsFloat: Double; + function GetAsInteger: Longint; + function GetAsInt64: Int64; + function GetAsMemo: string; + function GetAsString: string; + function GetIsNull: Boolean; + function GetAsWideString: WideString; + procedure SetAsBCD(const Value: Currency); + procedure SetAsBlob(const Value: TBoldBlobData); + procedure SetAsBoolean(Value: Boolean); + procedure SetAsCurrency(const Value: Currency); + procedure SetAsDate(const Value: TDateTime); + procedure SetAsDateTime(const Value: TDateTime); + procedure SetAsFloat(const Value: Double); + procedure SetAsInteger(Value: Longint); + procedure SetAsInt64(const Value: Int64); + procedure SetAsMemo(const Value: string); + procedure SetAsString(const Value: string); + procedure SetAsSmallInt(Value: Longint); + procedure SetAsTime(const Value: TDateTime); + procedure SetAsWord(Value: Longint); + procedure SetText(const Value: string); + procedure SetAsWideString(const Value: Widestring); + function GetAsAnsiString: TBoldAnsiString; + procedure SetAsAnsiString(const Value: TBoldAnsiString); + function GetUniParam: TUniParam; + procedure AssignFieldValue(const source: IBoldField); + procedure Assign(const source: IBoldParameter); + property UniParam: TUniParam read GetUniParam; + public + constructor Create(UniDACParameter: TUniParam; DatasetWrapper: TBoldAbstractQueryWrapper); + end; + + { TBoldUniDACQuery } + TBoldUniDACQuery = class(TBoldBatchDataSetWrapper, IBoldQuery, IBoldExecQuery, IBoldParameterized) + private + fQuery: TUniQuery; + fReadTransactionStarted: Boolean; + fUseReadTransactions: boolean; + function GetQuery: TUniQuery; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure AssignParams(Sourceparams: TParams); + function GetParamCount: Integer; + function GetParam(i: Integer): IBoldParameter; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetParamCheck: Boolean; + procedure SetParamCheck(value: Boolean); + function GetRequestLiveQuery: Boolean; + function ParamByName(const Value: string): IBoldParameter; override; + function FindParam(const Value: string): IBoldParameter; override; + function Createparam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; override; + procedure SetRequestLiveQuery(NewValue: Boolean); + procedure AssignSQL(SQL: TStrings); virtual; + function GetSQLStrings: TStrings; override; + function GetRecordCount: Integer; + function GetUseReadTransactions: boolean; + procedure SetUseReadTransactions(value: boolean); + procedure BeginExecuteQuery; + procedure EndExecuteQuery; + protected + function GetParams: TParams; override; + function GetSqlText: string; override; + procedure AssignSQLText(const SQL: string); override; + function GetRowsAffected: Integer; + function GetDataSet: TDataSet; override; + procedure ClearParams; + procedure Open; override; + procedure Close; override; + procedure ExecSQL; override; + function GetRecNo: integer; override; + property Query: TUniQuery read GetQuery; + public + constructor Create(BoldUniDACConnection: TBoldUniDACConnection); reintroduce; + destructor Destroy; override; + procedure Clear; override; + end; + + { TBoldUniDACQuery } + TBoldUniDACExecQuery = class(TBoldAbstractQueryWrapper, IBoldExecQuery, IBoldParameterized) + private + fExecQuery: TUniSQL; + fReadTransactionStarted: Boolean; + fUseReadTransactions: boolean; + function GetExecQuery: TUniSQL; + function GetParams: TParams; + procedure AssignParams(Sourceparams: TParams); + function GetParamCount: Integer; + function GetParam(i: Integer): IBoldParameter; + function GetParamCheck: Boolean; + procedure SetParamCheck(value: Boolean); + function ParamByName(const Value: string): IBoldParameter; + function FindParam(const Value: string): IBoldParameter; + function Createparam(FldType: TFieldType; const ParamName: string): IBoldParameter; overload; + function CreateParam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; overload; + function EnsureParamByName(const Value: string): IBoldParameter; + function GetSQLText: string; + function GetSQLStrings: TStrings; + procedure AssignSQL(SQL: TStrings); virtual; + procedure AssignSQLText(const SQL: string); + function GetRowsAffected: Integer; + function GetUseReadTransactions: boolean; + procedure SetUseReadTransactions(value: boolean); + procedure BeginExecuteQuery; + procedure EndExecuteQuery; + function GetBatchQueryParamCount: integer; +// procedure Prepare; + protected + procedure StartSQLBatch; virtual; + procedure EndSQLBatch; virtual; + procedure FailSQLBatch; virtual; + procedure ClearParams; + procedure ExecSQL; virtual; + property ExecQuery: TUniSQL read GetExecQuery; + public + constructor Create(BoldUniDACConnection: TBoldUniDACConnection); reintroduce; + destructor Destroy; override; + procedure Clear; override; + end; + + { TBoldUniDACTable } + TBoldUniDACTable = class(TBoldDatasetWrapper, IBoldTable) + private + fUniTable: TUniTable; + function GetUniTable: TUniTable; + property UniTable: TUniTable read GetUniTable; + procedure AddIndex(const Name, Fields: string; Options: TIndexOptions; const DescFields: string = ''); + procedure CreateTable; + procedure DeleteTable; + function GetIndexDefs: TIndexDefs; + procedure SetTableName(const NewName: string); + function GetTableName: string; + procedure SetExclusive(NewValue: Boolean); + function GetExclusive: Boolean; + function GetExists: Boolean; +// function GetCommaListOfIndexesForColumn(const aColumnName: string): string; +// function GetPrimaryIndex: string; + protected + function GetDefaultConstraintNameForColumn(const aColumnName: string): string; {override;} + function GetDataSet: TDataSet; override; + function ParamByName(const Value: string): IBoldParameter; override; + function FindParam(const Value: string): IBoldParameter; override; + public + constructor Create(aUniTable: TUniTable; BoldUniDACConnection: TBoldUniDACConnection); reintroduce; + end; + + { TBoldUniDACConnection } + TBoldUniDACConnection = class(TBoldDatabaseWrapper, IBoldDataBase) + fUniConnection: TUniConnection; + fCachedTable: TBoldUniDACTable; + fCachedQuery1: TBoldUniDACQuery; + fCachedQuery2: TBoldUniDACQuery; + fCachedExecQuery1: TBoldUniDACQuery; + fExecuteQueryCount: integer; + function GetUniConnection: TUniConnection; + property UniConnection: TUniConnection read GetUniConnection; + function GetConnected: Boolean; + function GetInTransaction: Boolean; + function GetIsSQLBased: Boolean; + procedure SetlogInPrompt(NewValue: Boolean); + function GetLogInPrompt: Boolean; + procedure SetKeepConnection(NewValue: Boolean); + function GetKeepConnection: Boolean; + procedure StartTransaction; + procedure StartReadTransaction; + procedure Commit; + procedure RollBack; + procedure Open; + procedure Close; + procedure Reconnect; + function SupportsTableCreation: Boolean; + procedure ReleaseCachedObjects; + function GetIsExecutingQuery: Boolean; + procedure BeginExecuteQuery; + procedure EndExecuteQuery; + protected + procedure AllTableNames(Pattern: string; ShowSystemTables: Boolean; TableNameList: TStrings); override; + function GetTable: IBoldTable; override; + function GetQuery: IBoldQuery; override; + function GetExecQuery: IBoldExecQuery; override; + procedure ReleaseTable(var Table: IBoldTable); override; + procedure ReleaseQuery(var Query: IBoldQuery); override; + procedure ReleaseExecQuery(var Query: IBoldExecQuery); override; + public + constructor Create(aUniConnection: TUniConnection; SQLDataBaseConfig: TBoldSQLDatabaseConfig); + destructor Destroy; override; + procedure CreateDatabase(DropExisting: boolean = true); override; + procedure DropDatabase; override; + function DatabaseExists: boolean; override; + function GetDatabaseError(const E: Exception; const sSQL: string = ''): + EBoldDatabaseError; + property ExecuteQueryCount: integer read fExecuteQueryCount; + end; + +var + BoldUniDACQueryClass: TBoldUniDACQueryClass = TBoldUniDACQuery; + BoldUniDACExecQueryClass: TBoldUniDACExecQueryClass = TBoldUniDACExecQuery; + +implementation + +uses + Variants, + Masks, + + BoldUtils, + BoldGuard, + BoldCoreConsts, + + CRAccess, + UniScript; + +{ TBoldUniDACQuery } + +function TBoldUniDACQuery.GetQuery: TUniQuery; +begin + if not Assigned(fQuery) then + begin + fQuery := TUniQuery.Create(nil); + fQuery.Connection := (DatabaseWrapper as TBoldUniDACConnection).UniConnection; + end; + Result := fQuery; +end; + +function TBoldUniDACQuery.GetDataSet: TDataSet; +begin + Result := Query; +end; + +function TBoldUniDACQuery.GetParamCheck: Boolean; +begin + result := Query.ParamCheck; +end; + +function TBoldUniDACQuery.GetParamCount: Integer; +begin + Result := Query.Params.Count; +end; + +function TBoldUniDACQuery.GetParams: TParams; +begin + result := Query.Params; +end; + +function TBoldUniDACQuery.GetParam(i: Integer): IBoldParameter; +begin + Result := TBoldUniDACParameter.Create(Query.Params[i], Self); +end; + +function TBoldUniDACQuery.GetRecNo: integer; +begin + result := Query.RecNo - 1; +end; + +function TBoldUniDACQuery.GetRecordCount: Integer; +begin + Result := Query.RecordCount; +end; + +function TBoldUniDACQuery.GetRequestLiveQuery: Boolean; +begin + Result := False; +end; + +function TBoldUniDACQuery.GetRowsAffected: Integer; +begin + result := Query.RowsAffected; +end; + +function TBoldUniDACQuery.GetSQLStrings: TStrings; +begin + result := Query.SQL; +end; + +function TBoldUniDACQuery.GetSQLText: string; +begin + Result := Query.SQL.Text; +end; + +function TBoldUniDACQuery.GetUseReadTransactions: boolean; +begin + result := fUseReadTransactions; +end; + +procedure TBoldUniDACQuery.AssignParams(Sourceparams: TParams); +var + lIndexSourceParams: Integer; + lUniParam: TUniParam; +begin + Query.Params.Clear; + if Assigned(Sourceparams) and (Sourceparams.Count > 0) then + begin + for lIndexSourceParams := 0 to Sourceparams.Count - 1 do + begin + lUniParam := Query.Params.CreateParam(Sourceparams[lIndexSourceParams].DataType, Sourceparams[lIndexSourceParams].Name, Sourceparams[lIndexSourceParams].ParamType) as TUniParam; + lUniParam.Value := Sourceparams[lIndexSourceParams].Value; + end; + end; +end; + +procedure TBoldUniDACQuery.AssignSQL(SQL: TStrings); +begin + Query.SQL.Assign(SQL); + //function ParseSQL(SQL: WideString; DoCreate: Boolean): WideString; + //DoCreate indicates whether to clear all existing parameter definitions before parsing the SQL statement. +end; + +procedure TBoldUniDACQuery.AssignSQLText(const SQL: string); +begin + Query.SQL.Text := Sql; +{ if SQL = '' then + Query.Params.clear + else + Query.Params.ParseSQL(SQL, False);} +end; + +procedure TBoldUniDACQuery.BeginExecuteQuery; +begin + (DatabaseWrapper as TBoldUniDACConnection).BeginExecuteQuery; +end; + +procedure TBoldUniDACQuery.Clear; +begin + AssignSQLText(''); + ClearParams; +end; + +procedure TBoldUniDACQuery.ClearParams; +begin + Query.Params.Clear; +end; + +procedure TBoldUniDACQuery.Close; +begin + inherited; + if (fReadTransactionStarted) and (DatabaseWrapper as TBoldUniDACConnection).GetInTransaction then + (DatabaseWrapper as TBoldUniDACConnection).Commit; + fReadTransactionStarted := false; +end; + +constructor TBoldUniDACQuery.Create(BoldUniDACConnection: TBoldUniDACConnection); +begin + inherited Create(BoldUniDACConnection); + fUseReadTransactions := true; + fQuery := TUniQuery.Create(nil); + fQuery.Connection := (DatabaseWrapper as TBoldUniDACConnection).UniConnection; +end; + +function TBoldUniDACQuery.CreateParam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; +var + lUniParam: TUniParam; +begin + lUniParam := Query.Params.CreateParam(FldType, ParamName, ptUnknown) as TUniParam; +// lUniParam.Size := Size; + lUniParam.Value := NULL; + Result := TBoldUniDACParameter.Create(lUniParam, Self); +end; + +destructor TBoldUniDACQuery.Destroy; +begin + if (fReadTransactionStarted) then + Close; + FreeAndNil(fQuery); + inherited; +end; + +procedure TBoldUniDACQuery.EndExecuteQuery; +begin + (DatabaseWrapper as TBoldUniDACConnection).EndExecuteQuery; +end; + +type TStringsAccess = class(TStrings); + +procedure TBoldUniDACQuery.ExecSQL; +var + Retries: Integer; + Done: Boolean; +begin + if InBatch then + begin + BatchExecSQL; + exit; + end; + BeginExecuteQuery; + try + BoldLogSQLWithParams(Query.SQL, self); + Retries := 0; + Done := false; + while not Done do + begin + try + if (DatabaseWrapper as TBoldUniDACConnection).GetInTransaction then + fReadTransactionStarted := false + else + begin + if fUseReadTransactions then + (DatabaseWrapper as TBoldUniDACConnection).StartReadTransaction; + fReadTransactionStarted := fUseReadTransactions; + end; + Query.Execute; + if fReadTransactionStarted and (DatabaseWrapper as TBoldUniDACConnection).GetInTransaction then + begin + (DatabaseWrapper as TBoldUniDACConnection).Commit; + fReadTransactionStarted := false; + end; + Done := true; + except + on e: Exception do + begin + if (DatabaseWrapper as TBoldUniDACConnection).GetInTransaction then + (DatabaseWrapper as TBoldUniDACConnection).Rollback; + if (not fReadTransactionStarted) or (Retries > 4) then + raise TBoldUniDACConnection(DatabaseWrapper).GetDatabaseError(E, Query.SQL.Text); + fReadTransactionStarted := false; + INC(Retries); + sleep(Retries*200); + end; + end; + end; + finally + EndExecuteQuery; + end; +end; + +function TBoldUniDACQuery.FindParam(const Value: string): IBoldParameter; +var + Param: TUniParam; +begin + result := nil; + Param := Query.FindParam(Value); + if Assigned(Param) then + Result := TBoldUniDACParameter.Create(Param, Self); +end; + +procedure TBoldUniDACQuery.Open; +var + Retries: Integer; + Done: Boolean; + EDatabase: EBoldDatabaseError; +begin + BeginExecuteQuery; + try + BoldLogSQLWithParams(Query.SQL, self); + Retries := 0; + Done := false; + while not Done do + begin + try + if (DatabaseWrapper as TBoldUniDACConnection).GetInTransaction then + fReadTransactionStarted := false + else + begin + if fUseReadTransactions then + (DatabaseWrapper as TBoldUniDACConnection).StartReadTransaction; + fReadTransactionStarted := fUseReadTransactions; + end; + Query.ReadOnly := True; + inherited; + Done := true; + except + on e: Exception do + begin + EDatabase := TBoldUniDACConnection(DatabaseWrapper). + GetDatabaseError(E, Query.SQL.Text); + if (EDatabase is EBoldDatabaseConnectionError) {and + (not Assigned(ReconnectAppExists) or ReconnectAppExists)} then + begin + EDatabase.free; +// ReconnectDatabase(Query.SQL.Text); + Reconnect; + end else + begin + if (DatabaseWrapper as TBoldUniDACConnection).GetInTransaction then + (DatabaseWrapper as TBoldUniDACConnection).Rollback; + if (not fReadTransactionStarted) or (Retries > 4) then + raise EDatabase + else + EDatabase.free; + fReadTransactionStarted := false; + INC(Retries); + sleep(Retries*200); + end; + end; + end; + end; + finally + EndExecuteQuery; + end; +end; + +function TBoldUniDACQuery.ParamByName(const Value: string): IBoldParameter; +var + lUniParam: TUniParam; +begin + lUniParam := Query.Params.ParamByName(Value); + Result := TBoldUniDACParameter.Create(lUniParam, Self) +end; + +procedure TBoldUniDACQuery.SetParamCheck(value: Boolean); +begin + if Query.ParamCheck <> Value then + Query.ParamCheck := Value; +end; + +procedure TBoldUniDACQuery.SetRequestLiveQuery(NewValue: Boolean); +begin + // ignore +end; + +procedure TBoldUniDACQuery.SetUseReadTransactions(value: boolean); +begin + fUseReadTransactions := value; +end; + +{ TBoldUniDACTable } + +constructor TBoldUniDACTable.Create(aUniTable: TUniTable; BoldUniDACConnection: TBoldUniDACConnection); +begin + inherited Create(BoldUniDACConnection); + fUniTable := aUniTable; +end; + +procedure TBoldUniDACTable.CreateTable; +begin + raise EBold.CreateFmt('MethodNotImplemented', [ClassName, 'CreateTable']); // do not localize +end; + +procedure TBoldUniDACTable.DeleteTable; +begin + raise EBold.CreateFmt('MethodNotImplemented', [ClassName, 'DeleteTable']); // do not localize +end; + +function TBoldUniDACTable.FindParam(const Value: string): IBoldParameter; +var + Param: TUniParam; +begin + result := nil; + Param := UniTable.FindParam(Value); + if Assigned(Param) then + Result := TBoldUniDACParameter.Create(Param, Self); +end; + +procedure TBoldUniDACTable.AddIndex(const Name, Fields: string; + Options: TIndexOptions; const DescFields: string); +begin + raise EBold.CreateFmt('MethodNotImplemented', [ClassName, 'AddIndex']); // do not localize +end; +(* +function TBoldUniDACTable.GetCommaListOfIndexesForColumn( + const aColumnName: string): string; +var + lUniMetaData: TUniMetaData; + lIndexList: TStringList; + lIndexedColumn: string; + lIndexName: string; + lBoldGuard: IBoldGuard; +const + cTableName = 'Table_Name'; + cIndexName = 'Index_Name'; + cColumnName = 'Column_Name'; +begin +// TODO possibly slow comment +// to improve performance move metadata to the Connection and store it there + + lBoldGuard := TBoldGuard.Create(lUniMetaData, lIndexList); + lUniMetaData := TUniMetaData.Create(nil); + lIndexList := TStringList.Create; + + Assert(Assigned(UniTable)); + Assert(Assigned(UniTable.Connection)); + lUniMetaData.Connection := UniTable.Connection; +// lUniMetaData.DatabaseName := UniTable.Connection.Database; + lUniMetaData.MetaDataKind := 'Indexes'; +{ lUniMetaData.TableName := GetTableName; + lUniMetaData.Open; + lUniMetaData.First; + while not lUniMetaData.Eof do + begin + lIndexedColumn := lUniMetaData.FieldByName(cColumnName).AsString; + if aColumnName = lIndexedColumn then + begin + lIndexName := lUniMetaData.FieldByName(cIndexName).AsString; + lIndexList.Add(lIndexName); + end; + lUniMetaData.Next; + end; + Result := lIndexList.CommaText; + lUniMetaData.Close; +} +end; + +function TBoldUniDACTable.GetPrimaryIndex: string; +var + lUniMetaData: TUniMetaData; + lIndexName: string; +const + cTableName = 'Table_Name'; + cIndexName = 'Index_Name'; + cColumnName = 'Column_Name'; + cPrimaryKey = 'Primary_Key'; +// COLUMN_NAME +begin +// TODO possibly slow comment +// to improve performance move metadata to the Connection and store it there + + lUniMetaData := TUniMetaData.Create(nil); + try + Assert(Assigned(UniTable)); + Assert(Assigned(UniTable.Connection)); + lUniMetaData.Connection := UniTable.Connection; +// lUniMetaData.DatabaseName := UniTable.Connection.Database; +{ lUniMetaData.MetaDataKind := otPrimaryKeys; + lUniMetaData.Open; + lUniMetaData.Filter := Format('(%s = ''%s'')', [cTableName, GetTableName]); + lUniMetaData.Filtered := True; + if lUniMetaData.RecordCount = 1 then + begin + lIndexName := lUniMetaData.FieldByName(cColumnName).AsString; + Result := lIndexName; + end + else + begin + Result := ''; + end; + lUniMetaData.Close; +} + finally + lUniMetaData.free; + end; +end; +*) +function TBoldUniDACTable.GetDataSet: TDataSet; +begin + Result := fUniTable; +end; + +function TBoldUniDACTable.GetDefaultConstraintNameForColumn( + const aColumnName: string): string; +var + lUniMetaData: TUniMetaData; + lDefaultConstraintName: string; + lBoldGuard: IBoldGuard; +const + cConstraintName = 'CONSTRAINT_NAME'; +begin + Assert(Assigned(UniTable)); + Assert(Assigned(UniTable.Connection)); + + lBoldGuard := TBoldGuard.Create(lUniMetaData); + lUniMetaData := TUniMetaData.Create(nil); + lUniMetaData.Connection := UniTable.Connection; +{ lUniMetaData.DatabaseName := UniTable.Connection.Database; + lUniMetaData.TableName := GetTableName; + lUniMetaData.ColumnName := aColumnName; + lUniMetaData.ObjectType := otConstraintColumnUsage; + lUniMetaData.Open; + lUniMetaData.First; + if not lUniMetaData.Eof then + begin + lDefaultConstraintName := lUniMetaData.FieldByName(cConstraintName).AsString; + end; + lUniMetaData.Close; +} + Result := lDefaultConstraintName; +end; + +function TBoldUniDACTable.GetExclusive: Boolean; +begin + Result := False; +end; + +function TBoldUniDACTable.GetExists: Boolean; +var + lAllTables: TStringList; + lGuard: IBoldGuard; +begin + lGuard := TBoldGuard.Create(lAllTables); + Result := False; + + // First we make sure we have a table component and that it is connected to a database + if Assigned(UniTable) and Assigned(UniTable.Connection) then + begin + // We now create a list that will hold all the table names in the database + lAllTables := TStringList.Create; + UniTable.Connection.GetTableNames(lAllTables); + Result := lAllTables.IndexOf(GetTableName) <> -1; + end; +end; + +function TBoldUniDACTable.GetIndexDefs: TIndexDefs; +begin + raise EBold.CreateFmt('%s MethodNotImplemented %s', [ClassName, 'GetIndexDefs']); // do not localize +// Result := UniTable.IndexFieldNames +end; + +function TBoldUniDACTable.GetUniTable: TUniTable; +begin + Result := fUniTable; +end; + +function TBoldUniDACTable.ParamByName(const Value: string): IBoldParameter; +var + lUniParam: TUniParam; +begin + lUniParam := UniTable.Params.ParamByName(Value); + Result := TBoldUniDACParameter.Create(lUniParam, Self) +end; + +function TBoldUniDACTable.GetTableName: string; +begin + Result := UniTable.TableName; +end; + +procedure TBoldUniDACTable.SetExclusive(NewValue: Boolean); +begin +end; + +procedure TBoldUniDACTable.SetTableName(const NewName: string); +begin + UniTable.TableName := NewName; +end; + +{ TBoldUniDACConnection } + +// Populate the "TableNameList" with tablenames from the database that maches "pattern" + +procedure TBoldUniDACConnection.AllTableNames(Pattern: string; ShowSystemTables: Boolean; TableNameList: TStrings); +var + lTempList: TStringList; + lIndexTempList: Integer; + lGuard: IBoldGuard; + i: integer; +begin + lGuard := TBoldGuard.Create(lTempList); + lTempList := TStringList.Create; + + // Retrieve the list of table names + // Note: This does not include views or procedures, there is a specific + // method in TUniConnection for that + UniConnection.GetTableNames(lTempList, ShowSystemTables); + + // convert from fully qualified names in format: database.catalogue.table to just table name + for i := 0 to lTempList.Count - 1 do + while pos('.', lTempList[i]) > 0 do + lTempList[i] := Copy(lTempList[i], pos('.', lTempList[i])+1, maxInt); + + if Pattern = '' then + TableNameList.Assign(lTempList) + else + // MatchesMask is used to compare filenames with wildcards, suits us here + // but there should be some care taken, when using tablenames with period + // signes, as that might be interpreted as filename extensions + for lIndexTempList := 0 to lTempList.Count - 1 do + begin + if MatchesMask(lTempList[lIndexTempList], Pattern) then + begin + TableNameList.Add(lTempList[lIndexTempList]); + end; + end; +end; + +procedure TBoldUniDACConnection.Commit; +begin + UniConnection.Commit; +end; + +function TBoldUniDACConnection.GetInTransaction: Boolean; +begin + Result := UniConnection.InTransaction; +end; + +function TBoldUniDACConnection.GetIsExecutingQuery: Boolean; +begin + Result := fExecuteQueryCount > 0; +end; + +function TBoldUniDACConnection.GetIsSQLBased: Boolean; +begin + Result := True; +end; + +function TBoldUniDACConnection.GetKeepConnection: Boolean; +begin + //CheckMe; + Result := True; +end; + +function TBoldUniDACConnection.GetLogInPrompt: Boolean; +begin + Result := UniConnection.LoginPrompt; +end; + +procedure TBoldUniDACConnection.RollBack; +begin + UniConnection.RollBack; +end; + +procedure TBoldUniDACConnection.SetKeepConnection(NewValue: Boolean); +begin + //CheckMe; +end; + +procedure TBoldUniDACConnection.SetlogInPrompt(NewValue: Boolean); +begin + UniConnection.LoginPrompt := NewValue; +end; + +procedure TBoldUniDACConnection.StartReadTransaction; +begin + UniConnection.DefaultTransaction.IsolationLevel := ilReadCommitted; + UniConnection.StartTransaction; +end; + +procedure TBoldUniDACConnection.StartTransaction; +begin + UniConnection.DefaultTransaction.IsolationLevel := ilRepeatableRead; + UniConnection.StartTransaction; +end; + +function TBoldUniDACConnection.DatabaseExists: boolean; +var + vQuery: IBoldQuery; + vDatabaseName: string; +begin + vDatabaseName := LowerCase(UniConnection.Database); + UniConnection.Database := ''; // need to clear this to connect succesfully + vQuery := GetQuery; + try + (vQuery.Implementor as TUniQuery).Connection := UniConnection; + vQuery.SQLText := SQLDataBaseConfig.GetDatabaseExistsQuery(vDatabaseName); + vQuery.Open; + result := vQuery.Fields[0].AsBoolean; + finally + ReleaseQuery(vQuery); + UniConnection.Database := vDatabaseName; + end; +end; + +destructor TBoldUniDACConnection.Destroy; +begin + ReleaseCachedObjects; + inherited; +end; + +procedure TBoldUniDACConnection.DropDatabase; +var + vQuery: IBoldExecQuery; + vDatabaseName: string; + vUniScript: TUniScript; + vIsInterbase: boolean; + vIsMSSQL: boolean; +const + cInterbase = 'InterBase'; + cMSSQL = 'SQL Server'; + cDropDatabaseSQL = 'Drop Database %s'; + cGenerateDatabaseSQL = 'Create Database %s'; + cGenerateDatabaseInterbaseSQL = 'Create Database ''%s'' user ''%s'' password ''%s'''; + cGenerateDatabaseSQLServer = 'USE master;' + BOLDCRLF + 'GO' + BOLDCRLF + ' Create Database %s'; +begin + vDatabaseName := LowerCase(UniConnection.Database); +// UniConnection.Database := ''; // need to clear this to connect succesfully + vUniScript := TUniScript.Create(nil); + try + vUniScript.Connection := UniConnection; + vIsInterbase := UniConnection.ProviderName = cInterBase; + vIsMSSQL := UniConnection.ProviderName = cMSSQL; + vUniScript.SQL.Text := Format(cDropDatabaseSQL, [vDatabaseName]); + if vIsMSSQL then + UniConnection.Database := 'master'; + try + vUniScript.Execute; + except + // ignore + end; + vUniScript.NoPreconnect := vIsInterbase; + if vIsInterbase then + vUniScript.SQL.Text := Format(cGenerateDatabaseInterbaseSQL, [vDatabaseName, UniConnection.Username, UniConnection.Password]) + else + if vIsMSSQL then + begin + vUniScript.SQL.Text := Format(cGenerateDatabaseSQLServer, [vDatabaseName]); + end + else + vUniScript.SQL.Text := Format(cGenerateDatabaseSQL, [vDatabaseName]); + vUniScript.Execute; + UniConnection.Close; + finally + vUniScript.free; + if vIsMSSQL then + UniConnection.Database := vDatabaseName; + end; +end; + +procedure TBoldUniDACConnection.EndExecuteQuery; +begin + dec(fExecuteQueryCount); +end; + +constructor TBoldUniDACConnection.Create(aUniConnection: TUniConnection; SQLDataBaseConfig: TBoldSQLDatabaseConfig); +begin + inherited Create(SQLDataBaseConfig); + fUniConnection := aUniConnection; +end; + +procedure TBoldUniDACConnection.BeginExecuteQuery; +begin + inc(fExecuteQueryCount); +end; + +procedure TBoldUniDACConnection.Close; +begin + UniConnection.Close; +end; + +procedure TBoldUniDACConnection.CreateDatabase(DropExisting: boolean); +var + vDatabaseName: string; + vUniScript: TUniScript; +begin + vDatabaseName := LowerCase(UniConnection.Database); + if DropExisting and DatabaseExists then + DropDatabase; +// UniConnection.Database := ''; // need to clear this to connect succesfully + vUniScript := TUniScript.Create(nil); + try + vUniScript.Connection := UniConnection; + vUniScript.SQL.Text := SQLDataBaseConfig.GetCreateDatabaseQuery(vDatabaseName); + vUniScript.Execute; + UniConnection.Close; + finally + UniConnection.Close; + vUniScript.free; + UniConnection.Database := vDatabaseName; + end; +end; + +function TBoldUniDACConnection.GetConnected: Boolean; +begin + Result := UniConnection.Connected; +end; + +function TBoldUniDACConnection.GetDatabaseError(const E: Exception; + const sSQL: string): EBoldDatabaseError; +const + SQLERRORCODE = 'SQL Error Code: '; +var + iErrorCode: Integer; + sMsg: string; + iPos: Integer; + aErrorType: TBoldDatabaseErrorType; + sServer, + sDatabase, + sUsername: string; + bUseWindowsAuth: Boolean; +const + // Provider names copied here to avoid dependancy + cMSSQLProvider = 'SQL Server'; // TSQLServerUniProvider.GetProviderName + cPostgreSQLProvider = 'PostgreSQL'; // TPostgreSQLUniProvider.GetProviderName + cOracleSQLProvider = 'Oracle'; // TOracleUniProvider.GetProviderName + cInterBaseProvider = 'InterBase'; + cMSSQLDeadLock = 1205; +begin + aErrorType := bdetError; + sServer := UniConnection.Server; + sDatabase := UniConnection.Database; + sUsername := UniConnection.Username; + bUseWindowsAuth := Pos('Authentication=Windows', UniConnection.ConnectString) > 0; + if (E is EUniError) then + begin + if UniConnection.ProviderName = cMSSQLProvider then + case EUniError(E).ErrorCode of + -2147467259, 2, 233: aErrorType := bdetConnection; // only set bdetConnection for cases where retry might work. + 208, 4145: aErrorType := bdetSQL; + 4060: aErrorType := bdetLogin; // SQLServer Error: 4060, Cannot open database "SessionStateService" requested by the login. The login failed. [SQLSTATE 42000] + 18456: aErrorType := bdetLogin; // SQLServer Error: 18456, Login failed for user 'domain\user'. [SQLSTATE 28000] + cMSSQLDeadLock: aErrorType := bdetDeadlock; + //Deadlock und weitere ErrorCodes? + end + else + if UniConnection.ProviderName = cInterBaseProvider then + case EUniError(E).ErrorCode of + -803: aErrorType := bdetUpdate; // attempt to store duplicate value (visible to active transactions) in unique index + end + else + if UniConnection.ProviderName = cPostgreSQLProvider then + case EUniError(E).ErrorCode of + 0: aErrorType := bdetLogin; + end + else + raise Exception.Create('Error codes not implemented for ' + UniConnection.ProviderName); + end; + Result := InternalGetDatabaseError(aErrorType, E, sSQL, sServer, sDatabase, + sUsername, bUseWindowsAuth); +end; + +function TBoldUniDACConnection.GetExecQuery: IBoldExecQuery; +begin + if Assigned(fCachedExecQuery1) then + begin + result := fCachedExecQuery1; + fCachedExecQuery1 := nil; + end else + begin + Result := BoldUniDACQueryClass.Create(Self); + end; +end; + +function TBoldUniDACConnection.GetUniConnection: TUniConnection; +begin + Result := fUniConnection; +end; + +function TBoldUniDACConnection.GetQuery: IBoldQuery; +begin + if Assigned(fCachedQuery1) then + begin + result := fCachedQuery1; + fCachedQuery1 := nil; + end else + if Assigned(fCachedQuery2) then + begin + result := fCachedQuery2; + fCachedQuery2 := nil; + end else + begin + Result := BoldUniDACQueryClass.Create(Self); + end; +end; + +function TBoldUniDACConnection.GetTable: IBoldTable; +var + lUniTable: TUniTable; +begin + if Assigned(fCachedTable) then + begin + result := fCachedTable; + fCachedTable := nil; + end + else + begin + lUniTable := TUniTable.Create(nil); + lUniTable.Connection := UniConnection; + Result := TBoldUniDACTable.Create(lUniTable, Self); + end; +end; + +procedure TBoldUniDACConnection.Open; +begin + try + UniConnection.Open; + except + on E: Exception do begin + raise GetDatabaseError(E); + end; + end; +end; + +procedure TBoldUniDACConnection.Reconnect; +begin + if Assigned(fUniConnection) then begin + fUniConnection.Connected := False; + fUniConnection.Connected := True; + end; +end; + +procedure TBoldUniDACConnection.ReleaseQuery(var Query: IBoldQuery); +var + lBoldUniDACQuery: TBoldUniDACQuery; +begin + if (Query.Implementor is TBoldUniDACQuery) then + begin + lBoldUniDACQuery := Query.Implementor as TBoldUniDACQuery; + lBoldUniDACQuery.clear; + Query := nil; + if not Assigned(fCachedQuery1) then + fCachedQuery1 := lBoldUniDACQuery + else + if not Assigned(fCachedQuery2) then + fCachedQuery2 := lBoldUniDACQuery + else + lBoldUniDACQuery.free; + end +end; + +procedure TBoldUniDACConnection.ReleaseExecQuery(var Query: IBoldExecQuery); +var + lBoldUniDACQuery: TBoldUniDACQuery; + lBoldUniDACExecQuery: TBoldUniDACExecQuery; +begin + if (Query.Implementor is TBoldUniDACQuery) then + begin + lBoldUniDACQuery := Query.Implementor as TBoldUniDACQuery; + if lBoldUniDACQuery.GetSQLStrings.Count <> 0 then + begin + lBoldUniDACQuery.GetSQLStrings.BeginUpdate; + lBoldUniDACQuery.clear; + end; + while TStringsAccess(lBoldUniDACQuery.GetSQLStrings).UpdateCount > 0 do + lBoldUniDACQuery.GetSQLStrings.EndUpdate; + Query := nil; + if not Assigned(fCachedExecQuery1) then + fCachedExecQuery1 := lBoldUniDACQuery + else + lBoldUniDACQuery.free; + end +{ else + if (Query.Implementor is TBoldUniDACExecQuery) then + begin + lBoldUniDACExecQuery := Query.Implementor as TBoldUniDACExecQuery; + lBoldUniDACExecQuery.clear; + Query := nil; + if not Assigned(fCachedExecQuery1) then + fCachedExecQuery1 := lBoldUniDACExecQuery + else + lBoldUniDACExecQuery.free; + end +} +end; + +procedure TBoldUniDACConnection.ReleaseTable(var Table: IBoldTable); +var + lBoldUniDACTable: TBoldUniDACTable; +begin + if Table.Implementor is TBoldUniDACTable then + begin + lBoldUniDACTable := Table.Implementor as TBoldUniDACTable; + Table := nil; + if not Assigned(fCachedTable) then + fCachedTable := lBoldUniDACTable + else + lBoldUniDACTable.free; + end; +end; + +function TBoldUniDACConnection.SupportsTableCreation: Boolean; +begin + Result := False; +end; + +{ TBoldUniDACParameter } + +procedure TBoldUniDACParameter.Clear; +begin + UniParam.Clear; +end; + +constructor TBoldUniDACParameter.Create(UniDACParameter: TUniParam; DatasetWrapper: TBoldAbstractQueryWrapper); +begin + inherited Create(DatasetWrapper); + fUniParam := UniDACParameter; +end; + +function TBoldUniDACParameter.GetAsAnsiString: TBoldAnsiString; +begin + Result := UniParam.AsAnsiString; +end; + +function TBoldUniDACParameter.GetAsBCD: Currency; +begin + Result := UniParam.AsBCD; +end; + +function TBoldUniDACParameter.GetAsblob: TBoldBlobData; +begin + Result := AnsiString(UniParam.Value); +end; + +function TBoldUniDACParameter.GetAsBoolean: Boolean; +begin + Result := UniParam.AsBoolean; +end; + +function TBoldUniDACParameter.GetAsCurrency: Currency; +begin + Result := UniParam.AsCurrency; +end; + +function TBoldUniDACParameter.GetAsDateTime: TDateTime; +begin + Result := UniParam.AsDateTime; +end; + +function TBoldUniDACParameter.GetAsFloat: Double; +begin + Result := UniParam.AsFloat; +end; + +function TBoldUniDACParameter.GetAsInt64: Int64; +begin + result := UniParam.AsLargeInt; +end; + +function TBoldUniDACParameter.GetAsInteger: Longint; +begin + Result := UniParam.AsInteger; +end; + +function TBoldUniDACParameter.GetAsMemo: string; +begin + Result := UniParam.AsMemo; +end; + +function TBoldUniDACParameter.GetAsString: string; +begin + Result := UniParam.AsString; + if Result = DatasetWrapper.DatabaseWrapper.SQLDataBaseConfig.EmptyStringMarker then + begin + Result := ''; + end; +end; + +function TBoldUniDACParameter.GetAsVariant: Variant; +begin + Result := UniParam.Value; +end; + +function TBoldUniDACParameter.GetAsWideString: WideString; +begin + Result := UniParam.AsWideString; + if Result = DatasetWrapper.DatabaseWrapper.SQLDataBaseConfig.EmptyStringMarker then + begin + Result := ''; + end; +end; + +function TBoldUniDACParameter.GetDataType: TFieldType; +begin + Result := UniParam.DataType; +end; + +function TBoldUniDACParameter.GetIsNull: Boolean; +begin + Result := VarIsNull(UniParam.Value) +end; + +function TBoldUniDACParameter.GetName: string; +begin + Result := UniParam.Name; +end; + +function TBoldUniDACParameter.GetUniParam: TUniParam; +begin + Result := fUniParam; +end; + +procedure TBoldUniDACParameter.SetAsAnsiString(const Value: TBoldAnsiString); +begin + UniParam.AsAnsiString := Value; +end; + +procedure TBoldUniDACParameter.SetAsBCD(const Value: Currency); +begin + UniParam.Value := Value; +end; + +procedure TBoldUniDACParameter.SetAsBlob(const Value: TBoldBlobData); +begin + if UniParam.DataType = ftUnknown then + begin + UniParam.DataType := ftBlob; + end; + if Value = '' then + begin +// UniParam.Value := DatasetWrapper.DatabaseWrapper.SQLDataBaseConfig.EmptyStringMarker; + UniParam.Value := Null; + end else + begin + UniParam.Value := TBoldBlobData(AnsiString(Value)); + end; +end; + +procedure TBoldUniDACParameter.SetAsBoolean(Value: Boolean); +begin + UniParam.AsBoolean := Value; +end; + +procedure TBoldUniDACParameter.SetAsCurrency(const Value: Currency); +begin + UniParam.AsCurrency := Value; +end; + +procedure TBoldUniDACParameter.SetAsDate(const Value: TDateTime); +begin + UniParam.AsDate := Value; +end; + +procedure TBoldUniDACParameter.SetAsDateTime(const Value: TDateTime); +begin + UniParam.AsDateTime := Value; +end; + +procedure TBoldUniDACParameter.SetAsFloat(const Value: Double); +begin + UniParam.AsFloat := Value; +end; + +procedure TBoldUniDACParameter.SetAsInt64(const Value: Int64); +begin + UniParam.AsLargeInt := Value; +end; + +procedure TBoldUniDACParameter.SetAsInteger(Value: Integer); +begin + UniParam.AsInteger := Value; +end; + +procedure TBoldUniDACParameter.SetAsMemo(const Value: string); +begin + UniParam.AsMemo := Value; +end; + +procedure TBoldUniDACParameter.SetAsSmallInt(Value: Integer); +begin + UniParam.AsSmallInt := Value; +end; + +procedure TBoldUniDACParameter.SetAsString(const Value: string); +begin + if Value = '' then + begin + UniParam.AsString := DatasetWrapper.DatabaseWrapper.SQLDataBaseConfig.EmptyStringMarker; + end else + begin + UniParam.AsString := Value; + end; +end; + +procedure TBoldUniDACParameter.SetAsTime(const Value: TDateTime); +begin + UniParam.AsTime := Value; +end; + +procedure TBoldUniDACParameter.SetAsVariant(const NewValue: Variant); +begin + UniParam.Value := NewValue; +end; + +procedure TBoldUniDACParameter.SetAsWideString(const Value: Widestring); +begin + if Value = '' then + begin + UniParam.AsString := DatasetWrapper.DatabaseWrapper.SQLDataBaseConfig.EmptyStringMarker; + end else + begin + UniParam.AsWideString := Value; + end; +end; + +procedure TBoldUniDACParameter.SetAsWord(Value: Integer); +begin + UniParam.AsWord := Value; +end; + +procedure TBoldUniDACParameter.SetDataType(Value: TFieldType); +begin + UniParam.DataType := Value; +end; + +procedure TBoldUniDACParameter.SetText(const Value: string); +begin + UniParam.Value := Value; +end; + +procedure TBoldUniDACParameter.Assign(const source: IBoldParameter); +begin + UniParam.Value := Source.AsVariant; +end; + +procedure TBoldUniDACParameter.AssignFieldValue(const source: IBoldField); +begin + UniParam.Assign(source.Field); +end; + +procedure TBoldUniDACConnection.ReleaseCachedObjects; +begin + FreeAndNil(fCachedTable); + FreeAndNil(fCachedQuery1); + FreeAndNil(fCachedQuery2); + FreeAndNil(fCachedExecQuery1); +end; + +{ TBoldUniDACExecQuery } + +procedure TBoldUniDACExecQuery.AssignParams(Sourceparams: TParams); +var + lIndexSourceParams: Integer; + lUniParam: TUniParam; +begin + ExecQuery.Params.Clear; + if Assigned(Sourceparams) and (Sourceparams.Count > 0) then + begin + for lIndexSourceParams := 0 to Sourceparams.Count - 1 do + begin + lUniParam := ExecQuery.Params.CreateParam(Sourceparams[lIndexSourceParams].DataType, Sourceparams[lIndexSourceParams].Name, Sourceparams[lIndexSourceParams].ParamType) as TUniParam; + lUniParam.Value := Sourceparams[lIndexSourceParams].Value; + end; + end; +end; + +procedure TBoldUniDACExecQuery.AssignSQL(SQL: TStrings); +begin + ExecQuery.SQL.BeginUpdate; + ExecQuery.SQL.Assign(SQL); + ExecQuery.SQL.EndUpdate; + ExecQuery.Params.ParseSQL(SQL.Text, False); +end; + +procedure TBoldUniDACExecQuery.AssignSQLText(const SQL: string); +var + lStringList: TStringList; + lGuard: IBoldGuard; +begin + lGuard := TBoldGuard.Create(lStringList); + lStringList := TStringList.Create; + lStringList.Add(SQL); + AssignSQL(lStringList); +end; + +procedure TBoldUniDACExecQuery.BeginExecuteQuery; +begin + (DatabaseWrapper as TBoldUniDACConnection).BeginExecuteQuery; +end; + +procedure TBoldUniDACExecQuery.Clear; +begin + inherited; + AssignSQLText(''); + ClearParams; +end; + +procedure TBoldUniDACExecQuery.ClearParams; +begin + ExecQuery.Params.Clear; +end; + +constructor TBoldUniDACExecQuery.Create(BoldUniDACConnection: TBoldUniDACConnection); +begin + inherited Create(BoldUniDACConnection); + fUseReadTransactions := true; +end; + +function TBoldUniDACExecQuery.Createparam(FldType: TFieldType; + const ParamName: string): IBoldParameter; +begin + result := CreateParam(FldType, ParamName, ptUnknown, 0); +end; + +function TBoldUniDACExecQuery.CreateParam(FldType: TFieldType; const ParamName: string; ParamType: TParamType; Size: integer): IBoldParameter; +var + lUniParam: TUniParam; +begin + lUniParam := ExecQuery.Params.CreateParam(FldType, ParamName, ptUnknown) as TUniParam; +// lUniParam.Size := Size; + lUniParam.Value := NULL; + Result := TBoldUniDACParameter.Create(lUniParam, Self); +end; + +destructor TBoldUniDACExecQuery.Destroy; +begin + FreeAndNil(fExecQuery); + inherited; +end; + +procedure TBoldUniDACExecQuery.EndExecuteQuery; +begin + (DatabaseWrapper as TBoldUniDACConnection).EndExecuteQuery; +end; + +function TBoldUniDACExecQuery.EnsureParamByName( + const Value: string): IBoldParameter; +var + lUniParam: TUniParam; +begin + lUniParam := ExecQuery.Params.FindParam(Value); + if not Assigned(lUniParam) then + lUniParam := ExecQuery.Params.CreateParam(ftUnknown, Value, ptUnknown) as TUniParam; + Result := TBoldUniDACParameter.Create(lUniParam, Self) +end; + +procedure TBoldUniDACExecQuery.ExecSQL; +var + Retries: Integer; + Done: Boolean; +begin + BeginExecuteQuery; + try + BoldLogSQLWithParams(ExecQuery.SQL, self); + Retries := 0; + Done := false; + while not Done do + begin + try + if (DatabaseWrapper as TBoldUniDACConnection).GetInTransaction then + fReadTransactionStarted := false + else + begin + if fUseReadTransactions then + (DatabaseWrapper as TBoldUniDACConnection).StartReadTransaction; + fReadTransactionStarted := fUseReadTransactions; + end; + ExecQuery.Execute; + if fReadTransactionStarted and (DatabaseWrapper as TBoldUniDACConnection).GetInTransaction then + begin + (DatabaseWrapper as TBoldUniDACConnection).Commit; + fReadTransactionStarted := false; + end; + Done := true; + except + on e: Exception do + begin + if (not fReadTransactionStarted) or (Retries > 4) then + raise TBoldUniDACConnection(DatabaseWrapper).GetDatabaseError(E, ExecQuery.SQL.Text); + if (DatabaseWrapper as TBoldUniDACConnection).GetInTransaction then + (DatabaseWrapper as TBoldUniDACConnection).Rollback; + fReadTransactionStarted := false; + INC(Retries); + sleep(Retries*200); + end; + end; + end; + finally + EndExecuteQuery; + end; +end; + +procedure TBoldUniDACExecQuery.StartSQLBatch; +begin + raise EBold.CreateFmt('MethodNotImplemented', [ClassName, 'StartSQLBatch']); // do not localize +end; + +procedure TBoldUniDACExecQuery.EndSQLBatch; +begin + raise EBold.CreateFmt('MethodNotImplemented', [ClassName, 'EndSQLBatch']); // do not localize +end; + +procedure TBoldUniDACExecQuery.FailSQLBatch; +begin + raise EBold.CreateFmt('MethodNotImplemented', [ClassName, 'FailSQLBatch']); // do not localize +end; + +function TBoldUniDACExecQuery.FindParam(const Value: string): IBoldParameter; +var + Param: TParam; +begin + Param := ExecQuery.FindParam(Value); + if not Assigned(Param) then + result := CreateParam(ftUnknown, Value); +end; + +function TBoldUniDACExecQuery.GetBatchQueryParamCount: integer; +begin + result := 0; // update when batch support is implemented +end; + +function TBoldUniDACExecQuery.GetExecQuery: TUniSQL; +begin + if not Assigned(fExecQuery) then + begin + fExecQuery := TUniSQL.Create(nil); + fExecQuery.Connection := (DatabaseWrapper as TBoldUniDACConnection).UniConnection; + end; + Result := fExecQuery; +end; + +function TBoldUniDACExecQuery.GetParamCheck: Boolean; +begin + result := ExecQuery.ParamCheck; +end; + +function TBoldUniDACExecQuery.GetParamCount: Integer; +begin + result := ExecQuery.Params.Count; +end; + +function TBoldUniDACExecQuery.GetParams: TParams; +begin + result := ExecQuery.Params; +end; + +function TBoldUniDACExecQuery.GetParam(i: Integer): IBoldParameter; +begin + Result := TBoldUniDACParameter.Create(ExecQuery.Params[i], Self); +end; + +function TBoldUniDACExecQuery.GetRowsAffected: Integer; +begin + Result := ExecQuery.RowsAffected; +end; + +function TBoldUniDACExecQuery.GetSQLStrings: TStrings; +begin + result := ExecQuery.SQL; +end; + +function TBoldUniDACExecQuery.GetSQLText: string; +begin + Result := ExecQuery.SQL.Text; +end; + +function TBoldUniDACExecQuery.GetUseReadTransactions: boolean; +begin + result := fUseReadTransactions; +end; + +function TBoldUniDACExecQuery.ParamByName(const Value: string): IBoldParameter; +var + lUniParam: TUniParam; +begin + lUniParam := ExecQuery.Params.ParamByName(Value); + if Assigned(lUniParam) then + begin + Result := TBoldUniDACParameter.Create(lUniParam, Self) + end else + begin + Result := nil; + end; +end; + +{procedure TBoldUniDACExecQuery.Prepare; +begin + ExecQuery.Prepare; +end;} + +procedure TBoldUniDACExecQuery.SetParamCheck(value: Boolean); +begin + ExecQuery.ParamCheck := Value; +end; + +procedure TBoldUniDACExecQuery.SetUseReadTransactions(value: boolean); +begin + fUseReadTransactions := value; +end; + +end. diff --git a/Source/Persistence/UniDAC/UniDACConsts.pas b/Source/Persistence/UniDAC/UniDACConsts.pas new file mode 100644 index 00000000..d6028fd7 --- /dev/null +++ b/Source/Persistence/UniDAC/UniDACConsts.pas @@ -0,0 +1,18 @@ +{ Global compiler directives } +{$include bold.inc} +unit UniDACConsts; + +interface + +resourcestring +//BoldDatabaseAdapterUniDAC + sAdapterNotConnected = '%s.GetDatabaseInterface: The adapter is not connected to an UniDAC connection'; + sCreatedNewAdapter = 'Created a new DatabaseAdapterUniDAC'; + sCanOnlyTransferToUniDACAdapter = 'The persistencehandle is connected to a %s, properties can only be transfered to a TBoldDatabaseAdapterUniDAC'; + sCreatedNewDB = 'Created a new UniDACDatabase'; + sCouldNotTransferConnectionString = 'Connection string settings could not be transferred to the new UniDAC connection: '; + sTransferManually = 'Please transfer these manually!'; + +implementation + +end. diff --git a/Source/Propagator/COM/BoldPropagatorHandleCOM.pas b/Source/Propagator/COM/BoldPropagatorHandleCOM.pas index e112665e..44dc83f8 100644 --- a/Source/Propagator/COM/BoldPropagatorHandleCOM.pas +++ b/Source/Propagator/COM/BoldPropagatorHandleCOM.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPropagatorHandleCOM; interface @@ -16,6 +19,7 @@ interface {forward declarations} TBoldPropagatorHandleCOM = class; + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldPropagatorHandleCOM = class(TBoldAbstractPropagatorHandle) private FActive: Boolean; @@ -229,7 +233,7 @@ procedure TBoldPropagatorHandleCOM._Receive(Originator: TObject; end; beDestroying: ConnectionHandle := nil; - end; //end + end; end; procedure TBoldPropagatorHandleCOM.SetConnected(const Value: Boolean); @@ -238,17 +242,17 @@ procedure TBoldPropagatorHandleCOM.SetConnected(const Value: Boolean); begin if Value then begin - //request connection FConnectionHandle.Connected := True; - DoConnect; // is this necessary?? + DoConnect; end else begin - //request disconnect FConnectionHandle.Connected := false; - DoDisconnect; //is this necessary?? + DoDisconnect; end; end; end; +initialization + end. diff --git a/Source/Propagator/Common/BoldAbstractPropagatorHandle.pas b/Source/Propagator/Common/BoldAbstractPropagatorHandle.pas index 9d6cb451..2f3049a1 100644 --- a/Source/Propagator/Common/BoldAbstractPropagatorHandle.pas +++ b/Source/Propagator/Common/BoldAbstractPropagatorHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAbstractPropagatorHandle; interface @@ -25,4 +28,10 @@ TBoldAbstractPropagatorHandle = class(TBoldSubscribableComponent) implementation +uses + BoldRev + ; + +initialization + end. diff --git a/Source/Propagator/Common/BoldLockingSupportInterfaces_TLB.pas b/Source/Propagator/Common/BoldLockingSupportInterfaces_TLB.pas index 1f9acb1b..2a4fc757 100644 --- a/Source/Propagator/Common/BoldLockingSupportInterfaces_TLB.pas +++ b/Source/Propagator/Common/BoldLockingSupportInterfaces_TLB.pas @@ -1,51 +1,47 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLockingSupportInterfaces_TLB; -// ************************************************************************ // -// WARNING -// ------- -// The types declared in this file were generated from data read from a -// Type Library. If this type library is explicitly or indirectly (via -// another type library referring to this type library) re-imported, or the -// 'Refresh' command of the Type Library Editor activated while editing the -// Type Library, the contents of this file will be regenerated and all -// manual modifications will be lost. -// ************************************************************************ // - -// PASTLWTR : 1.1 -// File generated on 6/1/2001 9:37:35 AM from Type Library described below. - -// *************************************************************************// -// NOTE: -// Items guarded by $IFDEF_LIVE_SERVER_AT_DESIGN_TIME are used by properties -// which return objects that may need to be explicitly created via a function -// call prior to any access via the property. These items have been disabled -// in order to prevent accidental use from within the object inspector. You -// may enable them by defining LIVE_SERVER_AT_DESIGN_TIME or by selectively -// removing them from the $IFDEF blocks. However, such items must still be -// programmatically created via a method of the appropriate CoClass before -// they can be used. -// ************************************************************************ // -// Type Lib: C:\Work\BfD\Source\Propagator\Common\BoldLockingSupportInterfaces.tlb (1) -// IID\LCID: {0EE38CD0-5848-4A2F-96E6-BFE2007AC6BD}\0 -// Helpfile: -// DepndLst: -// (1) v2.0 stdole, (C:\WINNT\System32\stdole2.tlb) -// (2) v4.0 StdVCL, (C:\WINNT\System32\STDVCL40.DLL) -// ************************************************************************ // -{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. + + + + + + + + + + + + + + + + + + + + + + + + + + + + +{$TYPEDADDRESS OFF} interface uses Windows, ActiveX, Classes, Graphics, OleServer, OleCtrls, StdVCL; -// *********************************************************************// -// GUIDS declared in the TypeLibrary. Following prefixes are used: -// Type Libraries : LIBID_xxxx -// CoClasses : CLASS_xxxx -// DISPInterfaces : DIID_xxxx -// Non-DISP interfaces: IID_xxxx -// *********************************************************************// + + + + + const - // TypeLibrary Major and minor versions BoldLockingSupportInterfacesMajorVersion = 1; BoldLockingSupportInterfacesMinorVersion = 0; @@ -55,17 +51,13 @@ interface IID_IBoldLockManagerAdmin: TGUID = '{89074E8A-9A98-4D2A-A113-65F495611C6C}'; type -// *********************************************************************// -// Forward declaration of types defined in TypeLibrary -// *********************************************************************// + IBoldLockManager = interface; IBoldLockManagerAdmin = interface; -// *********************************************************************// -// Interface: IBoldLockManager -// Flags: (256) OleAutomation -// GUID: {105D857F-DD36-48F8-9554-ABCC212053ED} -// *********************************************************************// + + + IBoldLockManager = interface(IUnknown) ['{105D857F-DD36-48F8-9554-ABCC212053ED}'] function GetLocks(ClientId: Integer; TimeOut: Integer; RequestedExclusiveLocks: OleVariant; @@ -76,11 +68,9 @@ interface RequestedSharedLocks: OleVariant): WordBool; safecall; end; -// *********************************************************************// -// Interface: IBoldLockManagerAdmin -// Flags: (256) OleAutomation -// GUID: {89074E8A-9A98-4D2A-A113-65F495611C6C} -// *********************************************************************// + + + IBoldLockManagerAdmin = interface(IUnknown) ['{89074E8A-9A98-4D2A-A113-65F495611C6C}'] function ListAllClients(out Clients: OleVariant): HResult; safecall; diff --git a/Source/Propagator/Common/BoldObjectMarshaler.pas b/Source/Propagator/Common/BoldObjectMarshaler.pas index 01b84174..ae8512e4 100644 --- a/Source/Propagator/Common/BoldObjectMarshaler.pas +++ b/Source/Propagator/Common/BoldObjectMarshaler.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldObjectMarshaler; interface @@ -27,7 +30,8 @@ implementation SysUtils, BoldUtils, comobj, - ActiveX; + ActiveX + ; { TBoldObjectMarshaler } @@ -48,7 +52,7 @@ destructor TBoldObjectMarshaler.Destroy; IStream(FStream) := nil; end; except on E: Exception do - BoldLogError('%s.Destroy: %s', [ClassName, E.Message]); // do not localize + BoldLogError('%s.Destroy: %s', [ClassName, E.Message]); end; inherited; end; @@ -63,13 +67,13 @@ function TBoldObjectMarshaler.MarshalObject( MSHCTX_INPROC, nil, MSHLFLAGS_TABLEWEAK); Result := true; except on E: Exception do - BoldLogError('%s.MarshalObject: %s', [ClassName, E.Message]); // do not localize + BoldLogError('%s.MarshalObject: %s', [ClassName, E.Message]); end; end; function TBoldObjectMarshaler.UnMarshalObject(out Obj): boolean; var - p: int64; + p: {$IFDEF BOLD_DELPHI13_OR_LATER}LargeUInt{$ELSE}int64{$ENDIF}; begin Result := false; try @@ -77,8 +81,10 @@ function TBoldObjectMarshaler.UnMarshalObject(out Obj): boolean; OleCheck(CoUnmarshalInterface(IStream(fStream), FMarshalIID, Obj)); Result := True; except on E: Exception do - BoldLogError('%s.UnMarshalObject: %s', [ClassName, E.Message]); // do not localize + BoldLogError('%s.UnMarshalObject: %s', [ClassName, E.Message]); end; end; +initialization + end. diff --git a/Source/Propagator/Common/BoldPropagatorConstants.pas b/Source/Propagator/Common/BoldPropagatorConstants.pas index ddeb9b5c..dae20edd 100644 --- a/Source/Propagator/Common/BoldPropagatorConstants.pas +++ b/Source/Propagator/Common/BoldPropagatorConstants.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPropagatorConstants; interface diff --git a/Source/Propagator/Common/BoldPropagatorGUIDs.pas b/Source/Propagator/Common/BoldPropagatorGUIDs.pas index ff5c39e3..436cd098 100644 --- a/Source/Propagator/Common/BoldPropagatorGUIDs.pas +++ b/Source/Propagator/Common/BoldPropagatorGUIDs.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPropagatorGUIDs; interface diff --git a/Source/Propagator/Common/BoldPropagatorInterfaces_TLB.pas b/Source/Propagator/Common/BoldPropagatorInterfaces_TLB.pas index 80f363d7..1af88243 100644 --- a/Source/Propagator/Common/BoldPropagatorInterfaces_TLB.pas +++ b/Source/Propagator/Common/BoldPropagatorInterfaces_TLB.pas @@ -1,41 +1,37 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPropagatorInterfaces_TLB; -// ************************************************************************ // -// WARNING -// ------- -// The types declared in this file were generated from data read from a -// Type Library. If this type library is explicitly or indirectly (via -// another type library referring to this type library) re-imported, or the -// 'Refresh' command of the Type Library Editor activated while editing the -// Type Library, the contents of this file will be regenerated and all -// manual modifications will be lost. -// ************************************************************************ // - -// PASTLWTR : 1.1 -// File generated on 2002-05-22 15:40:37 from Type Library described below. - -// ************************************************************************ // -// Type Lib: C:\Work\BFD\SOURCE\propagator\Common\BoldPropagatorInterfaces.tlb (1) -// IID\LCID: {DC6A300A-C8C2-4D26-9A8D-C8ECB164B54B}\0 -// Helpfile: -// DepndLst: -// (1) v2.0 stdole, (C:\WINNT\System32\stdole2.tlb) -// (2) v4.0 StdVCL, (C:\WINNT\System32\STDVCL40.DLL) -// ************************************************************************ // -{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. + + + + + + + + + + + + + + + + + + +{$TYPEDADDRESS OFF} interface uses Windows, ActiveX, Classes, Graphics, OleServer, OleCtrls, StdVCL; -// *********************************************************************// -// GUIDS declared in the TypeLibrary. Following prefixes are used: -// Type Libraries : LIBID_xxxx -// CoClasses : CLASS_xxxx -// DISPInterfaces : DIID_xxxx -// Non-DISP interfaces: IID_xxxx -// *********************************************************************// + + + + + const - // TypeLibrary Major and minor versions BoldPropagatorInterfacesMajorVersion = 1; BoldPropagatorInterfacesMinorVersion = 0; @@ -49,9 +45,7 @@ interface CLASS_BoldListener: TGUID = '{A1582C23-E7AB-451A-837F-2131B425E73B}'; type -// *********************************************************************// -// Forward declaration of types defined in TypeLibrary -// *********************************************************************// + IBoldEventPropagator = interface; IBoldClientHandler = interface; IBoldListener = interface; @@ -59,19 +53,14 @@ interface IBoldListenerAdmin = interface; IBoldListenerAdminDisp = dispinterface; -// *********************************************************************// -// Declaration of CoClasses defined in Type Library -// (NOTE: Here we map each CoClass to its Default Interface) -// *********************************************************************// + + BoldPropagator = IBoldClientHandler; BoldListener = IBoldListener; -// *********************************************************************// -// Interface: IBoldEventPropagator -// Flags: (256) OleAutomation -// GUID: {BB7ABB77-BCE2-44C8-9510-F760F507A298} -// *********************************************************************// + + IBoldEventPropagator = interface(IUnknown) ['{BB7ABB77-BCE2-44C8-9510-F760F507A298}'] function SendEvents(BoldClientID: Integer; Events: OleVariant): HResult; stdcall; @@ -79,11 +68,9 @@ interface function CancelSubscriptions(BoldClientID: Integer; Subscriptions: OleVariant): HResult; stdcall; end; -// *********************************************************************// -// Interface: IBoldClientHandler -// Flags: (256) OleAutomation -// GUID: {A86E36B1-5EA3-4961-8448-45FD822A271E} -// *********************************************************************// + + + IBoldClientHandler = interface(IUnknown) ['{A86E36B1-5EA3-4961-8448-45FD822A271E}'] function RegisterClient(LeaseDuration: Integer; PollingInterval: Integer; @@ -93,67 +80,55 @@ interface function UnRegisterClient(BoldClientID: Integer): HResult; stdcall; end; -// *********************************************************************// -// Interface: IBoldListener -// Flags: (320) Dual OleAutomation -// GUID: {0326BF5B-F5AF-4BED-B5E1-F84D2549415A} -// *********************************************************************// + + + IBoldListener = interface(IUnknown) ['{0326BF5B-F5AF-4BED-B5E1-F84D2549415A}'] function ReceiveEvents(Events: OleVariant): Integer; safecall; end; -// *********************************************************************// -// DispIntf: IBoldListenerDisp -// Flags: (320) Dual OleAutomation -// GUID: {0326BF5B-F5AF-4BED-B5E1-F84D2549415A} -// *********************************************************************// + + + IBoldListenerDisp = dispinterface ['{0326BF5B-F5AF-4BED-B5E1-F84D2549415A}'] function ReceiveEvents(Events: OleVariant): Integer; dispid 1; end; -// *********************************************************************// -// Interface: IBoldListenerAdmin -// Flags: (320) Dual OleAutomation -// GUID: {7457EA48-E3B5-4E07-8496-87229ACA5E2D} -// *********************************************************************// + + + IBoldListenerAdmin = interface(IUnknown) ['{7457EA48-E3B5-4E07-8496-87229ACA5E2D}'] function Ping: Integer; safecall; procedure DisconnectClient(const aMessage: WideString; RemainDisconnected: Integer); safecall; end; -// *********************************************************************// -// DispIntf: IBoldListenerAdminDisp -// Flags: (320) Dual OleAutomation -// GUID: {7457EA48-E3B5-4E07-8496-87229ACA5E2D} -// *********************************************************************// + + + IBoldListenerAdminDisp = dispinterface ['{7457EA48-E3B5-4E07-8496-87229ACA5E2D}'] function Ping: Integer; dispid 1; procedure DisconnectClient(const aMessage: WideString; RemainDisconnected: Integer); dispid 2; end; -// *********************************************************************// -// The Class CoBoldPropagator provides a Create and CreateRemote method to -// create instances of the default interface IBoldClientHandler exposed by -// the CoClass BoldPropagator. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoBoldPropagator = class class function Create: IBoldClientHandler; class function CreateRemote(const MachineName: string): IBoldClientHandler; end; -// *********************************************************************// -// The Class CoBoldListener provides a Create and CreateRemote method to -// create instances of the default interface IBoldListener exposed by -// the CoClass BoldListener. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoBoldListener = class class function Create: IBoldListener; class function CreateRemote(const MachineName: string): IBoldListener; diff --git a/Source/Propagator/Common/PropagatorConsts.pas b/Source/Propagator/Common/PropagatorConsts.pas index b7db2cba..49fd119a 100644 --- a/Source/Propagator/Common/PropagatorConsts.pas +++ b/Source/Propagator/Common/PropagatorConsts.pas @@ -86,4 +86,4 @@ interface implementation -end. \ No newline at end of file +end. diff --git a/Source/Propagator/Enterprise/BoldAbstractOutputQueueHandler.pas b/Source/Propagator/Enterprise/BoldAbstractOutputQueueHandler.pas index 46037929..2c2981a8 100644 --- a/Source/Propagator/Enterprise/BoldAbstractOutputQueueHandler.pas +++ b/Source/Propagator/Enterprise/BoldAbstractOutputQueueHandler.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAbstractOutputQueueHandler; interface @@ -8,7 +11,7 @@ interface type {forward declarations} TBoldAbstractOutputQueueHandler = class; - + TBoldAbstractOutputQueueHandler = class public procedure SendEvent(const ClientID: TBoldClientID; EventName: string); virtual; abstract; @@ -19,4 +22,7 @@ TBoldAbstractOutputQueueHandler = class implementation + +initialization + end. diff --git a/Source/Propagator/Enterprise/BoldAdvancedPropagator.pas b/Source/Propagator/Enterprise/BoldAdvancedPropagator.pas index cd2fb450..1cec0a80 100644 --- a/Source/Propagator/Enterprise/BoldAdvancedPropagator.pas +++ b/Source/Propagator/Enterprise/BoldAdvancedPropagator.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAdvancedPropagator; interface @@ -16,7 +19,8 @@ interface BoldThreadSafeLog, IniFiles, BoldPropagatorMainForm, - Classes; + Classes + ; type {forward declarations} @@ -65,15 +69,14 @@ implementation BoldUtils, BoldPropagatorConstants, BoldDefs, - BoldPropagatorServer, - PropagatorConsts; + BoldPropagatorServer; {TBoldAdvancedPropagator} procedure TBoldAdvancedPropagator.Initialize; begin if fEnableLogging then BoldInitLog(fLogFileName, fErrorLogFileName, fThreadLogFileName, fMaxLogFileSize); - BoldLogError(sInitializing, [ClassName]); + BoldLogError('%s.Initialize: Starting..........................................', [ClassName]); fClientHandler := TBoldClientHandler.Create; fEnqueuer := TBoldEnqueuer.Create(fClientHandler); fUIManager := TUIManager.Create; @@ -117,7 +120,7 @@ destructor TBoldAdvancedPropagator.Destroy; FreeAndNil(fPriorityListEnlister); FreeAndNil(fClientHandler); end; - BoldLogError(sDestroying, [ClassName]); + BoldLogError('%s.Destroy: Closing down peacefully..........................................', [ClassName]); BoldDoneLog; inherited; @@ -152,7 +155,7 @@ procedure TBoldAdvancedPropagator.DoneDequeue(Sender: TObject); if Assigned(fUIManager) then fUIManager.SetDequeueIndicator(false); except on E: Exception do - BoldLogError('%s.DoneDequeue: %s', [ClassName, E.message]); // do not localize + BoldLogError('%s.DoneDequeue: error = %s', [ClassName, E.message]) end; end; @@ -160,11 +163,13 @@ procedure TBoldAdvancedPropagator.StartDequeue(Sender: TObject); begin if Assigned(fUIManager) then fUIManager.SetDequeueIndicator(true); -end; +end; function TBoldAdvancedPropagator.getClientHandler: TBoldClientHandler; begin Result := fClientHandler; end; +initialization + end. diff --git a/Source/Propagator/Enterprise/BoldAdvancedPropagatorCOM.pas b/Source/Propagator/Enterprise/BoldAdvancedPropagatorCOM.pas index b84e5280..bc185c03 100644 --- a/Source/Propagator/Enterprise/BoldAdvancedPropagatorCOM.pas +++ b/Source/Propagator/Enterprise/BoldAdvancedPropagatorCOM.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAdvancedPropagatorCOM; interface @@ -45,7 +48,6 @@ implementation {TBoldAdvancedPropagatorCOM} function TBoldAdvancedPropagatorCOM.GetBoldClientHandler: IBoldClientHandler; begin -// ClientHandlerCOMFactory.CreateInstance(nil, IID_IBoldClientHandler, Result); Result := ClienthandlerCOMFactory.CreateComObject(nil) as IBoldClientHandler; end; @@ -82,4 +84,6 @@ constructor TBoldPropagatorFactory.Create(ComServer: TComServerObject; const Cla inherited Create(ComServer, TBoldAdvancedPropagatorCOM, ClassID, ClassName, Description, ciMultiInstance, tmFree); end; +initialization + end. diff --git a/Source/Propagator/Enterprise/BoldClientHandler.pas b/Source/Propagator/Enterprise/BoldClientHandler.pas index 05c6c2b2..e10b2f78 100644 --- a/Source/Propagator/Enterprise/BoldClientHandler.pas +++ b/Source/Propagator/Enterprise/BoldClientHandler.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldClientHandler; interface @@ -28,7 +31,7 @@ TBoldClientInfo = class; {TBoldClientHandler} TBoldClientHandler = class(TBoldPublisher) private - fClientInfoList: TBoldClientInfoList; //ClientInfoList sorted by ClientID + fClientInfoList: TBoldClientInfoList; fNOConnectedClients: integer; fEnabled: Boolean; fLockTime: TDateTime; @@ -50,7 +53,7 @@ TBoldClientHandler = class(TBoldPublisher) procedure AcquireLock; procedure ReleaseLock; protected - procedure EnqueueRemoveClientQueueEvent(const ClientId: TBoldClientId); virtual; // virtuality is for testcases... + procedure EnqueueRemoveClientQueueEvent(const ClientId: TBoldClientId); virtual; public constructor Create; virtual; destructor Destroy; override; {IBoldClientHandler} @@ -71,8 +74,7 @@ TBoldClientHandler = class(TBoldPublisher) function IsRegistered(const ClientId: TBoldClientId): Boolean; function DisconnectClient(const BoldClientId: TBoldClientId; const RegistrationTime: TTimeStamp): Boolean; procedure SendDisconnectRequest(const BoldClientId: TBoldClientId; const msg: string; RemainDisconnected: Integer); -// function ExternalRemoveClient(const ClientId: TBoldClientId; const RegistrationTime: TTimeStamp; -// const Reason: TBoldRemoveClientReasonType): Boolean; + function IsThereAClientTimingOutSoon(out ClientId: TBoldClientId; out RegistrationTime, LeaseTimeOut: TTimeStamp): Boolean; procedure RemoveExpiredLease(const ClientID: TBoldClientID; const RegistrationTime: TTimeStamp); @@ -83,7 +85,6 @@ TBoldClientHandler = class(TBoldPublisher) {$IFDEF DEBUG} procedure DebugLock; procedure DebugUnlock; - // this function can cause a deadlock between the client and the server if called at the wrong time, use with care! function ValidateClientInterface(const ListenerInterface: IBoldListener; const ClientIDString: string): Boolean; {$ENDIF} function GetListener(const ClientId: TBoldClientId; const RegistrationTime: TTimeStamp; out obj): Boolean; @@ -109,8 +110,7 @@ TBoldClientInfo = class fLongestIntervalBetweenEvents: TDateTime; fLostEvents: integer; fClientStatus: TBoldClientReceiveStatus; - // all instance variables should be cleared/initialized in - // TBoldClientInfo.Initialize + function LeaseIsExpired: Boolean; procedure ReInitializeListenerInterface; function GetClientStatusString: string; @@ -164,7 +164,6 @@ implementation uses BoldPropagatorConstants, BoldPropagatorServer, - PropagatorConsts, comobj; type @@ -199,7 +198,7 @@ constructor TBoldClientHandler.Create; begin inherited Create; fClientInfoList := TBoldClientInfoList.Create; - fClientHandlerLock := TBoldLoggableCriticalSection.Create('CH'); // do not localize + fClientHandlerLock := TBoldLoggableCriticalSection.Create('CH'); fLockTimeLock := TCriticalSection.Create; fNOConnectedClients := 0; fLockTime := 0; @@ -225,7 +224,7 @@ destructor TBoldClientHandler.Destroy; FreeAndNil(fClientHandlerLock); FreeAndNil(fLockTimeLock); except on E: Exception do - BoldLogError(sLogError, [ClassName, 'Destroy', E.Message]); // do not localize + BoldLogError('%s.Destroy Error: %s)', [ClassName, E.Message]); end; inherited; end; @@ -240,7 +239,7 @@ function TBoldClientHandler.InfoForClient(ClientID: TBoldClientID; out BoldClien Result := Assigned(BoldClientInfo); end; except on E: Exception do - BoldLogError(sLogErrorAndID, [ClassName, 'InfoForClient', ClientId, E.message]); // do not localize + BoldLogError('%s.InfoForClient Error: [ID=%d] %s)', [ClassName, ClientId, E.message]); end; end; @@ -259,13 +258,13 @@ function TBoldClientHandler.RegisterClient(LeaseDuration: Integer; PollingInterv RegistrationTime := fClientInfoList[BoldClientId].RegistrationTime; SendExtendedEvent(self, BOLD_PROPAGATOR_CLIENT_REGISTERED, [BoldClientID]); NotifyLeaseChanged; - BoldLog(sLoggingID, [ClientIdString, BoldClientId]); + BoldLog('Log In: %s [ID=%d]', [ClientIdString, BoldClientId]); inc(fTotalClients); if NoConnectedClients > fPeakClients then fPeakClients := NoConnectedClients; Result := S_OK; except on E: Exception do - BoldLogError(sLogErrorAndID, [ClassName, 'RegisterClient', BOldClientID, E.Message]); // do not localize + BoldLogError('%s.RegisterClient Error: [ID=%d] %s)', [ClassName, BOldClientID, E.Message]); end; finally ReleaseLock; @@ -291,12 +290,12 @@ function TBoldClientHandler.ExtendLease(BoldClientID: Integer; LeaseDuration: In NotifyLeaseChanged; end else - BoldLog(sExtendLeaseFailed, [BoldClientId]); + BoldLog('ExtendLease failed: [ID=%d] Client already disconnected ', [BoldClientId]); finally ReleaseLock; end; except on E: Exception do - BoldLogError(sLogErrorAndID, [ClassName, 'ExtendLease', BoldClientId, E.Message]); // do not localize + BoldLogError('%s.ExtendLease Error: [ID=%d] %s', [ClassName, BoldClientId, E.Message]); end; end; @@ -317,10 +316,9 @@ function TBoldClientHandler.UnRegisterClient(BoldClientID: Integer; Registration if InternalRemoveClient(BoldClientID) then begin Result := S_OK; - // notify all subscribers --- cleanup SendExtendedEvent(self, BOLD_PROPAGATOR_CLIENT_UNREGISTERED, [BoldClientID]); NotifyLeaseChanged; - BoldLog(sLogOff, + BoldLog('Log Off: %s [ID=%d] [Pkg: %d Ev: %d Int: %s Login: %s (%s ago) Status: %s]', [IdString, BoldClientId, ClientInfo.fSuccessfullyReceivedCount, ClientInfo.fSuccessfullyReceivedEventsCount, @@ -334,7 +332,7 @@ function TBoldClientHandler.UnRegisterClient(BoldClientID: Integer; Registration ReleaseLock; end; except on E: Exception do - BoldLogError(sLogErrorAndID, [ClassName, 'UnRegisterClient', BoldClientId, E.Message]); // do not localize + BoldLogError('%s.UnRegisterClient Error: [ID=%d] %s)', [ClassName, BoldClientId, E.Message]); end; end; @@ -343,7 +341,6 @@ function TBoldClientHandler.InternalRemoveClient(BoldClientId: TBoldClientID): B ClientInfo: TBoldClientInfo; begin Result := false; - // remove the clientid from the list if InfoForClient(BoldClientID, ClientInfo) and (ClientInfo.Initialized) then begin Result := true; @@ -374,7 +371,7 @@ procedure TBoldClientHandler.AddClient(const LeaseDuration: Integer; PollingInte ClientId := NewClientID; NOConnectedClients := NOConnectedClients + 1; except on E: Exception do - BoldLogError(sLogError, [ClassName, 'AddClient', E.Message]); // do not localize + BoldLogError('%s.AddClient: %s', [ClassName, E.Message]); end; end; @@ -396,7 +393,7 @@ procedure TBoldClientHandler.RemoveExpiredLease( IdString := ClientInfo.ClientIdentifierString; InternalRemoveClient(ClientID); SendExtendedEvent(self, BOLD_PROPAGATOR_CLIENT_LEASE_EXPIRED, [ClientID]); - BoldLog(sLeaseExpired, + BoldLog('Lease Expired: %s [ID=%d] [Pkg: %d Ev: %d Int: %s Last: %s ago Login: %s (%s ago) Status: %s]', [IdString, ClientID, ClientInfo.fSuccessfullyReceivedCount, ClientInfo.fSuccessfullyReceivedEventsCount, @@ -421,7 +418,7 @@ procedure TBoldClientHandler.GetRegisteredClientIDs(ClientIds: TStringList); if Assigned(ClientIds) then for i:= 0 to fClientInfoList.Count - 1 do if Assigned(fClientInfoList[i]) and fClientInfoList[i].Initialized then - ClientIds.Add(Format('%d=%s', [fClientInfoList[i].ClientId, fClientInfoList[i].ClientIdentifierString])); // do not localize + ClientIds.Add(Format('%d=%s', [fClientInfoList[i].ClientId, fClientInfoList[i].ClientIdentifierString])); finally ReleaseLock; end; @@ -447,18 +444,17 @@ function TBoldClientHandler.DisconnectClient( if InternalRemoveClient(BoldClientID) then begin Result := true; - // notify all subscribers --- cleanup SendExtendedEvent(self, BOLD_PROPAGATOR_CLIENT_CONNECTION_LOST, [BoldClientID]); NotifyLeaseChanged; if ClientInfo.fSuccessfullyReceivedCount = 0 then - BoldLog(sClientDisconnected, [ + BoldLog('Disconnected: %s [ID=%d] Login: %s (%s ago) Status: %s', [ IdString, BoldClientId, DateTimeToStr(TimeStampToDateTime(ClientInfo.RegistrationTime)), TimeToStr(now - TimeStampToDateTime(ClientInfo.RegistrationTime)), ClientInfo.ClientStatusString ]) else - BoldLog(sClientDisconnected_Long, + BoldLog('Disconnected: %s [ID=%d] [Pkg: %d Ev: %d Int: %s Last: %s ago Login: %s (%s) Status: %s]', [IdString, BoldClientId, ClientInfo.fSuccessfullyReceivedCount, ClientInfo.fSuccessfullyReceivedEventsCount, @@ -473,7 +469,7 @@ function TBoldClientHandler.DisconnectClient( ReleaseLock; end; except on E: Exception do - BoldLogError(sLogErrorAndID, [ClassName, 'DisconnectClient', BoldClientId, E.Message]); // do not localize + BoldLogError('%s.DisconnectClient Error: [ID=%d] %s)', [ClassName, BoldClientId, E.Message]); end; end; @@ -493,7 +489,7 @@ function TBoldClientHandler.GetRegistrationTime(const ClientID: TBoldClientId; ReleaseLock; end; except on E: Exception do - BoldLogError(sLogErrorAndID, [ClassName, 'GetRegistrationTime', ClientID, E.Message]); // do not localize + BoldLogError('%s.GetRegistrationTime Error: [ID=%d] %s)', [ClassName, ClientID, E.Message]); end; end; @@ -523,9 +519,9 @@ procedure TBoldClientHandler.GetRegisteredClientInfos( try Guard := TBoldGuard.Create(Temp); Temp := TStringList.Create; - Temp.Add('TotalClients='+IntToStr(fTotalClients)); // do not localize - Temp.Add('PeakClients='+IntToStr(fPeakClients)); // do not localize - Temp.Add('TotalLostEvents='+IntToStr(fTotalLostEvents)); // do not localize + Temp.Add('TotalClients='+IntToStr(fTotalClients)); + Temp.Add('PeakClients='+IntToStr(fPeakClients)); + Temp.Add('TotalLostEvents='+IntToStr(fTotalLostEvents)); ClientInfo.Add(temp.CommaText); if Assigned(ClientInfo) then for i:= 0 to fClientInfoList.Count - 1 do @@ -533,16 +529,16 @@ procedure TBoldClientHandler.GetRegisteredClientInfos( begin ClientInfoItem := fClientInfoList[i]; temp.Clear; - Temp.Add('ID=' +IntToStr(ClientInfoItem.ClientId)); // do not localize - Temp.Add('IDString=' +ClientInfoItem.ClientIdentifierString); // do not localize - Temp.Add('RegistrationTime=' +FormatDateTime('yyyy-mm-dd hh:nn:ss', TimeStampToDateTime(ClientInfoItem.RegistrationTime))); // do not localize - Temp.Add('LeaseTimeout=' +FormatDateTime('yyyy-mm-dd hh:nn:ss', TimeStampToDateTime(ClientInfoItem.LeaseTimeOut))); // do not localize - temp.add('Packages=' +intToStr(ClientInfoItem.fSuccessfullyReceivedCount)); // do not localize - temp.add('Events=' +intToStr(ClientInfoItem.fSuccessfullyReceivedEventsCount)); // do not localize - temp.add('LastSend=' +FormatDateTime('yyyy-mm-dd hh:nn:ss', ClientInfoItem.fLastSuccessfullReceive)); // do not localize - temp.add('LongestInterval=' +FormatDateTime('yyyy-mm-dd hh:nn:ss', ClientInfoItem.fLongestIntervalBetweenEvents)); // do not localize - temp.add('LostEvents=' +IntToStr(ClientInfoItem.fLostEvents)); // do not localize - temp.Add('Status=' +ClientInfoItem.ClientStatusString); // do not localize + Temp.Add('ID=' +IntToStr(ClientInfoItem.ClientId)); + Temp.Add('IDString=' +ClientInfoItem.ClientIdentifierString); + Temp.Add('RegistrationTime=' +FormatDateTime('yyyy-mm-dd hh:nn:ss', TimeStampToDateTime(ClientInfoItem.RegistrationTime))); + Temp.Add('LeaseTimeout=' +FormatDateTime('yyyy-mm-dd hh:nn:ss', TimeStampToDateTime(ClientInfoItem.LeaseTimeOut))); + temp.add('Packages=' +intToStr(ClientInfoItem.fSuccessfullyReceivedCount)); + temp.add('Events=' +intToStr(ClientInfoItem.fSuccessfullyReceivedEventsCount)); + temp.add('LastSend=' +FormatDateTime('yyyy-mm-dd hh:nn:ss', ClientInfoItem.fLastSuccessfullReceive)); + temp.add('LongestInterval=' +FormatDateTime('yyyy-mm-dd hh:nn:ss', ClientInfoItem.fLongestIntervalBetweenEvents)); + temp.add('LostEvents=' +IntToStr(ClientInfoItem.fLostEvents)); + temp.Add('Status=' +ClientInfoItem.ClientStatusString); ClientInfo.Add(Temp.CommaText); end; finally @@ -601,7 +597,7 @@ function TBoldClientHandler.IsThereAClientTimingOutSoon( ReleaseLock; end; except on E: Exception do - BoldLogError(sLogError, [ClassName, 'IsThereAClientTimingOutSoon', E.Message]); // do not localize + BoldLogError('%s.IsThereAClientTimingOutSoon Error: %s', [ClassName, E.Message]); end; end; @@ -758,7 +754,7 @@ function TBoldClientHandler.GetFirstLeaseTimeOutClient: TBoldClientInfo; end; end; except on E: Exception do - BoldLogError(sLogError, [ClassName, 'GetFirstLeaseTimeOutClient', E.Message]); // do not localize + BoldLogError('%s.GetFirstLeaseTimeOutClient Error: %s', [ClassName, E.Message]); end; end; @@ -834,21 +830,21 @@ function TBoldClientHandler.ValidateClientInterface( if Result then begin Events := TStringList.Create; - Events.Add('L'); {TODO: change this to a ping message} + Events.Add('L'); try OleCheck(ListenerInterface.ReceiveEvents(StringListToVarArray(Events))); except on E: Exception do begin Result := false; - ErrorMsg := Format(sInvalidListener, [ClassName, ClientIdString, E.Message]); + ErrorMsg := Format('%s.ValidateClientInterface: ClientListener not valid for Client %s; Error=%s', [ClassName, ClientIdString, E.Message]); if E is EOleSysError then - ErrorMsg := ErrorMsg + Format(sErrorCode, [(E as EOleSysError).ErrorCode]); + ErrorMsg := ErrorMsg + Format(' ErrorCode=%d', [(E as EOleSysError).ErrorCode]); BoldLogError(ErrorMsg); end; end; end else - BoldLogError(sListenerInterfaceMissing, [ClassName, ClientIdString]); + BoldLogError('%s.ValidateClientInterface Error: [ID=%s] Listener interface missing', [ClassName, ClientIdString]); end; {$ENDIF} @@ -870,7 +866,7 @@ procedure TBoldClientHandler.MarkHasReceivedEvents(const ClientID: TBoldClientID if ClientInfo.fClientStatus = crsNotReceiving then begin ClientInfo.fClientStatus := crsRecovered; - BoldLogError(sClientHasRecovered, [ + BoldLogError('!!! Client %s (%d) has recovered and received %d messages', [ ClientInfo.ClientIdentifierString, ClientId, EventCount]); end; @@ -892,7 +888,7 @@ procedure TBoldClientHandler.MarkFailedToReceiveEvents(const ClientId: TBoldClie begin ClientInfo.fLostEvents := ClientInfo.fLostEvents + EventCount; ClientInfo.fClientStatus := crsNotReceiving; - inc(fTotalLostEvents, EventCount); + inc(fTotalLostEvents, EventCount); end; finally ReleaseLock; @@ -952,7 +948,7 @@ procedure TBoldClientHandler.SendDisconnectRequest(const BoldClientId: TBoldClie ReleaseLock; end; except on E: Exception do - BoldLogError(sLogErrorAndID, [ClassName, 'SendDisconnectRequest', BoldClientId, E.Message]); // do not localize + BoldLogError('%s.SendDisconnectRequest Error: [ID=%d] %s)', [ClassName, BoldClientId, E.Message]); end; end; @@ -988,7 +984,7 @@ procedure TBoldClientInfo.Initialize(LeaseTime, PollingInterval: Cardinal; fClientStatus := crsOK; fInitialized := true; except on E: Exception do - BoldLogError(sLogErrorAndID, [ClassName, 'Initialize', ClientIdString, E.Message]); // do not localize + BoldLogError('%s.Initialize Error: [ID=%s] %s', [ClassName, ClientIdString, E.Message]); end; end; @@ -1004,7 +1000,7 @@ procedure TBoldClientInfo.UnInitialize; fInitialized := false; end except on E: Exception do - BoldLogError(sLogError, [ClassName, 'UnInitialize', E.Message]); // do not localize + BoldLogError('%s.UnInitialize Error: %s', [ClassName, E.Message]); end; end; @@ -1018,7 +1014,7 @@ function TBoldClientInfo.LeaseIsExpired: Boolean; CurrentTime := DateTimetoTimeStamp(Now); Result := TimeStampComp(LeaseTimeOut, CurrentTime) <= 0; except on E: Exception do - BoldLogError(sLogErrorAndID, [ClassName, 'LeaseIsExpired', ClientID, E.Message]); // do not localize + BoldLogError('%s.LeaseIsExpired Error: [ID=%d] %s', [ClassName, ClientID, E.Message]); end; end; @@ -1031,11 +1027,11 @@ procedure TBoldClientInfo.ReInitializeListenerInterface; function TBoldClientInfo.GetClientStatusString: string; begin case fClientStatus of - crsOK: result := sOK; - crsNotReceiving: result := sNotReceiving; - crsRecovered: result := sRecovered; - else result := sUnknown; - end; + crsOK: result := 'OK'; + crsNotReceiving: result := 'Not Receiving'; + crsRecovered: result := 'Recovered'; + else result := ''; + end; end; procedure TBoldClientInfo.ExtendLease(LeaseDuration: integer); @@ -1137,7 +1133,7 @@ function TBoldClientInfoList.GetExistingClientInfo( if ((Index >= 0) and (Index < fList.Count)) then Result := (fList[Index] as TBoldClientInfo); except on E: Exception do - BoldLogError(sLogErrorAndID, [ClassName, 'GetExistingClientInfo', index, E.message]); // do not localize + BoldLogError('%s.GetExistingClientInfo Error: [ID=%d] %s', [ClassName, index, E.message]); end; end; diff --git a/Source/Propagator/Enterprise/BoldClientHandlerCOM.pas b/Source/Propagator/Enterprise/BoldClientHandlerCOM.pas index ae7b9e03..13b1f7ea 100644 --- a/Source/Propagator/Enterprise/BoldClientHandlerCOM.pas +++ b/Source/Propagator/Enterprise/BoldClientHandlerCOM.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldClientHandlerCOM; interface @@ -9,7 +12,8 @@ interface BoldThreadSafeLog, BoldClientHandler, BoldPropagatorInterfaces_TLB, - BoldThreadedComObjectFactory; + BoldThreadedComObjectFactory + ; type {forward declarations} @@ -55,7 +59,6 @@ TBoldClientHandlerThreadedCOMFactory = class(TBoldThreadedComObjectFactory) var ClientHandlerCOMFactory: TBoldClientHandlerThreadedCOMFactory; -// ClientHandlerCOMFactory: TBoldClientHandlerCOMFactory; implementation uses @@ -69,20 +72,20 @@ function TBoldClientHandlerCOM.RegisterClient(LeaseDuration: Integer; PollingInt const BoldClientListener: IBoldListener; const ClientIDString: WideString; out BoldClientID: Integer): HResult; stdcall; begin - BoldLogThread('ID=ClientHandler/RegCli'); // do not localize + BoldLogThread('ID=ClientHandler/RegCli'); Result := ClientHandler.RegisterClient(LeaseDuration, PollingInterval, BoldClientListener, ClientIDString, BoldClientID, fRegistrationTime); end; function TBoldClientHandlerCOM.ExtendLease(BoldClientID: Integer; LeaseDuration: Integer; out ExtensionOK: WordBool): HResult; stdcall; begin - BoldLogThread('ID=ClientHandler/ExtLease'); // do not localize + BoldLogThread('ID=ClientHandler/ExtLease'); Result := ClientHandler.ExtendLease(BoldClientID, LeaseDuration, ExtensionOK); end; function TBoldClientHandlerCOM.UnRegisterClient(BoldClientID: Integer): HResult; stdcall; begin - BoldLogThread('ID=ClientHandlerH/UnReg'); // do not localize + BoldLogThread('ID=ClientHandlerH/UnReg'); Result := ClientHandler.UnRegisterClient(BoldClientID, fRegistrationTime); end; @@ -122,4 +125,6 @@ function TBoldClientHandlerThreadedCOMFactory.CreateComObject( (Result as TBoldClientHandlerCOM).ClientHandler := ClientHandler; end; +initialization + end. diff --git a/Source/Propagator/Enterprise/BoldClientHandlerExportHandle.pas b/Source/Propagator/Enterprise/BoldClientHandlerExportHandle.pas index 5e36dc46..01b60f8b 100644 --- a/Source/Propagator/Enterprise/BoldClientHandlerExportHandle.pas +++ b/Source/Propagator/Enterprise/BoldClientHandlerExportHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldClientHandlerExportHandle; interface @@ -43,7 +46,6 @@ constructor TBoldClientHandlerExportHandle.Create(Active: Boolean; ServerHandle: function TBoldClientHandlerExportHandle.GetComObject: IUnknown; begin Result := CreateComObject(TBoldPropagatorServer.Instance.ClientHandlerCLSID); -//Result := TBoldClientHandlerCOM.CreateFromFactory(ClientHandlerCOMFactory, nil) as IUnknown; end; function TBoldClientHandlerExportHandle.GetHandledObject: TObject; diff --git a/Source/Propagator/Enterprise/BoldClientNotifierHandler.pas b/Source/Propagator/Enterprise/BoldClientNotifierHandler.pas index cb03906a..de8b8326 100644 --- a/Source/Propagator/Enterprise/BoldClientNotifierHandler.pas +++ b/Source/Propagator/Enterprise/BoldClientNotifierHandler.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldClientNotifierHandler; interface @@ -105,8 +108,7 @@ implementation BoldGuard, BoldPriorityListEnlister, BoldPropagatorServer, - comobj, - PropagatorConsts; + comobj; { TBoldClientNotifierHandler } @@ -116,26 +118,26 @@ procedure TBoldClientNotifierHandler.Execute; begin try EnsureMessageQueue; - BoldLogThread('ID=ClientNotifierHandler'); // do not localize + BoldLogThread('ID=ClientNotifierHandler'); SignalReady; while not Terminated do begin if PeekMessage(rMsg, 0, 0, 0, PM_REMOVE) then begin - if rMsg.Message = WM_QUIT then // terminated + if rMsg.Message = WM_QUIT then Terminate - else if rMsg.message = BM_PRIORITY_CHANGED then // signal from PriorityList + else if rMsg.message = BM_PRIORITY_CHANGED then ProcessPriorityListHead else DispatchMessage(rMsg); end - else if fScheduledClients.Count > 0 then //if no messages to process then empty scheduled clients' queue + else if fScheduledClients.Count > 0 then ProcessScheduledClientsHead - else // if nothing to do then wait for a message + else WaitMessage; - end; //while + end; except on E: Exception do - BoldLogError(sLogError, [ClassName, 'Execute', E.Message]); // do not localize + BoldLogError('%s.Execute (Error: %s)', [ClassName, E.Message]); end; FreeAndNil(fTimer); end; @@ -153,7 +155,7 @@ function TBoldClientNotifierHandler.getClientNotifierPool: TBoldClientNotifierPo function TBoldClientNotifierHandler.getTimer: TTimer; begin Assert(GetCurrentThreadId = self.ThreadID, - Format('%s.getTimer: Timer should be accessed from %s''s thread', [ClassName])); // do not localize + Format('%s.getTimer: Timer should be accessed from %s''s thread', [ClassName])); if not Assigned(fTimer) then begin fTimer := TTimer.Create(nil); @@ -168,7 +170,7 @@ procedure TBoldClientNotifierHandler.OnPriorityChanged(Sender: TObject); PriorityQueue: TBoldPriorityQueue; begin Assert(Sender is TBoldPriorityQueue, - Format('%s.OnPriorityChanged: Sender is not a TBoldPriorityQueue', [ClassName])); // do not localize + Format('%s.OnPriorityChanged: Sender is not a TBoldPriorityQueue', [ClassName])); PriorityQueue := Sender as TBoldPriorityQueue; if Assigned(PriorityQueue.Head) then Notify(BM_PRIORITY_CHANGED); @@ -198,15 +200,15 @@ procedure TBoldClientNotifierHandler.SendtoClient; try aData := TBoldClientNotifierData.CreateInitialized(ClientQueueInfo.ClientID, RegistrationTime, ClientQueueInfo.QueueAsVarArray); - fScheduledClients.Push(Pointer(aData)); // add to scheduled clients' list - while ProcessScheduledClientsHead do; // empty scheduled clients' list + fScheduledClients.Push(Pointer(aData)); + while ProcessScheduledClientsHead do; except - raise EBold.CreateFmt(sFailedToSendToClient, [ClassName]); + raise EBold.CreateFmt('%s.SendToClient: could not send events to client', [ClassName]); end; finally FreeAndNil(ClientQueueInfo); end; - end; + end; end; procedure TBoldClientNotifierHandler.ProcessPriorityListHead; @@ -223,8 +225,8 @@ procedure TBoldClientNotifierHandler.ProcessPriorityListHead; begin CurrentTime := DateTimeToTimeStamp(Now); if(ClientQueueInfo.TimeOut.Date <= CurrentTime.Date) and - ((ClientQueueInfo.TimeOut.Time - CurrentTime.Time) <= 1) then //FIXME!! - SendToClient //send immediately + ((ClientQueueInfo.TimeOut.Time - CurrentTime.Time) <= 1) then + SendToClient else SetTimer(ClientQueueInfo.TimeOut); end; @@ -293,6 +295,7 @@ procedure TBoldClientNotifierHandler.SetPriorityList( end; end; + { TBoldClientNotifier } constructor TBoldClientNotifier.Create(AOwner: TBoldClientNotifierhandler); @@ -306,9 +309,9 @@ procedure TBoldClientNotifier.Execute; function BoolToStr(value: Boolean): string; begin if Value then - Result := 'True' // do not localize + Result := 'True' else - Result := 'False'; // do not localize + Result := 'False'; end; var res: integer; @@ -326,18 +329,17 @@ procedure TBoldClientNotifier.Execute; begin EnsureMessageQueue; SignalReady; - BoldLogThread('ID=ClientNotifier'); // do not localize + BoldLogThread('ID=ClientNotifier'); fAvailableEvent.SetEvent; while not (Terminated) do begin res := Integer(getMessage(rMsg, 0, 0, 0)); - if res = -1 then //error + if res = -1 then Terminate - else if res = 0 then // terminated + else if res = 0 then Terminate else if rMsg.message = BM_THRD_DOWORK then begin - // Do work here CoInitializeEx(nil, CoInitFlags); try if Owner.ClientHandler.GetListener(fClientData.FclientId, @@ -351,18 +353,16 @@ procedure TBoldClientNotifier.Execute; end; except on E: Exception do begin - // retrieve client information Owner.ClientHandler.HasInfoForClient(fClientData.FClientID, clientIdentifier, registrationTime, initialized, Status); Owner.ClientHandler.HasInfoForClient(fClientData.FClientID, clientIdentifier, LeaseDuration, pollingInterval, LeaseTimeout, Initialized); RegistrationTimeDT := TimeStampToDateTime(RegistrationTime); LeaseTimeoutDT := TimeStampToDateTime(LeaseTimeout); Owner.ClientHandler.MarkFailedToReceiveEvents(fClientData.FClientID, VarArrayHighBound(fClientData.fEvents, 1)+1); - // Log the error if Owner.fDisconnectClientsOnSendFailure then - DisconnectMsg := sDisconnectMsg + DisconnectMsg := ' [Disconnected]' else DisconnectMsg := ''; - BoldLogError(sClientFailure, [ + BoldLogError('%s.Execute: Client %s (ID=%d)%s failed to receive messages (%d msgs): %s. RegistrationTime: %s (%s ago), LeaseTimeout: %s (%s left)', [ ClassName, ClientIdentifier, fClientData.FClientId, @@ -373,7 +373,6 @@ procedure TBoldClientNotifier.Execute; TimeToStr(LeaseTimeoutDT), TimeToStr(now-LeaseTimeOutDT)]); if Owner.fDisconnectClientsOnSendFailure then - // disconnect the client Owner.DisconnectClient(fClientData.FClientID, fClientData.fRegistrationTime); end; end; @@ -388,7 +387,7 @@ procedure TBoldClientNotifier.Execute; else begin DispatchMessage(rMsg); end; - end; //while + end; if Assigned(fClientData) then FreeAndNil(fClientData); end; @@ -470,13 +469,13 @@ function TBoldClientNotifierPool.ScheduleClientNotifier(mData: TBoldClientNotifi ClientNotifier := TBoldClientNotifier(fThreadList[CurrentThread]); if ClientNotifier.IsAvailable then begin - ClientNotifier.SetClientData(mData); // should be freed by the clientnotifier + ClientNotifier.SetClientData(mData); ClientNotifier.DoWork; Result := true; end; CurrentThread := (CurrentThread + 1) mod fPoolSize; except on E: Exception do - BoldLogError(sLogError, [ClassName, 'ScheduleClientNotifier', E.Message]); // do not localize + BoldLogError('%s.ScheduleClientNotifier: %s', [ClassName, E.Message]); end; end; @@ -490,7 +489,6 @@ constructor TBoldClientNotifierData.CreateInitialized(const ClientID: TBoldClien fRegistrationTime := RegistrationTime; end; -end. - - +initialization +end. diff --git a/Source/Propagator/Enterprise/BoldClientQueue.pas b/Source/Propagator/Enterprise/BoldClientQueue.pas index ad5161d0..e46212ad 100644 --- a/Source/Propagator/Enterprise/BoldClientQueue.pas +++ b/Source/Propagator/Enterprise/BoldClientQueue.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldClientQueue; interface @@ -34,7 +37,7 @@ function TBoldClientQueue.AsVarArray: variant; begin Lock; try - if UnsafeIsEmpty then // already in lock + if UnsafeIsEmpty then Result := UnAssigned else begin @@ -47,4 +50,6 @@ function TBoldClientQueue.AsVarArray: variant; end; end; +initialization + end. diff --git a/Source/Propagator/Enterprise/BoldComServiceRegister.pas b/Source/Propagator/Enterprise/BoldComServiceRegister.pas index e94962a0..1ab19d32 100644 --- a/Source/Propagator/Enterprise/BoldComServiceRegister.pas +++ b/Source/Propagator/Enterprise/BoldComServiceRegister.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldComServiceRegister; interface @@ -26,7 +29,7 @@ TBoldComServiceRegister = class procedure RegisterClassFactories(const Reg: Boolean; const AppId: string; ClsIds: array of string); -procedure RegisterServerAsService(const bReg: Boolean; const ClassID, ServiceName: string); +procedure RegisterServerAsService(const bReg: Boolean; const ClassID, ServiceName: string); implementation @@ -47,7 +50,7 @@ procedure DeleteAppId(const RootKey: DWord; const Key: string); try Reg.RootKey := RootKey; if Reg.OpenKey(Key, False) - then Reg.DeleteValue('AppID'); // do not localize + then Reg.DeleteValue('AppID'); finally Reg.CloseKey; Reg.Free; @@ -81,8 +84,8 @@ procedure RegisterServerAsService(const bReg: Boolean; const ClassID, ServiceNam Reg := TRegistry.Create; try Reg.RootKey := HKEY_CLASSES_ROOT; - if Reg.OpenKey('AppID\' + ClassID, False) // do not localize - then Reg.DeleteValue('LocalService'); // do not localize + if Reg.OpenKey('AppID\' + ClassID, False) + then Reg.DeleteValue('LocalService'); finally Reg.CloseKey; Reg.Free; @@ -100,13 +103,13 @@ procedure RegisterClassFactories(const Reg: Boolean; begin comserv.comserver.UpdateRegistry(true); for i := 0 to High(ClsIds) do - CreateRegKey(Format('%s\%s', ['CLSID', ClsIds[i]]), 'AppID', AppId); // do not localize + CreateRegKey(Format('%s\%s', ['CLSID', ClsIds[i]]), 'AppID', AppId); end else begin comserv.comserver.UpdateRegistry(false); for i := 0 to High(ClsIds) do - DeleteAppId(HKEY_CLASSES_ROOT, Format('%s\%s', ['CLSID', ClsIds[i]])); // do not localize + DeleteAppId(HKEY_CLASSES_ROOT, Format('%s\%s', ['CLSID', ClsIds[i]])); end; end; @@ -118,10 +121,10 @@ procedure RegisterAppIdForClass(const Reg: Boolean; begin if Reg then for i := 0 to High(ClsIds) do - CreateRegKey(Format('%s\%s', ['CLSID', ClsIds[i]]), 'AppID', AppId) // do not localize + CreateRegKey(Format('%s\%s', ['CLSID', ClsIds[i]]), 'AppID', AppId) else for i := 0 to High(ClsIds) do - DeleteAppId(HKEY_CLASSES_ROOT, Format('%s\%s', ['CLSID', ClsIds[i]])); // do not localize + DeleteAppId(HKEY_CLASSES_ROOT, Format('%s\%s', ['CLSID', ClsIds[i]])); end; procedure DeleteCLSIDs(const RootKey: DWord; ClsIds: array of string); @@ -133,7 +136,7 @@ procedure DeleteCLSIDs(const RootKey: DWord; ClsIds: array of string); Reg.RootKey := RootKey; try for i := 0 to High(ClsIds) do - Reg.DeleteKey(Format('%s\%s', ['CLSID', ClsIds[i]])); // do not localize + Reg.DeleteKey(Format('%s\%s', ['CLSID', ClsIds[i]])); finally Reg.CloseKey; Reg.Free; @@ -167,4 +170,6 @@ procedure TBoldComServiceRegister.DoServiceStop; RegisterClassFactories(False, AppID, [AppID]); end; +initialization + end. diff --git a/Source/Propagator/Enterprise/BoldEnqueuer.pas b/Source/Propagator/Enterprise/BoldEnqueuer.pas index 0a868085..71f2f5cd 100644 --- a/Source/Propagator/Enterprise/BoldEnqueuer.pas +++ b/Source/Propagator/Enterprise/BoldEnqueuer.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldEnqueuer; interface @@ -12,7 +15,8 @@ interface BoldLoggableCriticalSection, BoldThreadSafeLog, windows, - classes; + classes +; type TBoldExternalEventType = (bemEvent, bemSubscription, bemCancelSubscription, bemRemoveClientQueue, @@ -88,11 +92,11 @@ constructor TBoldEnqueuer.Create(ClientHandler: TBoldClientHandler); begin inherited Create; FClientHandler := ClientHandler; - fLock := TBoldLoggableCriticalSection.Create('EQ'); // do not localize + fLock := TBoldLoggableCriticalSection.Create('EQ'); fLock.Acquire; try fEnabled := false; - fInQueue := TBoldExternalEventThreadSafeObjectQueue.Create('InQ'); // do not localize + fInQueue := TBoldExternalEventThreadSafeObjectQueue.Create('InQ'); fEnabled := true; finally fLock.Release; @@ -111,7 +115,7 @@ function TBoldEnqueuer.SendEvents(BoldClientID: Integer; Events: OleVariant): H except on E: Exception do begin Result := E_FAIL; - BoldLogError('%s.SendEvents ClientId=%d: %s', [ClassName, BoldClientId, E.Message]); // do not localize + BoldLogError('%s.SendEvents ClientId=%d: %s', [ClassName, BoldClientId, E.Message]); end; end; finally @@ -131,7 +135,7 @@ function TBoldEnqueuer.AddSubscriptions(BoldClientID: Integer; Subscriptions: O except on E: Exception do begin Result := E_FAIL; - BoldLogError('%s.AddSubscriptions ClientId=%d: %s', [ClassName, BoldClientId, E.Message]); // do not localize + BoldLogError('%s.AddSubscriptions ClientId=%d: %s', [ClassName, BoldClientId, E.Message]); end; end; finally @@ -150,7 +154,7 @@ function TBoldEnqueuer.CancelSubscriptions(BoldClientID: Integer; Subscriptions except on E: Exception do begin Result := E_FAIL; - BoldLogError('%s.CancelSubscriptions ClientId=%d: %s', [ClassName, BoldClientId, E.Message]); // do not localize + BoldLogError('%s.CancelSubscriptions ClientId=%d: %s', [ClassName, BoldClientId, E.Message]); end; end; finally @@ -188,7 +192,7 @@ function TBoldEnqueuer.SendLockEvent(BoldClientID: Integer; FInQueue.Enqueue(TBoldExternalEvent.Create(BoldClientID, bemLockLost, Event)); Result := True; except on E: Exception do - BoldLogError('%s.SendLockEvent ClientId=%d: %s', [ClassName, BoldClientId, E.Message]); // do not localize + BoldLogError('%s.SendLockEvent ClientId=%d: %s', [ClassName, BoldClientId, E.Message]); end; end; finally @@ -241,7 +245,6 @@ function TBoldEnqueuer.CheckStatus(ClientId: TBoldClientId; VarArray: OLEVariant result := W_CLIENT_NOT_RECEIVING else result := S_OK; - // Currently, do not inform the client about the warning... result := S_OK; end; diff --git a/Source/Propagator/Enterprise/BoldEnqueuerCOM.pas b/Source/Propagator/Enterprise/BoldEnqueuerCOM.pas index 6ad5ee03..96f28df9 100644 --- a/Source/Propagator/Enterprise/BoldEnqueuerCOM.pas +++ b/Source/Propagator/Enterprise/BoldEnqueuerCOM.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldEnqueuerCOM; interface @@ -58,14 +61,14 @@ implementation function TBoldEnqueuerCOM.AddSubscriptions(BoldClientID: Integer; Subscriptions: OleVariant): HResult; begin - BoldLogThread('ID=Enqueuer/AddS'); // do not localize + BoldLogThread('ID=Enqueuer/AddS'); Result := Enqueuer.AddSubscriptions(BoldClientID, Subscriptions); end; function TBoldEnqueuerCOM.CancelSubscriptions(BoldClientID: Integer; Subscriptions: OleVariant): HResult; begin - BoldLogThread('ID=Enqueuer/CancelS'); // do not localize + BoldLogThread('ID=Enqueuer/CancelS'); Result := Enqueuer.CancelSubscriptions(BoldClientID, Subscriptions); end; @@ -84,7 +87,7 @@ procedure TBoldEnqueuerCOM.Initialize; function TBoldEnqueuerCOM.SendEvents(BoldClientID: Integer; Events: OleVariant): HResult; begin - BoldLogThread('ID=Enqueuer/SendEv'); // do not localize + BoldLogThread('ID=Enqueuer/SendEv'); Result := Enqueuer.SendEvents(BoldClientId, Events); end; @@ -104,4 +107,6 @@ function TBoldEnqueuerThreadedCOMFactory.CreateComObject( (Result as TBoldEnqueuerCOM).Enqueuer := Enqueuer; end; +initialization + end. diff --git a/Source/Propagator/Enterprise/BoldEnqueuerExportHandle.pas b/Source/Propagator/Enterprise/BoldEnqueuerExportHandle.pas index 75c75526..ff24ceff 100644 --- a/Source/Propagator/Enterprise/BoldEnqueuerExportHandle.pas +++ b/Source/Propagator/Enterprise/BoldEnqueuerExportHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldEnqueuerExportHandle; interface @@ -43,7 +46,6 @@ constructor TBoldEnqueuerExportHandle.Create(Active: Boolean; ServerHandle: TBol function TBoldEnqueuerExportHandle.GetComObject: IUnknown; begin Result := CreateComObject(TBoldPropagatorServer.Instance.EnqueuerCLSID); -// Result := TBoldEnqueuerCOM.CreateFromFactory(EnqueuerCOMFactory, nil) as IUnknown; end; function TBoldEnqueuerExportHandle.GetHandledObject: TObject; diff --git a/Source/Propagator/Enterprise/BoldIndexList.pas b/Source/Propagator/Enterprise/BoldIndexList.pas index b65bc4a2..0a49660c 100644 --- a/Source/Propagator/Enterprise/BoldIndexList.pas +++ b/Source/Propagator/Enterprise/BoldIndexList.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldIndexList; interface @@ -80,7 +83,6 @@ constructor TBoldIndexList.Create(const IndexOrder: integer); procedure TBoldIndexList.DeleteINodeByKey(Key: variant); begin - //overriden in derived classes end; procedure TBoldIndexList.RemoveKey(Key: variant); @@ -97,7 +99,7 @@ procedure TBoldIndexList.RemoveKey(Key: variant); end; if Assigned(iNode) then begin - iNode.next := nil; // is this necessary??? + iNode.next := nil; DeleteINodeByKey(Key); end; end; @@ -155,4 +157,6 @@ procedure TBoldAbstractMultiIndexedList.RemoveKey(IndexOrder: integer; Indices[IndexOrder].RemoveKey(Key); end; +initialization + end. diff --git a/Source/Propagator/Enterprise/BoldIndexedList.pas b/Source/Propagator/Enterprise/BoldIndexedList.pas index 32c2a2a2..e0322435 100644 --- a/Source/Propagator/Enterprise/BoldIndexedList.pas +++ b/Source/Propagator/Enterprise/BoldIndexedList.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldIndexedList; interface @@ -9,7 +12,8 @@ interface BoldHashIndexes, BoldIndexableList, BoldGuard, - BoldContainers; + BoldContainers + ; const Initial_Client_Count = 1000; @@ -42,15 +46,16 @@ TBoldClientIDList = class(TBoldIndexList) TBoldExternalEventIndex = class(TBoldStringHashIndex) protected - function ItemAsKeyString(Item: TObject): string; override; + function ItemASKeyString(Item: TObject): string; override; end; TBoldExternalEventHashTable = class(TBoldUnorderedIndexableList) private - function GetItemByEventName(EventName: string): TBoldEventNameIndexNode; + class var IX_EventName: integer; + function GetItemByEventName(EventName: string): TBoldEventNameIndexNode; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public constructor Create; - procedure Add(Item: TBoldEventNameIndexNode); + procedure Add(Item: TBoldEventNameIndexNode); {$IFDEF BOLD_INLINE} inline; {$ENDIF} property ItemsByEventName[ExpressionName: string]: TBoldEventNameIndexNode read GetItemByEventName; end; @@ -58,9 +63,9 @@ TBoldEventNameList = class(TBoldIndexList) private fEvents: TBoldExternalEventHashTable; protected - function getItem(Key: variant): TBoldIndexNode; override; - procedure setItem(Key: variant; Value: TBoldIndexNode); override; - function getCount: integer; override; + function GetItem(Key: variant): TBoldIndexNode; override; + procedure SetItem(Key: variant; Value: TBoldIndexNode); override; + function GetCount: integer; override; function InsertINode(Key: variant): TBoldIndexNode; override; public constructor Create(const IndexOrder: integer); override; @@ -78,10 +83,8 @@ implementation BoldPropagatorSubscriptions, BoldDefs; -var - IX_EventName: integer = -1; - {TBoldClientIDList} +{TBoldClientIDList} constructor TBoldClientIDList.Create; begin inherited Create(IndexOrder); @@ -104,7 +107,7 @@ destructor TBoldClientIDList.Destroy; inherited; end; -function TBoldClientIDList.getClient(Index: Integer): TObject; +function TBoldClientIDList.GetClient(Index: Integer): TObject; var cnt, increment, i: integer; begin @@ -122,12 +125,12 @@ function TBoldClientIDList.getClient(Index: Integer): TObject; end; end; -function TBoldClientIDList.getCount: integer; +function TBoldClientIDList.GetCount: integer; begin Result := fClients.Count; end; -function TBoldClientIDList.getItem(Key: variant): TBoldIndexNode; +function TBoldClientIDList.GetItem(Key: variant): TBoldIndexNode; var aKey: integer; begin @@ -148,13 +151,13 @@ function TBoldClientIDList.InsertINode(Key: variant): TBoldIndexNode; Result := Clients[aKey] as TBoldIndexNode; end; -procedure TBoldClientIDList.setClient(Index: Integer; +procedure TBoldClientIDList.SetClient(Index: Integer; Value: TObject); begin Clients[Index] := Value; end; -procedure TBoldClientIDList.setItem(Key: variant; Value: TBoldIndexNode); +procedure TBoldClientIDList.SetItem(Key: variant; Value: TBoldIndexNode); var aKey: integer; begin @@ -205,14 +208,14 @@ destructor TBoldEventNameList.Destroy; inherited ; end; -function TBoldEventNameList.getCount: integer; +function TBoldEventNameList.GetCount: integer; begin Result := fEvents.Count; end; -function TBoldEventNameList.getItem(Key: variant): TBoldIndexNode; +function TBoldEventNameList.GetItem(Key: variant): TBoldIndexNode; begin - Assert(VarType(Key) = varString, Format('%s.getItem: Key is not TBoldStringKey', [ClassName])); + Assert(VarIsStr(Key), Format('%s.getItem: Key is not TBoldStringKey', [ClassName])); Result := fEvents.GetItemByEventName(string(Key)); end; @@ -242,13 +245,12 @@ procedure TBoldEventNameList.DeleteINodeByKey(Key: variant); fEvents.Remove(node); end; -procedure TBoldEventNameList.setItem(Key: variant; Value: TBoldIndexNode); +procedure TBoldEventNameList.SetItem(Key: variant; Value: TBoldIndexNode); begin Assert(Value is TBoldEventNameIndexNode); fEvents.Add(Value as TBoldEventNameIndexNode); end; - procedure TBoldEventNameList.DeleteNodes; var Traverser: TBoldIndexableListTraverser; @@ -256,12 +258,15 @@ procedure TBoldEventNameList.DeleteNodes; begin Guard := TBoldGuard.Create(Traverser); Traverser := fEvents.CreateTraverser; - while not Traverser.EndOfList do + Traverser.AutoMoveOnRemoveCurrent := false; + while Traverser.MoveNext do begin if Traverser.Item is TBoldIndexNode then - DeleteINode(Traverser.Item as TBoldIndexNode); - Traverser.Next; - end; //for + DeleteINode(Traverser.Item as TBoldIndexNode) + end; end; +initialization + TBoldExternalEventHashTable.IX_EventName := -1; + end. diff --git a/Source/Propagator/Enterprise/BoldListNodes.pas b/Source/Propagator/Enterprise/BoldListNodes.pas index eb219d6d..7595607e 100644 --- a/Source/Propagator/Enterprise/BoldListNodes.pas +++ b/Source/Propagator/Enterprise/BoldListNodes.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldListNodes; interface @@ -99,7 +102,6 @@ procedure TBoldAbstractLinkNode.Remove; begin for Index := 0 to NumberOfIndices - 1 do begin - // unlink next if Assigned(Next[Index]) then (Next[Index] as TBoldAbstractLinkNode).Previous[Index] := Previous[Index]; Prev := Previous[Index]; @@ -113,4 +115,6 @@ procedure TBoldAbstractLinkNode.Remove; end; end; +initialization + end. diff --git a/Source/Propagator/Enterprise/BoldLockList.pas b/Source/Propagator/Enterprise/BoldLockList.pas index 9119ef0e..f0f556f6 100644 --- a/Source/Propagator/Enterprise/BoldLockList.pas +++ b/Source/Propagator/Enterprise/BoldLockList.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLockList; interface @@ -32,12 +35,10 @@ TBoldLockIndex = class(TBoldStringHashIndex) TBoldLockNameHashList = class(TBoldUnorderedIndexableList) private -// function GetItem(Index: Integer): TBoldLockNameIndexNode; function GetItembyLockName(LockName: string): TBoldLockNameIndexNode; public constructor Create; procedure Add(Item: TBoldLockNameIndexNode); -// property Items[Index: Integer]: TBoldLockNameIndexNode read GetItem; default; property ItemsByLockName[LockName: string]: TBoldLockNameIndexNode read GetItembyLockName; end; @@ -78,7 +79,6 @@ TBoldLockNameList = class(TBoldIndexList) procedure setItem(Key: variant; Value: TBoldIndexNode); override; function getCount: integer; override; function InsertINode(Key: variant): TBoldIndexNode; override; -// function getINode(Index: integer): TBoldIndexNode; override; public constructor Create(const IndexOrder: integer); override; destructor Destroy; override; @@ -112,7 +112,7 @@ TBoldLockNode = class(TBoldAbstractLinkNode) procedure EnsureLock(Ensure: Boolean); function GetLockDuration(const CurrentTime: TTimeStamp): comp; property ClientId: TBoldClientId read fClientId write fClientId; - property TimeOut: Integer read fTimeOut write fTimeOut; // duration in milliseconds + property TimeOut: Integer read fTimeOut write fTimeOut; property LockAcquisitionTime: TTimeStamp read fLockAcquisitionTime write fLockAcquisitionTime; property LockType: TBoldLockType read fLockType write setLockType; property CanTimeOut: Boolean read fCanTimeOut; @@ -145,11 +145,14 @@ TBoldLockList = class(TBoldAbstractMultiIndexedList) property Locks[Index: string]: TBoldLockNameIndexNode read getLock; property Items[ClientId: TBoldClientID; LockName: string]: TBoldLockNode read getItem; default; property ClientIdIndexOrder: integer read fClientIdIndexOrder; - property LockNameIndexOrder: integer read fLockNameIndexOrder; + property LockNameIndexOrder: integer read fLockNameIndexOrder; end; implementation +uses + BoldRev; + var IX_LockName: integer = -1; IX_ClientID: integer = -1; @@ -367,11 +370,10 @@ procedure TBoldLockNameList.DeleteNodes; begin Guard := TBoldGuard.Create(Traverser); Traverser := fLocks.CreateTraverser; - while not Traverser.EndOfList do + while Traverser.MoveNext do begin if Traverser.Item is TBoldIndexNode then DeleteINode(Traverser.Item as TBoldIndexNode); - Traverser.Next; end; end; @@ -432,19 +434,16 @@ procedure TBoldLockNameList.InsertNode(Key: variant; CurrentNode := iNode.Clients.GetItembyClientId(NewLockNode.ClientId); if Assigned(CurrentNode) then begin - // remove node CurrentNode.Remove; FreeAndNil(CurrentNode); end else begin - // add node NewNode.Previous[IndexOrder] := iNode; NewNode.Next[IndexOrder] := iNode.Next; if Assigned(iNode.Next) then iNode.Next.Previous[IndexOrder] := NewNode; iNode.Next := NewNode; - // add node to ClientIdHashList NewLockNode.AddToList(iNode.Clients); end; end; @@ -493,7 +492,7 @@ function TBoldLockNode.GetHasTimedOut: Boolean; CurrentTime := DateTimetoTimeStamp(Now); LockAcquisitionDuration := TimeStampToMSecs(CurrentTime) - TimeStampToMSecs(LockAcquisitionTime); Result := (Int(LockAcquisitionDuration) >= TimeOut); - end; + end; end; function TBoldLockNode.GetLockDuration(const CurrentTime: TTimeStamp): comp; @@ -580,7 +579,7 @@ function TBoldClientIdIndex.ItemAsKeyString(Item: TObject): string; constructor TBoldClientIdHashList.Create(OwnerIndexNode: TBoldLockNameIndexNode); begin - OwnsEntries := false;//ToReview + OwnsEntries := false; SetIndexCapacity(1); SetIndexVariable(IX_ClientID, AddIndex(TBoldClientIDIndex.Create)); fOwnerIndexNode := OwnerIndexNode; @@ -607,4 +606,6 @@ function TBoldLockNameIndexNode.getClients: TBoldClientIdHashList; Result := fClients; end; +initialization + end. diff --git a/Source/Propagator/Enterprise/BoldLockManager.pas b/Source/Propagator/Enterprise/BoldLockManager.pas index 8d4f76b1..bb4e98b1 100644 --- a/Source/Propagator/Enterprise/BoldLockManager.pas +++ b/Source/Propagator/Enterprise/BoldLockManager.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLockManager; interface @@ -16,7 +19,7 @@ interface ; type - TBoldLockManager = class(TBoldPassthroughSubscriber) + TBoldLockManager = class(TBoldExtendedPassthroughSubscriber) private fHandedLocks: TBoldLockList; fPropagator: TBoldAdvancedPropagator; @@ -86,9 +89,8 @@ function TBoldLockManager.CanAcquireLocks( const ClientId: TBoldClientId; const if (CurrentNode.ClientId <> ClientId) then if CurrentNode.HasTimedOut then begin - // this is where locks get lost Temp := CurrentNode; - CurrentNode := CurrentNode.Next[HandedLocks.LockNameIndexOrder] as TBoldLockNode; //send LockLost event + CurrentNode := CurrentNode.Next[HandedLocks.LockNameIndexOrder] as TBoldLockNode; Temp.Remove; LockLostEvent := TBoldObjectSpaceExternalEvent.EncodeExternalEvent(bsLockLost, '', '',Locks[i] ,nil); Propagator.Enqueuer.SendLockEvent(Temp.ClientId, LockLostEvent, False); @@ -104,9 +106,9 @@ function TBoldLockManager.CanAcquireLocks( const ClientId: TBoldClientId; const end else CurrentNode := CurrentNode.Next[HandedLocks.LockNameIndexOrder] as TBoldLockNode; - end;//while + end; end - end;//for + end; end; constructor TBoldLockManager.Create(const Propagator: TBoldAdvancedPropagator); @@ -238,4 +240,6 @@ function TBoldLockManager.EnsureLocks(const ClientID: TBoldClientID; const Reque end; end; +initialization + end. diff --git a/Source/Propagator/Enterprise/BoldLockManagerAdmin.pas b/Source/Propagator/Enterprise/BoldLockManagerAdmin.pas index e2ca2896..e24cf35e 100644 --- a/Source/Propagator/Enterprise/BoldLockManagerAdmin.pas +++ b/Source/Propagator/Enterprise/BoldLockManagerAdmin.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLockManagerAdmin; interface @@ -5,10 +8,11 @@ interface uses BoldLockManager, BoldDefs, - Classes; + Classes + ; type - { TBoldLockManagerAdmin } + TBoldLockManagerAdmin = class private fLockManager: TBoldLockManager; @@ -31,8 +35,7 @@ implementation Sysutils, BoldUtils, BoldLockList, - windows, - PropagatorConsts; + windows; { TBoldLockManagerAdmin } @@ -111,14 +114,14 @@ procedure TBoldLockManagerAdmin.LocksForClients( const ClientIds: TStringList; c result := trunc(source - temp*factor); source := temp; end; - + begin if not Assigned(ClientIds) then - raise EBold.CreateFmt(sClientIDsNotAssigned, [ClassName, 'LocksForClients']); // do not localize + raise EBold.CreateFmt('%s.LocksForClients: ClientIds is not assigned', [ClassName]); if not Assigned(Locks) then - raise EBold.CreateFmt(sLocksNotAssigned, [ClassName]); + raise EBold.CreateFmt('%s.LocksForClients: Locks is not assigned', [ClassName]); if not Assigned(LockDurations) then - raise EBold.CreateFmt(sLockDurationNotAssigned, [ClassName]); + raise EBold.CreateFmt('%s.LocksForClients: LockDurations is not assigned', [ClassName]); ClientLocks := TStringList.Create; try CurrentTime := DateTimeToTimeStamp(Now); @@ -139,11 +142,11 @@ procedure TBoldLockManagerAdmin.LocksForClients( const ClientIds: TStringList; c sec := Getpart(temp, 60); min := Getpart(temp, 60); hour := Getpart(temp, 24); - LockDur := Format('%.2d:%.2d:%.2d:%.3d', [Hour, Min, Sec, MSec]); // do not localize + LockDur := Format('%.2d:%.2d:%.2d:%.3d', [Hour, Min, Sec, MSec]); if temp > 0 then - LockDur := format('%d day(s) ', [temp])+LockDur; // do not localize + LockDur := format('%d day(s) ', [temp])+LockDur; LockDurations.Add(LockDur); - Locks.Add(Format('%d=%s', [CurrentClientId, ClientLocks[j]])); // do not localize + Locks.Add(Format('%d=%s', [CurrentClientId, ClientLocks[j]])); end; ClientLocks.Clear; end; @@ -164,4 +167,6 @@ procedure TBoldLockManagerAdmin.SetLockManagerSuspended(Value: Boolean); LockManager.Suspended := Value; end; +initialization + end. diff --git a/Source/Propagator/Enterprise/BoldLockManagerAdminCOM.pas b/Source/Propagator/Enterprise/BoldLockManagerAdminCOM.pas index 34bfa9e8..f55a7112 100644 --- a/Source/Propagator/Enterprise/BoldLockManagerAdminCOM.pas +++ b/Source/Propagator/Enterprise/BoldLockManagerAdminCOM.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLockManagerAdminCOM; interface @@ -10,7 +13,6 @@ interface const CLSID_LOCKMANAGERADMIN : TGuid = '{D06C7BF6-EBC1-4D2E-954F-AEA567C262F7}'; - type {forward declarations} TBoldLockManagerAdminCOM = class; @@ -49,7 +51,8 @@ implementation BoldPropagatorServer, BoldApartmentThread, Classes, - windows; + windows + ; { TBoldLockManagerAdminCOM } @@ -148,4 +151,6 @@ constructor TBoldLockManagerAdminComFactory.Create( inherited Create(ComServer, TBoldLockManagerAdminCOM, ClassID, ClassName, Description, ciMultiInstance, batSTA); end; +initialization + end. diff --git a/Source/Propagator/Enterprise/BoldLockManagerAdminExportHandle.pas b/Source/Propagator/Enterprise/BoldLockManagerAdminExportHandle.pas index d7ae481b..422297f8 100644 --- a/Source/Propagator/Enterprise/BoldLockManagerAdminExportHandle.pas +++ b/Source/Propagator/Enterprise/BoldLockManagerAdminExportHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLockManagerAdminExportHandle; interface @@ -14,7 +17,7 @@ TBoldLockManagerAdminComExportHandle = class; TBoldLockManagerAdminComExportHandle = class(TBoldComExportHandle) protected function GetComObject: IUnknown; override; - function GetHandledObject: TObject; override; + function GetHandledObject: TObject; override; public constructor Create(Active: Boolean; ServerHandle: TBoldComServerHandle; ServerClass: string); reintroduce; end; @@ -42,11 +45,13 @@ constructor TBoldLockManagerAdminComExportHandle.Create(Active: Boolean; ServerH function TBoldLockManagerAdminComExportHandle.GetComObject: IUnknown; begin Result := CreateComObject(TBoldPropagatorServer.Instance.LockManagerAdminCLSID); -end; +end; function TBoldLockManagerAdminComExportHandle.GetHandledObject: TObject; begin Result := nil; end; +initialization + end. diff --git a/Source/Propagator/Enterprise/BoldLockManagerCOM.pas b/Source/Propagator/Enterprise/BoldLockManagerCOM.pas index 9ec51eb1..20ac6376 100644 --- a/Source/Propagator/Enterprise/BoldLockManagerCOM.pas +++ b/Source/Propagator/Enterprise/BoldLockManagerCOM.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLockManagerCOM; interface @@ -32,7 +35,7 @@ TBoldLockManagerCOM = class(TTypedComObject, IBoldLockManager) TBoldLockManagerCOMFactory = class(TBoldThreadedComObjectFactory) public - constructor Create(ComServer: TComServerObject; + constructor Create(ComServer: TComServerObject; const ClassID: TGUID; const ClassName, Description: string); end; @@ -73,7 +76,6 @@ function TBoldLockManagerCOM.EnsureLocks(ClientId: Integer; function TBoldLockManagerCOM.getLockManager: TBoldLockManager; begin - // get the LockManager from the global application object if not Assigned(fLockManager) then fLockManager := TBoldPropagatorServer.Instance.LockManager; Result := fLockManager; @@ -85,7 +87,6 @@ function TBoldLockManagerCOM.GetLocks(ClientId, TimeOut: Integer; var SharedLocks, ExclusiveLocks: TStringList; begin - // delegate call to lockmanager SharedLocks := TStringList.Create; ExclusiveLocks := TStringList.Create; try @@ -122,4 +123,6 @@ constructor TBoldLockManagerCOMFactory.Create(ComServer: TComServerObject; inherited Create(ComServer, TBoldLockManagerCOM, ClassID, ClassName, Description, ciMultiInstance, batSTA); end; +initialization + end. diff --git a/Source/Propagator/Enterprise/BoldLockManagerExportHandle.pas b/Source/Propagator/Enterprise/BoldLockManagerExportHandle.pas index 0030a91c..73b12642 100644 --- a/Source/Propagator/Enterprise/BoldLockManagerExportHandle.pas +++ b/Source/Propagator/Enterprise/BoldLockManagerExportHandle.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLockManagerExportHandle; interface @@ -15,9 +18,9 @@ TBoldLockManagerComExportHandle = class; TBoldLockManagerComExportHandle = class(TBoldComExportHandle) protected function GetComObject: IUnknown; override; - function GetHandledObject: TObject; override; + function GetHandledObject: TObject; override; public - constructor Create(Active: Boolean; ServerHandle: TBoldComServerHandle; ServerClass: string); reintroduce; + constructor Create(Active: Boolean; ServerHandle: TBoldComServerHandle; ServerClass: string); reintroduce; end; implementation @@ -49,4 +52,6 @@ function TBoldLockManagerComExportHandle.GetHandledObject: TObject; Result := nil; end; +initialization + end. diff --git a/Source/Propagator/Enterprise/BoldOutputQueueHandler.pas b/Source/Propagator/Enterprise/BoldOutputQueueHandler.pas index 156708ba..f85ae37a 100644 --- a/Source/Propagator/Enterprise/BoldOutputQueueHandler.pas +++ b/Source/Propagator/Enterprise/BoldOutputQueueHandler.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldOutputQueueHandler; interface @@ -26,7 +29,7 @@ TBoldOutputQueueHandler = class(TBoldAbstractOutputQueueHandler) function getPriorityListEnlister: TBoldAbstractPriorityListEnlister; virtual; property PriorityListEnlister: TBoldAbstractPriorityListEnlister read GetPrioritylistEnlister; public - constructor Create; + constructor Create; destructor Destroy; override; procedure SendEvent(const ClientID: TBoldClientID; EventName: string); override; procedure ClearQueueForClient(const ClientID: TBoldClientID); override; @@ -46,6 +49,7 @@ implementation BoldPropagatorServer, BoldThreadSafeLog; + { TBoldOutputQueueHandler } procedure TBoldOutputQueueHandler.ClearQueueForClient( @@ -72,7 +76,6 @@ function TBoldOutputQueueHandler.getOutputQueue( count, i: integer; ClientQueue: TBoldClientQueue; begin - //check index range if (Index >= fOutputQueues.Count) then begin count := (Index - fOutputQueues.Count) + 1; @@ -83,7 +86,7 @@ function TBoldOutputQueueHandler.getOutputQueue( end; if not Assigned(fOutputQueues[Index]) then begin - ClientQueue := TBoldClientQueue.Create(format('CliQ[%d]', [Index])); // do not localize + ClientQueue := TBoldClientQueue.Create(format('CliQ[%d]', [Index])); ClientQueue.OnQueueNotEmpty := OnQueueNotEmpty; ClientQueue.BoldClientID := Index; fOutputQueues[Index] := ClientQueue; @@ -119,7 +122,7 @@ procedure TBoldOutputQueueHandler.SendEvent(const ClientID: TBoldClientID; Event try OutputQueues[ClientID].Enqueue(EventName); except On E: Exception do - BoldLogError('%s.SendEvent: Client = %d', [ClassName, ClientId]); // do not localize + BoldLogError('%s.SendEvent: Client = %d', [ClassName, ClientId]); end; end; diff --git a/Source/Propagator/Enterprise/BoldPriorityListEnlister.pas b/Source/Propagator/Enterprise/BoldPriorityListEnlister.pas index 8e68c79b..48001be7 100644 --- a/Source/Propagator/Enterprise/BoldPriorityListEnlister.pas +++ b/Source/Propagator/Enterprise/BoldPriorityListEnlister.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPriorityListEnlister; interface diff --git a/Source/Propagator/Enterprise/BoldPropagatorApplication.pas b/Source/Propagator/Enterprise/BoldPropagatorApplication.pas index cb3f2fcb..31745448 100644 --- a/Source/Propagator/Enterprise/BoldPropagatorApplication.pas +++ b/Source/Propagator/Enterprise/BoldPropagatorApplication.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPropagatorApplication; interface @@ -7,7 +10,8 @@ interface BoldAdvancedPropagator, BoldPropagatorServer, dialogs, - forms; + forms + ; implementation diff --git a/Source/Propagator/Enterprise/BoldPropagatorCleanup.pas b/Source/Propagator/Enterprise/BoldPropagatorCleanup.pas index eb3ef547..f33a565e 100644 --- a/Source/Propagator/Enterprise/BoldPropagatorCleanup.pas +++ b/Source/Propagator/Enterprise/BoldPropagatorCleanup.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPropagatorCleanup; interface @@ -13,6 +16,7 @@ interface BoldThreadSafeLog, ExtCtrls; + type {forward declarrations} TBoldCleanUpSubscriber = class; @@ -41,7 +45,7 @@ TBoldCleanUpThread = class(TBoldNotifiableThread) property Timer: TTimer read getTimer write fTimer; end; - TBoldCleanupSubscriber = class(TBoldPassthroughSubscriber) + TBoldCleanupSubscriber = class(TBoldExtendedPassthroughSubscriber) private fCleanUpThread: TBoldCleanUpThread; fClientHandler: TBoldClientHandler; @@ -64,8 +68,7 @@ implementation BoldPropagatorMainForm, BoldPropagatorServer, Messages, - Classes, - PropagatorConsts; + Classes; function BoldPropagatorCleanupWndProc(Window: HWND; Message, wParam, lParam: Longint): Longint; stdcall; @@ -80,7 +83,7 @@ function BoldPropagatorCleanupWndProc(Window: HWND; try CleanUpThread.SetTimer; except on E: Exception do - BoldLogError(sWindowProcError, [E.Message]); + BoldLogError('Error in WindowProc %s', [E.Message]); end; end; else @@ -99,7 +102,7 @@ function BoldPropagatorCleanupWndProc(Window: HWND; hCursor: 0; hbrBackground: 0; lpszMenuName: nil; - lpszClassName: 'TBoldPropagatorCleanupWindow'); // do not localize + lpszClassName: 'TBoldPropagatorCleanupWindow'); { TBoldCleanupSubscriber } @@ -124,8 +127,8 @@ procedure TBoldCleanupSubscriber.DoLeaseChanged; begin try PostMessage(fCleanUpThread.QueueWindow, BM_PROPAGATOR_CLIENT_LEASE_CHANGED, 0, Integer(fCleanUpThread)); - except on e: Exception do - BoldLogError(sLogError, [ClassName, 'DoLeaseChanged', e.Message]); // do not localize + except + BoldLogError('%s.DoLeaseChanged', [ClassName]); end; end; @@ -144,7 +147,7 @@ procedure TBoldCleanupSubscriber.OnGetExtendedEvent( end; DoLeaseChanged; except - BoldLogError('%s.OnGetExtendedEvent: Bold_propagator_client_lease_changed', [ClassName]); // do not localize + BoldLogError('%s.OnGetExtendedEvent: Bold_propagator_client_lease_changed', [ClassName]); end; end; end; @@ -198,7 +201,7 @@ procedure TBoldCleanUpThread.Execute; EnsureMessageQueue; InitServerWindow (TRUE); SignalReady; - BoldLogThread('ID=Cleanup'); // do not localize + BoldLogThread('ID=Cleanup'); while not Terminated do begin @@ -265,8 +268,10 @@ procedure TBoldCleanUpThread.SetTimer; else RemoveTimedOutClient; except on E: Exception do - BoldlogError('%s.SetTimer: %s', [ClassName, E.Message]); //do not localize + BoldlogError('%s.SetTimer: %s', [ClassName, E.Message]); end; end; +initialization + end. diff --git a/Source/Propagator/Enterprise/BoldPropagatorMainForm.pas b/Source/Propagator/Enterprise/BoldPropagatorMainForm.pas index 26f1a733..61571e7f 100644 --- a/Source/Propagator/Enterprise/BoldPropagatorMainForm.pas +++ b/Source/Propagator/Enterprise/BoldPropagatorMainForm.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPropagatorMainForm; interface @@ -10,7 +13,6 @@ interface Forms, ComCtrls, StdCtrls, - BoldMemoryManager, ExtCtrls, Messages, Grids, @@ -176,8 +178,7 @@ implementation BoldPropagatorServer, BoldThreadSafeLog, Sysutils, - Boldutils, - PropagatorConsts; + Boldutils; {$R *.dfm} @@ -216,7 +217,7 @@ function StatToStr(value: integer): string; else if Whole >= 10 then result := IntToStr(Whole) + '.' + IntToStr(tenths) + Result else - result := IntToStr(Whole) + '.' + format('%.2d', [hundreds]) + Result // do not localize + result := IntToStr(Whole) + '.' + format('%.2d', [hundreds]) + Result end; (* OldDecimalSeparator := DecimalSeparator; @@ -244,7 +245,6 @@ procedure TPropagatorMainForm.AddUser(Id: integer; IdString: string; Registratio finally fClientInfoLock.Release; end; -// NewClient.RefreshGrid; end; procedure TPropagatorMainForm.ClearAllUsers; @@ -252,9 +252,8 @@ procedure TPropagatorMainForm.ClearAllUsers; fClientINfoLock.Acquire; try fLastTopRow := sgClients.TopRow; -// sgClients.RowCount := 2; -// for i := 0 to sgClients.ColCount-1 do -// sgClients.Cells[i, 1] := ''; + + fClients.Clear; fClientsUpdated := true; finally @@ -267,27 +266,26 @@ procedure TPropagatorMainForm.FormCreate(Sender: TObject); ConfigFile: TStringList; fileName: String; begin -// ComServer.UIInteractive := false; fClientInfoLock := TCriticalSection.Create; - BoldLogThread('ID=MainThread/GUI'); // do not localize + BoldLogThread('ID=MainThread/GUI'); fClients := TClientGUIInfoList.Create; fLastTopRow := -1; - Caption := Format(sFormCaption, [TBoldPropagatorServer.Instance.ServerName]); + Caption := Format('%s Console', [TBoldPropagatorServer.Instance.ServerName]); fStartTime := now; PageControl1.ActivePage := tsClients; UpdateUptime; - sgClients.Cells[0, 0] := sClientID; - sgClients.Cells[1, 0] := sName; - sgClients.Cells[2, 0] := sRegTime; - sgClients.Cells[3, 0] := sTimeOut; - sgClients.Cells[4, 0] := sSubscriptions; - sgClients.Cells[5, 0] := sQueue; - sgClients.Cells[6, 0] := sLongestInt; - sgClients.Cells[7, 0] := sLast; - sgClients.Cells[8, 0] := sPkg; - sgClients.Cells[9, 0] := sEv; - sgClients.Cells[10, 0] := sStatus; - sgClients.Cells[11, 0] := sLost; + sgClients.Cells[0, 0] := 'ClientID'; + sgClients.Cells[1, 0] := 'Name'; + sgClients.Cells[2, 0] := 'RegTime'; + sgClients.Cells[3, 0] := 'Timeout'; + sgClients.Cells[4, 0] := 'Subscriptions'; + sgClients.Cells[5, 0] := 'Queue'; + sgClients.Cells[6, 0] := 'Longest Int'; + sgClients.Cells[7, 0] := 'Last (ago)'; + sgClients.Cells[8, 0] := 'Pkg'; + sgClients.Cells[9, 0] := 'Ev'; + sgClients.Cells[10, 0] := 'Status'; + sgClients.Cells[11, 0] := 'Lost'; mnuCountSubscriptionsClick(self); rbDequeue.Parent := StatusBar1; rbDeQueue.Height := 13; @@ -295,23 +293,23 @@ procedure TPropagatorMainForm.FormCreate(Sender: TObject); rbDequeue.Left := 2; mmoDebugInfo.lines.Clear; - mmoDebugInfo.lines.add(Format(sFile, [paramStr(0)])); + mmoDebugInfo.lines.add('File: '+paramStr(0)); mmoDebugInfo.lines.add(''); {$IFDEF DEBUG} mnuHangPropagatorDEBUG.Visible := true; formstyle := fsStayOnTop; - {$ENDIF} + {$ENDIF} - FileName := ChangeFileExt(GetModuleFileNameAsString(true), '.ini'); // do not localize + FileName := ChangeFileExt(GetModuleFileNameAsString(true), '.ini'); if not FileExists(FileName) then begin - mmoDebugInfo.lines.add(sNoINIFile); + mmoDebugInfo.lines.add('INI file: N/A'); end else begin ConfigFile := TStringList.Create; ConfigFile.LoadFromFile(FileName); - mmoDebugInfo.lines.add(sINIFile); + mmoDebugInfo.lines.add('INI file:'); mmoDebugInfo.lines.add('---------------'); mmoDebugInfo.lines.AddStrings(ConfigFile); mmoDebugInfo.lines.add('---------------'); @@ -326,14 +324,13 @@ function TPropagatorMainForm.GetUpTime: TDAteTime; procedure TPropagatorMainForm.UpdateUptime; begin - mnuStarted.Caption := format(sStarted, [DateTimeToStr(startTime)]); - mnuUptime.Caption := format(sUptime, [trunc(Uptime), TimetoStr(Frac(Uptime))]); + mnuStarted.Caption := format('Started: %s', [DateTimeToStr(startTime)]); + mnuUptime.Caption := format('Uptime: %d days %s', [trunc(Uptime), TimetoStr(Frac(Uptime))]); end; procedure TPropagatorMainForm.mnuRefreshClick(Sender: TObject); begin - // this event will be replaced by the UIManager when it takes control of the GUI. - mnuRefreshGUI.Caption := sHangon; + mnuRefreshGUI.Caption := 'Hang on...'; UpdateUptime; UpdateStatistics; UpdateMemoryStats; @@ -349,6 +346,7 @@ procedure TPropagatorMainForm.SetIsDequeueing(const Value: boolean); rbDequeue.Checked := value; end; + procedure TPropagatorMainForm.UpdateStatistics; var s: string; @@ -384,8 +382,8 @@ procedure TPropagatorMainForm.UpdateStatistics; end; s := ''; AllStatus := ''; - AddStatus(sCli, ClientCount); - AddStatus(sTot, fTotalClients); + AddStatus('Cli', ClientCount); + AddStatus('Tot', fTotalClients); AddStatus('^', fPeakClients); StatusBar1.Panels[3].Width := StatusBar1.Canvas.TextWidth(s) + 20; @@ -393,19 +391,19 @@ procedure TPropagatorMainForm.UpdateStatistics; s := ''; if mnuCountSubscriptions.Checked then - AddStatus(sSubs, Subscriptions); - AddStatus(sInQ, InQ); - AddStatus(sInQPeak, InQPeak); - AddStatus(sOutQ, OutQ); - AddStatus(sAdded, Added); - AddStatus(sSent, sent); - AddStatus(sLost, fTotalLostEvents); + AddStatus('Subs', Subscriptions); + AddStatus('InQ', InQ); + AddStatus('InQ^', InQPeak); + AddStatus('OutQ', OutQ); + AddStatus('Added', Added); + AddStatus('Sent', sent); + AddStatus('Lost', fTotalLostEvents); StatusBar1.Panels[4].Text := s; BoldLog(AllStatus); while lbStatisticsHistory.items.Count > 100 do lbStatisticsHistory.items.Delete(lbStatisticsHistory.items.Count-1); - lbStatisticsHistory.items.insert(0, DateTimeToStr(now) + ': ' + AllStatus); + lbStatisticsHistory.items.insert(0, DateTimeToStr(now)+': '+AllStatus); if fLastTopRow <> -1 then begin if fLastTopRow > sgClients.RowCount - sgClients.VisibleRowCount then @@ -415,15 +413,16 @@ procedure TPropagatorMainForm.UpdateStatistics; end; end; + + procedure TPropagatorMainForm.UpdateMemoryStats; begin - mmoMemory.Text := BoldMemoryManager_.MemoryInfo; if Subscriptions > 0 then begin mmoMemory.Lines.Add('---'); - mmoMemory.Lines.Add(format(sBytesPerSubscription, [GetHeapStatus.TotalAllocated/Subscriptions])); + mmoMemory.Lines.Add(format('%0.2f bytes per subscription', [GetHeapStatus.TotalAllocated/Subscriptions])); end; - lbxSystemMemory.Items.Add(format(sMemAllocated, [GetHeapStatus.TotalAllocated/(1024*1024)])); + lbxSystemMemory.Items.Add(format('Allocated %6.2f Mb', [GetHeapStatus.TotalAllocated/(1024*1024)])); lbxSystemMemory.TopIndex := lbxSystemMemory.items.Count - lbxSystemMemory.Height div lbxSystemMemory.ItemHeight; end; @@ -452,7 +451,7 @@ procedure TPropagatorMainForm.BMPropagatorDoneDequeue(var Msg: TMessage); procedure TPropagatorMainForm.BMPropagatorStartDequeue(var Msg: TMessage); begin - rbDequeue.Checked := true; + rbDequeue.Checked := true; end; procedure TPropagatorMainForm.ClientInfoChanged(Id: integer; ClientSubscriptions, OutQ: integer); @@ -485,8 +484,7 @@ constructor TClientGuiInfo.create(form: TPropagatorMainForm; Id: integer; Name: fLongestInterval := LongestInterval; fStatus := Status; fLostEvents := LostEvents; -// if GuiForm.fClients.Count <> 1 then -// GuiForm.sgClients.RowCount := GuiForm.sgClients.RowCount + 1; + fRow := FGuiForm.ClientCount + 1; end; @@ -495,7 +493,7 @@ procedure TPropagatorMainForm.GlobalInfoChanged(Added, Sent: integer); fAdded := Added; fSent := Sent; UpdateStatistics; - mnuRefreshGUI.Caption := sRefresh; + mnuRefreshGUI.Caption := 'Refresh'; end; procedure TClientGuiInfo.RefreshGrid; @@ -506,7 +504,7 @@ procedure TClientGuiInfo.RefreshGrid; if LeaseExpires <> 0 then GuiForm.sgClients.Cells[3, Row] := TimeToStr(LeaseExpires) else - GuiForm.sgClients.Cells[3, Row] := '?'; // do not localize + GuiForm.sgClients.Cells[3, Row] := '?'; GuiForm.sgClients.Cells[4, row] := StatToStr(Subscriptions); GuiForm.sgClients.Cells[5, row] := StatToStr(OutQ); @@ -562,13 +560,13 @@ procedure TPropagatorMainForm.mnuLockClick(Sender: TObject); begin fLocked := false; fClientHandler.DebugUnLock; - mnuHangPropagatorDEBUG.Caption := 'Hang Propagator (DEBUG)'; // do not localize + mnuHangPropagatorDEBUG.Caption := 'Hang Propagator (DEBUG)'; end else begin fLocked := true; fClientHandler.DebugLock; - mnuHangPropagatorDEBUG.Caption := 'Release propagator'; // do not localize + mnuHangPropagatorDEBUG.Caption := 'Release propagator'; end; {$ENDIF} end; @@ -591,7 +589,6 @@ procedure TPropagatorMainForm.tmrDeadLockCheckerTimer(Sender: TObject); if fClients.Count = 0 then begin - // Fix GhostRow; sgClients.RowCount := 2; SgClients.Rows[1].Text := ''; end @@ -616,16 +613,16 @@ procedure TPropagatorMainForm.tmrDeadLockCheckerTimer(Sender: TObject); if fLongestLockTime < EncodeTime(0, 0, 3, 0) then begin DecodeTime(fLongestLockTime, h, m, s, ms); - StatusBar1.Panels[1].Text := IntToStr(s*1000+ms) + 'ms'; // do not localize + StatusBar1.Panels[1].Text := IntToStr(s*1000+ms) + 'ms'; end else StatusBar1.Panels[1].Text := TimeToStr(fLongestLockTime); end; if LockTime > 0 then - StatusBar1.Panels[2].Text := sDL + StatusBar1.Panels[2].Text := 'DL?' else - StatusBar1.Panels[2].Text := sOK; + StatusBar1.Panels[2].Text := 'OK'; if LockTime > EncodeTime(0, 0, 3, 0) then begin @@ -634,6 +631,7 @@ procedure TPropagatorMainForm.tmrDeadLockCheckerTimer(Sender: TObject); end; tmrDeadLockChecker.Enabled := true; + end; procedure TPropagatorMainForm.SetClientHandlerStats(TotalClients, @@ -711,11 +709,14 @@ procedure TPropagatorMainForm.mnuCountSubscriptionsClick( sgClients.ColWidths[4] := -1; sgClients.ColWidths[1] := 225; end + end; procedure TPropagatorMainForm.rbDequeueClick(Sender: TObject); begin - ; // do nothing + ; end; +initialization + end. diff --git a/Source/Propagator/Enterprise/BoldPropagatorServer.pas b/Source/Propagator/Enterprise/BoldPropagatorServer.pas index be08a1fa..d7cf484a 100644 --- a/Source/Propagator/Enterprise/BoldPropagatorServer.pas +++ b/Source/Propagator/Enterprise/BoldPropagatorServer.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPropagatorServer; interface @@ -12,8 +15,8 @@ interface BoldLockManager, BoldLockManagerAdmin, BoldContainers, - BoldThreadedComObjectFactory; - + BoldThreadedComObjectFactory + ; type TBoldPropagatorServer = class; TBoldPropagatorServerClass = class of TBoldPropagatorServer; @@ -100,8 +103,8 @@ implementation windows, comserv, registry, - BoldDefs, - PropagatorConsts; + BoldDefs + ; var G_PropagatorServer: TBoldPropagatorServer = nil; @@ -168,9 +171,8 @@ procedure TBoldPropagatorServer.Initialize; Application.Title := ServerName; FAdvancedPropagator := TBoldAdvancedPropagator.Create; dmServerHandles := TDmServerHandles.Create(nil); - if FindCmdLineSwitch('ServerName', ['-', '/'], True) then // do not localize + if FindCmdLineSwitch('ServerName', ['-', '/'], True) then begin - //setconfiguration SetConfiguration(ParamStr(2)); Halt; end @@ -186,23 +188,23 @@ procedure TBoldPropagatorServer.Initialize; procedure TBoldPropagatorServer.CreateClassFactories; begin {$IFDEF BOLD_USE_CO_ADVANCED_PROPAGATOR} - TBoldPropagatorFactory.Create(ComServer, CLASS_BoldPropagator, Format('%s.AdvancedPropagator', [Instance.ServerName]), // do not localize + TBoldPropagatorFactory.Create(ComServer, CLASS_BoldPropagator, Format('%s.AdvancedPropagator', [Instance.ServerName]), Instance.ServerName); {$ELSE} TBoldComServerConnectionFactory.Create(ComServer, Instance.PropagatorConnectionCLSID, - Format('%s.PropagatorConnection', [Instance.ServerName]), Instance.ServerName); // do not localize + Format('%s.PropagatorConnection', [Instance.ServerName]), Instance.ServerName); {$ENDIF} if not Assigned(ClientHandlerComFactory) then - ClientHandlerCOMFactory := TBoldClientHandlerThreadedCOMFactory.Create(ComServer, Instance.ClientHandlerCLSID, Format('%s.ClientHandler', [Instance.ServerName]), // do not localize + ClientHandlerCOMFactory := TBoldClientHandlerThreadedCOMFactory.Create(ComServer, Instance.ClientHandlerCLSID, Format('%s.ClientHandler', [Instance.ServerName]), Instance.ServerName); if not Assigned(EnqueuerCOMFactory) then - EnqueuerCOMFactory := TBoldEnqueuerThreadedComFactory.Create(ComServer, TBoldEnqueuerCOM, Instance.EnqueuerCLSID, Format('%s.EventPropagator', [Instance.ServerName]), 'EventPropagator', // do not localize + EnqueuerCOMFactory := TBoldEnqueuerThreadedComFactory.Create(ComServer, TBoldEnqueuerCOM, Instance.EnqueuerCLSID, Format('%s.EventPropagator', [Instance.ServerName]), 'EventPropagator', ciMultiInstance, batMTA); if not Assigned(LockManagerCOMFactory) then - LockManagerCOMFactory := TBoldLockManagerComFactory.Create(ComServer, Instance.LockManagerCLSID, Format('%s.LockManager', [Instance.ServerName]), 'Lock manager'); // do not localize + LockManagerCOMFactory := TBoldLockManagerComFactory.Create(ComServer, Instance.LockManagerCLSID, Format('%s.LockManager', [Instance.ServerName]), 'Lock manager'); if not Assigned(LockManagerAdminCOMFactory) then - LockManagerAdminCOMFactory := TBoldLockManagerAdminComFactory.Create(ComServer, Instance.LockManagerAdminCLSID, Format('%s.LockManagerAdmin', [Instance.ServerName]), 'Lock manager Admin'); // do not localize + LockManagerAdminCOMFactory := TBoldLockManagerAdminComFactory.Create(ComServer, Instance.LockManagerAdminCLSID, Format('%s.LockManagerAdmin', [Instance.ServerName]), 'Lock manager Admin'); end; procedure TBoldPropagatorServer.LoadConfiguration; @@ -212,30 +214,30 @@ procedure TBoldPropagatorServer.LoadConfiguration; ConfigFile: TMemIniFile; begin ConfigFileName := ModuleName; - ConfigFile := TMemIniFile.Create(ChangeFileExt(ConfigFileName, '.ini')); // do not localize + ConfigFile := TMemIniFile.Create(ChangeFileExt(ConfigFileName, '.ini')); try {Section 1: File Logging} - Section := 'FILE LOGGING'; // do not localize - FLogFileName := ChangeFileExt(ModuleName, '.log'); // do not localize - FErrorLogFileName := ChangeFileExt(ModuleName, '.error'); // do not localize - if ConfigFile.ReadBool(Section, 'THREAD', False) then // do not localize - fThreadLogFileName := ChangeFileExt(ModuleName, '.thread') // do not localize + Section := 'FILE LOGGING'; + FLogFileName := ChangeFileExt(ModuleName, '.log'); + FErrorLogFileName := ChangeFileExt(ModuleName, '.error'); + if ConfigFile.ReadBool(Section, 'THREAD', False) then + fThreadLogFileName := ChangeFileExt(ModuleName, '.thread') else fThreadLogFileName := ''; - FEnableLogging := ConfigFile.ReadBool(Section, 'ENABLED', DEFAULT_ENABLELOGGING); // do not localize - FMaxLogFileSize := ConfigFile.ReadInteger(Section, 'MAXFILESIZE', DEFAULT_LOGFILESIZE); //default size 20k // do not localize + FEnableLogging := ConfigFile.ReadBool(Section, 'ENABLED', DEFAULT_ENABLELOGGING); + FMaxLogFileSize := ConfigFile.ReadInteger(Section, 'MAXFILESIZE', DEFAULT_LOGFILESIZE); {Section 2: configuration parameters} - Section := 'CONFIG PARAMS'; // do not localize - FClientNotifierPoolSize := ConfigFile.ReadInteger(Section, 'THREADPOOLSIZE', DEFAULT_THREADPOOLSIZE); // do not localize - fDisconnectClientsOnSendFailure := ConfigFile.ReadBool(Section, 'DISCONNECTCLIENTSONSENDFAILURE', DEFAULT_DISCONNECT_CLIENTS_ON_SENDFAILURE); // do not localize + Section := 'CONFIG PARAMS'; + FClientNotifierPoolSize := ConfigFile.ReadInteger(Section, 'THREADPOOLSIZE', DEFAULT_THREADPOOLSIZE); + fDisconnectClientsOnSendFailure := ConfigFile.ReadBool(Section, 'DISCONNECTCLIENTSONSENDFAILURE', DEFAULT_DISCONNECT_CLIENTS_ON_SENDFAILURE); {Section 3: ComServer configuration params} - Section := 'COM SERVER'; // do not localize - FServerName := ConfigFile.ReadString(Section, 'SERVERNAME', 'EnterprisePropagator'); // do not localize - FClientHandlerCLSID := StringToGUID( ConfigFile.ReadString(Section, 'CLSIDCLIENTHANDLER', GUIDToString(CLSID_BOLDCLIENTHANDLER))); // do not localize - FEnqueuerCLSID := StringToGUID( ConfigFile.ReadString(Section, 'CLSIDEVENTPROPAGATOR', GUIDToString(CLSID_BOLDENQUEUER))); // do not localize - FLockManagerCLSID := StringToGUID( ConfigFile.ReadString(Section, 'CLSIDLOCKMANAGER', GUIDToString(CLSID_LOCKMANAGER))); // do not localize - FLockManagerAdminCLSID := StringToGUID( ConfigFile.ReadString(Section, 'CLSIDLOCKMANAGERADMIN', GUIDToString(CLSID_LOCKMANAGERADMIN))); // do not localize - FPropagatorCLSID := StringToGUID( ConfigFile.ReadString(Section, 'CLSIDENTERPRISEPROPAGATOR', GUIDToString(BoldPropagatorConnection_CLSID))); // do not localize + Section := 'COM SERVER'; + FServerName := ConfigFile.ReadString(Section, 'SERVERNAME', 'EnterprisePropagator'); + FClientHandlerCLSID := StringToGUID( ConfigFile.ReadString(Section, 'CLSIDCLIENTHANDLER', GUIDToString(CLSID_BOLDCLIENTHANDLER))); + FEnqueuerCLSID := StringToGUID( ConfigFile.ReadString(Section, 'CLSIDEVENTPROPAGATOR', GUIDToString(CLSID_BOLDENQUEUER))); + FLockManagerCLSID := StringToGUID( ConfigFile.ReadString(Section, 'CLSIDLOCKMANAGER', GUIDToString(CLSID_LOCKMANAGER))); + FLockManagerAdminCLSID := StringToGUID( ConfigFile.ReadString(Section, 'CLSIDLOCKMANAGERADMIN', GUIDToString(CLSID_LOCKMANAGERADMIN))); + FPropagatorCLSID := StringToGUID( ConfigFile.ReadString(Section, 'CLSIDENTERPRISEPROPAGATOR', GUIDToString(BoldPropagatorConnection_CLSID))); finally FreeAndNil(ConfigFile); end; @@ -267,7 +269,7 @@ procedure TBoldPropagatorServer.SetConfiguration(const ServerName: string); if Trim(aServerName) <> '' then begin tempstr := ModuleName; - ConfigFileName := ChangeFileExt(tempstr, '.ini'); // do not localize + ConfigFileName := ChangeFileExt(tempstr, '.ini'); if not FileExists(ConfigFileName) then begin FileHandle := FileCreate(ConfigFileName); @@ -276,14 +278,14 @@ procedure TBoldPropagatorServer.SetConfiguration(const ServerName: string); ConfigFile := TMemIniFile.Create(ConfigFileName); try {Section 1: File Logging} - Section := 'COM SERVER'; // do not localize - ConfigFile.WriteString(Section, 'SERVERNAME', aServerName); // do not localize + Section := 'COM SERVER'; + ConfigFile.WriteString(Section, 'SERVERNAME', aServerName); {Generate new GUIDs} - ConfigFile.WriteString(Section, 'CLSIDCLIENTHANDLER', BoldCreateGUIDAsString); // do not localize - ConfigFile.WriteString(Section, 'CLSIDEVENTPROPAGATOR', BoldCreateGUIDAsString); // do not localize - ConfigFile.WriteString(Section, 'CLSIDLOCKMANAGER', BoldCreateGUIDAsString); // do not localize - ConfigFile.WriteString(Section, 'CLSIDLOCKMANAGERADMIN', BoldCreateGUIDAsString); // do not localize - ConfigFile.WriteString(Section, 'CLSIDENTERPRISEPROPAGATOR', BoldCreateGUIDAsString); // do not localize + ConfigFile.WriteString(Section, 'CLSIDCLIENTHANDLER', BoldCreateGUIDAsString); + ConfigFile.WriteString(Section, 'CLSIDEVENTPROPAGATOR', BoldCreateGUIDAsString); + ConfigFile.WriteString(Section, 'CLSIDLOCKMANAGER', BoldCreateGUIDAsString); + ConfigFile.WriteString(Section, 'CLSIDLOCKMANAGERADMIN', BoldCreateGUIDAsString); + ConfigFile.WriteString(Section, 'CLSIDENTERPRISEPROPAGATOR', BoldCreateGUIDAsString); ConfigFile.UpdateFile; finally @@ -291,7 +293,8 @@ procedure TBoldPropagatorServer.SetConfiguration(const ServerName: string); end; end else - showmessage(Format(sInvalidCommandLineArgs, [aServerName])); + showmessage(Format('Invalid command line argument %s', [aServerName])); + ; end; function TBoldPropagatorServer.GetAppID: TGuid; @@ -306,11 +309,11 @@ function TBoldPropagatorServer.GetAppID: TGuid; ShortFileName := ExtractShortPathName(ShortFileName); ShortFileName := ExtractFileName(ShortFileName); Reg.RootKey := HKEY_CLASSES_ROOT; - Reg.OpenKey('AppID\' + ShortFileName, false); // do not localize - if Reg.ValueExists('AppId') then // do not localize - Result := StringToGuid(Reg.ReadString('AppId')) // do not localize + Reg.OpenKey('AppID\' + ShortFileName, false); + if Reg.ValueExists('AppId') then + Result := StringToGuid(Reg.ReadString('AppId')) else - raise EBold.Create(sAppIDNotFound) + raise EBold.Create('AppId not found, run DCOMCNFG to add appid to registry') finally Reg.CloseKey; Reg.Free; @@ -332,8 +335,8 @@ procedure TBoldPropagatorServer.RegServer(const AppId: TGuid); Reg := TRegistry.Create; try Reg.RootKey := HKEY_CLASSES_ROOT; - Reg.OpenKey('AppID\' + ModuleName, true); // do not localize - Reg.WriteString('AppId', GuidToString(vAppId)); // do not localize + Reg.OpenKey('AppID\' + ModuleName, true); + Reg.WriteString('AppId', GuidToString(vAppId)); finally Reg.CloseKey; Reg.Free; @@ -361,4 +364,6 @@ procedure TBoldPropagatorServer.RemoveComObject(Obj: TBoldComObject); FComObjects.Remove(Obj); end; +initialization + end. diff --git a/Source/Propagator/Enterprise/BoldPropagatorSubscriptions.pas b/Source/Propagator/Enterprise/BoldPropagatorSubscriptions.pas index 4eab13e8..6063945c 100644 --- a/Source/Propagator/Enterprise/BoldPropagatorSubscriptions.pas +++ b/Source/Propagator/Enterprise/BoldPropagatorSubscriptions.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPropagatorSubscriptions; interface @@ -7,7 +10,8 @@ interface classes, BoldDefs, BoldIndexList, - BoldIndexedList; + BoldIndexedList + ; type {forward declarations} @@ -65,8 +69,7 @@ implementation uses Sysutils, - BoldUtils, - PropagatorConsts; + BoldUtils; { TBoldSortedIntegerList } @@ -206,7 +209,7 @@ procedure TBoldSubscriptionList.GetAllSubscribedClientsExcept(const EventName: s aEvent: TBoldEventNameIndexNode; begin if not Assigned(ClientIds) then - raise EBold.CreateFmt(sClientIDsNotAssigned, [ClassName, 'GetAllSubscribedClientsExcept']); // do not localize + raise EBold.CreateFmt('%s.GetAllSubscribedClientsExcept: ClientIds not assigned', [ClassName]); aEvent := getEvent(EventName); if Assigned(aEvent) then begin @@ -297,4 +300,6 @@ function TBoldSubscriptionList.GetEventCountByClientID(const ClientID: TBoldClie end; end; +initialization + end. diff --git a/Source/Propagator/Enterprise/BoldPropagatorUIManager.pas b/Source/Propagator/Enterprise/BoldPropagatorUIManager.pas index 9176cb93..8383d2a6 100644 --- a/Source/Propagator/Enterprise/BoldPropagatorUIManager.pas +++ b/Source/Propagator/Enterprise/BoldPropagatorUIManager.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPropagatorUIManager; interface @@ -14,7 +17,7 @@ interface TUIManager = class; { TUIManager } - TUIManager = class(TBoldPassthroughSubscriber) + TUIManager = class(TBoldExtendedPassthroughSubscriber) private fClientHandler: TBoldClientHandler; fEnabled: Boolean; @@ -48,8 +51,7 @@ implementation windows, ComServ, classes, - comctrls, - PropagatorConsts; + comctrls; { UIManager } @@ -86,9 +88,7 @@ procedure TUIManager.OnGetExtendedEvent(Originator: TObject; procedure TUIManager.RefreshClick(Sender: TObject); begin - // this is the method that will be executed on the console refresh button - PropagatorMainForm.mnuRefreshGUI.Caption := sHangOn; -// PropagatorMainForm.btnRefresh.Refresh; + PropagatorMainForm.mnuRefreshGUI.Caption := 'Hang on...'; UpdateDisplay(true); end; @@ -169,14 +169,13 @@ procedure TUIManager.UpdateDisplay(All: Boolean); for i := 0 to ClientInfoList.Count - 1 do begin ClientInfo.CommaText := ClientInfoList[i]; - ClientID := StrToIntDef(ClientInfo.values['ID'], -1); // do not localize + ClientID := StrToIntDef(ClientInfo.values['ID'], -1); if ClientID = -1 then begin - // Some Global info from the ClientHandler PropagatorMainForm.SetClientHandlerStats( - StrToIntDef(ClientInfo.Values['TotalClients'], -1), // do not localize - StrToIntDef(ClientInfo.Values['PeakClients'], -1), // do not localize - StrToIntDef(ClientInfo.Values['TotalLostEvents'], -1)); // do not localize + StrToIntDef(ClientInfo.Values['TotalClients'], -1), + StrToIntDef(ClientInfo.Values['PeakClients'], -1), + StrToIntDef(ClientInfo.Values['TotalLostEvents'], -1)); end else begin @@ -185,19 +184,17 @@ procedure TUIManager.UpdateDisplay(All: Boolean); PropagatorMainForm.AddUser( ClientID, - ClientInfo.values['IDString'], // do not localize - StrToDateFmt(ClientInfo.values['RegistrationTime'], 'yyyy-mm-dd hh:nn:ss', '-'), // do not localize - StrToDateFmt(ClientInfo.values['LeaseTimeout'], 'yyyy-mm-dd hh:nn:ss', '-'), // do not localize - StrToIntDef(ClientInfo.values['Packages'], -1), // do not localize - StrToIntDef(ClientInfo.values['Events'], -1), // do not localize - StrToDateFmt(ClientInfo.values['LastSend'], 'yyyy-mm-dd hh:nn:ss', '-'), // do not localize - StrToDateFmt(ClientInfo.values['LongestInterval'], 'yyyy-mm-dd hh:nn:ss', '-'), // do not localize - ClientInfo.values['Status'], // do not localize - StrToIntDef(ClientInfo.values['LostEvents'], 0)); // do not localize + ClientInfo.values['IDString'], + StrToDateFmt(ClientInfo.values['RegistrationTime'], 'yyyy-mm-dd hh:nn:ss', '-'), + StrToDateFmt(ClientInfo.values['LeaseTimeout'], 'yyyy-mm-dd hh:nn:ss', '-'), + StrToIntDef(ClientInfo.values['Packages'], -1), + StrToIntDef(ClientInfo.values['Events'], -1), + StrToDateFmt(ClientInfo.values['LastSend'], 'yyyy-mm-dd hh:nn:ss', '-'), + StrToDateFmt(ClientInfo.values['LongestInterval'], 'yyyy-mm-dd hh:nn:ss', '-'), + ClientInfo.values['Status'], + StrToIntDef(ClientInfo.values['LostEvents'], 0)); end; end; - - // some testcases does not have a real Advanced Propagator... if assigned(TBoldPropagatorServer.Instance.AdvancedPropagator) then begin PropagatorMainForm.InQ := TBoldPropagatorServer.Instance.AdvancedPropagator.Dequeuer.InQueueCount; @@ -240,11 +237,13 @@ procedure TUIManager.ShutDownClick(Sender: TObject); for i := 0 to ClientInfoList.Count - 1 do begin ClientInfo.CommaText := ClientInfoList[i]; - ClientID := StrToIntDef(ClientInfo.values['ID'], -1); // do not localize - ClientHandler.SendDisconnectRequest(ClientId, sPropagatorMustBeShutDown, 60000); + ClientID := StrToIntDef(ClientInfo.values['ID'], -1); + ClientHandler.SendDisconnectRequest(ClientId, 'Propagator must be shut down', 60000); end; ClientInfoList.Free; ClientInfo.Free; end; +initialization + end. diff --git a/Source/Propagator/Enterprise/BoldServerHandlesDataMod.pas b/Source/Propagator/Enterprise/BoldServerHandlesDataMod.pas index 08c07fbd..145ff3be 100644 --- a/Source/Propagator/Enterprise/BoldServerHandlesDataMod.pas +++ b/Source/Propagator/Enterprise/BoldServerHandlesDataMod.pas @@ -1,7 +1,9 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldServerHandlesDataMod; interface - uses Messages, SysUtils, @@ -40,7 +42,6 @@ TdmServerHandles = class(TDataModule) implementation uses - BoldRev, BoldLockManagerCOM, BoldPropagatorServer, BoldComServer, @@ -86,9 +87,8 @@ procedure TdmServerHandles.DisconnectAll; while TBoldPropagatorServer.Instance.ComObjectCount > 0 do begin TBoldPropagatorServer.Instance.ComObjects[0].Disconnect; - TBoldPropagatorServer.Instance.ComObjects[0].Free; // this is because the RefCount is not zeroed after the call to CoDisconnectObject, review + TBoldPropagatorServer.Instance.ComObjects[0].Free; end; end; -initialization end. diff --git a/Source/Propagator/Enterprise/BoldServicePropagatorUnit.pas b/Source/Propagator/Enterprise/BoldServicePropagatorUnit.pas index 20e2cf88..41af3c74 100644 --- a/Source/Propagator/Enterprise/BoldServicePropagatorUnit.pas +++ b/Source/Propagator/Enterprise/BoldServicePropagatorUnit.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldServicePropagatorUnit; interface diff --git a/Source/Propagator/Enterprise/BoldSubscriptionHandler.pas b/Source/Propagator/Enterprise/BoldSubscriptionHandler.pas index 57625c78..7800d6bb 100644 --- a/Source/Propagator/Enterprise/BoldSubscriptionHandler.pas +++ b/Source/Propagator/Enterprise/BoldSubscriptionHandler.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSubscriptionHandler; interface @@ -12,9 +15,11 @@ interface BoldThreadSafeQueue, BoldEnqueuer, BoldAbstractOutputQueueHandler, - BoldThread; + BoldThread + ; type + {forward declarations} TBoldSubscriptionHandler = class; TBoldDequeuer = class; @@ -90,8 +95,7 @@ implementation Boldutils, BoldOutputQueueHandler, BoldPropagatorConstants, - BoldThreadSafeLog, - PropagatorConsts; + BoldThreadSafeLog; {TBoldDequeuer} constructor TBoldDequeuer.Create(InQueue: TBoldThreadSafeObjectQueue); @@ -129,7 +133,7 @@ procedure TboldDequeuer.Dequeue; Events.Clear; end; except on E: EOutOfMemory do - BoldLogError(sLogError, [ClassName, 'Dequeue', E.Message]); // do not localize + BoldLogError('%s.Dequeue: %s', [E.Message]); end; end; @@ -161,15 +165,15 @@ procedure TBoldDequeuer.Execute; begin EnsureMessageQueue; SignalReady; - BoldLogThread('ID=Dequeuer'); // do not localize + BoldLogThread('ID=Dequeuer'); while not Terminated do begin res := Integer(getMessage(rMsg, 0, 0, 0)); try - if res = -1 then //error + if res = -1 then Terminate - else if res = 0 then // terminated + else if res = 0 then Terminate else if rMsg.message = BM_QUEUE_NOT_EMPTY then begin @@ -200,7 +204,6 @@ procedure TBoldDequeuer.Execute; except on e: Exception do begin - // distinct beeps for any occasion! if (res=0) or (res=-1) then Windows.Beep(440, 500) else if (rMsg.Message = BM_REQUEST_CLIENT_INFO) or (rMsg.MEssage = BM_REQUEST_GLOBAL_INFO) then @@ -237,10 +240,11 @@ procedure TBoldDequeuer.NotifyQueueNotEmpty(Queue: TBoldThreadSafeQueue); try self.Notify(BM_QUEUE_NOT_EMPTY); except on E: Exception do - BoldLogError(sLogError, [ClassName, 'NotifyQueueNotEmpty', E.Message]); // do not localize + BoldLogError('%s.NotifyQueueNotEmpty: %s', [ClassName, E.Message]); end; end; + procedure TBoldDequeuer.EnqueueRemoveClientQueueEvent(const ClientID: TBoldClientId); begin fInQueue.Enqueue(TBoldExternalEvent.Create(ClientId, bemRemoveClientQueue, '')); @@ -300,7 +304,7 @@ function TBoldSubscriptionHandler.getOutQueueHandler: TBoldAbstractOutputQueueHa if Assigned(fOutQueueHandler) then Result := fOutQueueHandler else - raise EBold.CreateFmt(sOutputQueueHandlerNotAssigned, [ClassName]); + raise EBold.CreateFmt('%s.getQueueHandler: AbstractOutputQueueHandler is not assigned.', [ClassName]); end; function TBoldSubscriptionHandler.GetSentEventsCount: integer; @@ -323,7 +327,6 @@ procedure TBoldSubscriptionHandler.ProcessExternalEvent( case BoldExternalEvent.EventType of bemEvent: begin - // send event to all registered clients except the sender Clients := TBoldSortedIntegerList.Create; try FSubscriptions.GetAllSubscribedClientsExcept(EventNameWithoutParameters, @@ -332,7 +335,6 @@ procedure TBoldSubscriptionHandler.ProcessExternalEvent( finally FreeAndNil(Clients); end; - // cancel subscriptions for all clients that had subscriptions except the sender FSubscriptions.RemoveEvent(EventNameWithoutParameters); FSubscriptions.AddSubscription(BoldExternalEvent.BoldClientID, EventNameWithoutParameters); end; @@ -359,7 +361,7 @@ procedure TBoldSubscriptionHandler.ProcessExternalEvent( end; end; except on E: Exception do - BoldLogError(sLogError, [ClassName, 'ProcessExternalEvent', E.Message]); // do not localize + BoldLogError('%s.ProcessExternalEvent: error = %s', [ClassName, E.Message]); end; end; @@ -401,4 +403,6 @@ procedure TBoldSubscriptionHandler.SendEvent(EventName: string; end; end; +initialization + end. diff --git a/Source/Propagator/IDECOM/BoldPropagatorHandleCOMReg.pas b/Source/Propagator/IDECOM/BoldPropagatorHandleCOMReg.pas index 948d7d91..6172d381 100644 --- a/Source/Propagator/IDECOM/BoldPropagatorHandleCOMReg.pas +++ b/Source/Propagator/IDECOM/BoldPropagatorHandleCOMReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPropagatorHandleCOMReg; interface @@ -6,10 +9,11 @@ procedure Register; implementation -{$R *.res} +{$R BoldPropagatorHandleCOMReg.res} uses Classes, + BoldGuard, BoldPropagatorHandleCOM, BoldIDEConsts; diff --git a/Source/Propagator/IDECOM/BoldPropagatorHandleComReg.res b/Source/Propagator/IDECOM/BoldPropagatorHandleComReg.res new file mode 100644 index 00000000..0c139f75 Binary files /dev/null and b/Source/Propagator/IDECOM/BoldPropagatorHandleComReg.res differ diff --git a/Source/Propagator/LowEnd/BoldLowEndPropagatorClasses.pas b/Source/Propagator/LowEnd/BoldLowEndPropagatorClasses.pas index 0fa76f84..3ee7080d 100644 --- a/Source/Propagator/LowEnd/BoldLowEndPropagatorClasses.pas +++ b/Source/Propagator/LowEnd/BoldLowEndPropagatorClasses.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLowEndPropagatorClasses; interface @@ -99,7 +102,6 @@ procedure TBoldInternalPropagator.RefreshDisplay; Count, i: integer; Clients: TList; begin - // get the number of registered client count := 0; Clients := nil; for i := 0 to ClientList.Count - 1 do @@ -140,7 +142,6 @@ function TBoldClientPropagator.RegisterClient(LeaseDuration: Integer; PollingInt function TBoldClientPropagator.ExtendLease(BoldClientID: Integer; LeaseDuration: Integer; out ExtensionOK: WordBool): HResult; stdcall; begin - //NOT IMPLEMENTED Result := S_OK; end; @@ -174,7 +175,6 @@ function TBoldClientPropagator.SendEvents(BoldClientID: Integer; Events: OleVar function TBoldClientPropagator.CancelSubscriptions(BoldClientID: Integer; Subscriptions: OleVariant): HResult; begin - // not implemented Result := S_OK; end; diff --git a/Source/Propagator/LowEnd/BoldLowEndPropagatorMainForm.pas b/Source/Propagator/LowEnd/BoldLowEndPropagatorMainForm.pas index 6391ff18..2096445e 100644 --- a/Source/Propagator/LowEnd/BoldLowEndPropagatorMainForm.pas +++ b/Source/Propagator/LowEnd/BoldLowEndPropagatorMainForm.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLowEndPropagatorMainForm; interface @@ -40,7 +43,8 @@ implementation uses SysUtils, - BoldUtils; + BoldUtils, + BoldRev; {$R *.dfm} @@ -48,7 +52,7 @@ procedure TBoldLEPropagatorMainForm.ClearEventsList; begin try Memo1.Lines.BeginUpdate; - Memo1.Lines.Clear; + Memo1.Lines.Clear; finally Memo1.Lines.EndUpdate; end; @@ -93,4 +97,6 @@ procedure TBoldLEPropagatorMainForm.btnClearEventsClick(Sender: TObject); ClearEventsList; end; +initialization + end. diff --git a/Source/Samples/Actions/BoldDebugActions.pas b/Source/Samples/Actions/BoldDebugActions.pas index ec0b2190..e471ce83 100644 --- a/Source/Samples/Actions/BoldDebugActions.pas +++ b/Source/Samples/Actions/BoldDebugActions.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDebugActions; interface @@ -38,7 +41,7 @@ TBoldLogAction = class(TAction) protected function GetLogHandler: TBoldLogHandler; virtual; abstract; function GetLogType: string; virtual; abstract; - procedure SetLogHandler(Value: TBoldLogHandler); virtual; abstract; + procedure SetLogHandler(Value: TBoldLogHandler); virtual; abstract; property LogType: string read GetLogType; property LogHandler: TBoldLogHandler read GetLogHandler write SetLogHandler; public @@ -72,10 +75,15 @@ TBoldLogPMAction = class(TBoldLogAction) procedure SetLogHandler(Value: TBoldLogHandler); override; end; + { TBoldLogOSSAction } + TBoldLogOSSAction = class(TBoldLogAction) + protected + function GetLogHandler: TBoldLogHandler; override; + function GetLogType: string; override; + procedure SetLogHandler(Value: TBoldLogHandler); override; + end; + { TBoldLogFormAction } - // Note that as long as it's possible to determine the visible state - // from BoldLog it's impossible to be sure if next ExecuteTarget will show - // or hide the form... TBoldLogFormAction = class(TAction) private fShowing: boolean; @@ -89,9 +97,11 @@ implementation uses SysUtils, + Menus, // for TextToShortCut BoldOCL, BoldDBInterfaces, - BoldPMappers; + BoldPMappers, + BoldObjectSpaceExternalEvents; { TBoldSystemDebuggerAction } @@ -105,6 +115,7 @@ constructor TBoldSystemDebuggerAction.Create(AOwner: TComponent); begin inherited; Caption := 'System debugger'; + ShortCut := TextToShortCut('Ctrl+Shift+D'); end; procedure TBoldSystemDebuggerAction.ExecuteTarget(Target: TObject); @@ -133,20 +144,15 @@ function TBoldSystemDebuggerAction.GetDebugForm: TBoldSystemDebuggerFrm; procedure TBoldSystemDebuggerAction.CloseDebugForm; begin - if assigned(fDebugForm) then - fDebugForm.Close; + fDebugForm.Close; end; - procedure TBoldSystemDebuggerAction.Notification(AComponent: TComponent; Operation: TOperation); begin inherited; if (AComponent = fDebugForm) and (Operation = opRemove) then - begin fDebugForm := nil; - Checked:=False; - end; end; { TBoldLogOCLAction } @@ -241,7 +247,8 @@ procedure TBoldLogPMAction.SetLogHandler(Value: TBoldLogHandler); constructor TBoldLogFormAction.Create(AOwner: TComponent); begin inherited; - Caption := 'Toggle log'; + Caption := 'Log view'; + ShortCut := TextToShortCut('Ctrl+L'); end; procedure TBoldLogFormAction.ExecuteTarget(Target: TObject); @@ -259,4 +266,21 @@ function TBoldLogFormAction.HandlesTarget(Target: TObject): Boolean; Result := True; end; +{ TBoldLogOSSAction } + +function TBoldLogOSSAction.GetLogHandler: TBoldLogHandler; +begin + result := BoldOSSLogHandler; +end; + +function TBoldLogOSSAction.GetLogType: string; +begin + Result := 'OSS traffic'; +end; + +procedure TBoldLogOSSAction.SetLogHandler(Value: TBoldLogHandler); +begin + BoldOSSLogHandler := Value; +end; + end. diff --git a/Source/Samples/Actions/BoldEditOCLAction.pas b/Source/Samples/Actions/BoldEditOCLAction.pas index e1af25e0..f112e909 100644 --- a/Source/Samples/Actions/BoldEditOCLAction.pas +++ b/Source/Samples/Actions/BoldEditOCLAction.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldEditOCLAction; interface @@ -42,7 +45,6 @@ implementation uses SysUtils, - BoldIDEConsts, BoldOclPropEditor, BoldDefs; @@ -134,4 +136,6 @@ procedure TBoldEditOCLAction.SetOCLExpression(const Value: string); raise Exception.CreateFmt('%s is not connected to an OCL Component', [Name]); end; +initialization + end. diff --git a/Source/Samples/BoldCheckListBox/BoldCheckListBox.pas b/Source/Samples/BoldCheckListBox/BoldCheckListBox.pas index 47365ce1..bbae898b 100644 --- a/Source/Samples/BoldCheckListBox/BoldCheckListBox.pas +++ b/Source/Samples/BoldCheckListBox/BoldCheckListBox.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldCheckListBox; interface @@ -10,6 +13,7 @@ interface TBoldCheckListBox = class; { TBoldCheckListBox } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldCheckListBox = class(TBoldCustomCheckListBox) published property BoldListProperties; @@ -22,4 +26,8 @@ TBoldCheckListBox = class(TBoldCustomCheckListBox) implementation + +{ TBoldCheckListBox } +initialization + end. diff --git a/Source/Samples/BoldCheckListBox/BoldCheckListBoxReg.pas b/Source/Samples/BoldCheckListBox/BoldCheckListBoxReg.pas index be3a322b..44e160a9 100644 --- a/Source/Samples/BoldCheckListBox/BoldCheckListBoxReg.pas +++ b/Source/Samples/BoldCheckListBox/BoldCheckListBoxReg.pas @@ -1,9 +1,12 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldCheckListBoxReg; interface procedure Register; - + implementation uses diff --git a/Source/Samples/BoldCheckListBox/BoldCustomCheckListBox.pas b/Source/Samples/BoldCheckListBox/BoldCustomCheckListBox.pas index 4a006c92..39b4cd9e 100644 --- a/Source/Samples/BoldCheckListBox/BoldCustomCheckListBox.pas +++ b/Source/Samples/BoldCheckListBox/BoldCustomCheckListBox.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldCustomCheckListBox; interface @@ -14,7 +17,8 @@ interface BoldSystem, Classes, Controls, - CheckLst; + CheckLst, + BoldDefs; const CHECKBOXFOLLOWER_INDEX = 0; @@ -42,8 +46,8 @@ TBoldCustomCheckListBox = class(TCheckListBox, IBoldOCLComponent) function GetCurrentBoldElement: TBoldElement; function GetCurrentBoldObject: TBoldObject; function GetContextType: TBoldElementTypeInfo; - procedure SetExpression(Expression: string); - function GetExpression: String; + procedure SetExpression(const Value: TBoldExpression); + function GetExpression: TBoldExpression; function GetVariableList: TBoldExternalVariablelist; function GetBoldlistHandle: TBoldAbstractListHandle; procedure SetBoldListHandle(const Value: TBoldAbstractListHandle); @@ -60,7 +64,7 @@ TBoldCustomCheckListBox = class(TCheckListBox, IBoldOCLComponent) procedure _DisplayString(Follower: TBoldFollower); procedure Click; override; procedure DblClick; override; - procedure _ListInsertItem(Follower: TBoldFollower); + procedure _ListInsertItem(Index: integer; Follower: TBoldFollower); procedure _ListDeleteItem(Index: integer; Follower: TBoldFollower); procedure _ListBeforeMakeUpToDate(Follower: TBoldFollower); procedure _ListAfterMakeUpToDate(Follower: TBoldFollower); @@ -101,12 +105,10 @@ implementation constructor TBoldCustomCheckListBox.Create(AOwner: TComponent); begin inherited Create(AOwner); - //handle fBoldRowStringProperties := TBoldStringFollowerController.Create(self); fBoldRowStringProperties.OnGetContextType := GetContextType; fBoldRowCheckBoxProperties := TBoldCheckBoxStateFollowerController.Create(self); fBoldRowCheckBoxProperties.OnGetContextType := GetContextType; - /// fControllerList := TBoldControllerList.Create(self); fControllerList.Add(fBoldRowCheckBoxProperties); fControllerLIst.Add(fBoldRowStringProperties); @@ -221,7 +223,7 @@ procedure TBoldCustomCheckListBox.DblClick; else if BoldListProperties.DefaultDblClick and Assigned(CurrentBoldElement) then begin - {$IFDEF BOLDCOMCLIENT} // autoform + {$IFDEF BOLDCOMCLIENT} Autoform := nil; {$ELSE} AutoForm := AutoFormProviderRegistry.FormForElement(CurrentBoldElement); @@ -231,7 +233,7 @@ procedure TBoldCustomCheckListBox.DblClick; end; end; -function TBoldCustomCheckListBox.GetExpression: String; +function TBoldCustomCheckListBox.GetExpression: TBoldExpression; begin result := BoldRowStringProperties.Expression; end; @@ -241,9 +243,9 @@ function TBoldCustomCheckListBox.GetVariableList: TBoldExternalVariablelist; Result := BoldListProperties.VariableList; end; -procedure TBoldCustomCheckListBox.SetExpression(Expression: string); +procedure TBoldCustomCheckListBox.SetExpression(const Value: TBoldExpression); begin - BoldRowStringProperties.Expression := Expression; + BoldRowStringProperties.Expression := Value; end; function TBoldCustomCheckListBox.GetBoldlistHandle: TBoldAbstractListHandle; @@ -262,7 +264,7 @@ procedure TBoldCustomCheckListBox._ListDeleteItem(Index: Integer; Follower: TBol Items.Delete(Index); end; -procedure TBoldCustomCheckListBox._ListInsertItem(Follower: TBoldFollower); +procedure TBoldCustomCheckListBox._ListInsertItem(Index: integer; Follower: TBoldFollower); begin Items.Insert(Follower.Index, ''); end; @@ -299,7 +301,6 @@ procedure TBoldCustomCheckListBox._ListAfterMakeUpToDate( procedure TBoldCustomCheckListBox._ListBeforeMakeUpToDate( Follower: TBoldFollower); begin - // will fetch all if Assigned(BoldListHandle) and Assigned(BoldListHandle.List) then BoldListHandle.List.EnsureRange(0, BoldListHandle.List.Count - 1); Items.BeginUpdate; @@ -373,7 +374,6 @@ procedure TBoldCustomCheckListBox.SetAlignment(const Value: TAlignment); if Value <> FAlignment then begin FAlignment := Value; - // Enough to invalidate drawing surface Invalidate; end; end; @@ -400,4 +400,6 @@ procedure TBoldCustomCheckListBox.SetBoldListProperties( FBoldListProperties.Assign(Value); end; +initialization + end. diff --git a/Source/Samples/BoldCheckListBox/BoldSelectionListBox.pas b/Source/Samples/BoldCheckListBox/BoldSelectionListBox.pas index e461363b..10793fb4 100644 --- a/Source/Samples/BoldCheckListBox/BoldSelectionListBox.pas +++ b/Source/Samples/BoldCheckListBox/BoldSelectionListBox.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSelectionListBox; interface @@ -5,6 +8,7 @@ interface uses BoldCustomCheckListBox, BoldCheckBoxStateControlPack, + BoldControlPack, BoldListHandle, BoldElements, BoldDefs, @@ -19,14 +23,15 @@ interface {TBoldSelectionListBox} TBoldSelectionListBox = class; + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldSelectionListBox = class(TBoldCustomCheckListBox) private fCheckBoxRenderer: TBoldAsCheckBoxStateRenderer; fPublisher: TBoldPublisher; fSelectionHandle: TBoldListHandle; - function GetAsCheckBoxState(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression): TCheckBoxState; - procedure SetAsCheckBoxState(Element: TBoldElement; newValue: TCheckBoxState; Representation: TBoldRepresentation; Expression: TBoldExpression); - procedure OnSubscribe(Element: TBoldElement; Representation: TBoldRepresentation; Expression: TBoldExpression; Subscriber: TBoldSubscriber); + function GetAsCheckBoxState(aFollower: TBoldFollower): TCheckBoxState; + procedure SetAsCheckBoxState(aFollower: TBoldFollower; newValue: TCheckBoxState); + procedure OnSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); procedure SetSelectionHandle(const Value: TBoldListHandle); protected procedure Notification(AComponent: TComponent; Operation: TOperation); override; @@ -45,7 +50,8 @@ TBoldSelectionListBox = class(TBoldCustomCheckListBox) implementation uses - SysUtils; + SysUtils, + BoldRev; { TBoldSelectionListBox } @@ -67,13 +73,11 @@ destructor TBoldSelectionListBox.Destroy; inherited; end; -function TBoldSelectionListBox.GetAsCheckBoxState(Element: TBoldElement; - Representation: TBoldRepresentation; - Expression: TBoldExpression): TCheckBoxState; +function TBoldSelectionListBox.GetAsCheckBoxState(aFollower: TBoldFollower): TCheckBoxState; begin if Assigned(SelectionHandle) then begin - if (SelectionHandle.List.IndexOf(Element) <> -1 ) then + if (SelectionHandle.List.IndexOf(aFollower.Element) <> -1 ) then Result := cbChecked else Result := cbUnChecked; @@ -89,24 +93,20 @@ procedure TBoldSelectionListBox.Notification(AComponent: TComponent; Operation: SelectionHandle := nil; end; -procedure TBoldSelectionListBox.OnSubscribe(Element: TBoldElement; - Representation: TBoldRepresentation; Expression: TBoldExpression; - Subscriber: TBoldSubscriber); +procedure TBoldSelectionListBox.OnSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); begin SelectionHandle.AddSmallSubscription(Subscriber, [beValueIdentityChanged, beDestroying], breReSubscribe); SelectionHandle.List.DefaultSubscribe(Subscriber); fPublisher.AddSubscription(Subscriber, beSelectionHandleChanged, breReSubscribe); end; -procedure TBoldSelectionListBox.SetAsCheckBoxState(Element: TBoldElement; - newValue: TCheckBoxState; Representation: TBoldRepresentation; - Expression: TBoldExpression); +procedure TBoldSelectionListBox.SetAsCheckBoxState(aFollower: TBoldFollower; newValue: TCheckBoxState); begin if Assigned(SelectionHandle) then begin case newValue of - cbChecked: SelectionHandle.MutableList.Add(Element); - cbUnChecked: if (SelectionHandle.List.IndexOf(Element) <> -1) then SelectionHandle.MutableList.Remove(Element); + cbChecked: SelectionHandle.MutableList.Add(aFollower.Element); + cbUnChecked: if (SelectionHandle.List.IndexOf(aFollower.Element) <> -1) then SelectionHandle.MutableList.Remove(aFollower.Element); cbGrayed: ; end; end; @@ -122,4 +122,6 @@ procedure TBoldSelectionListBox.SetSelectionHandle( end; end; +initialization + end. diff --git a/Source/Samples/BoldCheckListBox/BoldSelectionListBoxReg.pas b/Source/Samples/BoldCheckListBox/BoldSelectionListBoxReg.pas index 95f0ff70..c892d057 100644 --- a/Source/Samples/BoldCheckListBox/BoldSelectionListBoxReg.pas +++ b/Source/Samples/BoldCheckListBox/BoldSelectionListBoxReg.pas @@ -1,9 +1,12 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSelectionListBoxReg; interface procedure Register; - + implementation uses @@ -16,4 +19,5 @@ procedure Register; RegisterComponents(BOLDPAGENAME_CONTROLS, [TBoldSelectionListBox]); end; + end. diff --git a/Source/Samples/ConstraintValidator/BoldConstraintValidator.pas b/Source/Samples/ConstraintValidator/BoldConstraintValidator.pas new file mode 100644 index 00000000..408de46e --- /dev/null +++ b/Source/Samples/ConstraintValidator/BoldConstraintValidator.pas @@ -0,0 +1,602 @@ +{ Global compiler directives } +{$include bold.inc} +unit BoldConstraintValidator; + +interface + +uses + Classes, + SysUtils, + Contnrs, + + BoldElements, + BoldSubscription, + BoldSystem, + BoldHandles, + BoldDefs, + BoldBase, + BoldComponentValidator; + +type + TBoldConstraintSeverity = (csError, csWarning); + TValidationMode = (vmManual, vmOnModify, vmPreUpdate); + +const + cDefaultSeverity = csError; + +type + TBoldConstraintValidator = class; + TBoldConstraintItem = class; + TBoldConstraintCollection = class; + TBoldConstraintFailureList = class; + EBoldConstraintFailure = class; + + TBoldConstraintsFailureEvent = procedure(var AHandled: boolean; AFailedConstraints: TBoldConstraintFailureList) of object; + TBoldConstraintFailureEvent = procedure(ABoldObject: TBoldObject; AConstraint: TBoldConstraintItem; const AFailureMessage: string) of object; + TBoldConstraintCheckEvent = procedure(ABoldObject: TBoldObject; AConstraint: TBoldConstraintItem; var AFailureMessage: string) of object; + + TBoldConstraintFailure = class(TBoldMemoryManagedObject) + private + fBoldObject: TBoldObject; + fConstraint: TBoldConstraintItem; + fFailureMessage: string; + public + constructor Create(ABoldObject: TBoldObject; AConstraint: TBoldConstraintItem; const AFailureMessage: string); + property BoldObject: TBoldObject read fBoldObject; + property Constraint: TBoldConstraintItem read fConstraint; + property FailureMessage: string read fFailureMessage; + end; + + TBoldConstraintFailureList = class(TObjectList) + private + function GetBoldObject(const index: integer): TBoldObject; + function GeTBoldConstraint(const index: integer): TBoldConstraintItem; + function GeTBoldConstraintFailure(const index: integer): TBoldConstraintFailure; + function GetFailureMessage(const index: integer): string; + function GetHasErrors: boolean; + function GetAsString: string; + public + property ConstraintFailure[const index: integer]: TBoldConstraintFailure read GeTBoldConstraintFailure; default; + property BoldObjects[const index: integer]: TBoldObject read GetBoldObject; + property Constraints[const index: integer]: TBoldConstraintItem read GeTBoldConstraint; + property FailureMessages[const index: integer]: string read GetFailureMessage; + property HasErrors: boolean read GetHasErrors; + property AsString: string read GetAsString; + end; + + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] + TBoldConstraintValidator = class(TBoldNonSystemHandle, IBoldValidateableComponent) + strict private + fValidatioNesting: integer; + fConstraints: TBoldConstraintCollection; + fValidationMode: TValidationMode; + fSubscriber: TBoldExtendedPassthroughSubscriber; + fFailedConstraints: TBoldConstraintFailureList; + procedure PreUpdate(Sender: TObject); + procedure Receive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; const Args: array of const); + { IBoldValidateableComponent } + function ValidateComponent(ComponentValidator: TBoldComponentValidator; NamePrefix: String): Boolean; override; + private +// fCheckModelConstraints: boolean; + fOnConstraintsFailed: TBoldConstraintsFailureEvent; + fOnConstraintFailed: TBoldConstraintFailureEvent; + fEnabled: Boolean; + procedure SetValidationMode(const Value: TValidationMode); + function GetSubscriber: TBoldSubscriber; + procedure ProcessFailedConstraints; + procedure SetEnabled(const Value: Boolean); + protected + procedure StaticBoldTypeChanged; override; + procedure Changed; + function BoldSystem: TBoldSystem; + procedure BeginValidate; + procedure EndValidate; + procedure AddFailure(ABoldObject: TBoldObject; AConstraint: TBoldConstraintItem; const AFailureMessage: string); + property Subscriber: TBoldSubscriber read GetSubscriber; + public + procedure AfterConstruction; override; + procedure BeforeDestruction; override; + procedure ValidateObject(ABoldObject: TBoldObject); + procedure ValidateDirtyObjects; + procedure ValidateList(AList: TBoldObjectList); + procedure ValidateObjects(const aObjects: array of TBoldObject); + published + property Constraints: TBoldConstraintCollection read fConstraints write fConstraints; + property ValidationMode: TValidationMode read fValidationMode write SetValidationMode default vmManual; +// TODO: +// property CheckModelConstraints: boolean read fCheckModelConstraints write fCheckModelConstraints; + property OnConstraintFailed: TBoldConstraintFailureEvent read fOnConstraintFailed write fOnConstraintFailed; + property OnConstraintsFailed: TBoldConstraintsFailureEvent read fOnConstraintsFailed write fOnConstraintsFailed; + property Enabled: Boolean read fEnabled write SetEnabled; + end; + + TBoldConstraintCollectionEnumerator = class(TCollectionEnumerator) + public + function GetCurrent: TBoldConstraintItem; + property Current: TBoldConstraintItem read GetCurrent; + end; + + TBoldConstraintCollection = class(TCollection) + strict private + fValidator: TBoldConstraintValidator; + protected + function GetItems(Index: integer): TBoldConstraintItem; + function GetOwner: TPersistent; override; + property Validator: TBoldConstraintValidator read fValidator; + public + constructor Create(Validator: TBoldConstraintValidator); + function GetEnumerator: TBoldConstraintCollectionEnumerator; + property Items[Index: integer]: TBoldConstraintItem read GetItems; default; + end; + + TBoldConstraintItem = class(TCollectionItem, IBoldOCLComponent) + strict private + fContext: String; + fExpression: TBoldExpression; + fErrorMessage: TBoldExpression; + fSeverity: TBoldConstraintSeverity; + fConstraintCheckEvent: TBoldConstraintCheckEvent; + private + function QueryInterface(const IId: TGUID; out Obj): HResult; virtual; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + protected + function GetDisplayName: string; override; + { IBoldOCLComponent } + function GetContextType: TBoldElementTypeInfo; + procedure SetExpression(const Value: TBoldExpression); + function GetVariableList: TBoldExternalVariableList; + function GetExpression: TBoldExpression; + public + procedure Assign(Source: TPersistent); override; + function Check(ABoldObject: TBoldObject): string; + published + property Context: String read fContext write fContext; + property Expression: TBoldExpression read GetExpression write SetExpression; + property Severity: TBoldConstraintSeverity read fSeverity write fSeverity default cDefaultSeverity; + property ErrorMessage: TBoldExpression read fErrorMessage write fErrorMessage; // default cDefaultErrorMessage; + property OnCheckConstraint: TBoldConstraintCheckEvent read fConstraintCheckEvent write fConstraintCheckEvent; + end; + + EBoldConstraintFailure = class(Exception) + private + fFailedConstraints: TBoldConstraintFailureList; + public + constructor Create(AFailedConstraints: TBoldConstraintFailureList); + property FailedConstraints: TBoldConstraintFailureList read fFailedConstraints; + end; + +implementation + +uses + BoldSystemRT; + +{ TBoldConstraintCollection } + +constructor TBoldConstraintCollection.Create(Validator: TBoldConstraintValidator); +begin + inherited Create(TBoldConstraintItem); + fValidator := Validator; +end; + +function TBoldConstraintCollection.GetEnumerator: TBoldConstraintCollectionEnumerator; +begin + result := TBoldConstraintCollectionEnumerator.Create(self); +end; + +function TBoldConstraintCollection.GetItems(Index: integer): TBoldConstraintItem; +begin + result := TBoldConstraintItem(inherited items[index]); +end; + +function TBoldConstraintCollection.GetOwner: TPersistent; +begin + result := Validator; +end; + +{ TBoldConstraintItem } + +procedure TBoldConstraintItem.Assign(Source: TPersistent); +var + SourceItem: TBoldConstraintItem; +begin + if Source is TBoldConstraintItem then + begin + SourceItem := Source as TBoldConstraintItem; + Context := SourceItem.Context; + Expression := SourceItem.Expression; + ErrorMessage := SourceItem.ErrorMessage; + Severity := SourceItem.Severity; + OnCheckConstraint := SourceItem.OnCheckConstraint; + end + else + inherited; +end; + +function TBoldConstraintItem.Check(ABoldObject: TBoldObject): string; +begin + result := ''; + if ABoldObject.BoldClassTypeInfo.BoldIsA(GetContextType) then + begin + if Assigned(fConstraintCheckEvent) then + try + fConstraintCheckEvent(ABoldObject, self, result); + except + on e:exception do + begin + result := ''; + raise; +// TraceLog.SystemMessage(E.ClassName+':'+E.Message, ekError); + end; + end + else + if not ABoldObject.EvaluateExpressionAsBoolean(Expression) then + result := ABoldObject.EvaluateExpressionAsString(ErrorMessage); + end; +end; + +function TBoldConstraintItem.GetContextType: TBoldElementTypeInfo; +var + BoldSystemTypeInfo: TBoldSystemTypeInfo; +begin + result := nil; + BoldSystemTypeInfo := (Collection as TBoldConstraintCollection).Validator.StaticSystemTypeInfo; + if Assigned(BoldSystemTypeInfo) then + result := BoldSystemTypeInfo.ClassTypeInfoByExpressionName[Context]; +end; + +function TBoldConstraintItem.GetDisplayName: string; +begin + if ErrorMessage = '' then + result := Format('[%s]:%s', [Context, Expression]) + else + result := Format('[%s]:%s', [Context, ErrorMessage]); +end; + +function TBoldConstraintItem.GetExpression: TBoldExpression; +begin + result := fExpression; +end; + +function TBoldConstraintItem.GetVariableList: TBoldExternalVariableList; +begin + result := nil; +end; + +function TBoldConstraintItem.QueryInterface(const IId: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then + Result := S_OK + else + Result := E_NOINTERFACE; +end; + +procedure TBoldConstraintItem.SetExpression(const Value: TBoldExpression); +begin + fExpression := Value; +end; + +function TBoldConstraintItem._AddRef: Integer; +begin + result := -1; +end; + +function TBoldConstraintItem._Release: Integer; +begin + result := -1; +end; + +{ TBoldConstraintCollectionEnumerator } + +function TBoldConstraintCollectionEnumerator.GetCurrent: TBoldConstraintItem; +begin + result := inherited GetCurrent as TBoldConstraintItem; +end; + +{ TBoldConstraintValidator } + +procedure TBoldConstraintValidator.AddFailure(ABoldObject: TBoldObject; + AConstraint: TBoldConstraintItem; const AFailureMessage: string); +begin + fFailedConstraints.Add(TBoldConstraintFailure.Create(ABoldObject, AConstraint, AFailureMessage)); + if Assigned(fOnConstraintFailed) then + OnConstraintFailed(ABoldObject, AConstraint, AFailureMessage); +end; + +procedure TBoldConstraintValidator.AfterConstruction; +begin + inherited; + Enabled := true; + fConstraints := TBoldConstraintCollection.Create(self); + fFailedConstraints := TBoldConstraintFailureList.Create; +end; + +procedure TBoldConstraintValidator.BeforeDestruction; +begin + FreeAndNil(fFailedConstraints); + FreeAndNil(fConstraints); + FreeAndNil(fSubscriber); + inherited; +end; + +procedure TBoldConstraintValidator.BeginValidate; +begin + inc(fValidatioNesting); +end; + +procedure TBoldConstraintValidator.EndValidate; +begin + dec(fValidatioNesting); + Assert(fValidatioNesting >= 0); + if (fValidatioNesting = 0) and (fFailedConstraints.count > 0) then + begin + ProcessFailedConstraints; + end; +end; + +function TBoldConstraintValidator.BoldSystem: TBoldSystem; +begin + result := nil; + if Assigned(StaticSystemHandle) then + result := StaticSystemHandle.System; +end; + +procedure TBoldConstraintValidator.Changed; +begin + FreeAndNil(fSubscriber); + if (BoldSystem <> nil) and Enabled then + begin + BoldSystem.OnPreUpdate := nil; + case ValidationMode of + vmManual:; + vmOnModify: + {$IFDEF BoldSystemBroadcastMemberEvents} + BoldSystem.AddSubscription(Subscriber, beCompleteModify, beCompleteModify); + {$ELSE} + raise Exception.Create(ClassName + ': vmOnModify mode requires BoldSystemBroadcastMemberEvents conditional define.'); + {$ENDIF} + vmPreUpdate: + BoldSystem.OnPreUpdate := PreUpdate; + end; + end; +end; + +function TBoldConstraintValidator.GetSubscriber: TBoldSubscriber; +begin + if not Assigned(fSubscriber) then + fSubscriber := TBoldExtendedPassthroughSubscriber.CreateWithExtendedReceive(Receive); + result := fSubscriber; +end; + +procedure TBoldConstraintValidator.PreUpdate(Sender: TObject); +begin + if Enabled and (ValidationMode = vmPreUpdate) then + ValidateList(Sender as TBoldObjectList); +end; + +procedure TBoldConstraintValidator.ProcessFailedConstraints; +var + Handled: boolean; +begin + Handled := false; + try + if Assigned(fOnConstraintsFailed) then + OnConstraintsFailed(Handled, fFailedConstraints); + if not Handled and fFailedConstraints.HasErrors then + raise EBoldConstraintFailure.Create(fFailedConstraints); + finally + fFailedConstraints.clear; + end; +end; + +procedure TBoldConstraintValidator.Receive(Originator: TObject; + OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent; + const Args: array of const); +var + BoldObject: TBoldObject; +begin + if Enabled then + case RequestedEvent of + beCompleteModify: + if (Originator is TBoldMember) then + begin + Assert(Args[0].VObject is TBoldMember); + BoldObject := TBoldMember(Args[0].VObject).OwningObject; + ValidateObject(BoldObject); + end; + end; +end; + +procedure TBoldConstraintValidator.SetEnabled(const Value: Boolean); +begin + if Value <> fEnabled then + begin + fEnabled := Value; + Changed; + end; +end; + +procedure TBoldConstraintValidator.SetValidationMode(const Value: TValidationMode); +begin + if fValidationMode <> Value then + begin + fValidationMode := Value; + Changed; + end; +end; + +procedure TBoldConstraintValidator.StaticBoldTypeChanged; +begin + inherited; + Changed; +end; + +procedure TBoldConstraintValidator.ValidateList(AList: TBoldObjectList); +var + BoldObject: TBoldObject; +begin + BeginValidate; + try + for BoldObject in AList do + ValidateObject(BoldObject); + finally + EndValidate; + end; +end; + +procedure TBoldConstraintValidator.ValidateObject(ABoldObject: TBoldObject); +var + Constraint: TBoldConstraintItem; + FailureMessage: string; +begin + if ABoldObject.BoldObjectIsDeleted then // do not check contraints for deleted objects + exit; + BeginValidate; + try + for Constraint in Constraints do + begin + FailureMessage := Constraint.Check(ABoldObject); + if FailureMessage <> '' then + AddFailure(ABoldObject, Constraint, FailureMessage); + end; + finally + EndValidate; + end; +end; + +procedure TBoldConstraintValidator.ValidateObjects(const aObjects: array of TBoldObject); +var + i: integer; +begin + BeginValidate; + try + for i := 0 to high(AObjects) do + ValidateObject(AObjects[i]); + finally + EndValidate; + end; +end; + +function TBoldConstraintValidator.ValidateComponent( + ComponentValidator: TBoldComponentValidator; NamePrefix: String): Boolean; +var + Context: TBoldElementTypeInfo; + Constraint: TBoldConstraintItem; +begin + result := inherited ValidateComponent(ComponentValidator, NamePrefix); + for Constraint in Constraints do + begin + result := ComponentValidator.ValidateExpressionInContext( + Constraint.Expression, + Constraint.GetContextType, + format('%s%s.Constraint[%d]', [NamePrefix, Constraint.DisplayName, Constraint.Index])) and result; + result := ComponentValidator.ValidateExpressionInContext( + Constraint.ErrorMessage, + Constraint.GetContextType, + format('%s%s.Constraint[%d]', [NamePrefix, Constraint.DisplayName, Constraint.Index])) and result; + end; +end; + +procedure TBoldConstraintValidator.ValidateDirtyObjects; +var + List: TBoldObjectList; +begin + if Assigned(StaticSystemHandle) and Assigned(StaticSystemHandle.System) and StaticSystemHandle.System.BoldDirty then + begin + List := StaticSystemHandle.System.DirtyObjectsAsBoldList; + try + ValidateList(List) + finally + List.free; + end; + end; +end; + +{ EBoldConstraintFailure } + +constructor EBoldConstraintFailure.Create( + AFailedConstraints: TBoldConstraintFailureList); +var + i: integer; + sl: TStringList; +begin + fFailedConstraints := AFailedConstraints; + sl := TStringList.Create; + try + for I := 0 to fFailedConstraints.Count - 1 do + begin + if fFailedConstraints[i].Constraint.Severity = csError then + sl.Add(fFailedConstraints.FailureMessages[i]); + end; + inherited Create(sl.text); + finally + sl.free; + end; +end; + +{ TBoldConstraintFailure } + +constructor TBoldConstraintFailure.Create(ABoldObject: TBoldObject; + AConstraint: TBoldConstraintItem; const AFailureMessage: string); +begin + inherited Create; + fBoldObject := ABoldObject; + fConstraint := AConstraint; + fFailureMessage := AFailureMessage; +end; + +{ TBoldConstraintFailureList } + +function TBoldConstraintFailureList.GeTBoldConstraintFailure( + const index: integer): TBoldConstraintFailure; +begin + result := self.Items[index] as TBoldConstraintFailure; +end; + +function TBoldConstraintFailureList.GetAsString: string; +var + i: integer; + sl: TStringList; +begin + sl := TStringList.Create; + try + for I := 0 to Count - 1 do + sl.Add(FailureMessages[i]); + result := sl.text; + finally + sl.free; + end; +end; + +function TBoldConstraintFailureList.GetBoldObject( + const index: integer): TBoldObject; +begin + result := ConstraintFailure[index].BoldObject +end; + +function TBoldConstraintFailureList.GeTBoldConstraint( + const index: integer): TBoldConstraintItem; +begin + result := ConstraintFailure[index].Constraint +end; + +function TBoldConstraintFailureList.GetFailureMessage(const index: integer): string; +begin + result := ConstraintFailure[index].FailureMessage; +end; + +function TBoldConstraintFailureList.GetHasErrors: boolean; +var + i: integer; +begin + for I := 0 to Count - 1 do + if Constraints[i].severity = csError then + begin + result := true; + exit; + end; + result := false; +end; + +end. + diff --git a/Source/Samples/ConstraintValidator/BoldConstraintValidatorReg.pas b/Source/Samples/ConstraintValidator/BoldConstraintValidatorReg.pas new file mode 100644 index 00000000..a001aed2 --- /dev/null +++ b/Source/Samples/ConstraintValidator/BoldConstraintValidatorReg.pas @@ -0,0 +1,66 @@ +{ Global compiler directives } +{$include bold.inc} +unit BoldConstraintValidatorReg; + +interface + +procedure Register; + +implementation + +uses + Classes, + DesignIntf, + + BoldConstraintValidator, + + BoldDefs, + BoldElements, + BoldSystemRt, + BoldPropertyEditors, + BoldIDEConsts; + +type + { TBoldTypeNameSelectorForConstraintValidator } + TBoldTypeNameSelectorForConstraintValidator = class (TBoldTypeNameSelectorForHandles) + protected + function GetApprovedTypes: TBoldValueTypes; override; + function GetContextType(Component: TPersistent): TBoldSystemTypeInfo; override; + end; + + { TBoldOclVariablesEditor } + TBoldConstraintValidatorEditor = class(TBoldComponentDblClickEditor) + protected + function GetDefaultMethodName: string; override; + end; + +procedure Register; +begin + RegisterComponents(BOLDPAGENAME_MISC, [TBoldConstraintValidator]); + RegisterPropertyEditor(TypeInfo(String), TBoldConstraintItem, 'Context', TBoldTypeNameSelectorForConstraintValidator); + RegisterPropertyEditor(TypeInfo(TBoldExpression), TBoldConstraintItem, 'Expression', TBoldOCLExpressionForOCLComponent); + RegisterPropertyEditor(TypeInfo(TBoldExpression), TBoldConstraintItem, 'ErrorMessage', TBoldOCLExpressionForOCLComponent); + RegisterComponentEditor(TBoldConstraintValidator, TBoldConstraintValidatorEditor); +end; + +{ TBoldTypeNameSelectorForConstraintValidator } + +function TBoldTypeNameSelectorForConstraintValidator.GetApprovedTypes: TBoldValueTypes; +begin + Result := [bvtClass]; +end; + +function TBoldTypeNameSelectorForConstraintValidator.GetContextType( + Component: TPersistent): TBoldSystemTypeInfo; +begin + result := (TBoldConstraintItem(Component).Collection.Owner as TBoldConstraintValidator).StaticSystemTypeInfo; +end; + +{ TBoldConstraintValidatorEditor } + +function TBoldConstraintValidatorEditor.GetDefaultMethodName: string; +begin + Result := 'Constraints'; +end; + +end. diff --git a/Source/Samples/FormSaver/BoldFormSaver.pas b/Source/Samples/FormSaver/BoldFormSaver.pas index 45021ed6..c423fac9 100644 --- a/Source/Samples/FormSaver/BoldFormSaver.pas +++ b/Source/Samples/FormSaver/BoldFormSaver.pas @@ -1,11 +1,16 @@ +{ Global compiler directives } +{$include bold.inc} unit BoldFormSaver; +{.$DEFINE DEBUG_BOLDFORMSAVER} + interface uses Classes, Forms, SysUtils, + Windows, BoldDefs, Boldsubscription, BoldElements, @@ -53,7 +58,10 @@ TBoldDirtyObjectListWithHandle = class(TBoldAbstractDirtyList) destructor Destroy; override; end; + TCallBackFunction = reference to function(Code: Integer; WParam: WPARAM; + var Msg: TMsg): LRESULT; + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldFormSaver = class(TBoldElementHandle) private FSaveToDBOnOk: Boolean; @@ -66,9 +74,16 @@ TBoldFormSaver = class(TBoldElementHandle) FTargetFormSaver: TBoldFormSaver; fTargetFormSaverSubscriber: TBoldPassThroughSubscriber; fOnUpdateException: TBoldFormSaverExceptionEvent; + FOrgActivate: TNotifyEvent; + FOrgDeactivate: TNotifyEvent; + class var + FFormSaverList: TList; + FWndProcHookHandle: HHOOK; + class procedure FinalizationFormSavers; static; procedure SetSaveToDBOnOk(const Value: Boolean); procedure SetSystemHandle(const Value: TBoldSystemHandle); function GetDirtyObjects: TBoldDirtyObjectListWithHandle; + class procedure RegisterFormSaver(FormSaver: TBoldFormSaver); static; procedure SetOnlyFirstDirty(const Value: Boolean); procedure _Activate(Sender: TObject); procedure _DeActivate(Sender: TObject); @@ -81,7 +96,10 @@ TBoldFormSaver = class(TBoldElementHandle) procedure SetTargetFormSaver(const Value: TBoldFormSaver); procedure SaveObjects(Objects: TBoldObjectList); procedure SetAutoRemoveCleanObjects(const Value: Boolean); + class procedure UnregisterFormSaver(FormSaver: TBoldFormSaver); static; protected + procedure DoActive; virtual; + procedure DoDeActivate; virtual; function GetValue: TBoldElement; override; function GetStaticSystemTypeInfo: TBoldSystemTypeInfo; override; function GetStaticBoldType: TBoldElementTypeInfo; override; @@ -89,7 +107,9 @@ TBoldFormSaver = class(TBoldElementHandle) procedure EnsureActive; public constructor Create(Owner: TComponent); override; + class constructor Create; destructor Destroy; override; + class destructor Destroy; procedure OK; procedure Cancel; procedure Apply; @@ -107,8 +127,86 @@ TBoldFormSaver = class(TBoldElementHandle) implementation uses + Controls, + Messages, + Types, + BoldBase, + BoldIndex, + BoldIndexableList, + BoldMetaElementList, BoldUtils; +function WndProcHook(Code: Integer; wParam: WParam; lParam: LParam): LRESULT; stdcall; + + function GetFormSaverByOwner(Owner: TComponent): TBoldFormSaver; + var + i: Integer; + begin + Result := nil; + if (Owner <> nil) and (TBoldFormSaver.FFormSaverList <> nil) then begin + for i := 0 to TBoldFormSaver.FFormSaverList.Count - 1 do begin + if TBoldFormSaver(TBoldFormSaver.FFormSaverList[i]).Owner = Owner then begin + Result := TBoldFormSaver.FFormSaverList[i]; + Break; + end; + end; + end; + end; + + function GetFormSaverByHandle(Handle: HWND): TBoldFormSaver; + var + aComp: TComponent; + i: Integer; + begin + aComp := FindControl(Handle); + if aComp is TBoldFormSaver then begin + Result := TBoldFormSaver(aComp); + end else begin + Result := GetFormSaverByOwner(aComp); + + // on modal dialogs also itertate over the calling forms + if (Result = nil) and (aComp is TForm) and + (fsModal in TForm(aComp).FormState) then + begin + for i := 0 to Screen.SaveFocusedList.Count - 1 do begin + Result := GetFormSaverByOwner(TForm(Screen.SaveFocusedList[i])); + if Assigned(Result) then begin + Break; + end; + end; + end; + end; + end; + +var + aMsg: PCWPStruct; + aFormSaver: TBoldFormSaver; +begin + aMsg := PCWPStruct(lParam); + + // Ensure, that there is always an active FormSaver, + // because OnActivate event is not always called. + if (aMsg.message = WM_ACTIVATE) and (LOWORD(aMsg.wParam) <> WA_INACTIVE) then begin + aFormSaver := GetFormSaverByHandle(aMsg.hwnd); + if Assigned(aFormSaver) then begin + aFormSaver.DoActive; + end; + end; + + Result := CallNextHookEx(TBoldFormSaver.FWndProcHookHandle, Code, wParam, lParam); + +{ Everytime a formsaverless form opens, the current FormSaver gets detached. + This is especially problematic on modal dialogues, because then they no longer + transfer their changes to the FormSaver of the owning host form. + if (aMsg.message = WM_ACTIVATE) and (LOWORD(aMsg.wParam) = WA_INACTIVE) then begin + aFormSaver := GetFormSaverByHandle(aMsg.hwnd); + if Assigned(aFormSaver) then begin + aFormSaver.DoDeActivate; + end; + end; +} +end; + const breSystemHandleDestroying = 100; breSystemHandleActivationChange = 101; @@ -127,14 +225,27 @@ procedure TBoldFormSaver.Apply; procedure TBoldFormSaver.Cancel; var - obj: TBoldObject; + aObj: TBoldObject; + aObjList: TBoldObjectList; + i: Integer; begin EnsureActive; - while DirtyObjects.count > 0 do - begin - Obj := DirtyObjects[DirtyObjects.count-1]; - DirtyObjects.removeByIndex(DirtyObjects.count-1); - obj.Discard; + aObjList := TBoldObjectList.Create; + try + while DirtyObjects.count > 0 do begin + aObj := DirtyObjects[DirtyObjects.count-1]; + DirtyObjects.removeByIndex(DirtyObjects.count-1); + + if not aObj.BoldObjectIsNew then begin + aObjList.Add(aObj); + end; + aObj.Discard; + end; + for i := aObjList.Count - 1 downto 0 do begin + aObjList[i].ReRead; + end; + finally + aObjList.Free; end; PostAction; end; @@ -156,16 +267,16 @@ procedure TBoldFormSaver.Cancel; constructor TBoldFormSaver.Create(Owner: TComponent); begin inherited; + RegisterFormSaver(Self); fSystemHandleSubscriber := TBoldPassthroughSubscriber.Create(_SystemHandleReceive); fTargetFormSaverSubscriber := TBoldPassthroughSubscriber.Create(_TargetFormSaverReveice); - if Owner is TForm then - begin - with Owner as TForm do - begin - onActivate := _Activate; - onDeActivate := _DeActivate; - if Active then - _Activate(self); + if Owner is TForm then begin + FOrgActivate := TForm(Owner).OnActivate; + FOrgDeactivate := TForm(Owner).OnDeactivate; + TForm(Owner).OnActivate := _Activate; + TForm(Owner).OnDeactivate := _DeActivate; + if TForm(Owner).Active then begin + DoActive; end; end; SaveToDBOnOk := true; @@ -173,21 +284,63 @@ constructor TBoldFormSaver.Create(Owner: TComponent); fAutoRemoveCleanObjects := true; end; -destructor TBoldFormSaver.destroy; +class constructor TBoldFormSaver.Create; +begin + inherited; + FFormSaverList := TList.Create; +end; + +destructor TBoldFormSaver.Destroy; begin RemoveMyDirtyListFromSystem; FreeAndNil(fDirtyObjects); FreeAndNil(fSystemHandleSubscriber); FreeAndNil(fTargetFormSaverSubscriber); + if Owner is TForm then begin + TForm(Owner).OnActivate := FOrgActivate; + TForm(Owner).OnDeactivate := FOrgDeactivate; + end; + UnregisterFormSaver(Self); inherited; end; +class destructor TBoldFormSaver.Destroy; +begin + FinalizationFormSavers; + FreeAndNil(FFormSaverList); + inherited; +end; + +procedure TBoldFormSaver.DoActive; +begin + {$IFDEF DEBUG_BOLDFORMSAVER} + OutputDebugString(PChar(Format( + 'Activating BoldFormSaver %s (%s)', [Name, TForm(Owner).Caption]))); + {$ENDIF} + SetDirtyListInSystem(DirtyObjects); +end; + +procedure TBoldFormSaver.DoDeActivate; +begin + {$IFDEF DEBUG_BOLDFORMSAVER} + OutputDebugString(PChar(Format( + 'Deactivating BoldFormSaver %s (%s)', [Name, TForm(Owner).Caption]))); + {$ENDIF} + SetDirtyListInSystem(nil); +end; + procedure TBoldFormSaver.EnsureActive; begin if not assigned(SystemHandle) or not SystemHandle.Active then raise EBold.Create('TBoldFormSaver: No system available'); end; +class procedure TBoldFormSaver.FinalizationFormSavers; +begin + UnhookWindowsHookEx(FWndProcHookHandle); + FWndProcHookHandle := 0; +end; + function TBoldFormSaver.GetDirtyObjects: TBoldDirtyObjectListWithHandle; begin if not assigned(fDirtyObjects) then @@ -233,6 +386,17 @@ procedure TBoldFormSaver.PostAction; (Owner as TForm).Close; end; +class procedure TBoldFormSaver.RegisterFormSaver(FormSaver: TBoldFormSaver); +begin + if FFormSaverList.IndexOf(FormSaver) < 0 then begin + if FFormSaverList.Count = 0 then begin + FWndProcHookHandle := SetWindowsHookEx( + WH_CALLWNDPROC, WndProcHook, 0, GetCurrentThreadId); + end; + FFormSaverList.Add(FormSaver); + end; +end; + procedure TBoldFormSaver.RemoveMyDirtyListFromSystem; begin @@ -273,7 +437,11 @@ procedure TBoldFormSaver.SaveObjects(Objects: TBoldObjectList); finally TempList.Free; end; - Objects.Clear; + if (not (csDestroying in ComponentState)) and + (DirtyObjects.Count = 0) then // ensure that every objects is saved + begin + Objects.Clear; + end; end; end; @@ -343,14 +511,30 @@ procedure TBoldFormSaver.SetTargetFormSaver(const Value: TBoldFormSaver); end; end; +class procedure TBoldFormSaver.UnregisterFormSaver(FormSaver: TBoldFormSaver); +begin + if FFormSaverList <> nil then + begin + FFormSaverList.Extract(FormSaver); + if FFormSaverList.Count = 0 then + FinalizationFormSavers; + end; +end; + procedure TBoldFormSaver._Activate(Sender: TObject); begin - SetDirtyListInSystem(DirtyObjects); + DoActive; + if Assigned(FOrgActivate) then begin + FOrgActivate(Sender); + end; end; procedure TBoldFormSaver._DeActivate(Sender: TObject); begin - SetDirtyListInSystem(nil); + DoDeActivate; + if Assigned(FOrgActivate) then begin + FOrgActivate(Sender); + end; end; procedure TBoldFormSaver._SystemHandleReceive(Originator: TObject; @@ -362,7 +546,7 @@ procedure TBoldFormSaver._SystemHandleReceive(Originator: TObject; if (RequestedEvent = breSystemHandleActivationChange) and (Originator = SystemHandle) and (Owner as TForm).Active then begin - _Activate(self); + DoDeActivate; end; end; diff --git a/Source/Samples/FormSaver/BoldFormSaverActions.pas b/Source/Samples/FormSaver/BoldFormSaverActions.pas new file mode 100644 index 00000000..5d0891b8 --- /dev/null +++ b/Source/Samples/FormSaver/BoldFormSaverActions.pas @@ -0,0 +1,157 @@ + +{ Global compiler directives } +{$include bold.inc} +unit BoldFormSaverActions; + +interface + +uses + classes, + BoldFormSaver, + BoldHandleAction; + +type + TBoldFormSaverAction = class; + TBoldFormSaverApplyAction = class; + TBoldFormSaverCancelAction = class; + TBoldFormSaverOkAction = class; + + TBoldFormSaverAction = class(TBoldHandleAction) + private + function GetBoldFormSaver: TBoldFormSaver; + protected + procedure SetBoldFormSaver(const Value: TBoldFormSaver); virtual; + procedure CheckAllowEnable(var EnableAction: boolean); override; + public + constructor Create(AOwner: TComponent); override; + published + property BoldFormSaver: TBoldFormSaver read GetBoldFormSaver write SetBoldFormSaver; + end; + + TBoldFormSaverApplyAction = class(TBoldFormSaverAction) + protected + procedure CheckAllowEnable(var EnableAction: boolean); override; + public + constructor Create(AOwner: TComponent); override; + procedure ExecuteTarget(Target: TObject); override; + end; + + TBoldFormSaverCancelAction = class(TBoldFormSaverAction) + protected + procedure CheckAllowEnable(var EnableAction: boolean); override; + public + constructor Create(AOwner: TComponent); override; + procedure ExecuteTarget(Target: TObject); override; + end; + + TBoldFormSaverOkAction = class(TBoldFormSaverAction) + protected + procedure CheckAllowEnable(var EnableAction: boolean); override; + public + constructor Create(AOwner: TComponent); override; + procedure ExecuteTarget(Target: TObject); override; + end; + +implementation + +uses + BoldSystem, + ActnList, + SysUtils, + Menus; // for TextToShortCut + +{ TBoldFormSaverAction } + +procedure TBoldFormSaverAction.CheckAllowEnable(var EnableAction: boolean); +begin + inherited; + if EnableAction then + EnableAction := Assigned(BoldFormSaver); +end; + +constructor TBoldFormSaverAction.Create(AOwner: TComponent); +begin + inherited; + Caption := 'FormSaver'; + ShortCut := TextToShortCut('Ctrl+Z'); +end; + +function TBoldFormSaverAction.GetBoldFormSaver: TBoldFormSaver; +begin + result := BoldElementHandle as TBoldFormSaver; +end; + +procedure TBoldFormSaverAction.SetBoldFormSaver(const Value: TBoldFormSaver); +begin + BoldElementHandle := Value; +end; + +{ TBoldFormSaverApplyAction } + +procedure TBoldFormSaverApplyAction.CheckAllowEnable(var EnableAction: boolean); +begin + inherited; + EnableAction := EnableAction and not BoldFormSaver.DirtyObjects.Empty; +end; + +constructor TBoldFormSaverApplyAction.Create(AOwner: TComponent); +begin + inherited; + Caption := '&Apply'; +end; + +procedure TBoldFormSaverApplyAction.ExecuteTarget(Target: TObject); +begin + inherited; + BoldFormSaver.Apply; +end; + +{ TBoldFormSaverCancelAction } + +procedure TBoldFormSaverCancelAction.CheckAllowEnable( + var EnableAction: boolean); +begin + inherited; + if EnableAction then + begin + if BoldFormSaver.DirtyObjects.Empty then + Caption := '&Close' + else + Caption := '&Cancel' + end; +end; + +constructor TBoldFormSaverCancelAction.Create(AOwner: TComponent); +begin + inherited; + Caption := '&Cancel'; + ShortCut := TextToShortCut('Escape'); +end; + +procedure TBoldFormSaverCancelAction.ExecuteTarget(Target: TObject); +begin + inherited; + BoldFormSaver.Cancel; +end; + +{ TBoldFormSaverOkAction } + +procedure TBoldFormSaverOkAction.CheckAllowEnable(var EnableAction: boolean); +begin + inherited; + EnableAction := EnableAction and not BoldFormSaver.DirtyObjects.Empty; +end; + +constructor TBoldFormSaverOkAction.Create(AOwner: TComponent); +begin + inherited; + Caption := '&Ok'; +end; + +procedure TBoldFormSaverOkAction.ExecuteTarget(Target: TObject); +begin + inherited; + BoldFormSaver.OK; +end; + +end. diff --git a/Source/Samples/IDE/BoldEditOCLActionPropEditor.pas b/Source/Samples/IDE/BoldEditOCLActionPropEditor.pas index 35bae8fc..3de835ff 100644 --- a/Source/Samples/IDE/BoldEditOCLActionPropEditor.pas +++ b/Source/Samples/IDE/BoldEditOCLActionPropEditor.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldEditOCLActionPropEditor; interface @@ -40,4 +43,6 @@ procedure TBoldOCLComponentEditor.GetValues(Proc: TGetStrProc); Designer.GetComponentNames(GetTypeData(GetPropType), FilterOnInterface); end; +initialization + end. diff --git a/Source/Samples/IDE/BoldSamplesReg.pas b/Source/Samples/IDE/BoldSamplesReg.pas index c6663df9..3593c870 100644 --- a/Source/Samples/IDE/BoldSamplesReg.pas +++ b/Source/Samples/IDE/BoldSamplesReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSamplesReg; interface @@ -6,21 +9,25 @@ procedure Register; implementation +{$R BoldSamplesReg.res} + uses SysUtils, Classes, DesignIntf, ActnList, +{$IFDEF BOLD_DELPHI16_OR_LATER} + Actions, +{$ENDIF} BoldFormSaver, + BoldGuard, BoldPropertyEditors, BoldNewObjectInterceptor, - BoldSortingGrid, BoldIDEConsts, BoldEditOCLAction, BoldEditOCLActionPropEditor, - BoldDebugActions; - -{$R *.res} + BoldDebugActions, + BoldFormSaverActions; type TTextFileProperty = class(TBoldFileNameProperty) @@ -28,13 +35,13 @@ TTextFileProperty = class(TBoldFileNameProperty) function FileFilter: string; override; end; + procedure RegisterComponentsOnPalette; begin RegisterComponents(BOLDPAGENAME_MISC, [ TBoldNewObjectInterceptor, - TBoldFormSaver, - TBoldSortingGrid + TBoldFormSaver ]); end; @@ -47,15 +54,19 @@ procedure RegisterBoldActions; TBoldLogOCLAction, TBoldLogSQLAction, TBoldLogPMAction, - TBoldLogFormAction + TBoldLogOSSAction, + TBoldLogFormAction, + TBoldFormSaverApplyAction, + TBoldFormSaverCancelAction, + TBoldFormSaverOkAction ], nil); end; procedure RegisterEditors; begin - RegisterPropertyEditor(TypeInfo(string), TBoldNewObjectInterceptor, 'Filename', TTextFileProperty); //do not localize - RegisterPropertyEditor(TypeInfo(TComponent), TBoldEditOCLAction, 'BoldComponent', TBoldOCLComponentEditor); //do not localize + RegisterPropertyEditor(TypeInfo(string), TBoldNewObjectInterceptor, 'Filename', TTextFileProperty); + RegisterPropertyEditor(TypeInfo(TComponent), TBoldEditOCLAction, 'BoldComponent', TBoldOCLComponentEditor); end; procedure Register; @@ -71,6 +82,5 @@ function TTextFileProperty.FileFilter: string; begin Result := Format('%s (*%s)|*%1:s', ['Text files', '.txt']); end; - + end. - diff --git a/Source/Samples/IDE/BoldSamplesReg.res b/Source/Samples/IDE/BoldSamplesReg.res new file mode 100644 index 00000000..11260faa Binary files /dev/null and b/Source/Samples/IDE/BoldSamplesReg.res differ diff --git a/Source/Samples/Misc/BoldLockUtils.pas b/Source/Samples/Misc/BoldLockUtils.pas index 418be6db..f7986a92 100644 --- a/Source/Samples/Misc/BoldLockUtils.pas +++ b/Source/Samples/Misc/BoldLockUtils.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldLockUtils; interface @@ -79,11 +82,8 @@ class procedure TBoldLockUtils.GetLockInfo(System: TBoldSystem; LockHolder: TBol Traverser: TBoldIndexTraverser; begin Traverser := List.CreateTraverser; - while not Traverser.EndOfList do - begin + while Traverser.MoveNext do AddLockInfo(Traverser.item as TBoldLock, Exclusive); - Traverser.Next; - end; Traverser.Free; end; @@ -127,7 +127,7 @@ class procedure TBoldLockUtils.LockInfoToStringGrid(StringGrid: TStringGrid; Sys InitCol(1, 60, 'Type'); InitCol(2, 120, 'Class'); InitCol(3, 200, 'Object'); - StringGrid.Rows[1].Text := ''; // Clear GhostRow + StringGrid.Rows[1].Text := ''; for i := 0 to LockInfo.Count-1 do StringGrid.Rows[i+1].CommaText := LockInfo[i]; diff --git a/Source/Samples/Misc/BoldObjectRetriever.pas b/Source/Samples/Misc/BoldObjectRetriever.pas index f5aa4b07..5dac5369 100644 --- a/Source/Samples/Misc/BoldObjectRetriever.pas +++ b/Source/Samples/Misc/BoldObjectRetriever.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldObjectRetriever; interface @@ -8,11 +11,11 @@ interface BoldValueSpaceInterfaces, BoldSystem; -function BoldRetrieveObjectByIdString(BoldSystem: TBoldSystem; IdString: String): TBoldObject; +function BoldRetrieveObjectByIdString(BoldSystem: TBoldSystem; IdString: String; aLoadIfNotInMemory: boolean = true): TBoldObject; implementation -function RetrieveObjectByInexactId(BoldSystem: TBoldSystem; ObjectId: tBoldObjectId): TBoldObject; +function RetrieveObjectByInexactId(BoldSystem: TBoldSystem; ObjectId: TBoldObjectId): TBoldObject; var TranslationList: TBoldIdTranslationList; IdList: TBoldObjectIdList; @@ -26,9 +29,9 @@ function RetrieveObjectByInexactId(BoldSystem: TBoldSystem; ObjectId: tBoldObjec IdList := TBoldObjectIdList.Create; try IdList.Add(ObjectId); - BoldSystem.PersistenceController.PMExactifyIds(IdList, TranslationList); + BoldSystem.PersistenceController.PMExactifyIds(IdList, TranslationList, true); ExactId := TranslationList.TranslateToNewId[ObjectId]; - if ExactId.TopSortedIndexExact then + if (not ExactId.NonExisting) and ExactId.TopSortedIndexExact then begin Locator := BoldSystem.EnsuredLocatorByID[ExactId]; if Locator.EnsuredBoldObject.BoldExistenceState = besExisting then @@ -41,7 +44,7 @@ function RetrieveObjectByInexactId(BoldSystem: TBoldSystem; ObjectId: tBoldObjec end; end; -function BoldRetrieveObjectByIdString(BoldSystem: TBoldSystem; IdString: String): TBoldObject; +function BoldRetrieveObjectByIdString(BoldSystem: TBoldSystem; IdString: String; aLoadIfNotInMemory: boolean): TBoldObject; var ObjectId: TBoldDefaultID; Locator: TBoldObjectLocator; @@ -54,11 +57,11 @@ function BoldRetrieveObjectByIdString(BoldSystem: TBoldSystem; IdString: String) ObjectId := TBoldDefaultID.CreateWithClassID(0, false); ObjectId.AsInteger := IdValue; try - // Check if the locator is already in memory Locator := BoldSystem.Locators.LocatorByID[ObjectId]; if assigned(Locator) then result := Locator.EnsuredBoldObject else + if aLoadIfNotInMemory then result := RetrieveObjectByInexactId(BoldSystem, ObjectId); finally ObjectId.Free; diff --git a/Source/Samples/ModelLoader/BoldModelLoader.pas b/Source/Samples/ModelLoader/BoldModelLoader.pas index 09e496ac..e49b54ae 100644 --- a/Source/Samples/ModelLoader/BoldModelLoader.pas +++ b/Source/Samples/ModelLoader/BoldModelLoader.pas @@ -1,7 +1,9 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldModelLoader; interface - uses Classes, Dialogs, @@ -30,7 +32,8 @@ implementation uses SysUtils, - BoldUtils; + BoldUtils, + BoldRev; var G_ModelLoader: TBoldModelLoader = nil; @@ -105,4 +108,3 @@ initialization finalization FreeAndNil(G_ModelLoader); end. - diff --git a/Source/Samples/NewObjectInterceptor/BoldNewObjectInterceptor.pas b/Source/Samples/NewObjectInterceptor/BoldNewObjectInterceptor.pas index 67561bf2..327e8ca5 100644 --- a/Source/Samples/NewObjectInterceptor/BoldNewObjectInterceptor.pas +++ b/Source/Samples/NewObjectInterceptor/BoldNewObjectInterceptor.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldNewObjectInterceptor; interface @@ -11,6 +14,7 @@ interface BoldPlaceableSubscriber; type + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldNewObjectInterceptor = class(TBoldPlaceableSubscriber) private fActive: boolean; @@ -86,7 +90,6 @@ procedure TBoldNewObjectInterceptor.InitializeAttribute(Attribute: TBoldAttribut begin if Attribute is TBAInteger then begin - // Note: Might be lengthy if range is narrow!! repeat i := Random(20000) - 10000; until (Attribute as TBAInteger).CheckRange(i); @@ -128,8 +131,6 @@ procedure TBoldNewObjectInterceptor.Receive(Originator: TObject; OriginalEvent: if Args[0].VObject is TBoldObjectLocator then begin Locator := Args[0].VObject as TBoldObjectLocator; - - // check id the object was loaded from the db... if not Locator.BoldObjectID.IsStorable then SetRandomAttributes(Locator.BoldObject); end; @@ -167,4 +168,6 @@ procedure TBoldNewObjectInterceptor.SubscribeToElement( (Element as TBoldSystem).Classes[0].DefaultSubscribe(Subscriber, breReEvaluate); end; +initialization + end. diff --git a/Source/Samples/SortingGrid/BoldSortingGrid.pas b/Source/Samples/SortingGrid/BoldSortingGrid.pas index 4b3fbd37..40451d64 100644 --- a/Source/Samples/SortingGrid/BoldSortingGrid.pas +++ b/Source/Samples/SortingGrid/BoldSortingGrid.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSortingGrid; interface @@ -55,8 +58,8 @@ TBoldSortingGrid = class(TBoldgrid) property Comparer: TBoldComparer read GetComparer; property ListHandle: TBoldListHandle read GetListHandle; public - constructor Create(aOwner: TComponent); override; - destructor Destroy; override; + constructor create(aOwner: TComponent); override; + destructor destroy; override; procedure DrawCell(ACol, aRow: Longint; ARect: TRect; AState: TGridDrawState); override; property OrderCol: integer read FOrderCol write SetOrderCol; property OrderDescending: Boolean read FOrderDescending write SetOrderDescending; @@ -74,7 +77,8 @@ implementation uses SysUtils, Graphics, - BoldDefs; + BoldDefs, + BoldRev; { TBoldSortingGrid } function TBoldSortingGrid.AdjustStringForNumericCompare(s: String): String; @@ -104,7 +108,6 @@ function TBoldSortingGrid.ComparerCompare(Item1, Item2: TBoldElement): Integer; begin Obj1 := Item1 as TBoldObject; Obj2 := Item2 as TBoldObject; - // if both objects are new, then sort them by ID, otherwise sort the new object after the old if Obj2.BoldObjectIsNew and Obj1.BoldObjectIsNew then begin result := StrToIntDef(Obj1.BoldObjectLocator.BoldObjectId.AsString, 0) - StrToIntDef(Obj2.BoldObjectLocator.BoldObjectId.AsString, 0); @@ -260,22 +263,16 @@ procedure TBoldSortingGrid.MouseUp(Button: TMouseButton; Col: integer; begin inherited; - // are we in the title? if (FixedRows = 0) or (csDesigning in ComponentState) or (y > RowHeights[0]) then exit; - - // has sorting been disabled if not EnableSorting then exit; - - // has the mouse moved since it was pressed? if (x <> fLastMouseDown.x) or (y <> fLastMouseDown.y) then exit; - + Col := 0; while (x > 0) and (Col < ColCount) do begin - // Act only on the visible columns if (Col < FixedCols) or (Col >= LeftCol) then begin dec(x, ColWidths[Col]); diff --git a/Source/Samples/SystemComparer/BoldSystemComparer.pas b/Source/Samples/SystemComparer/BoldSystemComparer.pas index d7442c72..6fc23a34 100644 --- a/Source/Samples/SystemComparer/BoldSystemComparer.pas +++ b/Source/Samples/SystemComparer/BoldSystemComparer.pas @@ -1,27 +1,43 @@ -unit BoldSystemComparer; +{ Global compiler directives } +{$include bold.inc} +unit BoldSystemComparer; interface uses Classes, BoldSystem, + BoldElements, + BoldDomainElement, BoldHandles; type + TOnDifferenceEvent = procedure (ALeft, ARight: TBoldDomainElement; AMessage: string; var AContinue: boolean) of object; + TCompareOptions = set of (coDerived, // derived members + coTransient, // transient members + coTransientObjects, // transient objects + coCompareObjectTimestamp // Object timestamp + {coIgnoreCurrentTime}); TBoldSystemComparer = class + private + fOnDifference: TOnDifferenceEvent; + fOptions: TCompareOptions; protected - class function GetCorrespondingObject(LeftObject: TBoldObject; RightSystem: TBoldSystem): TBoldObject; virtual; - class function CompareObjects(Left, Right: TBoldObject): string; virtual; - class function CompareAttributes(Left, Right: TBoldAttribute): string; virtual; - class function CompareMembers(Left, Right: TBoldMember): string; virtual; - class function CompareObjectReferences(Left, Right: TBoldObjectReference): string; virtual; - class function CompareObjectLists(Left, Right: TBoldObjectList): string; virtual; - class function FullObjectName(BoldObject: TBoldObject): string; virtual; - class function FullMemberName(BoldMember: TBoldMember): string; virtual; - class function ObjectReferenceAsString(ObjectReference: TBoldObjectReference): string; virtual; + function GetCorrespondingObject(LeftObject: TBoldObject; RightSystem: TBoldSystem): TBoldObject; virtual; + function CompareObjects(Left, Right: TBoldObject): string; virtual; + function CompareAttributes(Left, Right: TBoldAttribute): string; virtual; + function CompareMembers(Left, Right: TBoldMember): string; virtual; + function CompareObjectReferences(Left, Right: TBoldObjectReference): string; virtual; + function CompareObjectLists(Left, Right: TBoldObjectList): string; virtual; + function FullObjectName(BoldObject: TBoldObject): string; virtual; + function FullMemberName(BoldMember: TBoldMember): string; virtual; + function ObjectReferenceAsString(ObjectReference: TBoldObjectReference): string; virtual; + function DoOnDifference(ALeft, ARight: TBoldDomainElement; AMessage: string): boolean; public - class function CompareSystems(Left, Right: TBoldSystem): string; virtual; + function CompareSystems(Left, Right: TBoldSystem): string; virtual; + property OnDifference: TOnDifferenceEvent read fOnDifference write fOnDifference; + property Options: TCompareOptions read fOptions write fOptions; end; @@ -31,23 +47,31 @@ implementation SysUtils, BoldUtils; - { TBoldSystemComparer } -class function TBoldSystemComparer.CompareAttributes(Left, +function TBoldSystemComparer.CompareAttributes(Left, Right: TBoldAttribute): string; begin if not Left.IsEqual(Right) then + begin result := Format('Attributes differ: %s:''%s'' <> %s:''%s''', [ FullMemberName(Left), Left.AsString, FullMemberName(right), Right.AsString]); + if DoOnDifference(Left, Right, result) then + result := ''; + end; end; -class function TBoldSystemComparer.CompareMembers(Left, +function TBoldSystemComparer.CompareMembers(Left, Right: TBoldMember): string; begin + result := ''; + if not (coDerived in Options) and left.Derived then + exit; + if not (coTransient in Options) and not left.BoldPersistent then + exit; if (Left is TBoldAttribute) and (Right is TBoldAttribute) then Result := CompareAttributes(TBoldAttribute(Left), TBoldAttribute(Right)) else if (Left is TBoldObjectReference) and (Right is TBoldObjectReference) then @@ -56,9 +80,11 @@ class function TBoldSystemComparer.CompareMembers(Left, result := CompareObjectLists(TBoldObjectList(Left), TBoldObjectList(Right)) else result := Format('members differ in type %s <> %s', [FullMemberName(Left), FullMemberName(Right)]); + if (result <> '') and DoOnDifference(Left, Right, result) then + result := ''; end; -class function TBoldSystemComparer.CompareObjectLists(Left, +function TBoldSystemComparer.CompareObjectLists(Left, Right: TBoldObjectList): string; var i: integer; @@ -66,7 +92,7 @@ class function TBoldSystemComparer.CompareObjectLists(Left, RightCopy: TBoldObjectList; Ordered: Boolean; begin - Ordered := Left.BoldRoleRTInfo.IsOrdered; + Ordered := Left.BoldRoleRTInfo.IsOrdered; if Left.Count <> Right.Count then Result := Format( 'multilinks have different count : %s:%d <> %s:%d', [ @@ -74,6 +100,8 @@ class function TBoldSystemComparer.CompareObjectLists(Left, left.Count, FullMemberName(right), right.Count]) + else if Left.Empty then + exit else if Ordered then begin for i := 0 to Left.Count-1 do @@ -86,7 +114,7 @@ class function TBoldSystemComparer.CompareObjectLists(Left, FullObjectName(Left[i]), FullMemberName(Right), FullObjectName(Right[i])]); - Exit; + break; end; end else @@ -103,21 +131,23 @@ class function TBoldSystemComparer.CompareObjectLists(Left, begin Result := Format( 'Position %d in left not found in right : %s[%d]:%s no in %s', [ - i, i, + i, FullMemberName(Left), + i, FullObjectName(Left[i]), - FullMemberName(Right), - FullObjectName(Right[i])]); - Exit; + FullMemberName(Right)]); + break; end; end; finally RightCopy.Free; end; end; + if (result <> '') and DoOnDifference(Left, Right, result) then + result := ''; end; -class function TBoldSystemComparer.CompareObjectReferences(Left, +function TBoldSystemComparer.CompareObjectReferences(Left, Right: TBoldObjectReference): string; begin if GetCorrespondingObject(Left.BoldObject, right.BoldSystem) <> Right.BoldObject then @@ -127,14 +157,16 @@ class function TBoldSystemComparer.CompareObjectReferences(Left, ObjectReferenceAsString(Left), FullMemberName(right), ObjectReferenceAsString(Right)]); + if (result <> '') and DoOnDifference(Left, Right, result) then + result := ''; end; -class function TBoldSystemComparer.CompareObjects(Left, +function TBoldSystemComparer.CompareObjects(Left, Right: TBoldObject): string; var i: integer; begin - if Left.BoldClassTypeInfo.ExpressionName <> right.BoldClassTypeInfo.ExpressionName then + if not Left.BoldClassTypeInfo.BoldIsA(right.BoldClassTypeInfo) then Result := Format( 'Objects have different ClassName : %s:%d <> %s:%d', [ FullObjectName(Left), @@ -150,21 +182,26 @@ class function TBoldSystemComparer.CompareObjects(Left, right.BoldMemberCount]) else begin + if (coCompareObjectTimestamp in Options) and + (left.AsIBoldObjectContents[bdepContents].TimeStamp <> right.AsIBoldObjectContents[bdepContents].TimeStamp) then + result := Format('Left %s Timestamp: %d <> Right %s Timestamp: %d', [Left.DebugInfo, left.AsIBoldObjectContents[bdepContents].TimeStamp, right.DebugInfo, right.AsIBoldObjectContents[bdepContents].TimeStamp]) + else for i := 0 to Left.BoldMemberCount-1 do begin result := CompareMembers(Left.BoldMembers[i], Right.BoldMembers[i]); - if Result <> ' ' then + if Result <> '' then Break; end; end; + if (result <> '') and DoOnDifference(Left, Right, result) then + result := ''; end; -class function TBoldSystemComparer.CompareSystems(Left, +function TBoldSystemComparer.CompareSystems(Left, Right: TBoldSystem): string; var i: integer; - IndexOfCorresponding: integer; - RightCopy: TBoldObjectList; + LeftObject, RightObject: TBoldObject; begin if Left.Classes[0].Count <> Right.Classes[0].Count then Result := Format( @@ -174,30 +211,42 @@ class function TBoldSystemComparer.CompareSystems(Left, ) else begin - RightCopy := TBoldObjectList.Create; - try - RightCopy.AddList(Right.Classes[0]); - for i := 0 to Left.Classes[0].Count-1 do - begin - IndexOfCorresponding := RightCopy.IndexOf(GetCorrespondingObject(Left.Classes[0][i], Right)); - if IndexOfCorresponding <> -1 then - begin - Result := Compareobjects(Left.Classes[0][i], Left.Classes[0][IndexOfCorresponding]); - RightCopy.RemoveByIndex(IndexOfCorresponding) - end - else - Result := Format( - 'Object %s in left not found in right' , [FullObjectName(Left.Classes[0][i])]); - if result <> '' then - Exit; - end; - finally - RightCopy.Free; + Left.Classes[0].EnsureObjects; + Right.Classes[0].EnsureObjects; +{$IFDEF FetchFromClassList} + for i := 0 to Left.BoldSystemTypeInfo.TopSortedClasses.Count -1 do + Left.Classes[i].EnsureObjects; + for i := 0 to Right.BoldSystemTypeInfo.TopSortedClasses.Count -1 do + Right.Classes[i].EnsureObjects; +{$ENDIF} + for i := 0 to Left.Classes[0].Count-1 do + begin + LeftObject := Left.Classes[0][i]; + if not (coTransientObjects in Options) and not LeftObject.BoldPersistent then + continue; // skip transient objects + RightObject := Right.Locators.ObjectByID[LeftObject.BoldObjectLocator.BoldObjectID]; + if Assigned(RightObject) then + Result := Compareobjects(LeftObject, RightObject) + else + Result := Format( + 'Object %s in left not found in right' , [FullObjectName(Left.Classes[0][i])]); + if result <> '' then + break; end; end; + if (result <> '') and DoOnDifference(Left, Right, result) then + result := ''; end; -class function TBoldSystemComparer.FullMemberName( +function TBoldSystemComparer.DoOnDifference(ALeft, ARight: TBoldDomainElement; + AMessage: string): boolean; +begin + result := false; + if Assigned(fOnDifference) then + fOnDifference(ALeft, ARight, AMessage, result); +end; + +function TBoldSystemComparer.FullMemberName( BoldMember: TBoldMember): string; begin if not Assigned(BoldMember) then @@ -206,7 +255,7 @@ class function TBoldSystemComparer.FullMemberName( Result := Format('%s.%s', [FullObjectName(BoldMember.OwningObject), BoldMember.BoldMemberRTInfo.expressionname]); end; -class function TBoldSystemComparer.FullObjectName( +function TBoldSystemComparer.FullObjectName( BoldObject: TBoldObject): string; begin if not Assigned(BoldObject) then @@ -215,7 +264,7 @@ class function TBoldSystemComparer.FullObjectName( Result := Format('%s:%s', [BoldObject.BoldClassTypeInfo.expressionname, BoldObject.BoldObjectLocator.AsString]); end; -class function TBoldSystemComparer.GetCorrespondingObject( +function TBoldSystemComparer.GetCorrespondingObject( LeftObject: TBoldObject; RightSystem: TBoldSystem): TBoldObject; begin if not Assigned(LeftObject) then @@ -224,13 +273,15 @@ class function TBoldSystemComparer.GetCorrespondingObject( Result := RightSystem.Locators.ObjectByID[LeftObject.BoldObjectLocator.BoldObjectID]; end; -class function TBoldSystemComparer.ObjectReferenceAsString(ObjectReference: +function TBoldSystemComparer.ObjectReferenceAsString(ObjectReference: TBoldObjectReference): string; begin if Assigned(ObjectReference) then Result := FullObjectName(ObjectReference.BoldObject) else - result := 'Nil'; //do not localize + result := 'Nil'; end; +initialization + end. diff --git a/Source/Samples/SystemDebugger/BoldSystemDebuggerForm.pas b/Source/Samples/SystemDebugger/BoldSystemDebuggerForm.pas index 6e9631d2..7d54ad70 100644 --- a/Source/Samples/SystemDebugger/BoldSystemDebuggerForm.pas +++ b/Source/Samples/SystemDebugger/BoldSystemDebuggerForm.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldSystemDebuggerForm; interface @@ -11,7 +14,6 @@ interface BoldRootedHandles, BoldAFP, BoldAfpDefault, - BoldMemoryManager, BoldSystem, BoldOcl, BoldLogHandler, @@ -24,7 +26,9 @@ interface BoldCursorHandle, BoldDBInterfaces, BoldGui, - BoldListHandle, BoldReferenceHandle, ExtCtrls; + BoldListHandle, + BoldReferenceHandle, + ExtCtrls; type TBoldSystemDebuggerFrm = class(TForm) @@ -86,13 +90,11 @@ implementation uses SysUtils, - BoldRev, BoldUtils; procedure TBoldSystemDebuggerFrm.btnUpdateMemoryInfoClick(Sender: TObject); begin - mmoMemoryInfo.Lines.Text := BoldMemoryManager_.MemoryInfo; mmoSharedStrings.Lines.text := BoldSharedStringManager.InfoString; end; @@ -155,7 +157,6 @@ procedure TBoldSystemDebuggerFrm.btnUpdateDirtyObjectsClick(Sender: TObject); var i: integer; begin - // Only activated if system is assigned fDirtyList.Clear; for i := 0 to System.DirtyObjects.Count-1 do fDirtyList.add(TBoldObject(System.DirtyObjects[i])); @@ -163,7 +164,6 @@ procedure TBoldSystemDebuggerFrm.btnUpdateDirtyObjectsClick(Sender: TObject); procedure TBoldSystemDebuggerFrm.btnUpdateDatabaseClick(Sender: TObject); begin - // Only activated if system is assigned System.UpdateDatabase end; diff --git a/Source/Samples/UMLPlugins/BoldUMLNameTrimmer.pas b/Source/Samples/UMLPlugins/BoldUMLNameTrimmer.pas index 133909f3..636ca0df 100644 --- a/Source/Samples/UMLPlugins/BoldUMLNameTrimmer.pas +++ b/Source/Samples/UMLPlugins/BoldUMLNameTrimmer.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLNameTrimmer; interface @@ -32,14 +35,13 @@ implementation uses SysUtils, - BoldUtils; + BoldUtils, + BoldRev; var _UMLNameFixer: TUMLNameFixer = nil; { TUMLNameFixer } - -// Main method to invoke plug in functionality procedure TUMLNameFixer.Execute(context: IUMLModelPlugInContext); var UMLModel: TUMLModel; @@ -54,32 +56,22 @@ procedure TUMLNameFixer.Execute(context: IUMLModelPlugInContext); BoldLog.EndLog; end; end; - -// Mask color for bitmap function TUMLNameFixer.GetImageMaskColor: TColor; begin Result := clTeal; end; - -// Resource for menu and button icon function TUMLNameFixer.GetImageResourceName: String; begin result := 'NameTrimmer'; end; - -// Caption for menu and hint for button function TUMLNameFixer.GetMenuItemName: String; begin Result := 'Name trimmer'; end; - -// Type of tool function TUMLNameFixer.GetPlugInType: TPlugInType; begin Result := ptTool; end; - -// Trims name of class + all its members and association ends procedure TUMLNameFixer.TrimClassAndMembers(UMLClass: TUMLClass); var i: integer; @@ -92,8 +84,6 @@ procedure TUMLNameFixer.TrimClassAndMembers(UMLClass: TUMLClass); for i := 0 to UMLClass.AssociationEnd.Count - 1 do TrimName(UMLClass.AssociationEnd[i]); end; - -// Trimmer of names procedure TUMLNameFixer.TrimName(UMLElement: TUMLModelElement); begin if UMLElement.Name <> Trim(UMLElement.Name) then @@ -104,6 +94,7 @@ procedure TUMLNameFixer.TrimName(UMLElement: TUMLModelElement); end; initialization + _UMLNameFixer := TUMLNameFixer.Create(true); finalization diff --git a/Source/Samples/Unicode/BoldAttributeWideString.pas b/Source/Samples/Unicode/BoldAttributeWideString.pas index 97381a50..1d6eff38 100644 --- a/Source/Samples/Unicode/BoldAttributeWideString.pas +++ b/Source/Samples/Unicode/BoldAttributeWideString.pas @@ -1,22 +1,22 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldAttributeWideString; -// useful links: -// Delphi-Unicode.net: http://www.delphi-unicode.net -// Unicode components: http://mikroklubben.adsl.dk/~nikse/delphi-unicode.zip -// unicode fonts: http://www.hclrss.demon.co.uk/unicode/fonts.html -// Arial MS Unicode.ttf: http://office.microsoft.com/downloads/2000/aruniupd.aspx - -// To install this attribute type in your application, add the following to your -// TypeNameHandle: -// -// ModelName: UniCode -// ExpressionName: WideString -// DelphiName: TBAWideString -// ContentName: WideString -// PMapper: TBoldPMWideString -// Accessor: AsWideString -// NativeType: WideString -// UnitName: BoldAttributeWideString + + + + + + + + + + + + + + interface @@ -42,18 +42,18 @@ TBAWideString = class(TBoldAttribute) function GetWideStringRepresentation(Representation: TBoldRepresentation): WideString; procedure SetWideStringRepresentation(Representation: TBoldRepresentation; const Value: WideString); protected - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; procedure FreeContent; override; function GetStringRepresentation(Representation: TBoldRepresentation): string; override; - procedure SetStringRepresentation(Representation: TBoldRepresentation; Value: string); override; + procedure SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); override; function MaySetValue(NewValue: WideString; Subscriber: TBoldSubscriber): Boolean; - function ProxyClass: TBoldMember_ProxyClass; override; + //function ProxyClass: TBoldMember_ProxyClass; override; public procedure Assign(Source: TBoldElement); override; - procedure AssignValue(Source: IBoldValue); override; + procedure AssignValue(const Source: IBoldValue); override; function CompareToAs(CompType: TBoldCompareType; BoldElement: TBoldElement): Integer; override; - function ValidateWideString(Value: WideString; Representation: TBoldRepresentation): Boolean; - function ValidateString(Value: String; Representation: TBoldRepresentation): Boolean; override; + function ValidateWideString(Value: WideString; Representation: TBoldRepresentation): Boolean; + function ValidateString(const Value: String; Representation: TBoldRepresentation): Boolean; override; function CanSetValue(NewValue: WideString; Subscriber: TBoldSubscriber): Boolean; function ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; override; procedure SetEmptyValue; override; @@ -63,7 +63,7 @@ TBAWideString = class(TBoldAttribute) { The following class implements a proxy for a WideString attribute to support IBoldWideStringContent, a part of the ValueSpace-interface mechanism used for objectspace transactions, persistence and other things } - + { TBAWideString_Proxy } TBAWideString_Proxy = class(TBoldAttribute_Proxy, IBoldWideStringContent) private @@ -79,7 +79,8 @@ implementation Windows, SysUtils, { Bold } - BoldMemberTypeDictionary; + BoldMemberTypeDictionary, + BoldRev; {******************************************************************************} {* TBAWideString *} @@ -87,12 +88,14 @@ implementation {* Proxy routines *************************************************************} +(* { The following method returns a class reference to a WideString proxy class } { thus allowing Bold to instantiate it } function TBAWideString.ProxyClass: TBoldMember_ProxyClass; begin result := TBAWideString_Proxy; end; +*) function TBAWideString.ProxyInterface(const IId: TGUID; Mode: TBoldDomainElementProxyMode; out Obj): Boolean; @@ -130,7 +133,7 @@ procedure TBAWideString.FreeContent; {* Public get/set methods *****************************************************} -procedure TBAWideString.SetStringRepresentation(Representation: TBoldRepresentation; Value: string); +procedure TBAWideString.SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); begin SetWideStringRepresentation(Representation, Value); end; @@ -142,15 +145,15 @@ function TBAWideString.GetStringRepresentation(Representation: TBoldRepresentati {* Validation routines ********************************************************} -function TBAWideString.ValidateString(Value: string; Representation: TBoldRepresentation): Boolean; +function TBAWideString.ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; begin Result := ValidateWideString(Value, Representation); end; function TBAWideString.CanSetValue(NewValue: Widestring; Subscriber: TBoldSubscriber): Boolean; begin - Result := MaySetValue(NewValue, Subscriber) and - SendQuery(bqMaySetValue, [NewValue], Subscriber); + Result := MaySetValue(NewValue, Subscriber) {$IFNDEF BOLD_NO_QUERIES}and + SendQuery(bqMaySetValue, [NewValue], Subscriber){$ENDIF}; end; {* Assignment routines ********************************************************} @@ -168,7 +171,7 @@ procedure TBAWideString.Assign(Source: TBoldElement); inherited; end; -procedure TBAWideString.AssignContentValue(Source: IBoldValue); +procedure TBAWideString.AssignContentValue(const Source: IBoldValue); var s: IBoldWideStringContent; begin @@ -191,7 +194,7 @@ procedure TBAWideString.AssignContentValue(Source: IBoldValue); end; end; -procedure TBAWideString.AssignValue(Source: IBoldValue); +procedure TBAWideString.AssignValue(const Source: IBoldValue); var sw: IBoldWideStringContent; begin @@ -219,16 +222,10 @@ function TBAWideString.CompareToAs(CompType: TBoldCompareType; BoldElement: TBol Result := NullSmallest(BoldElement) else case CompType of - ctDefault: - Result := WideCompareText(AsWideString, CompareString.AsWideString); - ctAsString: - Result := WideCompareStr(AsWideString, CompareString.AsWideString); - ctAsText: + ctDefault, ctCaseInsensitive: Result := WideCompareText(AsWideString, CompareString.AsWideString); - ctAsAnsiString: + ctAsString, ctCaseSensitive: Result := WideCompareStr(AsWideString, CompareString.AsWideString); - ctAsAnsiText: - Result := WideCompareText(AsWideString, CompareString.AsWideString); else Result := inherited CompareToAs(CompType, BoldElement); end @@ -243,7 +240,8 @@ function TBAWideString.CompareToAs(CompType: TBoldCompareType; BoldElement: TBol function TBAWideString_Proxy.GetProxedWideString: TBAWideString; begin - Result := ProxedElement as TBAWideString; + Result := ProxedMember as TBAWideString; + //Result := ProxedElement as TBAWideString; end; function TBAWideString.MaySetValue(NewValue: WideString; Subscriber: TBoldSubscriber): Boolean; @@ -257,7 +255,7 @@ function TBAWideString.GetWideStringRepresentation(Representation: TBoldRepresen if not CanRead(nil) then BoldRaiseLastFailure(self, 'GetWideStringRepresentation', ''); case Representation of - brDefault: + brDefault: begin if IsNull then {IsNull ensures current} Result := '' @@ -319,7 +317,7 @@ procedure TBAWideString.SetContent(Newvalue: WideString); initialization BoldmemberTypes.AddMemberTypeDescriptor(TBAWideString, alConcrete); - + finalization if BoldMemberTypesAssigned then BoldMemberTypes.RemoveDescriptorByClass(TBAWideString); diff --git a/Source/Samples/Unicode/BoldPMWideString.pas b/Source/Samples/Unicode/BoldPMWideString.pas index 7103d33c..abdc18a8 100644 --- a/Source/Samples/Unicode/BoldPMWideString.pas +++ b/Source/Samples/Unicode/BoldPMWideString.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldPMWideString; interface @@ -26,11 +29,11 @@ TBoldPMWideString = class(TBoldSingleColumnMember) function GetColumnTypeAsSQL(ColumnIndex: Integer): string; override; function GetColumnBDEFieldType(ColumnIndex: Integer): TFieldType; override; function GetColumnSize(ColumnIndex: Integer): Integer; override; - function CompareField(ObjectContent: IBoldObjectContents; Field: IBoldField; ColumnIndex: integer; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; + function CompareField(const ObjectContent: IBoldObjectContents; const Field: IBoldField; ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; override; public constructor CreateFromMold(Moldmember: TMoldMember; MoldClass: TMoldClass; Owner: TBoldObjectPersistenceMapper; const MemberIndex: Integer; TypeNameDictionary: TBoldTypeNameDictionary); override; - procedure ValueToParam(ObjectContent: IBoldObjectContents; Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; - procedure ValueFromField(OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; Field: IBoldField; ColumnIndex: Integer); override; + procedure ValueToParam(const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); override; + procedure ValueFromField(OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; const Field: IBoldField; ColumnIndex: Integer); override; class function CanStore(const ContentName: string): Boolean; override; end; @@ -66,8 +69,8 @@ class function TBoldPMWideString.CanStore(const ContentName: string): Boolean; end; function TBoldPMWideString.CompareField( - ObjectContent: IBoldObjectContents; Field: IBoldField; - ColumnIndex: integer; ValueSpace: IBoldValueSpace; + const ObjectContent: IBoldObjectContents; const Field: IBoldField; + ColumnIndex: integer; const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList): Boolean; var aWideString: IBoldWideStringContent; @@ -97,9 +100,9 @@ function TBoldPMWideString.GetColumnTypeAsSQL(ColumnIndex: Integer): string; end; procedure TBoldPMWideString.ValueFromField( - OwningObjectId: TBoldObjectId; ObjectContent: IBoldObjectContents; - ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; - Field: IBoldField; ColumnIndex: Integer); + OwningObjectId: TBoldObjectId; const ObjectContent: IBoldObjectContents; + const ValueSpace: IBoldValueSpace; TranslationList: TBoldIdTranslationList; + const Field: IBoldField; ColumnIndex: Integer); var aWideString: IBoldWideStringContent; begin @@ -117,7 +120,7 @@ procedure TBoldPMWideString.ValueFromField( end; procedure TBoldPMWideString.ValueToParam( - ObjectContent: IBoldObjectContents; Param: IBoldParameter; + const ObjectContent: IBoldObjectContents; const Param: IBoldParameter; ColumnIndex: Integer; TranslationList: TBoldIdTranslationList); var aWideString: IBoldWideStringContent; diff --git a/Source/Samples/Unicode/BoldWideStringControlPack.pas b/Source/Samples/Unicode/BoldWideStringControlPack.pas index 4af19a92..2f22e71c 100644 --- a/Source/Samples/Unicode/BoldWideStringControlPack.pas +++ b/Source/Samples/Unicode/BoldWideStringControlPack.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWideStringControlPack; {$UNDEF BOLDCOMCLIENT} @@ -59,6 +62,7 @@ TBoldAsWideStringRenderer = class(TBoldSingleRenderer) function GetAsWideStringAndSubscribe(Element: TBoldElement; FollowerController: TBoldWideStringFollowerController; Subscriber: TBoldSubscriber): WideString; virtual; procedure SetAsWideString(Element: TBoldElement; Value: WideString; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); virtual; procedure DrawOnCanvas(Follower: TBoldFollower; Canvas: TCanvas; Rect: TRect; Alignment: TAlignment; Margins: TPoint); override; + function HasSetValueEventOverrides: boolean; override; public class function DefaultRenderer: TBoldAsWideStringRenderer; class procedure DrawWideStringOnCanvas(Canvas: TCanvas; Rect: TRect; Alignment: TAlignment; Margins: TPoint; S: WideString); @@ -72,7 +76,7 @@ TBoldAsWideStringRenderer = class(TBoldSingleRenderer) function IsChanged(RendererData: TBoldWideStringRendererData; NewValue: WideString; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; procedure SetFont(Element: TBoldElement; EffectiveFont, Font: TFont; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); procedure SetColor(Element: TBoldElement; var EffectiveColor: TColor; Color: TColor; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList); - procedure MakeUptodateAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldFollowerController; Subscriber: TBoldSubscriber); override; + procedure MakeUpToDateAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldFollowerController; Subscriber: TBoldSubscriber); override; procedure MultiMakeUpToDateAndSubscribe(Elements: TBoldClientableList; Subscribers: TBoldObjectArray; RendererData: TBoldObjectArray; FollowerController: TBoldFollowerController); procedure DefaultMakeUptodateAndSetMayModifyAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldWideStringFollowerController; Subscriber: TBoldSubscriber); virtual; published @@ -97,7 +101,7 @@ TBoldWideStringFollowerController = class(TBoldSingleFollowerController) function GetSupportsMultiEnsure: Boolean; override; function GetEffectiveRenderer: TBoldRenderer; override; property EffectiveAsWideStringRenderer: TBoldAsWideStringRenderer read GetEffectiveAsWideStringRenderer; - procedure DoMultiMakeUptodateAndSubscribe(Followers: TBoldObjectArray); override; + procedure DoMultiMakeUptodateAndSubscribe(Followers: TBoldFollowerArray); override; public procedure MakeClean(Follower: TBoldFollower); override; function GetCurrentAsWideString(Follower: TBoldFollower): WideString; @@ -121,7 +125,8 @@ implementation {$IFNDEF BOLDCOMCLIENT} BoldSystem, {$ENDIF} - Variants; + Variants, + BoldRev; var DefaultAsWideStringRenderer: TBoldAsWideStringRenderer; @@ -194,7 +199,7 @@ procedure TBoldWideStringFollowerController.MakeClean(Follower: TBoldFollower); begin if ValidateWideString(GetCurrentAsWideString(Follower), Follower) then begin - ReleaseChangedValue(Follower); // note, must do first, since set can change element + ReleaseChangedValue(Follower); SetAsWideString(GetCurrentAsWideString(Follower), Follower); end else @@ -213,7 +218,6 @@ procedure TBoldWideStringFollowerController.DoMakeUptodateAndSubscribe(Follower: Renderer := EffectiveRenderer as TBoldAsWideStringRenderer; if Assigned(Renderer.OnGetAsWideString) or Assigned(Renderer.OnSubscribe) or Assigned(Renderer.OnMayModify) then begin Renderer.MakeUptodateAndSubscribe(Follower.Element, Follower.RendererData, Self, Subscriber); - Follower.RendererData.MayModify := Renderer.MayModify(Follower.Element, Representation, Expression, GetVariableListAndSubscribe(follower.Subscriber), Follower.Subscriber); end else renderer.DefaultMakeUptodateAndSetMayModifyAndSubscribe(Follower.Element, Follower.RendererData, Self, Subscriber); end; @@ -232,7 +236,6 @@ procedure TBoldWideStringFollowerController.SetNilWideStringRepresentation(const var Left: Integer; begin - // Adjust for alignment case Alignment of taLeftJustify: Left := Margins.X + Rect.Left; taRightJustify: Left := (Rect.Right - Rect.Left) - Canvas.TextWidth(S) + Rect.Left - 1 - Margins.X; @@ -258,7 +261,7 @@ procedure TBoldAsWideStringRenderer.MakeUpToDateAndSubscribe(Element: TBoldEleme procedure TBoldAsWideStringRenderer.DefaultMakeUptodateAndSetMayModifyAndSubscribe(Element: TBoldElement; RendererData: TBoldRendererData; FollowerController: TBoldWideStringFollowerController; Subscriber: TBoldSubscriber); var - {$IFDEF BOLDCOMCLIENT} // defaultMakeUpToDate + {$IFDEF BOLDCOMCLIENT} e: IBoldElement; {$ELSE} E: TBoldIndirectElement; @@ -272,20 +275,18 @@ procedure TBoldAsWideStringRenderer.DefaultMakeUptodateAndSetMayModifyAndSubscri S := '('+Name+')' else S := '('+ClassName+')'; - RendererData.MayModify := False; end else begin if Assigned(Element) then begin - {$IFDEF BOLDCOMCLIENT} // defaultMakeUpToDate + {$IFDEF BOLDCOMCLIENT} e := Element.EvaluateAndSubscribeToExpression(FollowerController.Expression, Subscriber.ClientId, Subscriber.SubscriberId, False, false); if Assigned(E) then begin S := E.WideStringRepresentation[FollowerController.Representation]; if Assigned(Subscriber) then E.SubscribeToWideStringRepresentation(FollowerController.Representation, Subscriber.ClientId, Subscriber.SubscriberId, breReEvaluate, false); - RendererData.MayModify := true; end else S := FollowerController.NilWideStringRepresentation @@ -298,7 +299,6 @@ procedure TBoldAsWideStringRenderer.DefaultMakeUptodateAndSetMayModifyAndSubscri s := FollowerController.NilWideStringRepresentation; if Assigned(Subscriber) then E.Value.SubscribeToStringRepresentation(FollowerController.Representation, Subscriber, breReEvaluate); - RendererData.MayModify := E.Value.ObserverMayModifyAsString(FollowerController.Representation, Subscriber); (RendererData as TBoldWideStringRendererData).MaxWideStringLength := -1; end else if Assigned(E.Value) then @@ -309,7 +309,6 @@ procedure TBoldAsWideStringRenderer.DefaultMakeUptodateAndSetMayModifyAndSubscri S := E.Value.StringRepresentation[FollowerController.Representation]; if Assigned(Subscriber) then E.Value.SubscribeToStringRepresentation(FollowerController.Representation, Subscriber, breReEvaluate); - RendererData.MayModify := E.Value.ObserverMayModifyAsString(FollowerController.Representation, Subscriber); if (E.Value is TBoldAttribute) and assigned((E.Value as TBoldAttribute).BoldAttributeRTInfo) then (RendererData as TBoldWideStringRendererData).MaxWideStringLength := (E.Value as TBoldAttribute).BoldAttributeRTInfo.Length else @@ -336,7 +335,7 @@ function TBoldAsWideStringRenderer.GetRendererDataClass: TBoldRendererDataClass; function TBoldAsWideStringRenderer.DefaultGetAsWideStringAndSubscribe(Element: TBoldElement; FollowerController: TBoldWideStringFollowerController; Subscriber: TBoldSubscriber): WideString; var - {$IFDEF BOLDCOMCLIENT} // DefaultGet + {$IFDEF BOLDCOMCLIENT} e: IBoldElement; {$ELSE} E: TBoldIndirectElement; @@ -354,7 +353,7 @@ function TBoldAsWideStringRenderer.DefaultGetAsWideStringAndSubscribe(Element: T begin if Assigned(Element) then begin - {$IFDEF BOLDCOMCLIENT} // defaultGet + {$IFDEF BOLDCOMCLIENT} e := Element.EvaluateAndSubscribeToExpression(FollowerController.Expression, Subscriber.ClientId, Subscriber.SubscriberId, False, false); if Assigned(E) then begin @@ -414,7 +413,7 @@ function TBoldAsWideStringRenderer.DefaultValidateCharacter(Element: TBoldElemen if Assigned(ValueElement) then Result := ValueElement.ValidateCharacter(C, Representation) else - Result := False; + Result := HasSetValueEventOverrides; end; function TBoldAsWideStringRenderer.DefaultValidateWideString(Element: TBoldElement; Value: WideString; Representation: TBoldRepresentation; Expression: TBoldExpression; VariableList: TBoldExternalVariableList): Boolean; @@ -430,7 +429,7 @@ function TBoldAsWideStringRenderer.DefaultValidateWideString(Element: TBoldEleme Result := ValueElement.ValidateString(Value, Representation) end else - Result := False; + Result := HasSetValueEventOverrides; end; function TBoldAsWideStringRenderer.GetAsWideStringAndSubscribe(Element: TBoldElement; FollowerController: TBoldWideStringFollowerController; Subscriber: TBoldSubscriber): WideString; @@ -520,6 +519,11 @@ function TBoldAsWideStringRenderer.GetSupportsMulti: Boolean; {$ENDIF} end; +function TBoldAsWideStringRenderer.HasSetValueEventOverrides: boolean; +begin + result := Assigned(FOnSetAsWideString); +end; + function TBoldWideStringFollowerController.GetSupportsMultiEnsure: Boolean; begin {$IFDEF BOLDCOMCLIENT} @@ -531,30 +535,28 @@ function TBoldWideStringFollowerController.GetSupportsMultiEnsure: Boolean; end; procedure TBoldWideStringFollowerController.DoMultiMakeUptodateAndSubscribe( - Followers: TBoldObjectArray); + Followers: TBoldFollowerArray); var Renderer: TBoldAsWideStringRenderer; Elements: TBoldClientableList; Subscribers: TBoldObjectArray; RendererData: TBoldObjectArray; - I: integer; - MaxIndex: integer; + F: TBoldFollower; begin Assert(SupportsMulti); - MaxIndex := Followers.Count - 1; Renderer := EffectiveRenderer as TBoldAsWideStringRenderer; - Elements := TBoldClientableList.Create(MaxIndex,[]); - Subscribers := TBoldObjectArray.Create(MaxIndex,[]); - RendererData := TBoldObjectArray.Create(MaxIndex,[]); + Elements := TBoldClientableList.Create(Length(Followers),[]); + Subscribers := TBoldObjectArray.Create(Length(Followers),[]); + RendererData := TBoldObjectArray.Create(Length(Followers),[]); try - for I := 0 to MaxIndex do + for F in Followers do begin - Elements.Add(TBoldFollower(Followers[I]).Element); - if TBoldFollower(Followers[I]).State in bfdNeedResubscribe then - Subscribers.Add(Followers[i]) + Elements.Add(F.Element); + if F.State in bfdNeedResubscribe then + Subscribers.Add(F) else Subscribers.Add(nil); - RendererData.Add(TBoldFollower(Followers[I]).RendererData); + RendererData.Add(F.RendererData); end; Renderer.MultiMakeUpToDateAndSubscribe(Elements, Subscribers, RendererData, Self); finally @@ -620,4 +622,3 @@ finalization FreeAndNil(DefaultAsWideStringRenderer); end. - diff --git a/Source/Samples/Unicode/BoldWideStringInterface.pas b/Source/Samples/Unicode/BoldWideStringInterface.pas index b755bc62..4ca0a358 100644 --- a/Source/Samples/Unicode/BoldWideStringInterface.pas +++ b/Source/Samples/Unicode/BoldWideStringInterface.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldWideStringInterface; interface @@ -34,7 +37,7 @@ TBFSWideString = class(TBoldFreeStandingNullableValue, IBoldWideStringContent) procedure SetContentAsWideString(NewValue: WideString); protected function GetStreamName: string; override; - procedure AssignContentValue(Source: IBoldValue); override; + procedure AssignContentValue(const Source: IBoldValue); override; public property asString: String read GetContentAsString write SetContentAsString; property asWideString: WideString read GetContentAsWideString write SetContentAsWideString; @@ -47,7 +50,10 @@ implementation uses { RTL / VCL } - SysUtils; + SysUtils, + + { Bold } + BoldRev; {******************************************************************************} {* TBFSUnicodeString *} @@ -61,7 +67,7 @@ function TBFSWideString.GetStreamName: String; {* Content management *********************************************************} -procedure TBFSWideString.AssignContentValue(Source: IBoldValue); +procedure TBFSWideString.AssignContentValue(const Source: IBoldValue); var U: IBoldWideStringContent; S: IBoldStringContent; @@ -103,5 +109,5 @@ procedure TBFSWideString.SetContentAsWideString(NewValue: WideString); initialization with FreeStandingValueFactory do RegisterFreeStandingClass(BoldContentName_WideString, TBFSWideString); - + end. diff --git a/Source/SearchPath.txt b/Source/SearchPath.txt new file mode 100644 index 00000000..bab5eb1b --- /dev/null +++ b/Source/SearchPath.txt @@ -0,0 +1 @@ +$(BoldDelphi)\Source\BoldAwareGUI;$(BoldDelphi)\Source\BoldQAwareGUI;$(BoldDelphi)\Source\ClientGuiCom;$(BoldDelphi)\Source\ClientHandlesCom;$(BoldDelphi)\Source\Common;$(BoldDelphi)\Source\ConcurrencyControl;$(BoldDelphi)\Source\Extensions;$(BoldDelphi)\Source\FreestandingValueSpace;$(BoldDelphi)\Source\Handles;$(BoldDelphi)\Source\MoldModel;$(BoldDelphi)\Source\ObjectSpace;$(BoldDelphi)\Source\Persistence;$(BoldDelphi)\Source\PMapper;$(BoldDelphi)\Source\Propagator;$(BoldDelphi)\Source\Samples;$(BoldDelphi)\Source\UMLModel;$(BoldDelphi)\Source\Unassigned;$(BoldDelphi)\Source\ValueSpace;$(BoldDelphi)\Source\BoldAwareGUI\Actions;$(BoldDelphi)\Source\BoldAwareGUI\BoldControls;$(BoldDelphi)\Source\BoldAwareGUI\ControlPacks;$(BoldDelphi)\Source\BoldAwareGUI\Core;$(BoldDelphi)\Source\BoldAwareGUI\FormGen;$(BoldDelphi)\Source\BoldAwareGUI\IDE;$(BoldDelphi)\Source\BoldQAwareGUI\BoldControls;$(BoldDelphi)\Source\BoldQAwareGUI\ControlPacks;$(BoldDelphi)\Source\BoldQAwareGUI\Core;$(BoldDelphi)\Source\ClientGuiCom\BoldControls;$(BoldDelphi)\Source\ClientGuiCom\ControlPacks;$(BoldDelphi)\Source\ClientGuiCom\Core;$(BoldDelphi)\Source\ClientGuiCom\IDE;$(BoldDelphi)\Source\ClientHandlesCom\Core;$(BoldDelphi)\Source\ClientHandlesCom\IDE;$(BoldDelphi)\Source\Common\COM;$(BoldDelphi)\Source\Common\Connection;$(BoldDelphi)\Source\Common\ConnectionCOM;$(BoldDelphi)\Source\Common\ConnectionHandles;$(BoldDelphi)\Source\Common\ConnectionHandlesCOM;$(BoldDelphi)\Source\Common\Core;$(BoldDelphi)\Source\Common\Environment;$(BoldDelphi)\Source\Common\Handles;$(BoldDelphi)\Source\Common\HTTP;$(BoldDelphi)\Source\Common\IDE;$(BoldDelphi)\Source\Common\IDECOM;$(BoldDelphi)\Source\Common\Include;$(BoldDelphi)\Source\Common\Logging;$(BoldDelphi)\Source\Common\MsXml;$(BoldDelphi)\Source\Common\Queue;$(BoldDelphi)\Source\Common\Rose2000;$(BoldDelphi)\Source\Common\Rose98;$(BoldDelphi)\Source\Common\SOAP;$(BoldDelphi)\Source\Common\Subscription;$(BoldDelphi)\Source\Common\Support;$(BoldDelphi)\Source\Common\SupportWin;$(BoldDelphi)\Source\Common\TaggedValues;$(BoldDelphi)\Source\Common\Template;$(BoldDelphi)\Source\Common\UML;$(BoldDelphi)\Source\Common\UtilsGUI;$(BoldDelphi)\Source\ConcurrencyControl\COM;$(BoldDelphi)\Source\ConcurrencyControl\Common;$(BoldDelphi)\Source\ConcurrencyControl\IDECOM;$(BoldDelphi)\Source\Extensions\OLLE;$(BoldDelphi)\Source\Extensions\OLLE\Core;$(BoldDelphi)\Source\Extensions\OLLE\IDE;$(BoldDelphi)\Source\FreestandingValueSpace\Core;$(BoldDelphi)\Source\Handles\Actions;$(BoldDelphi)\Source\Handles\COM;$(BoldDelphi)\Source\Handles\Core;$(BoldDelphi)\Source\Handles\IDE;$(BoldDelphi)\Source\Handles\IDECOM;$(BoldDelphi)\Source\Handles\Manipulators;$(BoldDelphi)\Source\Handles\PessimisticLocking;$(BoldDelphi)\Source\Handles\UnLoader;$(BoldDelphi)\Source\Handles\XML;$(BoldDelphi)\Source\MoldModel\Bld;$(BoldDelphi)\Source\MoldModel\CodeGenerator;$(BoldDelphi)\Source\MoldModel\Core;$(BoldDelphi)\Source\MoldModel\Handles;$(BoldDelphi)\Source\MoldModel\IDE;$(BoldDelphi)\Source\MoldModel\TypeNameDictionary;$(BoldDelphi)\Source\MoldModel\UtilsGUI;$(BoldDelphi)\Source\ObjectSpace\BORepresentation;$(BoldDelphi)\Source\ObjectSpace\COM;$(BoldDelphi)\Source\ObjectSpace\Core;$(BoldDelphi)\Source\ObjectSpace\IDE;$(BoldDelphi)\Source\ObjectSpace\Interfaces;$(BoldDelphi)\Source\ObjectSpace\Ocl;$(BoldDelphi)\Source\ObjectSpace\PessimisticLocking;$(BoldDelphi)\Source\ObjectSpace\RTModel;$(BoldDelphi)\Source\ObjectSpace\Undo;$(BoldDelphi)\Source\ObjectSpace\Unloader;$(BoldDelphi)\Source\ObjectSpace\UtilsGUI;$(BoldDelphi)\Source\ObjectSpace\IDE\AttributeWizard;$(BoldDelphi)\Source\Persistence\ADO;$(BoldDelphi)\Source\Persistence\Advantage;$(BoldDelphi)\Source\Persistence\BDE;$(BoldDelphi)\Source\Persistence\COM;$(BoldDelphi)\Source\Persistence\Core;$(BoldDelphi)\Source\Persistence\DB;$(BoldDelphi)\Source\Persistence\DBExpress;$(BoldDelphi)\Source\Persistence\DBISAM;$(BoldDelphi)\Source\Persistence\DOA;$(BoldDelphi)\Source\Persistence\ExternalPersistence;$(BoldDelphi)\Source\Persistence\File;$(BoldDelphi)\Source\Persistence\FireDAC;$(BoldDelphi)\Source\Persistence\HTTP;$(BoldDelphi)\Source\Persistence\IBX;$(BoldDelphi)\Source\Persistence\IDE;$(BoldDelphi)\Source\Persistence\IDECOM;$(BoldDelphi)\Source\Persistence\IDEUDP;$(BoldDelphi)\Source\Persistence\ObjectUpgrading;$(BoldDelphi)\Source\Persistence\Propagation;$(BoldDelphi)\Source\Persistence\SOAP;$(BoldDelphi)\Source\Persistence\SQLDirect;$(BoldDelphi)\Source\Persistence\System;$(BoldDelphi)\Source\Persistence\UDPPropagator;$(BoldDelphi)\Source\Persistence\UniDAC;$(BoldDelphi)\Source\PMapper\Core;$(BoldDelphi)\Source\PMapper\DbEvolutor;$(BoldDelphi)\Source\PMapper\Default;$(BoldDelphi)\Source\PMapper\SQL;$(BoldDelphi)\Source\PMapper\Validator;$(BoldDelphi)\Source\Propagator\COM;$(BoldDelphi)\Source\Propagator\Common;$(BoldDelphi)\Source\Propagator\Enterprise;$(BoldDelphi)\Source\Propagator\IDECOM;$(BoldDelphi)\Source\Propagator\LowEnd;$(BoldDelphi)\Source\Samples\Actions;$(BoldDelphi)\Source\Samples\BoldCheckListBox;$(BoldDelphi)\Source\Samples\ConstraintValidator;$(BoldDelphi)\Source\Samples\FormSaver;$(BoldDelphi)\Source\Samples\IDE;$(BoldDelphi)\Source\Samples\Misc;$(BoldDelphi)\Source\Samples\ModelLoader;$(BoldDelphi)\Source\Samples\NewObjectInterceptor;$(BoldDelphi)\Source\Samples\SortingGrid;$(BoldDelphi)\Source\Samples\SystemComparer;$(BoldDelphi)\Source\Samples\SystemDebugger;$(BoldDelphi)\Source\Samples\UMLPlugins;$(BoldDelphi)\Source\Samples\Unicode;$(BoldDelphi)\Source\UMLModel\Core;$(BoldDelphi)\Source\UMLModel\Editor;$(BoldDelphi)\Source\UMLModel\Handles;$(BoldDelphi)\Source\UMLModel\Ide;$(BoldDelphi)\Source\UMLModel\ModelLinks;$(BoldDelphi)\Source\UMLModel\Plugins;$(BoldDelphi)\Source\UMLModel\ModelLinks\Bld;$(BoldDelphi)\Source\UMLModel\ModelLinks\Core;$(BoldDelphi)\Source\UMLModel\ModelLinks\ModelMaker;$(BoldDelphi)\Source\UMLModel\ModelLinks\Rose98;$(BoldDelphi)\Source\UMLModel\ModelLinks\XMI;$(BoldDelphi)\Source\UMLModel\ModelLinks\ModelMaker\Link;$(BoldDelphi)\Source\UMLModel\ModelLinks\ModelMaker\MMPlugin;$(BoldDelphi)\Source\UMLModel\ModelLinks\ModelMaker\Support;$(BoldDelphi)\Source\ValueSpace\Condition;$(BoldDelphi)\Source\ValueSpace\ExternalEvents;$(BoldDelphi)\Source\ValueSpace\Id;$(BoldDelphi)\Source\ValueSpace\Interfaces;$(BoldDelphi)\Source\ValueSpace\XMLStreaming; \ No newline at end of file diff --git a/Source/UMLModel/Core/BoldUMLAbstractModelValidator.pas b/Source/UMLModel/Core/BoldUMLAbstractModelValidator.pas index 1e7f7e47..9280ddf3 100644 --- a/Source/UMLModel/Core/BoldUMLAbstractModelValidator.pas +++ b/Source/UMLModel/Core/BoldUMLAbstractModelValidator.pas @@ -1,8 +1,12 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLAbstractModelValidator; interface uses + BoldModel, BoldUMLAttributes, BoldUMLModel, BoldSQLDatabaseConfig; @@ -14,9 +18,10 @@ TBoldUMLAbstractModelValidator = class private fSQLDataBaseConfig: TBoldSQLDataBaseConfig; fLanguage: TBoldModelValidatorSourceLanguage; - fUMLModel: TUMLModel; + fBoldModel: TBoldModel; function GetValidator: TValidator; - procedure AddViolation(severity: TSeverity; description: String; element: TUMLModelElement); + procedure AddViolation(severity: TSeverity; const description: String; element: TUMLModelElement); + function GetUMLModel: TUMLModel; protected procedure AddError(description: String; args: array of const; element: TUMLModelElement); procedure AddHint(description: String; args: array of const; element: TUMLModelElement); @@ -25,8 +30,9 @@ TBoldUMLAbstractModelValidator = class property SQLDataBaseConfig: TBoldSQLDataBaseConfig read fSQLDataBaseConfig; property Language: TBoldModelValidatorSourceLanguage read fLanguage; public - constructor Create(UMLModel: TUMLModel; SQLDataBaseConfig: TBoldSQLDataBaseConfig = nil; const Language: TBoldModelValidatorSourceLanguage = mvslNone); - property UMLModel: TUMLModel read fUMLModel; + constructor Create(ABoldModel: TBoldModel; SQLDataBaseConfig: TBoldSQLDataBaseConfig = nil; const Language: TBoldModelValidatorSourceLanguage = mvslNone); + property UMLModel: TUMLModel read GetUMLModel; + property BoldModel: TBoldModel read fBoldModel; property Validator: TValidator read GetValidator; function HighestSeverity: TSeverity; end; @@ -39,11 +45,12 @@ TBoldUMLAbstractModelValidator = class BoldDefaultValidatorSourceLanguage = mvslCpp; {$ENDIF} - implementation uses - SysUtils; + SysUtils, + BoldDefs, + BoldRev; procedure TBoldUMLAbstractModelValidator.AddError(description: String; args: array of const; element: TUMLModelElement); begin @@ -60,7 +67,7 @@ procedure TBoldUMLAbstractModelValidator.AddHint(description: String; args: arra AddViolation(sHint, format(description, args), element); end; -procedure TBoldUMLAbstractModelValidator.AddViolation(severity: TSeverity; description: String; element: TUMLModelElement); +procedure TBoldUMLAbstractModelValidator.AddViolation(severity: TSeverity; const description: String; element: TUMLModelElement); var v : TViolation; begin @@ -78,14 +85,22 @@ procedure TBoldUMLAbstractModelValidator.ClearViolations; Validator.Violation[i].Delete end; -constructor TBoldUMLAbstractModelValidator.Create(UMLModel: TUMLModel; SQLDataBaseConfig: TBoldSQLDataBaseConfig; const Language: TBoldModelValidatorSourceLanguage); +constructor TBoldUMLAbstractModelValidator.Create(ABoldModel: TBoldModel; SQLDataBaseConfig: TBoldSQLDataBaseConfig; const Language: TBoldModelValidatorSourceLanguage); begin inherited Create; fSQLDataBaseConfig := SQLDataBaseConfig; - fUMLModel := UMLModel; + fBoldModel := ABoldModel; fLanguage := Language; end; +function TBoldUMLAbstractModelValidator.GetUMLModel: TUMLModel; +begin + if Assigned(BoldModel) then + result := BoldModel.EnsuredUMLModel + else + result := nil; +end; + function TBoldUMLAbstractModelValidator.GetValidator: TValidator; begin result := UMLModel.Validator; @@ -101,4 +116,6 @@ function TBoldUMLAbstractModelValidator.HighestSeverity: TSeverity; result := Validator.violation[i].Severity; end; +initialization + end. diff --git a/Source/UMLModel/Core/BoldUMLAttributes.pas b/Source/UMLModel/Core/BoldUMLAttributes.pas index 5d230366..f23eb1e5 100644 --- a/Source/UMLModel/Core/BoldUMLAttributes.pas +++ b/Source/UMLModel/Core/BoldUMLAttributes.pas @@ -1,9 +1,12 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLAttributes; interface uses - Classes, + Classes, BoldAttributes, BoldDefs, BoldUMLTypes; @@ -17,17 +20,19 @@ TBAChangeableKind = class(TBAValueSet) function GetAsChangeableKind: TChangeableKind; procedure SetAsChangeableKind(ChangeableKind: TChangeableKind); protected - function GetValues: TBAValueSetValueList; override; + class function GetValues: TBAValueSetValueList; override; public property AsChangeableKind: TChangeableKind read GetAsChangeableKind write SetAsChangeableKind; end; + + TBAVisibilityKind = class(TBAValueSet) private function GetAsVisibilityKind: TVisibilityKind; procedure SetAsVisibilityKind(VisibilityKind: TVisibilityKind); protected - function GetValues: TBAValueSetValueList; override; + class function GetValues: TBAValueSetValueList; override; public property AsVisibilityKind: TVisibilityKind read GetAsVisibilityKind write SetAsVisibilityKind; end; @@ -37,7 +42,7 @@ TBAAggregationKind = class(TBAValueSet) function GetAsAggregationKind: TAggregationKind; procedure SetAsAggregationKind(AggregationKind: TAggregationKind); protected - function GetValues: TBAValueSetValueList; override; + class function GetValues: TBAValueSetValueList; override; public property AsAggregationKind: TAggregationKind read GetAsAggregationKind write SetAsAggregationKind; end; @@ -47,7 +52,7 @@ TBAScopeKind = class(TBAValueSet) function getAsScopeKind: TScopeKind; procedure setAsScopeKind(ScopeKind: TScopeKind); protected - function GetValues: TBAValueSetValueList; override; + class function GetValues: TBAValueSetValueList; override; public property AsScopeKind: TScopeKind read getAsScopeKind write setAsScopeKind; end; @@ -57,7 +62,7 @@ TBAParameterDirectionKind = class(TBAValueSet) function getAsParameterDirectionKind: TBoldParameterDirectionKind; procedure setAsParameterDirectionKind(ParameterDirectionKind: TBoldParameterDirectionKind); protected - function GetValues: TBAValueSetValueList; override; + class function GetValues: TBAValueSetValueList; override; public property AsParameterDirectionKInd: TBoldParameterDirectionKind read getAsParameterDirectionKind write setAsParameterDirectionKind; end; @@ -67,7 +72,7 @@ TBASeverity = class(TBAValueSet) function getAsSeverity: TSeverity; procedure setAsSeverity(Severity: TSeverity); protected - function GetValues: TBAValueSetValueList; override; + class function GetValues: TBAValueSetValueList; override; public property AsSeverity: TSeverity read getAsSeverity write setAsSeverity; end; @@ -77,7 +82,7 @@ TBAOrderingKind = class(TBAValueSet) function getAsOrderingKind: TOrderingKind; procedure setAsOrderingKind(OrderingKind: TOrderingKind); protected - function GetValues: TBAValueSetValueList; override; + class function GetValues: TBAValueSetValueList; override; public property AsOrderingKind: TOrderingKind read getAsOrderingKind write setAsOrderingKind; end; @@ -87,7 +92,7 @@ TBAPseudostateKind = class(TBAValueSet) function getAsPseudostateKind: TPseudostateKind; procedure setAsPseudostateKind(PseudostateKind: TPseudostateKind); protected - function GetValues: TBAValueSetValueList; override; + class function GetValues: TBAValueSetValueList; override; public property AsPseudostateKind: TPseudostateKind read getAsPseudostateKind write setAsPseudostateKind; end; @@ -97,7 +102,7 @@ TBACallConcurrencyKind = class(TBAValueSet) function getAsCallConcurrencyKind: TCallConcurrencyKind; procedure setAsCallConcurrencyKind(CallConcurrencyKind: TCallConcurrencyKind); protected - function GetValues: TBAValueSetValueList; override; + class function GetValues: TBAValueSetValueList; override; public property AsCallConcurrencyKind: TCallConcurrencyKind read getAsCallConcurrencyKind write setAsCallConcurrencyKind; end; @@ -107,7 +112,7 @@ TBAMessageDirectionKind = class(TBAValueSet) function getAsMessageDirectionKind: TMessageDirectionKind; procedure setAsMessageDirectionKind(MessageDirectionKind: TMessageDirectionKind); protected - function GetValues: TBAValueSetValueList; override; + class function GetValues: TBAValueSetValueList; override; public property AsMessageDirectionKind: TMessageDirectionKind read getAsMessageDirectionKind write setAsMessageDirectionKind; end; @@ -116,7 +121,6 @@ implementation uses SysUtils, - UMLConsts, BoldMemberTypeDictionary; var @@ -132,13 +136,13 @@ implementation _MessageDirectionKindValues: TBAValueSetValueList; -function TBAScopeKind.GetValues: TBAValueSetValueList; +class function TBAScopeKind.GetValues: TBAValueSetValueList; begin if not Assigned(_ScopeKindValues) then begin _ScopeKindValues := TBAValueSetValueList.Create; - _ScopeKindValues.Add(1, ['instance']); // do not localize - _ScopeKindValues.Add(2, ['classifier']); // do not localize + _ScopeKindValues.Add(1, ['instance']); + _ScopeKindValues.Add(2, ['classifier']); end; Result := _ScopeKindValues; end; @@ -148,7 +152,7 @@ function TBAScopeKind.getAsScopeKind: TScopeKind; case AsInteger of 1: result := skInstance; 2: result := skClassifier; - else raise EBold.CreateFmt(sWrongValue, [ClassName, 'GetAsScopeKind']); // do not localize + else raise EBold.Create('TBAScopeKind.GetAsScopeKind: Wrong value.'); end; end; @@ -160,15 +164,15 @@ procedure TBAScopeKind.setAsScopeKind(ScopeKind: TScopeKind); end; end; -function TBAParameterDirectionKind.GetValues: TBAValueSetValueList; +class function TBAParameterDirectionKind.GetValues: TBAValueSetValueList; begin if not Assigned(_ParameterDirectionKindValues) then begin _ParameterDirectionKindValues := TBAValueSetValueList.Create; - _ParameterDirectionKindValues.Add(1, ['in']); // do not localize - _ParameterDirectionKindValues.Add(2, ['out']); // do not localize - _ParameterDirectionKindValues.Add(3, ['inout']); // do not localize - _ParameterDirectionKindValues.Add(4, ['return']); // do not localize + _ParameterDirectionKindValues.Add(1, ['in']); + _ParameterDirectionKindValues.Add(2, ['out']); + _ParameterDirectionKindValues.Add(3, ['inout']); + _ParameterDirectionKindValues.Add(4, ['return']); end; Result := _ParameterDirectionKindValues; end; @@ -180,7 +184,7 @@ function TBAParameterDirectionKind.getAsParameterDirectionKind: TBoldParameterDi 2: result := pdOut; 3: Result := pdInout; 4: Result := pdReturn; - else raise EBold.CreateFmt(sWrongValue, [ClassName, 'getAsParameterDirectionKind']); // do not localize + else raise EBold.Create('TBAParameterDirectionKind.GetAsParameterDirectionKind: Wrong value.'); end; end; @@ -194,15 +198,16 @@ procedure TBAParameterDirectionKind.setAsParameterDirectionKind(ParameterDirecti end; end; -function TBASeverity.GetValues: TBAValueSetValueList; + +class function TBASeverity.GetValues: TBAValueSetValueList; begin if not Assigned(_SeverityValues) then begin _SeverityValues := TBAValueSetValueList.Create; - _SeverityValues.Add(0, ['None']); // do not localize - _SeverityValues.Add(1, ['Hint']); // do not localize - _SeverityValues.Add(2, ['Warning']); // do not localize - _SeverityValues.Add(3, ['Error']); // do not localize + _SeverityValues.Add(0, ['None']); + _SeverityValues.Add(1, ['Hint']); + _SeverityValues.Add(2, ['Warning']); + _SeverityValues.Add(3, ['Error']); end; Result := _SeverityValues; end; @@ -214,7 +219,7 @@ function TBASeverity.getAsSeverity: TSeverity; 1: Result := sHint; 2: result := sWarning; 3: result := sError; - else raise EBold.CreateFmt(sWrongValue, [ClassName, 'getAsSeverity']); // do not localize + else raise EBold.Create('TBASeverity.GetAsSeverity: Wrong value.'); end; end; @@ -236,18 +241,18 @@ function TBAAggregationKind.GetAsAggregationKind: TAggregationKind; 1: Result := akNone; 2: Result := akAggregate; 3: Result := akComposite; - else raise EBold.CreateFmt(sWrongValue, [ClassName, 'GetAsAggregationKind']); // do not localize + else raise EBold.Create('TBAAggregationKind.GetAsAggregationKind: Wrong value.'); end; end; -function TBAAggregationKind.GetValues: TBAValueSetValueList; +class function TBAAggregationKind.GetValues: TBAValueSetValueList; begin if not Assigned(_AggregationKindValues) then begin _AggregationKindValues := TBAValueSetValueList.Create; - _AggregationKindValues.Add(1, ['none']); // do not localize - _AggregationKindValues.Add(2, ['aggregate']); // do not localize - _AggregationKindValues.Add(3, ['composite']); // do not localize + _AggregationKindValues.Add(1, ['none']); + _AggregationKindValues.Add(2, ['aggregate']); + _AggregationKindValues.Add(3, ['composite']); end; Result := _AggregationKindValues; end; @@ -270,18 +275,18 @@ function TBAVisibilityKind.GetAsVisibilityKind: TVisibilityKind; 1: Result := vkPrivate; 2: Result := vkProtected; 3: Result := vkPublic; - else raise EBold.CreateFmt(sWrongValue, [ClassName, 'GetAsVisibilityKind']); // do not localize + else raise EBold.Create('TBAVisibilityKind.GetAsVisibilityKind: Wrong value.'); end; end; -function TBAVisibilityKind.GetValues: TBAValueSetValueList; +class function TBAVisibilityKind.GetValues: TBAValueSetValueList; begin if not Assigned(_VisibilityKindValues) then begin _VisibilityKindValues := TBAValueSetValueList.Create; - _VisibilityKindValues.Add(1, ['private']); // do not localize - _VisibilityKindValues.Add(2, ['protected']); // do not localize - _VisibilityKindValues.Add(3, ['public']); // do not localize + _VisibilityKindValues.Add(1, ['private']); + _VisibilityKindValues.Add(2, ['protected']); + _VisibilityKindValues.Add(3, ['public']); end; Result := _VisibilityKindValues; end; @@ -303,18 +308,18 @@ function TBAChangeableKind.GetAsChangeableKind: TChangeableKind; 1: Result := ckChangeable; 2: Result := ckFrozen; 3: Result := ckAddOnly; - else raise EBold.CreateFmt(sWrongValue, [ClassName, 'GetAsChangeableKind']); // do not localize + else raise EBold.Create('TBAChangeableKind.GetAsChangeableKind: Wrong value.'); end; end; -function TBAChangeableKind.GetValues: TBAValueSetValueList; +class function TBAChangeableKind.GetValues: TBAValueSetValueList; begin if not Assigned(_ChangeableKindValues) then begin _ChangeableKindValues := TBAValueSetValueList.Create; - _ChangeableKindValues.Add(1, ['changeable']); // do not localize - _ChangeableKindValues.Add(2, ['frozen']); // do not localize - _ChangeableKindValues.Add(3, ['addOnly']); // do not localize + _ChangeableKindValues.Add(1, ['changeable']); + _ChangeableKindValues.Add(2, ['frozen']); + _ChangeableKindValues.Add(3, ['addOnly']); end; Result := _ChangeableKindValues; end; @@ -335,17 +340,17 @@ function TBAOrderingKind.getAsOrderingKind: TOrderingKind; case AsInteger of 0: Result := okUnordered; 1: Result := okOrdered; - else raise EBold.CreateFmt(sWrongValue, [ClassName, 'getAsOrderingKind']); // do not localize + else raise EBold.Create('TBAOrderingKind.GetAsOrderingKind: Wrong value.'); end; end; -function TBAOrderingKind.GetValues: TBAValueSetValueList; +class function TBAOrderingKind.GetValues: TBAValueSetValueList; begin if not Assigned(_OrderingKindValues) then begin _OrderingKindValues := TBAValueSetValueList.Create; - _OrderingKindValues.Add(0, ['unordered']); // do not localize - _OrderingKindValues.Add(1, ['ordered']); // do not localize + _OrderingKindValues.Add(0, ['unordered']); + _OrderingKindValues.Add(1, ['ordered']); end; Result := _OrderingKindValues; end; @@ -371,23 +376,23 @@ function TBAPseudostateKind.getAsPseudostateKind: TPseudostateKind; 5: Result := pkBranch; 6: Result := pkJunction; 7: Result := pkFinal; - else raise EBold.CreateFmt(sWrongValue, [ClassName, 'getAsPseudostateKind']); // do not localize + else raise EBold.Create('TBAOrderingKind.GetAsOrderingKind: Wrong value.'); end; end; -function TBAPseudostateKind.GetValues: TBAValueSetValueList; +class function TBAPseudostateKind.GetValues: TBAValueSetValueList; begin if not Assigned(_PseudostateKindValues) then begin _PseudostateKindValues := TBAValueSetValueList.Create; - _PseudostateKindValues.Add(0, ['initial']); // do not localize - _PseudostateKindValues.Add(1, ['deepHistory']); // do not localize - _PseudostateKindValues.Add(2, ['shallowHistory']); // do not localize - _PseudostateKindValues.Add(3, ['join']); // do not localize - _PseudostateKindValues.Add(4, ['fork']); // do not localize - _PseudostateKindValues.Add(5, ['branch']); // do not localize - _PseudostateKindValues.Add(6, ['junction']); // do not localize - _PseudostateKindValues.Add(7, ['final']); // do not localize + _PseudostateKindValues.Add(0, ['initial']); + _PseudostateKindValues.Add(1, ['deepHistory']); + _PseudostateKindValues.Add(2, ['shallowHistory']); + _PseudostateKindValues.Add(3, ['join']); + _PseudostateKindValues.Add(4, ['fork']); + _PseudostateKindValues.Add(5, ['branch']); + _PseudostateKindValues.Add(6, ['junction']); + _PseudostateKindValues.Add(7, ['final']); end; Result := _PseudostateKindValues; end; @@ -405,6 +410,7 @@ procedure TBAPseudostateKind.setAsPseudostateKind( pkJunction: AsInteger := 6; pkFinal: AsInteger := 7; end; + end; { TBACallConcurrencyKind } @@ -415,18 +421,18 @@ function TBACallConcurrencyKind.getAsCallConcurrencyKind: TCallConcurrencyKind; 0: Result := cckSequential; 1: Result := cckGuarded; 2: Result := cckConcurrent; - else raise EBold.CreateFmt(sWrongValue, [ClassName, 'getAsCallConcurrencyKind']); // do not localize + else raise EBold.Create('TBAOrderingKind.GetAsOrderingKind: Wrong value.'); end; end; -function TBACallConcurrencyKind.GetValues: TBAValueSetValueList; +class function TBACallConcurrencyKind.GetValues: TBAValueSetValueList; begin if not Assigned(_CallConcurrencyKindValues) then begin _CallConcurrencyKindValues := TBAValueSetValueList.Create; - _CallConcurrencyKindValues.Add(0, ['sequential']); // do not localize - _CallConcurrencyKindValues.Add(1, ['guarded']); // do not localize - _CallConcurrencyKindValues.Add(2, ['concurrent']); // do not localize + _CallConcurrencyKindValues.Add(0, ['sequential']); + _CallConcurrencyKindValues.Add(1, ['guarded']); + _CallConcurrencyKindValues.Add(2, ['concurrent']); end; Result := _CallConcurrencyKindValues; end; @@ -448,17 +454,17 @@ function TBAMessageDirectionKind.getAsMessageDirectionKind: TMessageDirectionKin case AsInteger of 0: Result := mdkActivation; 1: Result := mdkReturn; - else raise EBold.CreateFmt(sWrongValue, [ClassName, 'getAsMessageDirectionKind']); // do not localize + else raise EBold.Create('TBAOrderingKind.GetAsOrderingKind: Wrong value.'); end; end; -function TBAMessageDirectionKind.GetValues: TBAValueSetValueList; +class function TBAMessageDirectionKind.GetValues: TBAValueSetValueList; begin if not Assigned(_MessageDirectionKindValues) then begin _MessageDirectionKindValues := TBAValueSetValueList.Create; - _MessageDirectionKindValues.Add(0, ['activation']); // do not localize - _MessageDirectionKindValues.Add(1, ['return']); // do not localize + _MessageDirectionKindValues.Add(0, ['activation']); + _MessageDirectionKindValues.Add(1, ['return']); end; Result := _MessageDirectionKindValues; end; diff --git a/Source/UMLModel/Core/BoldUMLModel.inc b/Source/UMLModel/Core/BoldUMLModel.inc index c1a91228..1d2bc260 100644 --- a/Source/UMLModel/Core/BoldUMLModel.inc +++ b/Source/UMLModel/Core/BoldUMLModel.inc @@ -10,10 +10,15 @@ procedure TUMLModel.Clear; begin + BoldSystem.StartTransaction(); + try while ownedElement.Count > 0 do ownedElement[ownedElement.Count-1].Delete; while M_taggedValue.Count > 0 do M_taggedValue[M_taggedValue.Count-1].Delete; + finally + BoldSystem.CommitTransaction(); + end; end; function TUMLAssociationEnd.GetOtherEnd: TUMLAssociationEnd; @@ -201,7 +206,9 @@ end; procedure TUMLClassifier.GetAllOverrideableMethods(Methods: TList); procedure GetSuperclassMethods(aClass: TUMLClassifier; SuperMethods: TList); - var Index: Integer; + var + Index: Integer; + UMLOperation: TUMLOperation; begin if Assigned(aClass.SuperClass) then GetSuperclassMethods(aClass.SuperClass, SuperMethods); @@ -209,9 +216,10 @@ procedure TUMLClassifier.GetAllOverrideableMethods(Methods: TList); begin if aClass.Feature[Index] is TUMLOperation then begin - if ((aClass.Feature[Index] as TUMLOperation).GetBoldTV(TAG_DELPHIOPERATIONKIND) = TV_DELPHIOPERATIONKIND_VIRTUAL) or - ((aClass.Feature[Index] as TUMLOperation).GetBoldTV(TAG_DELPHIOPERATIONKIND) = TV_DELPHIOPERATIONKIND_DYNAMIC) or - ((aClass.Feature[Index] as TUMLOperation).GetBoldTV(TAG_DELPHIOPERATIONKIND) = TV_DELPHIOPERATIONKIND_ABSTRACTVIRTUAL) then + UMLOperation := (aClass.Feature[Index] as TUMLOperation); + if (UMLOperation.GetBoldTV(TAG_DELPHIOPERATIONKIND) = TV_DELPHIOPERATIONKIND_VIRTUAL) or + (UMLOperation.GetBoldTV(TAG_DELPHIOPERATIONKIND) = TV_DELPHIOPERATIONKIND_DYNAMIC) or + (UMLOperation.GetBoldTV(TAG_DELPHIOPERATIONKIND) = TV_DELPHIOPERATIONKIND_ABSTRACTVIRTUAL) then Methods.Add(aClass.Feature[Index]); end; @@ -337,7 +345,7 @@ var i: Integer; begin Result := nil; - AllStereotypes := (aSystem.Classes[aSystem.BoldSystemTypeInfo.ClassTypeInfoByExpressionName['UMLStereotype'].TopSortedIndex] as TUMLStereotypeList); + AllStereotypes := aSystem.ClassByObjectClass[TUMLStereotype] as TUMLStereotypeList; for i := 0 to AllStereotypes.Count - 1 do begin if AllStereotypes[i].Name = aName then @@ -464,8 +472,6 @@ begin SetTaggedValue(TAG_DERIVED, NewValue); end; - - procedure TUMLAssociationEnd._isOrdered_DeriveAndSubscribe(DerivedObject: TObject; Subscriber: TBoldSubscriber); begin M_isOrdered.AsBoolean := Ordering = okOrdered; diff --git a/Source/UMLModel/Core/BoldUMLModel.pas b/Source/UMLModel/Core/BoldUMLModel.pas index 7272ef52..e0f72886 100644 --- a/Source/UMLModel/Core/BoldUMLModel.pas +++ b/Source/UMLModel/Core/BoldUMLModel.pas @@ -1,17 +1,6 @@ -(*****************************************) -(* This file is autogenerated *) -(* Any manual changes will be LOST! *) -(*****************************************) -(* Generated 2002-06-19 17:13:50 *) -(*****************************************) -(* This file should be stored in the *) -(* same directory as the form/datamodule *) -(* with the corresponding model *) -(*****************************************) -(* Copyright notice: *) -(* *) -(*****************************************) +{ Global compiler directives } +{$include bold.inc} unit BoldUMLModel; {$DEFINE BoldUMLModel_unitheader} @@ -74,8 +63,8 @@ function Targumentstimulus1._Get_M_stimulus1: TBoldObjectReference; function Targumentstimulus1._Getstimulus1: TUMLStimulus; begin - assert(not assigned(M_stimulus1.BoldObject) or (M_stimulus1.BoldObject is TUMLStimulus), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'stimulus1', M_stimulus1.BoldObject.ClassName, 'TUMLStimulus'])); Result := TUMLStimulus(M_stimulus1.BoldObject); + assert(not assigned(Result) or (Result is TUMLStimulus), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'stimulus1', Result.ClassName, 'TUMLStimulus'])); end; function Targumentstimulus1._Get_M_argument: TBoldObjectReference; @@ -86,8 +75,8 @@ function Targumentstimulus1._Get_M_argument: TBoldObjectReference; function Targumentstimulus1._Getargument: TUMLInstance; begin - assert(not assigned(M_argument.BoldObject) or (M_argument.BoldObject is TUMLInstance), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'argument', M_argument.BoldObject.ClassName, 'TUMLInstance'])); Result := TUMLInstance(M_argument.BoldObject); + assert(not assigned(Result) or (Result is TUMLInstance), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'argument', Result.ClassName, 'TUMLInstance'])); end; procedure Targumentstimulus1List.Add(NewObject: Targumentstimulus1); @@ -137,8 +126,8 @@ function TassociationEndRoleavailableQualifier._Get_M_availableQualifier: TBoldO function TassociationEndRoleavailableQualifier._GetavailableQualifier: TUMLAttribute; begin - assert(not assigned(M_availableQualifier.BoldObject) or (M_availableQualifier.BoldObject is TUMLAttribute), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'availableQualifier', M_availableQualifier.BoldObject.ClassName, 'TUMLAttribute'])); Result := TUMLAttribute(M_availableQualifier.BoldObject); + assert(not assigned(Result) or (Result is TUMLAttribute), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'availableQualifier', Result.ClassName, 'TUMLAttribute'])); end; function TassociationEndRoleavailableQualifier._Get_M_associationEndRole: TBoldObjectReference; @@ -149,8 +138,8 @@ function TassociationEndRoleavailableQualifier._Get_M_associationEndRole: TBoldO function TassociationEndRoleavailableQualifier._GetassociationEndRole: TUMLAssociationEndRole; begin - assert(not assigned(M_associationEndRole.BoldObject) or (M_associationEndRole.BoldObject is TUMLAssociationEndRole), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'associationEndRole', M_associationEndRole.BoldObject.ClassName, 'TUMLAssociationEndRole'])); Result := TUMLAssociationEndRole(M_associationEndRole.BoldObject); + assert(not assigned(Result) or (Result is TUMLAssociationEndRole), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'associationEndRole', Result.ClassName, 'TUMLAssociationEndRole'])); end; procedure TassociationEndRoleavailableQualifierList.Add(NewObject: TassociationEndRoleavailableQualifier); @@ -200,8 +189,8 @@ function TclassifierclassifierRole_._Get_M_classifierRole_: TBoldObjectReference function TclassifierclassifierRole_._GetclassifierRole_: TUMLClassifierRole; begin - assert(not assigned(M_classifierRole_.BoldObject) or (M_classifierRole_.BoldObject is TUMLClassifierRole), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'classifierRole_', M_classifierRole_.BoldObject.ClassName, 'TUMLClassifierRole'])); Result := TUMLClassifierRole(M_classifierRole_.BoldObject); + assert(not assigned(Result) or (Result is TUMLClassifierRole), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'classifierRole_', Result.ClassName, 'TUMLClassifierRole'])); end; function TclassifierclassifierRole_._Get_M_classifier: TBoldObjectReference; @@ -212,8 +201,8 @@ function TclassifierclassifierRole_._Get_M_classifier: TBoldObjectReference; function TclassifierclassifierRole_._Getclassifier: TUMLClassifier; begin - assert(not assigned(M_classifier.BoldObject) or (M_classifier.BoldObject is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'classifier', M_classifier.BoldObject.ClassName, 'TUMLClassifier'])); Result := TUMLClassifier(M_classifier.BoldObject); + assert(not assigned(Result) or (Result is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'classifier', Result.ClassName, 'TUMLClassifier'])); end; procedure TclassifierclassifierRole_List.Add(NewObject: TclassifierclassifierRole_); @@ -263,8 +252,8 @@ function TclassifierInStateinState._Get_M_inState: TBoldObjectReference; function TclassifierInStateinState._GetinState: TUMLState; begin - assert(not assigned(M_inState.BoldObject) or (M_inState.BoldObject is TUMLState), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'inState', M_inState.BoldObject.ClassName, 'TUMLState'])); Result := TUMLState(M_inState.BoldObject); + assert(not assigned(Result) or (Result is TUMLState), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'inState', Result.ClassName, 'TUMLState'])); end; function TclassifierInStateinState._Get_M_classifierInState: TBoldObjectReference; @@ -275,8 +264,8 @@ function TclassifierInStateinState._Get_M_classifierInState: TBoldObjectReferenc function TclassifierInStateinState._GetclassifierInState: TUMLClassifierInState; begin - assert(not assigned(M_classifierInState.BoldObject) or (M_classifierInState.BoldObject is TUMLClassifierInState), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'classifierInState', M_classifierInState.BoldObject.ClassName, 'TUMLClassifierInState'])); Result := TUMLClassifierInState(M_classifierInState.BoldObject); + assert(not assigned(Result) or (Result is TUMLClassifierInState), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'classifierInState', Result.ClassName, 'TUMLClassifierInState'])); end; procedure TclassifierInStateinStateList.Add(NewObject: TclassifierInStateinState); @@ -326,8 +315,8 @@ function TclassifierRole_availableFeature._Get_M_availableFeature: TBoldObjectRe function TclassifierRole_availableFeature._GetavailableFeature: TUMLFeature; begin - assert(not assigned(M_availableFeature.BoldObject) or (M_availableFeature.BoldObject is TUMLFeature), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'availableFeature', M_availableFeature.BoldObject.ClassName, 'TUMLFeature'])); Result := TUMLFeature(M_availableFeature.BoldObject); + assert(not assigned(Result) or (Result is TUMLFeature), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'availableFeature', Result.ClassName, 'TUMLFeature'])); end; function TclassifierRole_availableFeature._Get_M_classifierRole_: TBoldObjectReference; @@ -338,8 +327,8 @@ function TclassifierRole_availableFeature._Get_M_classifierRole_: TBoldObjectRef function TclassifierRole_availableFeature._GetclassifierRole_: TUMLClassifierRole; begin - assert(not assigned(M_classifierRole_.BoldObject) or (M_classifierRole_.BoldObject is TUMLClassifierRole), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'classifierRole_', M_classifierRole_.BoldObject.ClassName, 'TUMLClassifierRole'])); Result := TUMLClassifierRole(M_classifierRole_.BoldObject); + assert(not assigned(Result) or (Result is TUMLClassifierRole), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'classifierRole_', Result.ClassName, 'TUMLClassifierRole'])); end; procedure TclassifierRole_availableFeatureList.Add(NewObject: TclassifierRole_availableFeature); @@ -389,8 +378,8 @@ function TclassifierRoleavailableContents._Get_M_availableContents: TBoldObjectR function TclassifierRoleavailableContents._GetavailableContents: TUMLModelElement; begin - assert(not assigned(M_availableContents.BoldObject) or (M_availableContents.BoldObject is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'availableContents', M_availableContents.BoldObject.ClassName, 'TUMLModelElement'])); Result := TUMLModelElement(M_availableContents.BoldObject); + assert(not assigned(Result) or (Result is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'availableContents', Result.ClassName, 'TUMLModelElement'])); end; function TclassifierRoleavailableContents._Get_M_classifierRole: TBoldObjectReference; @@ -401,8 +390,8 @@ function TclassifierRoleavailableContents._Get_M_classifierRole: TBoldObjectRefe function TclassifierRoleavailableContents._GetclassifierRole: TUMLClassifierRole; begin - assert(not assigned(M_classifierRole.BoldObject) or (M_classifierRole.BoldObject is TUMLClassifierRole), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'classifierRole', M_classifierRole.BoldObject.ClassName, 'TUMLClassifierRole'])); Result := TUMLClassifierRole(M_classifierRole.BoldObject); + assert(not assigned(Result) or (Result is TUMLClassifierRole), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'classifierRole', Result.ClassName, 'TUMLClassifierRole'])); end; procedure TclassifierRoleavailableContentsList.Add(NewObject: TclassifierRoleavailableContents); @@ -452,8 +441,8 @@ function TclientclientDependency._Get_M_clientDependency: TBoldObjectReference; function TclientclientDependency._GetclientDependency: TUMLDependency; begin - assert(not assigned(M_clientDependency.BoldObject) or (M_clientDependency.BoldObject is TUMLDependency), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'clientDependency', M_clientDependency.BoldObject.ClassName, 'TUMLDependency'])); Result := TUMLDependency(M_clientDependency.BoldObject); + assert(not assigned(Result) or (Result is TUMLDependency), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'clientDependency', Result.ClassName, 'TUMLDependency'])); end; function TclientclientDependency._Get_M_client: TBoldObjectReference; @@ -464,8 +453,8 @@ function TclientclientDependency._Get_M_client: TBoldObjectReference; function TclientclientDependency._Getclient: TUMLModelElement; begin - assert(not assigned(M_client.BoldObject) or (M_client.BoldObject is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'client', M_client.BoldObject.ClassName, 'TUMLModelElement'])); Result := TUMLModelElement(M_client.BoldObject); + assert(not assigned(Result) or (Result is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'client', Result.ClassName, 'TUMLModelElement'])); end; procedure TclientclientDependencyList.Add(NewObject: TclientclientDependency); @@ -515,8 +504,8 @@ function TcollaborationconstrainingElement._Get_M_constrainingElement: TBoldObje function TcollaborationconstrainingElement._GetconstrainingElement: TUMLModelElement; begin - assert(not assigned(M_constrainingElement.BoldObject) or (M_constrainingElement.BoldObject is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'constrainingElement', M_constrainingElement.BoldObject.ClassName, 'TUMLModelElement'])); Result := TUMLModelElement(M_constrainingElement.BoldObject); + assert(not assigned(Result) or (Result is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'constrainingElement', Result.ClassName, 'TUMLModelElement'])); end; function TcollaborationconstrainingElement._Get_M_collaboration: TBoldObjectReference; @@ -527,8 +516,8 @@ function TcollaborationconstrainingElement._Get_M_collaboration: TBoldObjectRefe function TcollaborationconstrainingElement._Getcollaboration: TUMLCollaboration; begin - assert(not assigned(M_collaboration.BoldObject) or (M_collaboration.BoldObject is TUMLCollaboration), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'collaboration', M_collaboration.BoldObject.ClassName, 'TUMLCollaboration'])); Result := TUMLCollaboration(M_collaboration.BoldObject); + assert(not assigned(Result) or (Result is TUMLCollaboration), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'collaboration', Result.ClassName, 'TUMLCollaboration'])); end; procedure TcollaborationconstrainingElementList.Add(NewObject: TcollaborationconstrainingElement); @@ -578,8 +567,8 @@ function TcommentannotatedElement._Get_M_annotatedElement: TBoldObjectReference; function TcommentannotatedElement._GetannotatedElement: TUMLModelElement; begin - assert(not assigned(M_annotatedElement.BoldObject) or (M_annotatedElement.BoldObject is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'annotatedElement', M_annotatedElement.BoldObject.ClassName, 'TUMLModelElement'])); Result := TUMLModelElement(M_annotatedElement.BoldObject); + assert(not assigned(Result) or (Result is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'annotatedElement', Result.ClassName, 'TUMLModelElement'])); end; function TcommentannotatedElement._Get_M_comment: TBoldObjectReference; @@ -590,8 +579,8 @@ function TcommentannotatedElement._Get_M_comment: TBoldObjectReference; function TcommentannotatedElement._Getcomment: TUMLComment; begin - assert(not assigned(M_comment.BoldObject) or (M_comment.BoldObject is TUMLComment), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'comment', M_comment.BoldObject.ClassName, 'TUMLComment'])); Result := TUMLComment(M_comment.BoldObject); + assert(not assigned(Result) or (Result is TUMLComment), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'comment', Result.ClassName, 'TUMLComment'])); end; procedure TcommentannotatedElementList.Add(NewObject: TcommentannotatedElement); @@ -641,8 +630,8 @@ function TconstrainedElementconstraint._Get_M_constraint: TBoldObjectReference; function TconstrainedElementconstraint._Getconstraint: TUMLConstraint; begin - assert(not assigned(M_constraint.BoldObject) or (M_constraint.BoldObject is TUMLConstraint), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'constraint', M_constraint.BoldObject.ClassName, 'TUMLConstraint'])); Result := TUMLConstraint(M_constraint.BoldObject); + assert(not assigned(Result) or (Result is TUMLConstraint), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'constraint', Result.ClassName, 'TUMLConstraint'])); end; function TconstrainedElementconstraint._Get_M_constrainedElement: TBoldObjectReference; @@ -653,8 +642,8 @@ function TconstrainedElementconstraint._Get_M_constrainedElement: TBoldObjectRef function TconstrainedElementconstraint._GetconstrainedElement: TUMLModelElement; begin - assert(not assigned(M_constrainedElement.BoldObject) or (M_constrainedElement.BoldObject is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'constrainedElement', M_constrainedElement.BoldObject.ClassName, 'TUMLModelElement'])); Result := TUMLModelElement(M_constrainedElement.BoldObject); + assert(not assigned(Result) or (Result is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'constrainedElement', Result.ClassName, 'TUMLModelElement'])); end; procedure TconstrainedElementconstraintList.Add(NewObject: TconstrainedElementconstraint); @@ -704,8 +693,8 @@ function Tcontentspartition._Get_M_partition: TBoldObjectReference; function Tcontentspartition._Getpartition: TUMLPartition; begin - assert(not assigned(M_partition.BoldObject) or (M_partition.BoldObject is TUMLPartition), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'partition', M_partition.BoldObject.ClassName, 'TUMLPartition'])); Result := TUMLPartition(M_partition.BoldObject); + assert(not assigned(Result) or (Result is TUMLPartition), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'partition', Result.ClassName, 'TUMLPartition'])); end; function Tcontentspartition._Get_M_contents: TBoldObjectReference; @@ -716,8 +705,8 @@ function Tcontentspartition._Get_M_contents: TBoldObjectReference; function Tcontentspartition._Getcontents: TUMLModelElement; begin - assert(not assigned(M_contents.BoldObject) or (M_contents.BoldObject is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'contents', M_contents.BoldObject.ClassName, 'TUMLModelElement'])); Result := TUMLModelElement(M_contents.BoldObject); + assert(not assigned(Result) or (Result is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'contents', Result.ClassName, 'TUMLModelElement'])); end; procedure TcontentspartitionList.Add(NewObject: Tcontentspartition); @@ -767,8 +756,8 @@ function TcontextraisedSignal._Get_M_raisedSignal: TBoldObjectReference; function TcontextraisedSignal._GetraisedSignal: TUMLSignal; begin - assert(not assigned(M_raisedSignal.BoldObject) or (M_raisedSignal.BoldObject is TUMLSignal), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'raisedSignal', M_raisedSignal.BoldObject.ClassName, 'TUMLSignal'])); Result := TUMLSignal(M_raisedSignal.BoldObject); + assert(not assigned(Result) or (Result is TUMLSignal), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'raisedSignal', Result.ClassName, 'TUMLSignal'])); end; function TcontextraisedSignal._Get_M_context: TBoldObjectReference; @@ -779,8 +768,8 @@ function TcontextraisedSignal._Get_M_context: TBoldObjectReference; function TcontextraisedSignal._Getcontext: TUMLBehavioralFeature; begin - assert(not assigned(M_context.BoldObject) or (M_context.BoldObject is TUMLBehavioralFeature), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'context', M_context.BoldObject.ClassName, 'TUMLBehavioralFeature'])); Result := TUMLBehavioralFeature(M_context.BoldObject); + assert(not assigned(Result) or (Result is TUMLBehavioralFeature), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'context', Result.ClassName, 'TUMLBehavioralFeature'])); end; procedure TcontextraisedSignalList.Add(NewObject: TcontextraisedSignal); @@ -830,8 +819,8 @@ function TdeploymentLocationresident._Get_M_resident: TBoldObjectReference; function TdeploymentLocationresident._Getresident: TUMLComponent; begin - assert(not assigned(M_resident.BoldObject) or (M_resident.BoldObject is TUMLComponent), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'resident', M_resident.BoldObject.ClassName, 'TUMLComponent'])); Result := TUMLComponent(M_resident.BoldObject); + assert(not assigned(Result) or (Result is TUMLComponent), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'resident', Result.ClassName, 'TUMLComponent'])); end; function TdeploymentLocationresident._Get_M_deploymentLocation: TBoldObjectReference; @@ -842,8 +831,8 @@ function TdeploymentLocationresident._Get_M_deploymentLocation: TBoldObjectRefer function TdeploymentLocationresident._GetdeploymentLocation: TUMLNode; begin - assert(not assigned(M_deploymentLocation.BoldObject) or (M_deploymentLocation.BoldObject is TUMLNode), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'deploymentLocation', M_deploymentLocation.BoldObject.ClassName, 'TUMLNode'])); Result := TUMLNode(M_deploymentLocation.BoldObject); + assert(not assigned(Result) or (Result is TUMLNode), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'deploymentLocation', Result.ClassName, 'TUMLNode'])); end; procedure TdeploymentLocationresidentList.Add(NewObject: TdeploymentLocationresident); @@ -935,7 +924,7 @@ function TUMLElementImport._Getvisibility: TVisibilityKind; Result := M_visibility.AsVisibilityKind; end; -procedure TUMLElementImport._Setvisibility(NewValue: TVisibilityKind); +procedure TUMLElementImport._Setvisibility(const NewValue: TVisibilityKind); begin M_visibility.AsVisibilityKind := NewValue; end; @@ -951,7 +940,7 @@ function TUMLElementImport._Getalias: String; Result := M_alias.AsString; end; -procedure TUMLElementImport._Setalias(NewValue: String); +procedure TUMLElementImport._Setalias(const NewValue: String); begin M_alias.AsString := NewValue; end; @@ -964,11 +953,11 @@ function TUMLElementImport._Get_M_package: TBoldObjectReference; function TUMLElementImport._Getpackage: TUMLPackage; begin - assert(not assigned(M_package.BoldObject) or (M_package.BoldObject is TUMLPackage), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'package', M_package.BoldObject.ClassName, 'TUMLPackage'])); Result := TUMLPackage(M_package.BoldObject); + assert(not assigned(Result) or (Result is TUMLPackage), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'package', Result.ClassName, 'TUMLPackage'])); end; -procedure TUMLElementImport._Setpackage(value: TUMLPackage); +procedure TUMLElementImport._Setpackage(const value: TUMLPackage); begin M_package.BoldObject := value; end; @@ -981,11 +970,11 @@ function TUMLElementImport._Get_M_modelElement: TBoldObjectReference; function TUMLElementImport._GetmodelElement: TUMLModelElement; begin - assert(not assigned(M_modelElement.BoldObject) or (M_modelElement.BoldObject is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'modelElement', M_modelElement.BoldObject.ClassName, 'TUMLModelElement'])); Result := TUMLModelElement(M_modelElement.BoldObject); + assert(not assigned(Result) or (Result is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'modelElement', Result.ClassName, 'TUMLModelElement'])); end; -procedure TUMLElementImport._SetmodelElement(value: TUMLModelElement); +procedure TUMLElementImport._SetmodelElement(const value: TUMLModelElement); begin M_modelElement.BoldObject := value; end; @@ -1040,7 +1029,7 @@ function TUMLElementResidence._Getvisibility: TVisibilityKind; Result := M_visibility.AsVisibilityKind; end; -procedure TUMLElementResidence._Setvisibility(NewValue: TVisibilityKind); +procedure TUMLElementResidence._Setvisibility(const NewValue: TVisibilityKind); begin M_visibility.AsVisibilityKind := NewValue; end; @@ -1053,11 +1042,11 @@ function TUMLElementResidence._Get_M_residentElement: TBoldObjectReference; function TUMLElementResidence._GetresidentElement: TUMLComponent; begin - assert(not assigned(M_residentElement.BoldObject) or (M_residentElement.BoldObject is TUMLComponent), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'residentElement', M_residentElement.BoldObject.ClassName, 'TUMLComponent'])); Result := TUMLComponent(M_residentElement.BoldObject); + assert(not assigned(Result) or (Result is TUMLComponent), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'residentElement', Result.ClassName, 'TUMLComponent'])); end; -procedure TUMLElementResidence._SetresidentElement(value: TUMLComponent); +procedure TUMLElementResidence._SetresidentElement(const value: TUMLComponent); begin M_residentElement.BoldObject := value; end; @@ -1070,11 +1059,11 @@ function TUMLElementResidence._Get_M_residence: TBoldObjectReference; function TUMLElementResidence._Getresidence: TUMLModelElement; begin - assert(not assigned(M_residence.BoldObject) or (M_residence.BoldObject is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'residence', M_residence.BoldObject.ClassName, 'TUMLModelElement'])); Result := TUMLModelElement(M_residence.BoldObject); + assert(not assigned(Result) or (Result is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'residence', Result.ClassName, 'TUMLModelElement'])); end; -procedure TUMLElementResidence._Setresidence(value: TUMLModelElement); +procedure TUMLElementResidence._Setresidence(const value: TUMLModelElement); begin M_residence.BoldObject := value; end; @@ -1126,8 +1115,8 @@ function TextensionPointextend._Get_M_extend: TBoldObjectReference; function TextensionPointextend._Getextend: TUMLExtend; begin - assert(not assigned(M_extend.BoldObject) or (M_extend.BoldObject is TUMLExtend), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'extend', M_extend.BoldObject.ClassName, 'TUMLExtend'])); Result := TUMLExtend(M_extend.BoldObject); + assert(not assigned(Result) or (Result is TUMLExtend), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'extend', Result.ClassName, 'TUMLExtend'])); end; function TextensionPointextend._Get_M_extensionPoint: TBoldObjectReference; @@ -1138,8 +1127,8 @@ function TextensionPointextend._Get_M_extensionPoint: TBoldObjectReference; function TextensionPointextend._GetextensionPoint: TUMLExtensionPoint; begin - assert(not assigned(M_extensionPoint.BoldObject) or (M_extensionPoint.BoldObject is TUMLExtensionPoint), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'extensionPoint', M_extensionPoint.BoldObject.ClassName, 'TUMLExtensionPoint'])); Result := TUMLExtensionPoint(M_extensionPoint.BoldObject); + assert(not assigned(Result) or (Result is TUMLExtensionPoint), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'extensionPoint', Result.ClassName, 'TUMLExtensionPoint'])); end; procedure TextensionPointextendList.Add(NewObject: TextensionPointextend); @@ -1189,8 +1178,8 @@ function Tinstanceclassifier._Get_M_classifier: TBoldObjectReference; function Tinstanceclassifier._Getclassifier: TUMLClassifier; begin - assert(not assigned(M_classifier.BoldObject) or (M_classifier.BoldObject is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'classifier', M_classifier.BoldObject.ClassName, 'TUMLClassifier'])); Result := TUMLClassifier(M_classifier.BoldObject); + assert(not assigned(Result) or (Result is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'classifier', Result.ClassName, 'TUMLClassifier'])); end; function Tinstanceclassifier._Get_M_instance: TBoldObjectReference; @@ -1201,8 +1190,8 @@ function Tinstanceclassifier._Get_M_instance: TBoldObjectReference; function Tinstanceclassifier._Getinstance: TUMLInstance; begin - assert(not assigned(M_instance.BoldObject) or (M_instance.BoldObject is TUMLInstance), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'instance', M_instance.BoldObject.ClassName, 'TUMLInstance'])); Result := TUMLInstance(M_instance.BoldObject); + assert(not assigned(Result) or (Result is TUMLInstance), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'instance', Result.ClassName, 'TUMLInstance'])); end; procedure TinstanceclassifierList.Add(NewObject: Tinstanceclassifier); @@ -1252,8 +1241,8 @@ function Tparameterstate._Get_M_state: TBoldObjectReference; function Tparameterstate._Getstate: TUMLObjectFlowState; begin - assert(not assigned(M_state.BoldObject) or (M_state.BoldObject is TUMLObjectFlowState), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'state', M_state.BoldObject.ClassName, 'TUMLObjectFlowState'])); Result := TUMLObjectFlowState(M_state.BoldObject); + assert(not assigned(Result) or (Result is TUMLObjectFlowState), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'state', Result.ClassName, 'TUMLObjectFlowState'])); end; function Tparameterstate._Get_M_parameter: TBoldObjectReference; @@ -1264,8 +1253,8 @@ function Tparameterstate._Get_M_parameter: TBoldObjectReference; function Tparameterstate._Getparameter: TUMLParameter; begin - assert(not assigned(M_parameter.BoldObject) or (M_parameter.BoldObject is TUMLParameter), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'parameter', M_parameter.BoldObject.ClassName, 'TUMLParameter'])); Result := TUMLParameter(M_parameter.BoldObject); + assert(not assigned(Result) or (Result is TUMLParameter), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'parameter', Result.ClassName, 'TUMLParameter'])); end; procedure TparameterstateList.Add(NewObject: Tparameterstate); @@ -1315,8 +1304,8 @@ function Tparticipantspecification._Get_M_specification: TBoldObjectReference; function Tparticipantspecification._Getspecification: TUMLClassifier; begin - assert(not assigned(M_specification.BoldObject) or (M_specification.BoldObject is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'specification', M_specification.BoldObject.ClassName, 'TUMLClassifier'])); Result := TUMLClassifier(M_specification.BoldObject); + assert(not assigned(Result) or (Result is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'specification', Result.ClassName, 'TUMLClassifier'])); end; function Tparticipantspecification._Get_M_participant: TBoldObjectReference; @@ -1327,8 +1316,8 @@ function Tparticipantspecification._Get_M_participant: TBoldObjectReference; function Tparticipantspecification._Getparticipant: TUMLAssociationEnd; begin - assert(not assigned(M_participant.BoldObject) or (M_participant.BoldObject is TUMLAssociationEnd), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'participant', M_participant.BoldObject.ClassName, 'TUMLAssociationEnd'])); Result := TUMLAssociationEnd(M_participant.BoldObject); + assert(not assigned(Result) or (Result is TUMLAssociationEnd), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'participant', Result.ClassName, 'TUMLAssociationEnd'])); end; procedure TparticipantspecificationList.Add(NewObject: Tparticipantspecification); @@ -1378,8 +1367,8 @@ function Tpredecessormessage3._Get_M_message3: TBoldObjectReference; function Tpredecessormessage3._Getmessage3: TUMLMessage; begin - assert(not assigned(M_message3.BoldObject) or (M_message3.BoldObject is TUMLMessage), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'message3', M_message3.BoldObject.ClassName, 'TUMLMessage'])); Result := TUMLMessage(M_message3.BoldObject); + assert(not assigned(Result) or (Result is TUMLMessage), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'message3', Result.ClassName, 'TUMLMessage'])); end; function Tpredecessormessage3._Get_M_predecessor: TBoldObjectReference; @@ -1390,8 +1379,8 @@ function Tpredecessormessage3._Get_M_predecessor: TBoldObjectReference; function Tpredecessormessage3._Getpredecessor: TUMLMessage; begin - assert(not assigned(M_predecessor.BoldObject) or (M_predecessor.BoldObject is TUMLMessage), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'predecessor', M_predecessor.BoldObject.ClassName, 'TUMLMessage'])); Result := TUMLMessage(M_predecessor.BoldObject); + assert(not assigned(Result) or (Result is TUMLMessage), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'predecessor', Result.ClassName, 'TUMLMessage'])); end; procedure Tpredecessormessage3List.Add(NewObject: Tpredecessormessage3); @@ -1492,8 +1481,8 @@ function Tpresentationsubject._Get_M_subject: TBoldObjectReference; function Tpresentationsubject._Getsubject: TUMLModelElement; begin - assert(not assigned(M_subject.BoldObject) or (M_subject.BoldObject is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'subject', M_subject.BoldObject.ClassName, 'TUMLModelElement'])); Result := TUMLModelElement(M_subject.BoldObject); + assert(not assigned(Result) or (Result is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'subject', Result.ClassName, 'TUMLModelElement'])); end; function Tpresentationsubject._Get_M_presentation: TBoldObjectReference; @@ -1504,8 +1493,8 @@ function Tpresentationsubject._Get_M_presentation: TBoldObjectReference; function Tpresentationsubject._Getpresentation: TUMLPresentationElement; begin - assert(not assigned(M_presentation.BoldObject) or (M_presentation.BoldObject is TUMLPresentationElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'presentation', M_presentation.BoldObject.ClassName, 'TUMLPresentationElement'])); Result := TUMLPresentationElement(M_presentation.BoldObject); + assert(not assigned(Result) or (Result is TUMLPresentationElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'presentation', Result.ClassName, 'TUMLPresentationElement'])); end; procedure TpresentationsubjectList.Add(NewObject: Tpresentationsubject); @@ -1555,8 +1544,8 @@ function TsourceFlowsource._Get_M_source: TBoldObjectReference; function TsourceFlowsource._Getsource: TUMLModelElement; begin - assert(not assigned(M_source.BoldObject) or (M_source.BoldObject is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'source', M_source.BoldObject.ClassName, 'TUMLModelElement'])); Result := TUMLModelElement(M_source.BoldObject); + assert(not assigned(Result) or (Result is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'source', Result.ClassName, 'TUMLModelElement'])); end; function TsourceFlowsource._Get_M_sourceFlow: TBoldObjectReference; @@ -1567,8 +1556,8 @@ function TsourceFlowsource._Get_M_sourceFlow: TBoldObjectReference; function TsourceFlowsource._GetsourceFlow: TUMLFlow; begin - assert(not assigned(M_sourceFlow.BoldObject) or (M_sourceFlow.BoldObject is TUMLFlow), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'sourceFlow', M_sourceFlow.BoldObject.ClassName, 'TUMLFlow'])); Result := TUMLFlow(M_sourceFlow.BoldObject); + assert(not assigned(Result) or (Result is TUMLFlow), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'sourceFlow', Result.ClassName, 'TUMLFlow'])); end; procedure TsourceFlowsourceList.Add(NewObject: TsourceFlowsource); @@ -1618,8 +1607,8 @@ function TstatedeferrableEvent._Get_M_deferrableEvent: TBoldObjectReference; function TstatedeferrableEvent._GetdeferrableEvent: TUMLEvent; begin - assert(not assigned(M_deferrableEvent.BoldObject) or (M_deferrableEvent.BoldObject is TUMLEvent), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'deferrableEvent', M_deferrableEvent.BoldObject.ClassName, 'TUMLEvent'])); Result := TUMLEvent(M_deferrableEvent.BoldObject); + assert(not assigned(Result) or (Result is TUMLEvent), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'deferrableEvent', Result.ClassName, 'TUMLEvent'])); end; function TstatedeferrableEvent._Get_M_state: TBoldObjectReference; @@ -1630,8 +1619,8 @@ function TstatedeferrableEvent._Get_M_state: TBoldObjectReference; function TstatedeferrableEvent._Getstate: TUMLState; begin - assert(not assigned(M_state.BoldObject) or (M_state.BoldObject is TUMLState), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'state', M_state.BoldObject.ClassName, 'TUMLState'])); Result := TUMLState(M_state.BoldObject); + assert(not assigned(Result) or (Result is TUMLState), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'state', Result.ClassName, 'TUMLState'])); end; procedure TstatedeferrableEventList.Add(NewObject: TstatedeferrableEvent); @@ -1681,8 +1670,8 @@ function TsuppliersupplierDependency._Get_M_supplierDependency: TBoldObjectRefer function TsuppliersupplierDependency._GetsupplierDependency: TUMLDependency; begin - assert(not assigned(M_supplierDependency.BoldObject) or (M_supplierDependency.BoldObject is TUMLDependency), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'supplierDependency', M_supplierDependency.BoldObject.ClassName, 'TUMLDependency'])); Result := TUMLDependency(M_supplierDependency.BoldObject); + assert(not assigned(Result) or (Result is TUMLDependency), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'supplierDependency', Result.ClassName, 'TUMLDependency'])); end; function TsuppliersupplierDependency._Get_M_supplier: TBoldObjectReference; @@ -1693,8 +1682,8 @@ function TsuppliersupplierDependency._Get_M_supplier: TBoldObjectReference; function TsuppliersupplierDependency._Getsupplier: TUMLModelElement; begin - assert(not assigned(M_supplier.BoldObject) or (M_supplier.BoldObject is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'supplier', M_supplier.BoldObject.ClassName, 'TUMLModelElement'])); Result := TUMLModelElement(M_supplier.BoldObject); + assert(not assigned(Result) or (Result is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'supplier', Result.ClassName, 'TUMLModelElement'])); end; procedure TsuppliersupplierDependencyList.Add(NewObject: TsuppliersupplierDependency); @@ -1744,8 +1733,8 @@ function TtargetFlowtarget._Get_M_target: TBoldObjectReference; function TtargetFlowtarget._Gettarget: TUMLModelElement; begin - assert(not assigned(M_target.BoldObject) or (M_target.BoldObject is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'target', M_target.BoldObject.ClassName, 'TUMLModelElement'])); Result := TUMLModelElement(M_target.BoldObject); + assert(not assigned(Result) or (Result is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'target', Result.ClassName, 'TUMLModelElement'])); end; function TtargetFlowtarget._Get_M_targetFlow: TBoldObjectReference; @@ -1756,8 +1745,8 @@ function TtargetFlowtarget._Get_M_targetFlow: TBoldObjectReference; function TtargetFlowtarget._GettargetFlow: TUMLFlow; begin - assert(not assigned(M_targetFlow.BoldObject) or (M_targetFlow.BoldObject is TUMLFlow), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'targetFlow', M_targetFlow.BoldObject.ClassName, 'TUMLFlow'])); Result := TUMLFlow(M_targetFlow.BoldObject); + assert(not assigned(Result) or (Result is TUMLFlow), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'targetFlow', Result.ClassName, 'TUMLFlow'])); end; procedure TtargetFlowtargetList.Add(NewObject: TtargetFlowtarget); @@ -1807,11 +1796,11 @@ function TUMLTemplateParameter._Get_M_modelElement2: TBoldObjectReference; function TUMLTemplateParameter._GetmodelElement2: TUMLModelElement; begin - assert(not assigned(M_modelElement2.BoldObject) or (M_modelElement2.BoldObject is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'modelElement2', M_modelElement2.BoldObject.ClassName, 'TUMLModelElement'])); Result := TUMLModelElement(M_modelElement2.BoldObject); + assert(not assigned(Result) or (Result is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'modelElement2', Result.ClassName, 'TUMLModelElement'])); end; -procedure TUMLTemplateParameter._SetmodelElement2(value: TUMLModelElement); +procedure TUMLTemplateParameter._SetmodelElement2(const value: TUMLModelElement); begin M_modelElement2.BoldObject := value; end; @@ -1824,11 +1813,11 @@ function TUMLTemplateParameter._Get_M_modelElement: TBoldObjectReference; function TUMLTemplateParameter._GetmodelElement: TUMLModelElement; begin - assert(not assigned(M_modelElement.BoldObject) or (M_modelElement.BoldObject is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'modelElement', M_modelElement.BoldObject.ClassName, 'TUMLModelElement'])); Result := TUMLModelElement(M_modelElement.BoldObject); + assert(not assigned(Result) or (Result is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'modelElement', Result.ClassName, 'TUMLModelElement'])); end; -procedure TUMLTemplateParameter._SetmodelElement(value: TUMLModelElement); +procedure TUMLTemplateParameter._SetmodelElement(const value: TUMLModelElement); begin M_modelElement.BoldObject := value; end; @@ -1841,11 +1830,11 @@ function TUMLTemplateParameter._Get_M_defaultElement: TBoldObjectReference; function TUMLTemplateParameter._GetdefaultElement: TUMLModelElement; begin - assert(not assigned(M_defaultElement.BoldObject) or (M_defaultElement.BoldObject is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'defaultElement', M_defaultElement.BoldObject.ClassName, 'TUMLModelElement'])); Result := TUMLModelElement(M_defaultElement.BoldObject); + assert(not assigned(Result) or (Result is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'defaultElement', Result.ClassName, 'TUMLModelElement'])); end; -procedure TUMLTemplateParameter._SetdefaultElement(value: TUMLModelElement); +procedure TUMLTemplateParameter._SetdefaultElement(const value: TUMLModelElement); begin M_defaultElement.BoldObject := value; end; @@ -1914,11 +1903,11 @@ function TValidator._Get_M_UMLModel: TBoldObjectReference; function TValidator._GetUMLModel: TUMLModel; begin - assert(not assigned(M_UMLModel.BoldObject) or (M_UMLModel.BoldObject is TUMLModel), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'UMLModel', M_UMLModel.BoldObject.ClassName, 'TUMLModel'])); Result := TUMLModel(M_UMLModel.BoldObject); + assert(not assigned(Result) or (Result is TUMLModel), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'UMLModel', Result.ClassName, 'TUMLModel'])); end; -procedure TValidator._SetUMLModel(value: TUMLModel); +procedure TValidator._SetUMLModel(const value: TUMLModel); begin M_UMLModel.BoldObject := value; end; @@ -1960,15 +1949,12 @@ procedure TValidatorList.SetBoldObject(index: Integer; NewObject: TValidator); SetElement(index, NewObject); end; -function TValidator.GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; +function TValidator.GetDeriveMethodForMember(MemberIndex: Integer): TBoldDeriveAndResubscribe; begin - if (Member = M_HighestSeverity) then result := _HighestSeverity_DeriveAndSubscribe else - result := inherited GetDeriveMethodForMember(Member); -end; - -function TValidator.GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; -begin - result := inherited GetReverseDeriveMethodForMember(Member); + case MemberIndex of + 0: result := _HighestSeverity_DeriveAndSubscribe; + else result := inherited GetDeriveMethodForMember(MemberIndex); + end; end; { TViolation } @@ -1984,7 +1970,7 @@ function TViolation._GetDescription: String; Result := M_Description.AsString; end; -procedure TViolation._SetDescription(NewValue: String); +procedure TViolation._SetDescription(const NewValue: String); begin M_Description.AsString := NewValue; end; @@ -2000,7 +1986,7 @@ function TViolation._GetSeverity: TSeverity; Result := M_Severity.AsSeverity; end; -procedure TViolation._SetSeverity(NewValue: TSeverity); +procedure TViolation._SetSeverity(const NewValue: TSeverity); begin M_Severity.AsSeverity := NewValue; end; @@ -2013,11 +1999,11 @@ function TViolation._Get_M_Validator: TBoldObjectReference; function TViolation._GetValidator: TValidator; begin - assert(not assigned(M_Validator.BoldObject) or (M_Validator.BoldObject is TValidator), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'Validator', M_Validator.BoldObject.ClassName, 'TValidator'])); Result := TValidator(M_Validator.BoldObject); + assert(not assigned(Result) or (Result is TValidator), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'Validator', Result.ClassName, 'TValidator'])); end; -procedure TViolation._SetValidator(value: TValidator); +procedure TViolation._SetValidator(const value: TValidator); begin M_Validator.BoldObject := value; end; @@ -2030,11 +2016,11 @@ function TViolation._Get_M_ModelElement: TBoldObjectReference; function TViolation._GetModelElement: TUMLModelElement; begin - assert(not assigned(M_ModelElement.BoldObject) or (M_ModelElement.BoldObject is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'ModelElement', M_ModelElement.BoldObject.ClassName, 'TUMLModelElement'])); Result := TUMLModelElement(M_ModelElement.BoldObject); + assert(not assigned(Result) or (Result is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'ModelElement', Result.ClassName, 'TUMLModelElement'])); end; -procedure TViolation._SetModelElement(value: TUMLModelElement); +procedure TViolation._SetModelElement(const value: TUMLModelElement); begin M_ModelElement.BoldObject := value; end; @@ -2089,7 +2075,7 @@ function TUMLModelElement._Getname: String; Result := M_name.AsString; end; -procedure TUMLModelElement._Setname(NewValue: String); +procedure TUMLModelElement._Setname(const NewValue: String); begin M_name.AsString := NewValue; end; @@ -2105,7 +2091,7 @@ function TUMLModelElement._Getvisibility: TVisibilityKind; Result := M_visibility.AsVisibilityKind; end; -procedure TUMLModelElement._Setvisibility(NewValue: TVisibilityKind); +procedure TUMLModelElement._Setvisibility(const NewValue: TVisibilityKind); begin M_visibility.AsVisibilityKind := NewValue; end; @@ -2121,7 +2107,7 @@ function TUMLModelElement._GetisSpecification: boolean; Result := M_isSpecification.AsBoolean; end; -procedure TUMLModelElement._SetisSpecification(NewValue: boolean); +procedure TUMLModelElement._SetisSpecification(const NewValue: boolean); begin M_isSpecification.AsBoolean := NewValue; end; @@ -2148,7 +2134,7 @@ function TUMLModelElement._GetstereotypeName: String; Result := M_stereotypeName.AsString; end; -procedure TUMLModelElement._SetstereotypeName(NewValue: String); +procedure TUMLModelElement._SetstereotypeName(const NewValue: String); begin M_stereotypeName.AsString := NewValue; end; @@ -2175,7 +2161,7 @@ function TUMLModelElement._Getderived: boolean; Result := M_derived.AsBoolean; end; -procedure TUMLModelElement._Setderived(NewValue: boolean); +procedure TUMLModelElement._Setderived(const NewValue: boolean); begin M_derived.AsBoolean := NewValue; end; @@ -2266,11 +2252,11 @@ function TUMLModelElement._Get_M_binding: TBoldObjectReference; function TUMLModelElement._Getbinding: TUMLBinding; begin - assert(not assigned(M_binding.BoldObject) or (M_binding.BoldObject is TUMLBinding), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'binding', M_binding.BoldObject.ClassName, 'TUMLBinding'])); Result := TUMLBinding(M_binding.BoldObject); + assert(not assigned(Result) or (Result is TUMLBinding), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'binding', Result.ClassName, 'TUMLBinding'])); end; -procedure TUMLModelElement._Setbinding(value: TUMLBinding); +procedure TUMLModelElement._Setbinding(const value: TUMLBinding); begin M_binding.BoldObject := value; end; @@ -2349,11 +2335,11 @@ function TUMLModelElement._Get_M_namespace_: TBoldObjectReference; function TUMLModelElement._Getnamespace_: TUMLNamespace; begin - assert(not assigned(M_namespace_.BoldObject) or (M_namespace_.BoldObject is TUMLNamespace), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'namespace_', M_namespace_.BoldObject.ClassName, 'TUMLNamespace'])); Result := TUMLNamespace(M_namespace_.BoldObject); + assert(not assigned(Result) or (Result is TUMLNamespace), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'namespace_', Result.ClassName, 'TUMLNamespace'])); end; -procedure TUMLModelElement._Setnamespace_(value: TUMLNamespace); +procedure TUMLModelElement._Setnamespace_(const value: TUMLNamespace); begin M_namespace_.BoldObject := value; end; @@ -2393,11 +2379,11 @@ function TUMLModelElement._Get_M_stereotype: TBoldObjectReference; function TUMLModelElement._Getstereotype: TUMLStereotype; begin - assert(not assigned(M_stereotype.BoldObject) or (M_stereotype.BoldObject is TUMLStereotype), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'stereotype', M_stereotype.BoldObject.ClassName, 'TUMLStereotype'])); Result := TUMLStereotype(M_stereotype.BoldObject); + assert(not assigned(Result) or (Result is TUMLStereotype), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'stereotype', Result.ClassName, 'TUMLStereotype'])); end; -procedure TUMLModelElement._Setstereotype(value: TUMLStereotype); +procedure TUMLModelElement._Setstereotype(const value: TUMLStereotype); begin M_stereotype.BoldObject := value; end; @@ -2410,11 +2396,11 @@ function TUMLModelElement._Get_M_model: TBoldObjectReference; function TUMLModelElement._Getmodel: TUMLModel; begin - assert(not assigned(M_model.BoldObject) or (M_model.BoldObject is TUMLModel), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'model', M_model.BoldObject.ClassName, 'TUMLModel'])); Result := TUMLModel(M_model.BoldObject); + assert(not assigned(Result) or (Result is TUMLModel), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'model', Result.ClassName, 'TUMLModel'])); end; -procedure TUMLModelElement._Setmodel(value: TUMLModel); +procedure TUMLModelElement._Setmodel(const value: TUMLModel); begin M_model.BoldObject := value; end; @@ -2427,11 +2413,11 @@ function TUMLModelElement._Get_M_qualifyingOwner: TBoldObjectReference; function TUMLModelElement._GetqualifyingOwner: TUMLModelElement; begin - assert(not assigned(M_qualifyingOwner.BoldObject) or (M_qualifyingOwner.BoldObject is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'qualifyingOwner', M_qualifyingOwner.BoldObject.ClassName, 'TUMLModelElement'])); Result := TUMLModelElement(M_qualifyingOwner.BoldObject); + assert(not assigned(Result) or (Result is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'qualifyingOwner', Result.ClassName, 'TUMLModelElement'])); end; -procedure TUMLModelElement._SetqualifyingOwner(value: TUMLModelElement); +procedure TUMLModelElement._SetqualifyingOwner(const value: TUMLModelElement); begin M_qualifyingOwner.BoldObject := value; end; @@ -2479,19 +2465,23 @@ procedure TUMLModelElementList.SetBoldObject(index: Integer; NewObject: TUMLMode SetElement(index, NewObject); end; -function TUMLModelElement.GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; +function TUMLModelElement.GetDeriveMethodForMember(MemberIndex: Integer): TBoldDeriveAndResubscribe; begin - if (Member = M_stereotypeName) then result := _stereotypeName_DeriveAndSubscribe else - if (Member = M_documentation) then result := _documentation_DeriveAndSubscribe else - if (Member = M_derived) then result := _derived_DeriveAndSubscribe else - result := inherited GetDeriveMethodForMember(Member); + case MemberIndex of + 4: result := _stereotypeName_DeriveAndSubscribe; + 5: result := _documentation_DeriveAndSubscribe; + 6: result := _derived_DeriveAndSubscribe; + else result := inherited GetDeriveMethodForMember(MemberIndex); + end; end; -function TUMLModelElement.GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; +function TUMLModelElement.GetReverseDeriveMethodForMember(MemberIndex: Integer): TBoldReverseDerive; begin - result := inherited GetReverseDeriveMethodForMember(Member); - if not assigned(result) and (Member = M_stereotypeName) then result := _stereotypeName_ReverseDerive; - if not assigned(result) and (Member = M_derived) then result := _derived_ReverseDerive; + case MemberIndex of + 4: result := _stereotypeName_ReverseDerive; + 6: result := _derived_ReverseDerive; + else result := inherited GetReverseDeriveMethodForMember(MemberIndex); + end; end; { TUMLAction } @@ -2507,7 +2497,7 @@ function TUMLAction._Getrecurrence: String; Result := M_recurrence.AsString; end; -procedure TUMLAction._Setrecurrence(NewValue: String); +procedure TUMLAction._Setrecurrence(const NewValue: String); begin M_recurrence.AsString := NewValue; end; @@ -2523,7 +2513,7 @@ function TUMLAction._Gettarget: String; Result := M_target.AsString; end; -procedure TUMLAction._Settarget(NewValue: String); +procedure TUMLAction._Settarget(const NewValue: String); begin M_target.AsString := NewValue; end; @@ -2539,7 +2529,7 @@ function TUMLAction._GetisAsynchronous: boolean; Result := M_isAsynchronous.AsBoolean; end; -procedure TUMLAction._SetisAsynchronous(NewValue: boolean); +procedure TUMLAction._SetisAsynchronous(const NewValue: boolean); begin M_isAsynchronous.AsBoolean := NewValue; end; @@ -2555,7 +2545,7 @@ function TUMLAction._Getscript: String; Result := M_script.AsString; end; -procedure TUMLAction._Setscript(NewValue: String); +procedure TUMLAction._Setscript(const NewValue: String); begin M_script.AsString := NewValue; end; @@ -2568,11 +2558,11 @@ function TUMLAction._Get_M_transition: TBoldObjectReference; function TUMLAction._Gettransition: TUMLTransition; begin - assert(not assigned(M_transition.BoldObject) or (M_transition.BoldObject is TUMLTransition), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'transition', M_transition.BoldObject.ClassName, 'TUMLTransition'])); Result := TUMLTransition(M_transition.BoldObject); + assert(not assigned(Result) or (Result is TUMLTransition), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'transition', Result.ClassName, 'TUMLTransition'])); end; -procedure TUMLAction._Settransition(value: TUMLTransition); +procedure TUMLAction._Settransition(const value: TUMLTransition); begin M_transition.BoldObject := value; end; @@ -2597,11 +2587,11 @@ function TUMLAction._Get_M_actionSequence: TBoldObjectReference; function TUMLAction._GetactionSequence: TUMLActionSequence; begin - assert(not assigned(M_actionSequence.BoldObject) or (M_actionSequence.BoldObject is TUMLActionSequence), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'actionSequence', M_actionSequence.BoldObject.ClassName, 'TUMLActionSequence'])); Result := TUMLActionSequence(M_actionSequence.BoldObject); + assert(not assigned(Result) or (Result is TUMLActionSequence), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'actionSequence', Result.ClassName, 'TUMLActionSequence'])); end; -procedure TUMLAction._SetactionSequence(value: TUMLActionSequence); +procedure TUMLAction._SetactionSequence(const value: TUMLActionSequence); begin M_actionSequence.BoldObject := value; end; @@ -2662,7 +2652,7 @@ function TUMLArgument._Getvalue: String; Result := M_value.AsString; end; -procedure TUMLArgument._Setvalue(NewValue: String); +procedure TUMLArgument._Setvalue(const NewValue: String); begin M_value.AsString := NewValue; end; @@ -2675,11 +2665,11 @@ function TUMLArgument._Get_M_action: TBoldObjectReference; function TUMLArgument._Getaction: TUMLAction; begin - assert(not assigned(M_action.BoldObject) or (M_action.BoldObject is TUMLAction), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'action', M_action.BoldObject.ClassName, 'TUMLAction'])); Result := TUMLAction(M_action.BoldObject); + assert(not assigned(Result) or (Result is TUMLAction), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'action', Result.ClassName, 'TUMLAction'])); end; -procedure TUMLArgument._Setaction(value: TUMLAction); +procedure TUMLArgument._Setaction(const value: TUMLAction); begin M_action.BoldObject := value; end; @@ -2734,7 +2724,7 @@ function TUMLAssociationEnd._GetisNavigable: boolean; Result := M_isNavigable.AsBoolean; end; -procedure TUMLAssociationEnd._SetisNavigable(NewValue: boolean); +procedure TUMLAssociationEnd._SetisNavigable(const NewValue: boolean); begin M_isNavigable.AsBoolean := NewValue; end; @@ -2750,7 +2740,7 @@ function TUMLAssociationEnd._Getordering: TOrderingKind; Result := M_ordering.AsOrderingKind; end; -procedure TUMLAssociationEnd._Setordering(NewValue: TOrderingKind); +procedure TUMLAssociationEnd._Setordering(const NewValue: TOrderingKind); begin M_ordering.AsOrderingKind := NewValue; end; @@ -2766,7 +2756,7 @@ function TUMLAssociationEnd._Getaggregation: TAggregationKind; Result := M_aggregation.AsAggregationKind; end; -procedure TUMLAssociationEnd._Setaggregation(NewValue: TAggregationKind); +procedure TUMLAssociationEnd._Setaggregation(const NewValue: TAggregationKind); begin M_aggregation.AsAggregationKind := NewValue; end; @@ -2782,7 +2772,7 @@ function TUMLAssociationEnd._GettargetScope: TScopeKind; Result := M_targetScope.AsScopeKind; end; -procedure TUMLAssociationEnd._SettargetScope(NewValue: TScopeKind); +procedure TUMLAssociationEnd._SettargetScope(const NewValue: TScopeKind); begin M_targetScope.AsScopeKind := NewValue; end; @@ -2798,7 +2788,7 @@ function TUMLAssociationEnd._Getmultiplicity: String; Result := M_multiplicity.AsString; end; -procedure TUMLAssociationEnd._Setmultiplicity(NewValue: String); +procedure TUMLAssociationEnd._Setmultiplicity(const NewValue: String); begin M_multiplicity.AsString := NewValue; end; @@ -2814,7 +2804,7 @@ function TUMLAssociationEnd._Getchangeability: TChangeableKind; Result := M_changeability.AsChangeableKind; end; -procedure TUMLAssociationEnd._Setchangeability(NewValue: TChangeableKind); +procedure TUMLAssociationEnd._Setchangeability(const NewValue: TChangeableKind); begin M_changeability.AsChangeableKind := NewValue; end; @@ -2852,7 +2842,7 @@ function TUMLAssociationEnd._GetisOrdered: boolean; Result := M_isOrdered.AsBoolean; end; -procedure TUMLAssociationEnd._SetisOrdered(NewValue: boolean); +procedure TUMLAssociationEnd._SetisOrdered(const NewValue: boolean); begin M_isOrdered.AsBoolean := NewValue; end; @@ -2895,11 +2885,11 @@ function TUMLAssociationEnd._Get_M_type_: TBoldObjectReference; function TUMLAssociationEnd._Gettype_: TUMLClassifier; begin - assert(not assigned(M_type_.BoldObject) or (M_type_.BoldObject is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'type_', M_type_.BoldObject.ClassName, 'TUMLClassifier'])); Result := TUMLClassifier(M_type_.BoldObject); + assert(not assigned(Result) or (Result is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'type_', Result.ClassName, 'TUMLClassifier'])); end; -procedure TUMLAssociationEnd._Settype_(value: TUMLClassifier); +procedure TUMLAssociationEnd._Settype_(const value: TUMLClassifier); begin M_type_.BoldObject := value; end; @@ -2912,11 +2902,11 @@ function TUMLAssociationEnd._Get_M_otherEnd: TBoldObjectReference; function TUMLAssociationEnd._GetotherEnd: TUMLAssociationEnd; begin - assert(not assigned(M_otherEnd.BoldObject) or (M_otherEnd.BoldObject is TUMLAssociationEnd), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'otherEnd', M_otherEnd.BoldObject.ClassName, 'TUMLAssociationEnd'])); Result := TUMLAssociationEnd(M_otherEnd.BoldObject); + assert(not assigned(Result) or (Result is TUMLAssociationEnd), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'otherEnd', Result.ClassName, 'TUMLAssociationEnd'])); end; -procedure TUMLAssociationEnd._SetotherEnd(value: TUMLAssociationEnd); +procedure TUMLAssociationEnd._SetotherEnd(const value: TUMLAssociationEnd); begin M_otherEnd.BoldObject := value; end; @@ -2929,11 +2919,11 @@ function TUMLAssociationEnd._Get_M_association: TBoldObjectReference; function TUMLAssociationEnd._Getassociation: TUMLAssociation; begin - assert(not assigned(M_association.BoldObject) or (M_association.BoldObject is TUMLAssociation), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'association', M_association.BoldObject.ClassName, 'TUMLAssociation'])); Result := TUMLAssociation(M_association.BoldObject); + assert(not assigned(Result) or (Result is TUMLAssociation), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'association', Result.ClassName, 'TUMLAssociation'])); end; -procedure TUMLAssociationEnd._Setassociation(value: TUMLAssociation); +procedure TUMLAssociationEnd._Setassociation(const value: TUMLAssociation); begin M_association.BoldObject := value; end; @@ -2975,18 +2965,22 @@ procedure TUMLAssociationEndList.SetBoldObject(index: Integer; NewObject: TUMLAs SetElement(index, NewObject); end; -function TUMLAssociationEnd.GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; +function TUMLAssociationEnd.GetDeriveMethodForMember(MemberIndex: Integer): TBoldDeriveAndResubscribe; begin - if (Member = M_multi) then result := _multi_DeriveAndSubscribe else - if (Member = M_mandatory) then result := _mandatory_DeriveAndSubscribe else - if (Member = M_isOrdered) then result := _isOrdered_DeriveAndSubscribe else - result := inherited GetDeriveMethodForMember(Member); + case MemberIndex of + 46: result := _multi_DeriveAndSubscribe; + 47: result := _mandatory_DeriveAndSubscribe; + 48: result := _isOrdered_DeriveAndSubscribe; + else result := inherited GetDeriveMethodForMember(MemberIndex); + end; end; -function TUMLAssociationEnd.GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; +function TUMLAssociationEnd.GetReverseDeriveMethodForMember(MemberIndex: Integer): TBoldReverseDerive; begin - result := inherited GetReverseDeriveMethodForMember(Member); - if not assigned(result) and (Member = M_isOrdered) then result := _isOrdered_ReverseDerive; + case MemberIndex of + 48: result := _isOrdered_ReverseDerive; + else result := inherited GetReverseDeriveMethodForMember(MemberIndex); + end; end; { TUMLAttributeLink } @@ -2999,11 +2993,11 @@ function TUMLAttributeLink._Get_M_value: TBoldObjectReference; function TUMLAttributeLink._Getvalue: TUMLInstance; begin - assert(not assigned(M_value.BoldObject) or (M_value.BoldObject is TUMLInstance), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'value', M_value.BoldObject.ClassName, 'TUMLInstance'])); Result := TUMLInstance(M_value.BoldObject); + assert(not assigned(Result) or (Result is TUMLInstance), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'value', Result.ClassName, 'TUMLInstance'])); end; -procedure TUMLAttributeLink._Setvalue(value: TUMLInstance); +procedure TUMLAttributeLink._Setvalue(const value: TUMLInstance); begin M_value.BoldObject := value; end; @@ -3016,11 +3010,11 @@ function TUMLAttributeLink._Get_M_attribute: TBoldObjectReference; function TUMLAttributeLink._Getattribute: TUMLAttribute; begin - assert(not assigned(M_attribute.BoldObject) or (M_attribute.BoldObject is TUMLAttribute), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'attribute', M_attribute.BoldObject.ClassName, 'TUMLAttribute'])); Result := TUMLAttribute(M_attribute.BoldObject); + assert(not assigned(Result) or (Result is TUMLAttribute), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'attribute', Result.ClassName, 'TUMLAttribute'])); end; -procedure TUMLAttributeLink._Setattribute(value: TUMLAttribute); +procedure TUMLAttributeLink._Setattribute(const value: TUMLAttribute); begin M_attribute.BoldObject := value; end; @@ -3033,11 +3027,11 @@ function TUMLAttributeLink._Get_M_instance: TBoldObjectReference; function TUMLAttributeLink._Getinstance: TUMLInstance; begin - assert(not assigned(M_instance.BoldObject) or (M_instance.BoldObject is TUMLInstance), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'instance', M_instance.BoldObject.ClassName, 'TUMLInstance'])); Result := TUMLInstance(M_instance.BoldObject); + assert(not assigned(Result) or (Result is TUMLInstance), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'instance', Result.ClassName, 'TUMLInstance'])); end; -procedure TUMLAttributeLink._Setinstance(value: TUMLInstance); +procedure TUMLAttributeLink._Setinstance(const value: TUMLInstance); begin M_instance.BoldObject := value; end; @@ -3050,11 +3044,11 @@ function TUMLAttributeLink._Get_M_linkEnd: TBoldObjectReference; function TUMLAttributeLink._GetlinkEnd: TUMLLinkEnd; begin - assert(not assigned(M_linkEnd.BoldObject) or (M_linkEnd.BoldObject is TUMLLinkEnd), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'linkEnd', M_linkEnd.BoldObject.ClassName, 'TUMLLinkEnd'])); Result := TUMLLinkEnd(M_linkEnd.BoldObject); + assert(not assigned(Result) or (Result is TUMLLinkEnd), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'linkEnd', Result.ClassName, 'TUMLLinkEnd'])); end; -procedure TUMLAttributeLink._SetlinkEnd(value: TUMLLinkEnd); +procedure TUMLAttributeLink._SetlinkEnd(const value: TUMLLinkEnd); begin M_linkEnd.BoldObject := value; end; @@ -3160,7 +3154,7 @@ function TUMLConstraint._Getbody: String; Result := M_body.AsString; end; -procedure TUMLConstraint._Setbody(NewValue: String); +procedure TUMLConstraint._Setbody(const NewValue: String); begin M_body.AsString := NewValue; end; @@ -3185,11 +3179,11 @@ function TUMLConstraint._Get_M_constrainedElement2: TBoldObjectReference; function TUMLConstraint._GetconstrainedElement2: TUMLStereotype; begin - assert(not assigned(M_constrainedElement2.BoldObject) or (M_constrainedElement2.BoldObject is TUMLStereotype), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'constrainedElement2', M_constrainedElement2.BoldObject.ClassName, 'TUMLStereotype'])); Result := TUMLStereotype(M_constrainedElement2.BoldObject); + assert(not assigned(Result) or (Result is TUMLStereotype), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'constrainedElement2', Result.ClassName, 'TUMLStereotype'])); end; -procedure TUMLConstraint._SetconstrainedElement2(value: TUMLStereotype); +procedure TUMLConstraint._SetconstrainedElement2(const value: TUMLStereotype); begin M_constrainedElement2.BoldObject := value; end; @@ -3307,7 +3301,7 @@ function TUMLExtensionPoint._Getlocation: String; Result := M_location.AsString; end; -procedure TUMLExtensionPoint._Setlocation(NewValue: String); +procedure TUMLExtensionPoint._Setlocation(const NewValue: String); begin M_location.AsString := NewValue; end; @@ -3320,11 +3314,11 @@ function TUMLExtensionPoint._Get_M_useCase: TBoldObjectReference; function TUMLExtensionPoint._GetuseCase: TUMLUseCase; begin - assert(not assigned(M_useCase.BoldObject) or (M_useCase.BoldObject is TUMLUseCase), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'useCase', M_useCase.BoldObject.ClassName, 'TUMLUseCase'])); Result := TUMLUseCase(M_useCase.BoldObject); + assert(not assigned(Result) or (Result is TUMLUseCase), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'useCase', Result.ClassName, 'TUMLUseCase'])); end; -procedure TUMLExtensionPoint._SetuseCase(value: TUMLUseCase); +procedure TUMLExtensionPoint._SetuseCase(const value: TUMLUseCase); begin M_useCase.BoldObject := value; end; @@ -3391,7 +3385,7 @@ function TUMLFeature._GetownerScope: TScopeKind; Result := M_ownerScope.AsScopeKind; end; -procedure TUMLFeature._SetownerScope(NewValue: TScopeKind); +procedure TUMLFeature._SetownerScope(const NewValue: TScopeKind); begin M_ownerScope.AsScopeKind := NewValue; end; @@ -3416,11 +3410,11 @@ function TUMLFeature._Get_M_owner: TBoldObjectReference; function TUMLFeature._Getowner: TUMLClassifier; begin - assert(not assigned(M_owner.BoldObject) or (M_owner.BoldObject is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'owner', M_owner.BoldObject.ClassName, 'TUMLClassifier'])); Result := TUMLClassifier(M_owner.BoldObject); + assert(not assigned(Result) or (Result is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'owner', Result.ClassName, 'TUMLClassifier'])); end; -procedure TUMLFeature._Setowner(value: TUMLClassifier); +procedure TUMLFeature._Setowner(const value: TUMLClassifier); begin M_owner.BoldObject := value; end; @@ -3462,16 +3456,6 @@ procedure TUMLFeatureList.SetBoldObject(index: Integer; NewObject: TUMLFeature); SetElement(index, NewObject); end; -function TUMLFeature.GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; -begin - result := inherited GetDeriveMethodForMember(Member); -end; - -function TUMLFeature.GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; -begin - result := inherited GetReverseDeriveMethodForMember(Member); -end; - { TUMLGuard } function TUMLGuard._Get_M_expression: TBAString; @@ -3485,7 +3469,7 @@ function TUMLGuard._Getexpression: String; Result := M_expression.AsString; end; -procedure TUMLGuard._Setexpression(NewValue: String); +procedure TUMLGuard._Setexpression(const NewValue: String); begin M_expression.AsString := NewValue; end; @@ -3498,11 +3482,11 @@ function TUMLGuard._Get_M_transition: TBoldObjectReference; function TUMLGuard._Gettransition: TUMLTransition; begin - assert(not assigned(M_transition.BoldObject) or (M_transition.BoldObject is TUMLTransition), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'transition', M_transition.BoldObject.ClassName, 'TUMLTransition'])); Result := TUMLTransition(M_transition.BoldObject); + assert(not assigned(Result) or (Result is TUMLTransition), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'transition', Result.ClassName, 'TUMLTransition'])); end; -procedure TUMLGuard._Settransition(value: TUMLTransition); +procedure TUMLGuard._Settransition(const value: TUMLTransition); begin M_transition.BoldObject := value; end; @@ -3608,11 +3592,11 @@ function TUMLInstance._Get_M_componentInstance: TBoldObjectReference; function TUMLInstance._GetcomponentInstance: TUMLComponentInstance; begin - assert(not assigned(M_componentInstance.BoldObject) or (M_componentInstance.BoldObject is TUMLComponentInstance), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'componentInstance', M_componentInstance.BoldObject.ClassName, 'TUMLComponentInstance'])); Result := TUMLComponentInstance(M_componentInstance.BoldObject); + assert(not assigned(Result) or (Result is TUMLComponentInstance), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'componentInstance', Result.ClassName, 'TUMLComponentInstance'])); end; -procedure TUMLInstance._SetcomponentInstance(value: TUMLComponentInstance); +procedure TUMLInstance._SetcomponentInstance(const value: TUMLComponentInstance); begin M_componentInstance.BoldObject := value; end; @@ -3664,11 +3648,11 @@ function TUMLInteraction._Get_M_context: TBoldObjectReference; function TUMLInteraction._Getcontext: TUMLCollaboration; begin - assert(not assigned(M_context.BoldObject) or (M_context.BoldObject is TUMLCollaboration), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'context', M_context.BoldObject.ClassName, 'TUMLCollaboration'])); Result := TUMLCollaboration(M_context.BoldObject); + assert(not assigned(Result) or (Result is TUMLCollaboration), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'context', Result.ClassName, 'TUMLCollaboration'])); end; -procedure TUMLInteraction._Setcontext(value: TUMLCollaboration); +procedure TUMLInteraction._Setcontext(const value: TUMLCollaboration); begin M_context.BoldObject := value; end; @@ -3726,11 +3710,11 @@ function TUMLLink._Get_M_association: TBoldObjectReference; function TUMLLink._Getassociation: TUMLAssociation; begin - assert(not assigned(M_association.BoldObject) or (M_association.BoldObject is TUMLAssociation), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'association', M_association.BoldObject.ClassName, 'TUMLAssociation'])); Result := TUMLAssociation(M_association.BoldObject); + assert(not assigned(Result) or (Result is TUMLAssociation), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'association', Result.ClassName, 'TUMLAssociation'])); end; -procedure TUMLLink._Setassociation(value: TUMLAssociation); +procedure TUMLLink._Setassociation(const value: TUMLAssociation); begin M_association.BoldObject := value; end; @@ -3749,11 +3733,11 @@ function TUMLLink._Get_M_xobject: TBoldObjectReference; function TUMLLink._Getxobject: TUMLObject; begin - assert(not assigned(M_xobject.BoldObject) or (M_xobject.BoldObject is TUMLObject), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'xobject', M_xobject.BoldObject.ClassName, 'TUMLObject'])); Result := TUMLObject(M_xobject.BoldObject); + assert(not assigned(Result) or (Result is TUMLObject), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'xobject', Result.ClassName, 'TUMLObject'])); end; -procedure TUMLLink._Setxobject(value: TUMLObject); +procedure TUMLLink._Setxobject(const value: TUMLObject); begin M_xobject.BoldObject := value; end; @@ -3817,11 +3801,11 @@ function TUMLLinkEnd._Get_M_instance: TBoldObjectReference; function TUMLLinkEnd._Getinstance: TUMLInstance; begin - assert(not assigned(M_instance.BoldObject) or (M_instance.BoldObject is TUMLInstance), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'instance', M_instance.BoldObject.ClassName, 'TUMLInstance'])); Result := TUMLInstance(M_instance.BoldObject); + assert(not assigned(Result) or (Result is TUMLInstance), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'instance', Result.ClassName, 'TUMLInstance'])); end; -procedure TUMLLinkEnd._Setinstance(value: TUMLInstance); +procedure TUMLLinkEnd._Setinstance(const value: TUMLInstance); begin M_instance.BoldObject := value; end; @@ -3834,11 +3818,11 @@ function TUMLLinkEnd._Get_M_associationEnd: TBoldObjectReference; function TUMLLinkEnd._GetassociationEnd: TUMLAssociationEnd; begin - assert(not assigned(M_associationEnd.BoldObject) or (M_associationEnd.BoldObject is TUMLAssociationEnd), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'associationEnd', M_associationEnd.BoldObject.ClassName, 'TUMLAssociationEnd'])); Result := TUMLAssociationEnd(M_associationEnd.BoldObject); + assert(not assigned(Result) or (Result is TUMLAssociationEnd), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'associationEnd', Result.ClassName, 'TUMLAssociationEnd'])); end; -procedure TUMLLinkEnd._SetassociationEnd(value: TUMLAssociationEnd); +procedure TUMLLinkEnd._SetassociationEnd(const value: TUMLAssociationEnd); begin M_associationEnd.BoldObject := value; end; @@ -3851,11 +3835,11 @@ function TUMLLinkEnd._Get_M_link: TBoldObjectReference; function TUMLLinkEnd._Getlink: TUMLLink; begin - assert(not assigned(M_link.BoldObject) or (M_link.BoldObject is TUMLLink), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'link', M_link.BoldObject.ClassName, 'TUMLLink'])); Result := TUMLLink(M_link.BoldObject); + assert(not assigned(Result) or (Result is TUMLLink), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'link', Result.ClassName, 'TUMLLink'])); end; -procedure TUMLLinkEnd._Setlink(value: TUMLLink); +procedure TUMLLinkEnd._Setlink(const value: TUMLLink); begin M_link.BoldObject := value; end; @@ -3907,11 +3891,11 @@ function TUMLMessage._Get_M_interaction: TBoldObjectReference; function TUMLMessage._Getinteraction: TUMLInteraction; begin - assert(not assigned(M_interaction.BoldObject) or (M_interaction.BoldObject is TUMLInteraction), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'interaction', M_interaction.BoldObject.ClassName, 'TUMLInteraction'])); Result := TUMLInteraction(M_interaction.BoldObject); + assert(not assigned(Result) or (Result is TUMLInteraction), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'interaction', Result.ClassName, 'TUMLInteraction'])); end; -procedure TUMLMessage._Setinteraction(value: TUMLInteraction); +procedure TUMLMessage._Setinteraction(const value: TUMLInteraction); begin M_interaction.BoldObject := value; end; @@ -3924,11 +3908,11 @@ function TUMLMessage._Get_M_communicationConnection: TBoldObjectReference; function TUMLMessage._GetcommunicationConnection: TUMLAssociationRole; begin - assert(not assigned(M_communicationConnection.BoldObject) or (M_communicationConnection.BoldObject is TUMLAssociationRole), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'communicationConnection', M_communicationConnection.BoldObject.ClassName, 'TUMLAssociationRole'])); Result := TUMLAssociationRole(M_communicationConnection.BoldObject); + assert(not assigned(Result) or (Result is TUMLAssociationRole), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'communicationConnection', Result.ClassName, 'TUMLAssociationRole'])); end; -procedure TUMLMessage._SetcommunicationConnection(value: TUMLAssociationRole); +procedure TUMLMessage._SetcommunicationConnection(const value: TUMLAssociationRole); begin M_communicationConnection.BoldObject := value; end; @@ -3941,11 +3925,11 @@ function TUMLMessage._Get_M_action: TBoldObjectReference; function TUMLMessage._Getaction: TUMLAction; begin - assert(not assigned(M_action.BoldObject) or (M_action.BoldObject is TUMLAction), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'action', M_action.BoldObject.ClassName, 'TUMLAction'])); Result := TUMLAction(M_action.BoldObject); + assert(not assigned(Result) or (Result is TUMLAction), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'action', Result.ClassName, 'TUMLAction'])); end; -procedure TUMLMessage._Setaction(value: TUMLAction); +procedure TUMLMessage._Setaction(const value: TUMLAction); begin M_action.BoldObject := value; end; @@ -3988,11 +3972,11 @@ function TUMLMessage._Get_M_activator: TBoldObjectReference; function TUMLMessage._Getactivator: TUMLMessage; begin - assert(not assigned(M_activator.BoldObject) or (M_activator.BoldObject is TUMLMessage), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'activator', M_activator.BoldObject.ClassName, 'TUMLMessage'])); Result := TUMLMessage(M_activator.BoldObject); + assert(not assigned(Result) or (Result is TUMLMessage), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'activator', Result.ClassName, 'TUMLMessage'])); end; -procedure TUMLMessage._Setactivator(value: TUMLMessage); +procedure TUMLMessage._Setactivator(const value: TUMLMessage); begin M_activator.BoldObject := value; end; @@ -4005,11 +3989,11 @@ function TUMLMessage._Get_M_receiver: TBoldObjectReference; function TUMLMessage._Getreceiver: TUMLClassifierRole; begin - assert(not assigned(M_receiver.BoldObject) or (M_receiver.BoldObject is TUMLClassifierRole), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'receiver', M_receiver.BoldObject.ClassName, 'TUMLClassifierRole'])); Result := TUMLClassifierRole(M_receiver.BoldObject); + assert(not assigned(Result) or (Result is TUMLClassifierRole), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'receiver', Result.ClassName, 'TUMLClassifierRole'])); end; -procedure TUMLMessage._Setreceiver(value: TUMLClassifierRole); +procedure TUMLMessage._Setreceiver(const value: TUMLClassifierRole); begin M_receiver.BoldObject := value; end; @@ -4022,11 +4006,11 @@ function TUMLMessage._Get_M_sender: TBoldObjectReference; function TUMLMessage._Getsender: TUMLClassifierRole; begin - assert(not assigned(M_sender.BoldObject) or (M_sender.BoldObject is TUMLClassifierRole), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'sender', M_sender.BoldObject.ClassName, 'TUMLClassifierRole'])); Result := TUMLClassifierRole(M_sender.BoldObject); + assert(not assigned(Result) or (Result is TUMLClassifierRole), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'sender', Result.ClassName, 'TUMLClassifierRole'])); end; -procedure TUMLMessage._Setsender(value: TUMLClassifierRole); +procedure TUMLMessage._Setsender(const value: TUMLClassifierRole); begin M_sender.BoldObject := value; end; @@ -4144,7 +4128,7 @@ function TUMLParameter._GetdefaultValue: String; Result := M_defaultValue.AsString; end; -procedure TUMLParameter._SetdefaultValue(NewValue: String); +procedure TUMLParameter._SetdefaultValue(const NewValue: String); begin M_defaultValue.AsString := NewValue; end; @@ -4160,7 +4144,7 @@ function TUMLParameter._Getkind: TBoldParameterDirectionKind; Result := M_kind.AsParameterDirectionKind; end; -procedure TUMLParameter._Setkind(NewValue: TBoldParameterDirectionKind); +procedure TUMLParameter._Setkind(const NewValue: TBoldParameterDirectionKind); begin M_kind.AsParameterDirectionKind := NewValue; end; @@ -4176,7 +4160,7 @@ function TUMLParameter._GettypeName: String; Result := M_typeName.AsString; end; -procedure TUMLParameter._SettypeName(NewValue: String); +procedure TUMLParameter._SettypeName(const NewValue: String); begin M_typeName.AsString := NewValue; end; @@ -4189,11 +4173,11 @@ function TUMLParameter._Get_M_event: TBoldObjectReference; function TUMLParameter._Getevent: TUMLEvent; begin - assert(not assigned(M_event.BoldObject) or (M_event.BoldObject is TUMLEvent), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'event', M_event.BoldObject.ClassName, 'TUMLEvent'])); Result := TUMLEvent(M_event.BoldObject); + assert(not assigned(Result) or (Result is TUMLEvent), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'event', Result.ClassName, 'TUMLEvent'])); end; -procedure TUMLParameter._Setevent(value: TUMLEvent); +procedure TUMLParameter._Setevent(const value: TUMLEvent); begin M_event.BoldObject := value; end; @@ -4218,11 +4202,11 @@ function TUMLParameter._Get_M_type_: TBoldObjectReference; function TUMLParameter._Gettype_: TUMLClassifier; begin - assert(not assigned(M_type_.BoldObject) or (M_type_.BoldObject is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'type_', M_type_.BoldObject.ClassName, 'TUMLClassifier'])); Result := TUMLClassifier(M_type_.BoldObject); + assert(not assigned(Result) or (Result is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'type_', Result.ClassName, 'TUMLClassifier'])); end; -procedure TUMLParameter._Settype_(value: TUMLClassifier); +procedure TUMLParameter._Settype_(const value: TUMLClassifier); begin M_type_.BoldObject := value; end; @@ -4235,11 +4219,11 @@ function TUMLParameter._Get_M_behavioralFeature: TBoldObjectReference; function TUMLParameter._GetbehavioralFeature: TUMLBehavioralFeature; begin - assert(not assigned(M_behavioralFeature.BoldObject) or (M_behavioralFeature.BoldObject is TUMLBehavioralFeature), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'behavioralFeature', M_behavioralFeature.BoldObject.ClassName, 'TUMLBehavioralFeature'])); Result := TUMLBehavioralFeature(M_behavioralFeature.BoldObject); + assert(not assigned(Result) or (Result is TUMLBehavioralFeature), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'behavioralFeature', Result.ClassName, 'TUMLBehavioralFeature'])); end; -procedure TUMLParameter._SetbehavioralFeature(value: TUMLBehavioralFeature); +procedure TUMLParameter._SetbehavioralFeature(const value: TUMLBehavioralFeature); begin M_behavioralFeature.BoldObject := value; end; @@ -4281,16 +4265,20 @@ procedure TUMLParameterList.SetBoldObject(index: Integer; NewObject: TUMLParamet SetElement(index, NewObject); end; -function TUMLParameter.GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; +function TUMLParameter.GetDeriveMethodForMember(MemberIndex: Integer): TBoldDeriveAndResubscribe; begin - if (Member = M_typeName) then result := _typeName_DeriveAndSubscribe else - result := inherited GetDeriveMethodForMember(Member); + case MemberIndex of + 42: result := _typeName_DeriveAndSubscribe; + else result := inherited GetDeriveMethodForMember(MemberIndex); + end; end; -function TUMLParameter.GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; +function TUMLParameter.GetReverseDeriveMethodForMember(MemberIndex: Integer): TBoldReverseDerive; begin - result := inherited GetReverseDeriveMethodForMember(Member); - if not assigned(result) and (Member = M_typeName) then result := _typeName_ReverseDerive; + case MemberIndex of + 42: result := _typeName_ReverseDerive; + else result := inherited GetReverseDeriveMethodForMember(MemberIndex); + end; end; { TUMLPartition } @@ -4315,11 +4303,11 @@ function TUMLPartition._Get_M_activityGraph: TBoldObjectReference; function TUMLPartition._GetactivityGraph: TUMLActivityGraph; begin - assert(not assigned(M_activityGraph.BoldObject) or (M_activityGraph.BoldObject is TUMLActivityGraph), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'activityGraph', M_activityGraph.BoldObject.ClassName, 'TUMLActivityGraph'])); Result := TUMLActivityGraph(M_activityGraph.BoldObject); + assert(not assigned(Result) or (Result is TUMLActivityGraph), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'activityGraph', Result.ClassName, 'TUMLActivityGraph'])); end; -procedure TUMLPartition._SetactivityGraph(value: TUMLActivityGraph); +procedure TUMLPartition._SetactivityGraph(const value: TUMLActivityGraph); begin M_activityGraph.BoldObject := value; end; @@ -4422,11 +4410,11 @@ function TUMLStateMachine._Get_M_context: TBoldObjectReference; function TUMLStateMachine._Getcontext: TUMLModelElement; begin - assert(not assigned(M_context.BoldObject) or (M_context.BoldObject is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'context', M_context.BoldObject.ClassName, 'TUMLModelElement'])); Result := TUMLModelElement(M_context.BoldObject); + assert(not assigned(Result) or (Result is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'context', Result.ClassName, 'TUMLModelElement'])); end; -procedure TUMLStateMachine._Setcontext(value: TUMLModelElement); +procedure TUMLStateMachine._Setcontext(const value: TUMLModelElement); begin M_context.BoldObject := value; end; @@ -4439,11 +4427,11 @@ function TUMLStateMachine._Get_M_top: TBoldObjectReference; function TUMLStateMachine._Gettop: TUMLState; begin - assert(not assigned(M_top.BoldObject) or (M_top.BoldObject is TUMLState), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'top', M_top.BoldObject.ClassName, 'TUMLState'])); Result := TUMLState(M_top.BoldObject); + assert(not assigned(Result) or (Result is TUMLState), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'top', Result.ClassName, 'TUMLState'])); end; -procedure TUMLStateMachine._Settop(value: TUMLState); +procedure TUMLStateMachine._Settop(const value: TUMLState); begin M_top.BoldObject := value; end; @@ -4495,11 +4483,11 @@ function TUMLStateVertex._Get_M_container: TBoldObjectReference; function TUMLStateVertex._Getcontainer: TUMLCompositeState; begin - assert(not assigned(M_container.BoldObject) or (M_container.BoldObject is TUMLCompositeState), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'container', M_container.BoldObject.ClassName, 'TUMLCompositeState'])); Result := TUMLCompositeState(M_container.BoldObject); + assert(not assigned(Result) or (Result is TUMLCompositeState), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'container', Result.ClassName, 'TUMLCompositeState'])); end; -procedure TUMLStateVertex._Setcontainer(value: TUMLCompositeState); +procedure TUMLStateVertex._Setcontainer(const value: TUMLCompositeState); begin M_container.BoldObject := value; end; @@ -4575,11 +4563,11 @@ function TUMLStimulus._Get_M_dispatchAction: TBoldObjectReference; function TUMLStimulus._GetdispatchAction: TUMLAction; begin - assert(not assigned(M_dispatchAction.BoldObject) or (M_dispatchAction.BoldObject is TUMLAction), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'dispatchAction', M_dispatchAction.BoldObject.ClassName, 'TUMLAction'])); Result := TUMLAction(M_dispatchAction.BoldObject); + assert(not assigned(Result) or (Result is TUMLAction), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'dispatchAction', Result.ClassName, 'TUMLAction'])); end; -procedure TUMLStimulus._SetdispatchAction(value: TUMLAction); +procedure TUMLStimulus._SetdispatchAction(const value: TUMLAction); begin M_dispatchAction.BoldObject := value; end; @@ -4592,11 +4580,11 @@ function TUMLStimulus._Get_M_communicationLink: TBoldObjectReference; function TUMLStimulus._GetcommunicationLink: TUMLLink; begin - assert(not assigned(M_communicationLink.BoldObject) or (M_communicationLink.BoldObject is TUMLLink), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'communicationLink', M_communicationLink.BoldObject.ClassName, 'TUMLLink'])); Result := TUMLLink(M_communicationLink.BoldObject); + assert(not assigned(Result) or (Result is TUMLLink), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'communicationLink', Result.ClassName, 'TUMLLink'])); end; -procedure TUMLStimulus._SetcommunicationLink(value: TUMLLink); +procedure TUMLStimulus._SetcommunicationLink(const value: TUMLLink); begin M_communicationLink.BoldObject := value; end; @@ -4609,11 +4597,11 @@ function TUMLStimulus._Get_M_receiver: TBoldObjectReference; function TUMLStimulus._Getreceiver: TUMLInstance; begin - assert(not assigned(M_receiver.BoldObject) or (M_receiver.BoldObject is TUMLInstance), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'receiver', M_receiver.BoldObject.ClassName, 'TUMLInstance'])); Result := TUMLInstance(M_receiver.BoldObject); + assert(not assigned(Result) or (Result is TUMLInstance), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'receiver', Result.ClassName, 'TUMLInstance'])); end; -procedure TUMLStimulus._Setreceiver(value: TUMLInstance); +procedure TUMLStimulus._Setreceiver(const value: TUMLInstance); begin M_receiver.BoldObject := value; end; @@ -4626,11 +4614,11 @@ function TUMLStimulus._Get_M_sender: TBoldObjectReference; function TUMLStimulus._Getsender: TUMLInstance; begin - assert(not assigned(M_sender.BoldObject) or (M_sender.BoldObject is TUMLInstance), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'sender', M_sender.BoldObject.ClassName, 'TUMLInstance'])); Result := TUMLInstance(M_sender.BoldObject); + assert(not assigned(Result) or (Result is TUMLInstance), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'sender', Result.ClassName, 'TUMLInstance'])); end; -procedure TUMLStimulus._Setsender(value: TUMLInstance); +procedure TUMLStimulus._Setsender(const value: TUMLInstance); begin M_sender.BoldObject := value; end; @@ -4685,7 +4673,7 @@ function TUMLTaggedValue._Gettag: String; Result := M_tag.AsString; end; -procedure TUMLTaggedValue._Settag(NewValue: String); +procedure TUMLTaggedValue._Settag(const NewValue: String); begin M_tag.AsString := NewValue; end; @@ -4701,7 +4689,7 @@ function TUMLTaggedValue._Getvalue: String; Result := M_value.AsString; end; -procedure TUMLTaggedValue._Setvalue(NewValue: String); +procedure TUMLTaggedValue._Setvalue(const NewValue: String); begin M_value.AsString := NewValue; end; @@ -4714,11 +4702,11 @@ function TUMLTaggedValue._Get_M_modelElement: TBoldObjectReference; function TUMLTaggedValue._GetmodelElement: TUMLModelElement; begin - assert(not assigned(M_modelElement.BoldObject) or (M_modelElement.BoldObject is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'modelElement', M_modelElement.BoldObject.ClassName, 'TUMLModelElement'])); Result := TUMLModelElement(M_modelElement.BoldObject); + assert(not assigned(Result) or (Result is TUMLModelElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'modelElement', Result.ClassName, 'TUMLModelElement'])); end; -procedure TUMLTaggedValue._SetmodelElement(value: TUMLModelElement); +procedure TUMLTaggedValue._SetmodelElement(const value: TUMLModelElement); begin M_modelElement.BoldObject := value; end; @@ -4731,11 +4719,11 @@ function TUMLTaggedValue._Get_M_stereotype_: TBoldObjectReference; function TUMLTaggedValue._Getstereotype_: TUMLStereotype; begin - assert(not assigned(M_stereotype_.BoldObject) or (M_stereotype_.BoldObject is TUMLStereotype), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'stereotype_', M_stereotype_.BoldObject.ClassName, 'TUMLStereotype'])); Result := TUMLStereotype(M_stereotype_.BoldObject); + assert(not assigned(Result) or (Result is TUMLStereotype), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'stereotype_', Result.ClassName, 'TUMLStereotype'])); end; -procedure TUMLTaggedValue._Setstereotype_(value: TUMLStereotype); +procedure TUMLTaggedValue._Setstereotype_(const value: TUMLStereotype); begin M_stereotype_.BoldObject := value; end; @@ -4787,11 +4775,11 @@ function TUMLTransition._Get_M_State: TBoldObjectReference; function TUMLTransition._GetState: TUMLState; begin - assert(not assigned(M_State.BoldObject) or (M_State.BoldObject is TUMLState), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'State', M_State.BoldObject.ClassName, 'TUMLState'])); Result := TUMLState(M_State.BoldObject); + assert(not assigned(Result) or (Result is TUMLState), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'State', Result.ClassName, 'TUMLState'])); end; -procedure TUMLTransition._SetState(value: TUMLState); +procedure TUMLTransition._SetState(const value: TUMLState); begin M_State.BoldObject := value; end; @@ -4804,11 +4792,11 @@ function TUMLTransition._Get_M_trigger: TBoldObjectReference; function TUMLTransition._Gettrigger: TUMLEvent; begin - assert(not assigned(M_trigger.BoldObject) or (M_trigger.BoldObject is TUMLEvent), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'trigger', M_trigger.BoldObject.ClassName, 'TUMLEvent'])); Result := TUMLEvent(M_trigger.BoldObject); + assert(not assigned(Result) or (Result is TUMLEvent), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'trigger', Result.ClassName, 'TUMLEvent'])); end; -procedure TUMLTransition._Settrigger(value: TUMLEvent); +procedure TUMLTransition._Settrigger(const value: TUMLEvent); begin M_trigger.BoldObject := value; end; @@ -4821,11 +4809,11 @@ function TUMLTransition._Get_M_effect: TBoldObjectReference; function TUMLTransition._Geteffect: TUMLAction; begin - assert(not assigned(M_effect.BoldObject) or (M_effect.BoldObject is TUMLAction), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'effect', M_effect.BoldObject.ClassName, 'TUMLAction'])); Result := TUMLAction(M_effect.BoldObject); + assert(not assigned(Result) or (Result is TUMLAction), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'effect', Result.ClassName, 'TUMLAction'])); end; -procedure TUMLTransition._Seteffect(value: TUMLAction); +procedure TUMLTransition._Seteffect(const value: TUMLAction); begin M_effect.BoldObject := value; end; @@ -4838,11 +4826,11 @@ function TUMLTransition._Get_M_stateMachine: TBoldObjectReference; function TUMLTransition._GetstateMachine: TUMLStateMachine; begin - assert(not assigned(M_stateMachine.BoldObject) or (M_stateMachine.BoldObject is TUMLStateMachine), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'stateMachine', M_stateMachine.BoldObject.ClassName, 'TUMLStateMachine'])); Result := TUMLStateMachine(M_stateMachine.BoldObject); + assert(not assigned(Result) or (Result is TUMLStateMachine), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'stateMachine', Result.ClassName, 'TUMLStateMachine'])); end; -procedure TUMLTransition._SetstateMachine(value: TUMLStateMachine); +procedure TUMLTransition._SetstateMachine(const value: TUMLStateMachine); begin M_stateMachine.BoldObject := value; end; @@ -4855,11 +4843,11 @@ function TUMLTransition._Get_M_source: TBoldObjectReference; function TUMLTransition._Getsource: TUMLStateVertex; begin - assert(not assigned(M_source.BoldObject) or (M_source.BoldObject is TUMLStateVertex), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'source', M_source.BoldObject.ClassName, 'TUMLStateVertex'])); Result := TUMLStateVertex(M_source.BoldObject); + assert(not assigned(Result) or (Result is TUMLStateVertex), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'source', Result.ClassName, 'TUMLStateVertex'])); end; -procedure TUMLTransition._Setsource(value: TUMLStateVertex); +procedure TUMLTransition._Setsource(const value: TUMLStateVertex); begin M_source.BoldObject := value; end; @@ -4872,11 +4860,11 @@ function TUMLTransition._Get_M_target: TBoldObjectReference; function TUMLTransition._Gettarget: TUMLStateVertex; begin - assert(not assigned(M_target.BoldObject) or (M_target.BoldObject is TUMLStateVertex), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'target', M_target.BoldObject.ClassName, 'TUMLStateVertex'])); Result := TUMLStateVertex(M_target.BoldObject); + assert(not assigned(Result) or (Result is TUMLStateVertex), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'target', Result.ClassName, 'TUMLStateVertex'])); end; -procedure TUMLTransition._Settarget(value: TUMLStateVertex); +procedure TUMLTransition._Settarget(const value: TUMLStateVertex); begin M_target.BoldObject := value; end; @@ -4889,11 +4877,11 @@ function TUMLTransition._Get_M_guard: TBoldObjectReference; function TUMLTransition._Getguard: TUMLGuard; begin - assert(not assigned(M_guard.BoldObject) or (M_guard.BoldObject is TUMLGuard), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'guard', M_guard.BoldObject.ClassName, 'TUMLGuard'])); Result := TUMLGuard(M_guard.BoldObject); + assert(not assigned(Result) or (Result is TUMLGuard), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'guard', Result.ClassName, 'TUMLGuard'])); end; -procedure TUMLTransition._Setguard(value: TUMLGuard); +procedure TUMLTransition._Setguard(const value: TUMLGuard); begin M_guard.BoldObject := value; end; @@ -4990,11 +4978,11 @@ function TUMLCallAction._Get_M_operation: TBoldObjectReference; function TUMLCallAction._Getoperation: TUMLOperation; begin - assert(not assigned(M_operation.BoldObject) or (M_operation.BoldObject is TUMLOperation), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'operation', M_operation.BoldObject.ClassName, 'TUMLOperation'])); Result := TUMLOperation(M_operation.BoldObject); + assert(not assigned(Result) or (Result is TUMLOperation), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'operation', Result.ClassName, 'TUMLOperation'])); end; -procedure TUMLCallAction._Setoperation(value: TUMLOperation); +procedure TUMLCallAction._Setoperation(const value: TUMLOperation); begin M_operation.BoldObject := value; end; @@ -5046,11 +5034,11 @@ function TUMLCreateAction._Get_M_instantiation: TBoldObjectReference; function TUMLCreateAction._Getinstantiation: TUMLClassifier; begin - assert(not assigned(M_instantiation.BoldObject) or (M_instantiation.BoldObject is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'instantiation', M_instantiation.BoldObject.ClassName, 'TUMLClassifier'])); Result := TUMLClassifier(M_instantiation.BoldObject); + assert(not assigned(Result) or (Result is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'instantiation', Result.ClassName, 'TUMLClassifier'])); end; -procedure TUMLCreateAction._Setinstantiation(value: TUMLClassifier); +procedure TUMLCreateAction._Setinstantiation(const value: TUMLClassifier); begin M_instantiation.BoldObject := value; end; @@ -5180,11 +5168,11 @@ function TUMLSendAction._Get_M_signal: TBoldObjectReference; function TUMLSendAction._Getsignal: TUMLSignal; begin - assert(not assigned(M_signal.BoldObject) or (M_signal.BoldObject is TUMLSignal), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'signal', M_signal.BoldObject.ClassName, 'TUMLSignal'])); Result := TUMLSignal(M_signal.BoldObject); + assert(not assigned(Result) or (Result is TUMLSignal), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'signal', Result.ClassName, 'TUMLSignal'])); end; -procedure TUMLSendAction._Setsignal(value: TUMLSignal); +procedure TUMLSendAction._Setsignal(const value: TUMLSignal); begin M_signal.BoldObject := value; end; @@ -5317,7 +5305,7 @@ function TUMLAssociationEndRole._GetcollaborationMultiplicity: String; Result := M_collaborationMultiplicity.AsString; end; -procedure TUMLAssociationEndRole._SetcollaborationMultiplicity(NewValue: String); +procedure TUMLAssociationEndRole._SetcollaborationMultiplicity(const NewValue: String); begin M_collaborationMultiplicity.AsString := NewValue; end; @@ -5330,11 +5318,11 @@ function TUMLAssociationEndRole._Get_M_base: TBoldObjectReference; function TUMLAssociationEndRole._Getbase: TUMLAssociationEnd; begin - assert(not assigned(M_base.BoldObject) or (M_base.BoldObject is TUMLAssociationEnd), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'base', M_base.BoldObject.ClassName, 'TUMLAssociationEnd'])); Result := TUMLAssociationEnd(M_base.BoldObject); + assert(not assigned(Result) or (Result is TUMLAssociationEnd), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'base', Result.ClassName, 'TUMLAssociationEnd'])); end; -procedure TUMLAssociationEndRole._Setbase(value: TUMLAssociationEnd); +procedure TUMLAssociationEndRole._Setbase(const value: TUMLAssociationEnd); begin M_base.BoldObject := value; end; @@ -5398,11 +5386,11 @@ function TUMLCallEvent._Get_M_operation: TBoldObjectReference; function TUMLCallEvent._Getoperation: TUMLOperation; begin - assert(not assigned(M_operation.BoldObject) or (M_operation.BoldObject is TUMLOperation), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'operation', M_operation.BoldObject.ClassName, 'TUMLOperation'])); Result := TUMLOperation(M_operation.BoldObject); + assert(not assigned(Result) or (Result is TUMLOperation), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'operation', Result.ClassName, 'TUMLOperation'])); end; -procedure TUMLCallEvent._Setoperation(value: TUMLOperation); +procedure TUMLCallEvent._Setoperation(const value: TUMLOperation); begin M_operation.BoldObject := value; end; @@ -5457,7 +5445,7 @@ function TUMLChangeEvent._GetchangeExpression: String; Result := M_changeExpression.AsString; end; -procedure TUMLChangeEvent._SetchangeExpression(NewValue: String); +procedure TUMLChangeEvent._SetchangeExpression(const NewValue: String); begin M_changeExpression.AsString := NewValue; end; @@ -5509,11 +5497,11 @@ function TUMLSignalEvent._Get_M_signal: TBoldObjectReference; function TUMLSignalEvent._Getsignal: TUMLSignal; begin - assert(not assigned(M_signal.BoldObject) or (M_signal.BoldObject is TUMLSignal), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'signal', M_signal.BoldObject.ClassName, 'TUMLSignal'])); Result := TUMLSignal(M_signal.BoldObject); + assert(not assigned(Result) or (Result is TUMLSignal), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'signal', Result.ClassName, 'TUMLSignal'])); end; -procedure TUMLSignalEvent._Setsignal(value: TUMLSignal); +procedure TUMLSignalEvent._Setsignal(const value: TUMLSignal); begin M_signal.BoldObject := value; end; @@ -5568,7 +5556,7 @@ function TUMLTimeEvent._Getwhen: String; Result := M_when.AsString; end; -procedure TUMLTimeEvent._Setwhen(NewValue: String); +procedure TUMLTimeEvent._Setwhen(const NewValue: String); begin M_when.AsString := NewValue; end; @@ -5623,7 +5611,7 @@ function TUMLBehavioralFeature._GetisQuery: boolean; Result := M_isQuery.AsBoolean; end; -procedure TUMLBehavioralFeature._SetisQuery(NewValue: boolean); +procedure TUMLBehavioralFeature._SetisQuery(const NewValue: boolean); begin M_isQuery.AsBoolean := NewValue; end; @@ -5696,7 +5684,7 @@ function TUMLStructuralFeature._Getmultiplicity: String; Result := M_multiplicity.AsString; end; -procedure TUMLStructuralFeature._Setmultiplicity(NewValue: String); +procedure TUMLStructuralFeature._Setmultiplicity(const NewValue: String); begin M_multiplicity.AsString := NewValue; end; @@ -5712,7 +5700,7 @@ function TUMLStructuralFeature._Getchangeability: TChangeableKind; Result := M_changeability.AsChangeableKind; end; -procedure TUMLStructuralFeature._Setchangeability(NewValue: TChangeableKind); +procedure TUMLStructuralFeature._Setchangeability(const NewValue: TChangeableKind); begin M_changeability.AsChangeableKind := NewValue; end; @@ -5728,7 +5716,7 @@ function TUMLStructuralFeature._GettargetScope: TScopeKind; Result := M_targetScope.AsScopeKind; end; -procedure TUMLStructuralFeature._SettargetScope(NewValue: TScopeKind); +procedure TUMLStructuralFeature._SettargetScope(const NewValue: TScopeKind); begin M_targetScope.AsScopeKind := NewValue; end; @@ -5744,7 +5732,7 @@ function TUMLStructuralFeature._GettypeName: String; Result := M_typeName.AsString; end; -procedure TUMLStructuralFeature._SettypeName(NewValue: String); +procedure TUMLStructuralFeature._SettypeName(const NewValue: String); begin M_typeName.AsString := NewValue; end; @@ -5757,11 +5745,11 @@ function TUMLStructuralFeature._Get_M_type_: TBoldObjectReference; function TUMLStructuralFeature._Gettype_: TUMLClassifier; begin - assert(not assigned(M_type_.BoldObject) or (M_type_.BoldObject is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'type_', M_type_.BoldObject.ClassName, 'TUMLClassifier'])); Result := TUMLClassifier(M_type_.BoldObject); + assert(not assigned(Result) or (Result is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'type_', Result.ClassName, 'TUMLClassifier'])); end; -procedure TUMLStructuralFeature._Settype_(value: TUMLClassifier); +procedure TUMLStructuralFeature._Settype_(const value: TUMLClassifier); begin M_type_.BoldObject := value; end; @@ -5803,16 +5791,20 @@ procedure TUMLStructuralFeatureList.SetBoldObject(index: Integer; NewObject: TUM SetElement(index, NewObject); end; -function TUMLStructuralFeature.GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; +function TUMLStructuralFeature.GetDeriveMethodForMember(MemberIndex: Integer): TBoldDeriveAndResubscribe; begin - if (Member = M_typeName) then result := _typeName_DeriveAndSubscribe else - result := inherited GetDeriveMethodForMember(Member); + case MemberIndex of + 47: result := _typeName_DeriveAndSubscribe; + else result := inherited GetDeriveMethodForMember(MemberIndex); + end; end; -function TUMLStructuralFeature.GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; +function TUMLStructuralFeature.GetReverseDeriveMethodForMember(MemberIndex: Integer): TBoldReverseDerive; begin - result := inherited GetReverseDeriveMethodForMember(Member); - if not assigned(result) and (Member = M_typeName) then result := _typeName_ReverseDerive; + case MemberIndex of + 47: result := _typeName_ReverseDerive; + else result := inherited GetReverseDeriveMethodForMember(MemberIndex); + end; end; { TUMLComponentInstance } @@ -5831,11 +5823,11 @@ function TUMLComponentInstance._Get_M_nodeInstance: TBoldObjectReference; function TUMLComponentInstance._GetnodeInstance: TUMLNodeInstance; begin - assert(not assigned(M_nodeInstance.BoldObject) or (M_nodeInstance.BoldObject is TUMLNodeInstance), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'nodeInstance', M_nodeInstance.BoldObject.ClassName, 'TUMLNodeInstance'])); Result := TUMLNodeInstance(M_nodeInstance.BoldObject); + assert(not assigned(Result) or (Result is TUMLNodeInstance), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'nodeInstance', Result.ClassName, 'TUMLNodeInstance'])); end; -procedure TUMLComponentInstance._SetnodeInstance(value: TUMLNodeInstance); +procedure TUMLComponentInstance._SetnodeInstance(const value: TUMLNodeInstance); begin M_nodeInstance.BoldObject := value; end; @@ -5971,11 +5963,11 @@ function TUMLObject._Get_M_link: TBoldObjectReference; function TUMLObject._Getlink: TUMLLink; begin - assert(not assigned(M_link.BoldObject) or (M_link.BoldObject is TUMLLink), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'link', M_link.BoldObject.ClassName, 'TUMLLink'])); Result := TUMLLink(M_link.BoldObject); + assert(not assigned(Result) or (Result is TUMLLink), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'link', Result.ClassName, 'TUMLLink'])); end; -procedure TUMLObject._Setlink(value: TUMLLink); +procedure TUMLObject._Setlink(const value: TUMLLink); begin M_link.BoldObject := value; end; @@ -6069,7 +6061,7 @@ function TUMLGeneralizableElement._GetisRoot: boolean; Result := M_isRoot.AsBoolean; end; -procedure TUMLGeneralizableElement._SetisRoot(NewValue: boolean); +procedure TUMLGeneralizableElement._SetisRoot(const NewValue: boolean); begin M_isRoot.AsBoolean := NewValue; end; @@ -6085,7 +6077,7 @@ function TUMLGeneralizableElement._GetisLeaf: boolean; Result := M_isLeaf.AsBoolean; end; -procedure TUMLGeneralizableElement._SetisLeaf(NewValue: boolean); +procedure TUMLGeneralizableElement._SetisLeaf(const NewValue: boolean); begin M_isLeaf.AsBoolean := NewValue; end; @@ -6101,7 +6093,7 @@ function TUMLGeneralizableElement._GetisAbstract: boolean; Result := M_isAbstract.AsBoolean; end; -procedure TUMLGeneralizableElement._SetisAbstract(NewValue: boolean); +procedure TUMLGeneralizableElement._SetisAbstract(const NewValue: boolean); begin M_isAbstract.AsBoolean := NewValue; end; @@ -6231,7 +6223,7 @@ function TUMLExtend._Getcondition: String; Result := M_condition.AsString; end; -procedure TUMLExtend._Setcondition(NewValue: String); +procedure TUMLExtend._Setcondition(const NewValue: String); begin M_condition.AsString := NewValue; end; @@ -6256,11 +6248,11 @@ function TUMLExtend._Get_M_base: TBoldObjectReference; function TUMLExtend._Getbase: TUMLUseCase; begin - assert(not assigned(M_base.BoldObject) or (M_base.BoldObject is TUMLUseCase), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'base', M_base.BoldObject.ClassName, 'TUMLUseCase'])); Result := TUMLUseCase(M_base.BoldObject); + assert(not assigned(Result) or (Result is TUMLUseCase), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'base', Result.ClassName, 'TUMLUseCase'])); end; -procedure TUMLExtend._Setbase(value: TUMLUseCase); +procedure TUMLExtend._Setbase(const value: TUMLUseCase); begin M_base.BoldObject := value; end; @@ -6273,11 +6265,11 @@ function TUMLExtend._Get_M_extension: TBoldObjectReference; function TUMLExtend._Getextension: TUMLUseCase; begin - assert(not assigned(M_extension.BoldObject) or (M_extension.BoldObject is TUMLUseCase), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'extension', M_extension.BoldObject.ClassName, 'TUMLUseCase'])); Result := TUMLUseCase(M_extension.BoldObject); + assert(not assigned(Result) or (Result is TUMLUseCase), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'extension', Result.ClassName, 'TUMLUseCase'])); end; -procedure TUMLExtend._Setextension(value: TUMLUseCase); +procedure TUMLExtend._Setextension(const value: TUMLUseCase); begin M_extension.BoldObject := value; end; @@ -6395,7 +6387,7 @@ function TUMLGeneralization._Getdiscriminator: String; Result := M_discriminator.AsString; end; -procedure TUMLGeneralization._Setdiscriminator(NewValue: String); +procedure TUMLGeneralization._Setdiscriminator(const NewValue: String); begin M_discriminator.AsString := NewValue; end; @@ -6408,11 +6400,11 @@ function TUMLGeneralization._Get_M_parent: TBoldObjectReference; function TUMLGeneralization._Getparent: TUMLGeneralizableElement; begin - assert(not assigned(M_parent.BoldObject) or (M_parent.BoldObject is TUMLGeneralizableElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'parent', M_parent.BoldObject.ClassName, 'TUMLGeneralizableElement'])); Result := TUMLGeneralizableElement(M_parent.BoldObject); + assert(not assigned(Result) or (Result is TUMLGeneralizableElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'parent', Result.ClassName, 'TUMLGeneralizableElement'])); end; -procedure TUMLGeneralization._Setparent(value: TUMLGeneralizableElement); +procedure TUMLGeneralization._Setparent(const value: TUMLGeneralizableElement); begin M_parent.BoldObject := value; end; @@ -6425,11 +6417,11 @@ function TUMLGeneralization._Get_M_child: TBoldObjectReference; function TUMLGeneralization._Getchild: TUMLGeneralizableElement; begin - assert(not assigned(M_child.BoldObject) or (M_child.BoldObject is TUMLGeneralizableElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'child', M_child.BoldObject.ClassName, 'TUMLGeneralizableElement'])); Result := TUMLGeneralizableElement(M_child.BoldObject); + assert(not assigned(Result) or (Result is TUMLGeneralizableElement), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'child', Result.ClassName, 'TUMLGeneralizableElement'])); end; -procedure TUMLGeneralization._Setchild(value: TUMLGeneralizableElement); +procedure TUMLGeneralization._Setchild(const value: TUMLGeneralizableElement); begin M_child.BoldObject := value; end; @@ -6442,11 +6434,11 @@ function TUMLGeneralization._Get_M_powertype: TBoldObjectReference; function TUMLGeneralization._Getpowertype: TUMLClassifier; begin - assert(not assigned(M_powertype.BoldObject) or (M_powertype.BoldObject is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'powertype', M_powertype.BoldObject.ClassName, 'TUMLClassifier'])); Result := TUMLClassifier(M_powertype.BoldObject); + assert(not assigned(Result) or (Result is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'powertype', Result.ClassName, 'TUMLClassifier'])); end; -procedure TUMLGeneralization._Setpowertype(value: TUMLClassifier); +procedure TUMLGeneralization._Setpowertype(const value: TUMLClassifier); begin M_powertype.BoldObject := value; end; @@ -6498,11 +6490,11 @@ function TUMLInclude._Get_M_base: TBoldObjectReference; function TUMLInclude._Getbase: TUMLUseCase; begin - assert(not assigned(M_base.BoldObject) or (M_base.BoldObject is TUMLUseCase), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'base', M_base.BoldObject.ClassName, 'TUMLUseCase'])); Result := TUMLUseCase(M_base.BoldObject); + assert(not assigned(Result) or (Result is TUMLUseCase), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'base', Result.ClassName, 'TUMLUseCase'])); end; -procedure TUMLInclude._Setbase(value: TUMLUseCase); +procedure TUMLInclude._Setbase(const value: TUMLUseCase); begin M_base.BoldObject := value; end; @@ -6515,11 +6507,11 @@ function TUMLInclude._Get_M_addition: TBoldObjectReference; function TUMLInclude._Getaddition: TUMLUseCase; begin - assert(not assigned(M_addition.BoldObject) or (M_addition.BoldObject is TUMLUseCase), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'addition', M_addition.BoldObject.ClassName, 'TUMLUseCase'])); Result := TUMLUseCase(M_addition.BoldObject); + assert(not assigned(Result) or (Result is TUMLUseCase), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'addition', Result.ClassName, 'TUMLUseCase'])); end; -procedure TUMLInclude._Setaddition(value: TUMLUseCase); +procedure TUMLInclude._Setaddition(const value: TUMLUseCase); begin M_addition.BoldObject := value; end; @@ -6619,7 +6611,7 @@ function TUMLPseudostate._Getkind: TPseudostateKind; Result := M_kind.asPseudostateKind; end; -procedure TUMLPseudostate._Setkind(NewValue: TPseudostateKind); +procedure TUMLPseudostate._Setkind(const NewValue: TPseudostateKind); begin M_kind.asPseudostateKind := NewValue; end; @@ -6671,11 +6663,11 @@ function TUMLState._Get_M_entry: TBoldObjectReference; function TUMLState._Getentry: TUMLAction; begin - assert(not assigned(M_entry.BoldObject) or (M_entry.BoldObject is TUMLAction), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'entry', M_entry.BoldObject.ClassName, 'TUMLAction'])); Result := TUMLAction(M_entry.BoldObject); + assert(not assigned(Result) or (Result is TUMLAction), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'entry', Result.ClassName, 'TUMLAction'])); end; -procedure TUMLState._Setentry(value: TUMLAction); +procedure TUMLState._Setentry(const value: TUMLAction); begin M_entry.BoldObject := value; end; @@ -6694,11 +6686,11 @@ function TUMLState._Get_M_doActivity: TBoldObjectReference; function TUMLState._GetdoActivity: TUMLAction; begin - assert(not assigned(M_doActivity.BoldObject) or (M_doActivity.BoldObject is TUMLAction), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'doActivity', M_doActivity.BoldObject.ClassName, 'TUMLAction'])); Result := TUMLAction(M_doActivity.BoldObject); + assert(not assigned(Result) or (Result is TUMLAction), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'doActivity', Result.ClassName, 'TUMLAction'])); end; -procedure TUMLState._SetdoActivity(value: TUMLAction); +procedure TUMLState._SetdoActivity(const value: TUMLAction); begin M_doActivity.BoldObject := value; end; @@ -6711,11 +6703,11 @@ function TUMLState._Get_M_exit: TBoldObjectReference; function TUMLState._Getexit: TUMLAction; begin - assert(not assigned(M_exit.BoldObject) or (M_exit.BoldObject is TUMLAction), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'exit', M_exit.BoldObject.ClassName, 'TUMLAction'])); Result := TUMLAction(M_exit.BoldObject); + assert(not assigned(Result) or (Result is TUMLAction), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'exit', Result.ClassName, 'TUMLAction'])); end; -procedure TUMLState._Setexit(value: TUMLAction); +procedure TUMLState._Setexit(const value: TUMLAction); begin M_exit.BoldObject := value; end; @@ -6740,11 +6732,11 @@ function TUMLState._Get_M_stateMachine: TBoldObjectReference; function TUMLState._GetstateMachine: TUMLStateMachine; begin - assert(not assigned(M_stateMachine.BoldObject) or (M_stateMachine.BoldObject is TUMLStateMachine), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'stateMachine', M_stateMachine.BoldObject.ClassName, 'TUMLStateMachine'])); Result := TUMLStateMachine(M_stateMachine.BoldObject); + assert(not assigned(Result) or (Result is TUMLStateMachine), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'stateMachine', Result.ClassName, 'TUMLStateMachine'])); end; -procedure TUMLState._SetstateMachine(value: TUMLStateMachine); +procedure TUMLState._SetstateMachine(const value: TUMLStateMachine); begin M_stateMachine.BoldObject := value; end; @@ -6811,7 +6803,7 @@ function TUMLStubState._GetreferenceState: String; Result := M_referenceState.AsString; end; -procedure TUMLStubState._SetreferenceState(NewValue: String); +procedure TUMLStubState._SetreferenceState(const NewValue: String); begin M_referenceState.AsString := NewValue; end; @@ -6866,7 +6858,7 @@ function TUMLSynchState._Getbound: String; Result := M_bound.AsString; end; -procedure TUMLSynchState._Setbound(NewValue: String); +procedure TUMLSynchState._Setbound(const NewValue: String); begin M_bound.AsString := NewValue; end; @@ -6921,7 +6913,7 @@ function TUMLMethod._Getbody: String; Result := M_body.AsString; end; -procedure TUMLMethod._Setbody(NewValue: String); +procedure TUMLMethod._Setbody(const NewValue: String); begin M_body.AsString := NewValue; end; @@ -6934,11 +6926,11 @@ function TUMLMethod._Get_M_specification: TBoldObjectReference; function TUMLMethod._Getspecification: TUMLOperation; begin - assert(not assigned(M_specification.BoldObject) or (M_specification.BoldObject is TUMLOperation), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'specification', M_specification.BoldObject.ClassName, 'TUMLOperation'])); Result := TUMLOperation(M_specification.BoldObject); + assert(not assigned(Result) or (Result is TUMLOperation), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'specification', Result.ClassName, 'TUMLOperation'])); end; -procedure TUMLMethod._Setspecification(value: TUMLOperation); +procedure TUMLMethod._Setspecification(const value: TUMLOperation); begin M_specification.BoldObject := value; end; @@ -6993,7 +6985,7 @@ function TUMLOperation._Getconcurrency: TCallConcurrencyKind; Result := M_concurrency.asCallConcurrencyKind; end; -procedure TUMLOperation._Setconcurrency(NewValue: TCallConcurrencyKind); +procedure TUMLOperation._Setconcurrency(const NewValue: TCallConcurrencyKind); begin M_concurrency.asCallConcurrencyKind := NewValue; end; @@ -7009,7 +7001,7 @@ function TUMLOperation._GetisRoot: boolean; Result := M_isRoot.AsBoolean; end; -procedure TUMLOperation._SetisRoot(NewValue: boolean); +procedure TUMLOperation._SetisRoot(const NewValue: boolean); begin M_isRoot.AsBoolean := NewValue; end; @@ -7025,7 +7017,7 @@ function TUMLOperation._GetisLeaf: boolean; Result := M_isLeaf.AsBoolean; end; -procedure TUMLOperation._SetisLeaf(NewValue: boolean); +procedure TUMLOperation._SetisLeaf(const NewValue: boolean); begin M_isLeaf.AsBoolean := NewValue; end; @@ -7041,7 +7033,7 @@ function TUMLOperation._GetisAbstract: boolean; Result := M_isAbstract.AsBoolean; end; -procedure TUMLOperation._SetisAbstract(NewValue: boolean); +procedure TUMLOperation._SetisAbstract(const NewValue: boolean); begin M_isAbstract.AsBoolean := NewValue; end; @@ -7057,7 +7049,7 @@ function TUMLOperation._Getspecification: String; Result := M_specification.AsString; end; -procedure TUMLOperation._Setspecification(NewValue: String); +procedure TUMLOperation._Setspecification(const NewValue: String); begin M_specification.AsString := NewValue; end; @@ -7136,7 +7128,7 @@ function TUMLReception._Getspecification: String; Result := M_specification.AsString; end; -procedure TUMLReception._Setspecification(NewValue: String); +procedure TUMLReception._Setspecification(const NewValue: String); begin M_specification.AsString := NewValue; end; @@ -7152,7 +7144,7 @@ function TUMLReception._GetisRoot: boolean; Result := M_isRoot.AsBoolean; end; -procedure TUMLReception._SetisRoot(NewValue: boolean); +procedure TUMLReception._SetisRoot(const NewValue: boolean); begin M_isRoot.AsBoolean := NewValue; end; @@ -7168,7 +7160,7 @@ function TUMLReception._GetisLeaf: boolean; Result := M_isLeaf.AsBoolean; end; -procedure TUMLReception._SetisLeaf(NewValue: boolean); +procedure TUMLReception._SetisLeaf(const NewValue: boolean); begin M_isLeaf.AsBoolean := NewValue; end; @@ -7184,7 +7176,7 @@ function TUMLReception._GetisAbstract: boolean; Result := M_isAbstract.AsBoolean; end; -procedure TUMLReception._SetisAbstract(NewValue: boolean); +procedure TUMLReception._SetisAbstract(const NewValue: boolean); begin M_isAbstract.AsBoolean := NewValue; end; @@ -7197,11 +7189,11 @@ function TUMLReception._Get_M_signal: TBoldObjectReference; function TUMLReception._Getsignal: TUMLSignal; begin - assert(not assigned(M_signal.BoldObject) or (M_signal.BoldObject is TUMLSignal), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'signal', M_signal.BoldObject.ClassName, 'TUMLSignal'])); Result := TUMLSignal(M_signal.BoldObject); + assert(not assigned(Result) or (Result is TUMLSignal), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'signal', Result.ClassName, 'TUMLSignal'])); end; -procedure TUMLReception._Setsignal(value: TUMLSignal); +procedure TUMLReception._Setsignal(const value: TUMLSignal); begin M_signal.BoldObject := value; end; @@ -7256,7 +7248,7 @@ function TUMLAttribute._GetinitialValue: String; Result := M_initialValue.AsString; end; -procedure TUMLAttribute._SetinitialValue(NewValue: String); +procedure TUMLAttribute._SetinitialValue(const NewValue: String); begin M_initialValue.AsString := NewValue; end; @@ -7272,7 +7264,7 @@ function TUMLAttribute._Getpersistent: boolean; Result := M_persistent.AsBoolean; end; -procedure TUMLAttribute._Setpersistent(NewValue: boolean); +procedure TUMLAttribute._Setpersistent(const NewValue: boolean); begin M_persistent.AsBoolean := NewValue; end; @@ -7303,11 +7295,11 @@ function TUMLAttribute._Get_M_associationEnd: TBoldObjectReference; function TUMLAttribute._GetassociationEnd: TUMLAssociationEnd; begin - assert(not assigned(M_associationEnd.BoldObject) or (M_associationEnd.BoldObject is TUMLAssociationEnd), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'associationEnd', M_associationEnd.BoldObject.ClassName, 'TUMLAssociationEnd'])); Result := TUMLAssociationEnd(M_associationEnd.BoldObject); + assert(not assigned(Result) or (Result is TUMLAssociationEnd), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'associationEnd', Result.ClassName, 'TUMLAssociationEnd'])); end; -procedure TUMLAttribute._SetassociationEnd(value: TUMLAssociationEnd); +procedure TUMLAttribute._SetassociationEnd(const value: TUMLAssociationEnd); begin M_associationEnd.BoldObject := value; end; @@ -7349,16 +7341,20 @@ procedure TUMLAttributeList.SetBoldObject(index: Integer; NewObject: TUMLAttribu SetElement(index, NewObject); end; -function TUMLAttribute.GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; +function TUMLAttribute.GetDeriveMethodForMember(MemberIndex: Integer): TBoldDeriveAndResubscribe; begin - if (Member = M_persistent) then result := _persistent_DeriveAndSubscribe else - result := inherited GetDeriveMethodForMember(Member); + case MemberIndex of + 50: result := _persistent_DeriveAndSubscribe; + else result := inherited GetDeriveMethodForMember(MemberIndex); + end; end; -function TUMLAttribute.GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; +function TUMLAttribute.GetReverseDeriveMethodForMember(MemberIndex: Integer): TBoldReverseDerive; begin - result := inherited GetReverseDeriveMethodForMember(Member); - if not assigned(result) and (Member = M_persistent) then result := _persistent_ReverseDerive; + case MemberIndex of + 50: result := _persistent_ReverseDerive; + else result := inherited GetReverseDeriveMethodForMember(MemberIndex); + end; end; { TUMLAssociation } @@ -7374,7 +7370,7 @@ function TUMLAssociation._Getpersistent: boolean; Result := M_persistent.AsBoolean; end; -procedure TUMLAssociation._Setpersistent(NewValue: boolean); +procedure TUMLAssociation._Setpersistent(const NewValue: boolean); begin M_persistent.AsBoolean := NewValue; end; @@ -7410,11 +7406,11 @@ function TUMLAssociation._Get_M_class_: TBoldObjectReference; function TUMLAssociation._Getclass_: TUMLClass; begin - assert(not assigned(M_class_.BoldObject) or (M_class_.BoldObject is TUMLClass), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'class_', M_class_.BoldObject.ClassName, 'TUMLClass'])); Result := TUMLClass(M_class_.BoldObject); + assert(not assigned(Result) or (Result is TUMLClass), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'class_', Result.ClassName, 'TUMLClass'])); end; -procedure TUMLAssociation._Setclass_(value: TUMLClass); +procedure TUMLAssociation._Setclass_(const value: TUMLClass); begin M_class_.BoldObject := value; end; @@ -7462,16 +7458,20 @@ procedure TUMLAssociationList.SetBoldObject(index: Integer; NewObject: TUMLAssoc SetElement(index, NewObject); end; -function TUMLAssociation.GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; +function TUMLAssociation.GetDeriveMethodForMember(MemberIndex: Integer): TBoldDeriveAndResubscribe; begin - if (Member = M_persistent) then result := _persistent_DeriveAndSubscribe else - result := inherited GetDeriveMethodForMember(Member); + case MemberIndex of + 49: result := _persistent_DeriveAndSubscribe; + else result := inherited GetDeriveMethodForMember(MemberIndex); + end; end; -function TUMLAssociation.GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; +function TUMLAssociation.GetReverseDeriveMethodForMember(MemberIndex: Integer): TBoldReverseDerive; begin - result := inherited GetReverseDeriveMethodForMember(Member); - if not assigned(result) and (Member = M_persistent) then result := _persistent_ReverseDerive; + case MemberIndex of + 49: result := _persistent_ReverseDerive; + else result := inherited GetReverseDeriveMethodForMember(MemberIndex); + end; end; { TUMLClassifier } @@ -7487,7 +7487,7 @@ function TUMLClassifier._Getpersistent: boolean; Result := M_persistent.AsBoolean; end; -procedure TUMLClassifier._Setpersistent(NewValue: boolean); +procedure TUMLClassifier._Setpersistent(const NewValue: boolean); begin M_persistent.AsBoolean := NewValue; end; @@ -7566,11 +7566,11 @@ function TUMLClassifier._Get_M_superclass: TBoldObjectReference; function TUMLClassifier._Getsuperclass: TUMLClassifier; begin - assert(not assigned(M_superclass.BoldObject) or (M_superclass.BoldObject is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'superclass', M_superclass.BoldObject.ClassName, 'TUMLClassifier'])); Result := TUMLClassifier(M_superclass.BoldObject); + assert(not assigned(Result) or (Result is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'superclass', Result.ClassName, 'TUMLClassifier'])); end; -procedure TUMLClassifier._Setsuperclass(value: TUMLClassifier); +procedure TUMLClassifier._Setsuperclass(const value: TUMLClassifier); begin M_superclass.BoldObject := value; end; @@ -7636,16 +7636,20 @@ procedure TUMLClassifierList.SetBoldObject(index: Integer; NewObject: TUMLClassi SetElement(index, NewObject); end; -function TUMLClassifier.GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; +function TUMLClassifier.GetDeriveMethodForMember(MemberIndex: Integer): TBoldDeriveAndResubscribe; begin - if (Member = M_persistent) then result := _persistent_DeriveAndSubscribe else - result := inherited GetDeriveMethodForMember(Member); + case MemberIndex of + 49: result := _persistent_DeriveAndSubscribe; + else result := inherited GetDeriveMethodForMember(MemberIndex); + end; end; -function TUMLClassifier.GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; +function TUMLClassifier.GetReverseDeriveMethodForMember(MemberIndex: Integer): TBoldReverseDerive; begin - result := inherited GetReverseDeriveMethodForMember(Member); - if not assigned(result) and (Member = M_persistent) then result := _persistent_ReverseDerive; + case MemberIndex of + 49: result := _persistent_ReverseDerive; + else result := inherited GetReverseDeriveMethodForMember(MemberIndex); + end; end; { TUMLCollaboration } @@ -7676,11 +7680,11 @@ function TUMLCollaboration._Get_M_representedClassifier: TBoldObjectReference; function TUMLCollaboration._GetrepresentedClassifier: TUMLClassifier; begin - assert(not assigned(M_representedClassifier.BoldObject) or (M_representedClassifier.BoldObject is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'representedClassifier', M_representedClassifier.BoldObject.ClassName, 'TUMLClassifier'])); Result := TUMLClassifier(M_representedClassifier.BoldObject); + assert(not assigned(Result) or (Result is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'representedClassifier', Result.ClassName, 'TUMLClassifier'])); end; -procedure TUMLCollaboration._SetrepresentedClassifier(value: TUMLClassifier); +procedure TUMLCollaboration._SetrepresentedClassifier(const value: TUMLClassifier); begin M_representedClassifier.BoldObject := value; end; @@ -7693,11 +7697,11 @@ function TUMLCollaboration._Get_M_representedOperation: TBoldObjectReference; function TUMLCollaboration._GetrepresentedOperation: TUMLOperation; begin - assert(not assigned(M_representedOperation.BoldObject) or (M_representedOperation.BoldObject is TUMLOperation), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'representedOperation', M_representedOperation.BoldObject.ClassName, 'TUMLOperation'])); Result := TUMLOperation(M_representedOperation.BoldObject); + assert(not assigned(Result) or (Result is TUMLOperation), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'representedOperation', Result.ClassName, 'TUMLOperation'])); end; -procedure TUMLCollaboration._SetrepresentedOperation(value: TUMLOperation); +procedure TUMLCollaboration._SetrepresentedOperation(const value: TUMLOperation); begin M_representedOperation.BoldObject := value; end; @@ -7797,7 +7801,7 @@ function TUMLStereotype._Geticon: String; Result := M_icon.AsString; end; -procedure TUMLStereotype._Seticon(NewValue: String); +procedure TUMLStereotype._Seticon(const NewValue: String); begin M_icon.AsString := NewValue; end; @@ -7813,7 +7817,7 @@ function TUMLStereotype._GetbaseClass: String; Result := M_baseClass.AsString; end; -procedure TUMLStereotype._SetbaseClass(NewValue: String); +procedure TUMLStereotype._SetbaseClass(const NewValue: String); begin M_baseClass.AsString := NewValue; end; @@ -7886,7 +7890,7 @@ function TUMLAbstraction._Getmapping: String; Result := M_mapping.AsString; end; -procedure TUMLAbstraction._Setmapping(NewValue: String); +procedure TUMLAbstraction._Setmapping(const NewValue: String); begin M_mapping.AsString := NewValue; end; @@ -8064,7 +8068,7 @@ function TUMLCompositeState._GetisConcurrent: boolean; Result := M_isConcurrent.AsBoolean; end; -procedure TUMLCompositeState._SetisConcurrent(NewValue: boolean); +procedure TUMLCompositeState._SetisConcurrent(const NewValue: boolean); begin M_isConcurrent.AsBoolean := NewValue; end; @@ -8203,7 +8207,7 @@ function TUMLAssociationRole._Getmultiplicity: String; Result := M_multiplicity.AsString; end; -procedure TUMLAssociationRole._Setmultiplicity(NewValue: String); +procedure TUMLAssociationRole._Setmultiplicity(const NewValue: String); begin M_multiplicity.AsString := NewValue; end; @@ -8216,11 +8220,11 @@ function TUMLAssociationRole._Get_M_base: TBoldObjectReference; function TUMLAssociationRole._Getbase: TUMLAssociation; begin - assert(not assigned(M_base.BoldObject) or (M_base.BoldObject is TUMLAssociation), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'base', M_base.BoldObject.ClassName, 'TUMLAssociation'])); Result := TUMLAssociation(M_base.BoldObject); + assert(not assigned(Result) or (Result is TUMLAssociation), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'base', Result.ClassName, 'TUMLAssociation'])); end; -procedure TUMLAssociationRole._Setbase(value: TUMLAssociation); +procedure TUMLAssociationRole._Setbase(const value: TUMLAssociation); begin M_base.BoldObject := value; end; @@ -8320,7 +8324,7 @@ function TUMLClass._GetisActive: boolean; Result := M_isActive.AsBoolean; end; -procedure TUMLClass._SetisActive(NewValue: boolean); +procedure TUMLClass._SetisActive(const NewValue: boolean); begin M_isActive.AsBoolean := NewValue; end; @@ -8344,11 +8348,11 @@ function TUMLClass._Get_M_association: TBoldObjectReference; function TUMLClass._Getassociation: TUMLAssociation; begin - assert(not assigned(M_association.BoldObject) or (M_association.BoldObject is TUMLAssociation), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'association', M_association.BoldObject.ClassName, 'TUMLAssociation'])); Result := TUMLAssociation(M_association.BoldObject); + assert(not assigned(Result) or (Result is TUMLAssociation), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'association', Result.ClassName, 'TUMLAssociation'])); end; -procedure TUMLClass._Setassociation(value: TUMLAssociation); +procedure TUMLClass._Setassociation(const value: TUMLAssociation); begin M_association.BoldObject := value; end; @@ -8390,16 +8394,6 @@ procedure TUMLClassList.SetBoldObject(index: Integer; NewObject: TUMLClass); SetElement(index, NewObject); end; -function TUMLClass.GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; -begin - result := inherited GetDeriveMethodForMember(Member); -end; - -function TUMLClass.GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; -begin - result := inherited GetReverseDeriveMethodForMember(Member); -end; - { TUMLClassifierInState } function TUMLClassifierInState._Get_M_type_: TBoldObjectReference; @@ -8410,11 +8404,11 @@ function TUMLClassifierInState._Get_M_type_: TBoldObjectReference; function TUMLClassifierInState._Gettype_: TUMLClassifier; begin - assert(not assigned(M_type_.BoldObject) or (M_type_.BoldObject is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'type_', M_type_.BoldObject.ClassName, 'TUMLClassifier'])); Result := TUMLClassifier(M_type_.BoldObject); + assert(not assigned(Result) or (Result is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'type_', Result.ClassName, 'TUMLClassifier'])); end; -procedure TUMLClassifierInState._Settype_(value: TUMLClassifier); +procedure TUMLClassifierInState._Settype_(const value: TUMLClassifier); begin M_type_.BoldObject := value; end; @@ -8481,7 +8475,7 @@ function TUMLClassifierRole._Getmultiplicity: String; Result := M_multiplicity.AsString; end; -procedure TUMLClassifierRole._Setmultiplicity(NewValue: String); +procedure TUMLClassifierRole._Setmultiplicity(const NewValue: String); begin M_multiplicity.AsString := NewValue; end; @@ -8905,11 +8899,11 @@ function TUMLModel._Get_M_Validator: TBoldObjectReference; function TUMLModel._GetValidator: TValidator; begin - assert(not assigned(M_Validator.BoldObject) or (M_Validator.BoldObject is TValidator), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'Validator', M_Validator.BoldObject.ClassName, 'TValidator'])); Result := TValidator(M_Validator.BoldObject); + assert(not assigned(Result) or (Result is TValidator), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'Validator', Result.ClassName, 'TValidator'])); end; -procedure TUMLModel._SetValidator(value: TValidator); +procedure TUMLModel._SetValidator(const value: TValidator); begin M_Validator.BoldObject := value; end; @@ -8951,16 +8945,6 @@ procedure TUMLModelList.SetBoldObject(index: Integer; NewObject: TUMLModel); SetElement(index, NewObject); end; -function TUMLModel.GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; -begin - result := inherited GetDeriveMethodForMember(Member); -end; - -function TUMLModel.GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; -begin - result := inherited GetReverseDeriveMethodForMember(Member); -end; - { TUMLSubsystem } function TUMLSubsystem._Get_M_isInstantiable: TBABoolean; @@ -8974,7 +8958,7 @@ function TUMLSubsystem._GetisInstantiable: boolean; Result := M_isInstantiable.AsBoolean; end; -procedure TUMLSubsystem._SetisInstantiable(NewValue: boolean); +procedure TUMLSubsystem._SetisInstantiable(const NewValue: boolean); begin M_isInstantiable.AsBoolean := NewValue; end; @@ -9026,11 +9010,11 @@ function TUMLSubmachineState._Get_M_submachine: TBoldObjectReference; function TUMLSubmachineState._Getsubmachine: TUMLStateMachine; begin - assert(not assigned(M_submachine.BoldObject) or (M_submachine.BoldObject is TUMLStateMachine), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'submachine', M_submachine.BoldObject.ClassName, 'TUMLStateMachine'])); Result := TUMLStateMachine(M_submachine.BoldObject); + assert(not assigned(Result) or (Result is TUMLStateMachine), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'submachine', Result.ClassName, 'TUMLStateMachine'])); end; -procedure TUMLSubmachineState._Setsubmachine(value: TUMLStateMachine); +procedure TUMLSubmachineState._Setsubmachine(const value: TUMLStateMachine); begin M_submachine.BoldObject := value; end; @@ -9085,7 +9069,7 @@ function TUMLActionState._GetisDynamic: boolean; Result := M_isDynamic.AsBoolean; end; -procedure TUMLActionState._SetisDynamic(NewValue: boolean); +procedure TUMLActionState._SetisDynamic(const NewValue: boolean); begin M_isDynamic.AsBoolean := NewValue; end; @@ -9101,7 +9085,7 @@ function TUMLActionState._GetdynamicArguments: String; Result := M_dynamicArguments.AsString; end; -procedure TUMLActionState._SetdynamicArguments(NewValue: String); +procedure TUMLActionState._SetdynamicArguments(const NewValue: String); begin M_dynamicArguments.AsString := NewValue; end; @@ -9117,7 +9101,7 @@ function TUMLActionState._GetdynamicMultiplicity: String; Result := M_dynamicMultiplicity.AsString; end; -procedure TUMLActionState._SetdynamicMultiplicity(NewValue: String); +procedure TUMLActionState._SetdynamicMultiplicity(const NewValue: String); begin M_dynamicMultiplicity.AsString := NewValue; end; @@ -9172,7 +9156,7 @@ function TUMLObjectFlowState._GetisSynch: boolean; Result := M_isSynch.AsBoolean; end; -procedure TUMLObjectFlowState._SetisSynch(NewValue: boolean); +procedure TUMLObjectFlowState._SetisSynch(const NewValue: boolean); begin M_isSynch.AsBoolean := NewValue; end; @@ -9185,11 +9169,11 @@ function TUMLObjectFlowState._Get_M_type_: TBoldObjectReference; function TUMLObjectFlowState._Gettype_: TUMLClassifier; begin - assert(not assigned(M_type_.BoldObject) or (M_type_.BoldObject is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'type_', M_type_.BoldObject.ClassName, 'TUMLClassifier'])); Result := TUMLClassifier(M_type_.BoldObject); + assert(not assigned(Result) or (Result is TUMLClassifier), SysUtils.format(BoldMemberAssertInvalidObjectType, [ClassName, 'type_', Result.ClassName, 'TUMLClassifier'])); end; -procedure TUMLObjectFlowState._Settype_(value: TUMLClassifier); +procedure TUMLObjectFlowState._Settype_(const value: TUMLClassifier); begin M_type_.BoldObject := value; end; @@ -9295,7 +9279,7 @@ function TUMLSubactivityState._GetisDynamic: boolean; Result := M_isDynamic.AsBoolean; end; -procedure TUMLSubactivityState._SetisDynamic(NewValue: boolean); +procedure TUMLSubactivityState._SetisDynamic(const NewValue: boolean); begin M_isDynamic.AsBoolean := NewValue; end; @@ -9311,7 +9295,7 @@ function TUMLSubactivityState._GetdynamicArguments: String; Result := M_dynamicArguments.AsString; end; -procedure TUMLSubactivityState._SetdynamicArguments(NewValue: String); +procedure TUMLSubactivityState._SetdynamicArguments(const NewValue: String); begin M_dynamicArguments.AsString := NewValue; end; @@ -9327,7 +9311,7 @@ function TUMLSubactivityState._GetdynamicMultiplicity: String; Result := M_dynamicMultiplicity.AsString; end; -procedure TUMLSubactivityState._SetdynamicMultiplicity(NewValue: String); +procedure TUMLSubactivityState._SetdynamicMultiplicity(const NewValue: String); begin M_dynamicMultiplicity.AsString := NewValue; end; @@ -9415,263 +9399,261 @@ function GeneratedCodeCRC: String; procedure InstallObjectListClasses(BoldObjectListClasses: TBoldGeneratedClassList); begin - BoldObjectListClasses.AddObjectEntry('UMLModelRoot', TUMLModelRootList); // do not localize - BoldObjectListClasses.AddObjectEntry('Argumentstimulus1', Targumentstimulus1List); // do not localize - BoldObjectListClasses.AddObjectEntry('AssociationEndRoleavailableQualifier', TassociationEndRoleavailableQualifierList); // do not localize - BoldObjectListClasses.AddObjectEntry('ClassifierclassifierRole_', TclassifierclassifierRole_List); // do not localize - BoldObjectListClasses.AddObjectEntry('ClassifierInStateinState', TclassifierInStateinStateList); // do not localize - BoldObjectListClasses.AddObjectEntry('ClassifierRole_availableFeature', TclassifierRole_availableFeatureList); // do not localize - BoldObjectListClasses.AddObjectEntry('ClassifierRoleavailableContents', TclassifierRoleavailableContentsList); // do not localize - BoldObjectListClasses.AddObjectEntry('ClientclientDependency', TclientclientDependencyList); // do not localize - BoldObjectListClasses.AddObjectEntry('CollaborationconstrainingElement', TcollaborationconstrainingElementList); // do not localize - BoldObjectListClasses.AddObjectEntry('CommentannotatedElement', TcommentannotatedElementList); // do not localize - BoldObjectListClasses.AddObjectEntry('ConstrainedElementconstraint', TconstrainedElementconstraintList); // do not localize - BoldObjectListClasses.AddObjectEntry('Contentspartition', TcontentspartitionList); // do not localize - BoldObjectListClasses.AddObjectEntry('ContextraisedSignal', TcontextraisedSignalList); // do not localize - BoldObjectListClasses.AddObjectEntry('DeploymentLocationresident', TdeploymentLocationresidentList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLElement', TUMLElementList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLElementImport', TUMLElementImportList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLElementResidence', TUMLElementResidenceList); // do not localize - BoldObjectListClasses.AddObjectEntry('ExtensionPointextend', TextensionPointextendList); // do not localize - BoldObjectListClasses.AddObjectEntry('Instanceclassifier', TinstanceclassifierList); // do not localize - BoldObjectListClasses.AddObjectEntry('Parameterstate', TparameterstateList); // do not localize - BoldObjectListClasses.AddObjectEntry('Participantspecification', TparticipantspecificationList); // do not localize - BoldObjectListClasses.AddObjectEntry('Predecessormessage3', Tpredecessormessage3List); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLPresentationElement', TUMLPresentationElementList); // do not localize - BoldObjectListClasses.AddObjectEntry('Presentationsubject', TpresentationsubjectList); // do not localize - BoldObjectListClasses.AddObjectEntry('SourceFlowsource', TsourceFlowsourceList); // do not localize - BoldObjectListClasses.AddObjectEntry('StatedeferrableEvent', TstatedeferrableEventList); // do not localize - BoldObjectListClasses.AddObjectEntry('SuppliersupplierDependency', TsuppliersupplierDependencyList); // do not localize - BoldObjectListClasses.AddObjectEntry('TargetFlowtarget', TtargetFlowtargetList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLTemplateParameter', TUMLTemplateParameterList); // do not localize - BoldObjectListClasses.AddObjectEntry('Validator', TValidatorList); // do not localize - BoldObjectListClasses.AddObjectEntry('Violation', TViolationList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLModelElement', TUMLModelElementList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLAction', TUMLActionList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLArgument', TUMLArgumentList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLAssociationEnd', TUMLAssociationEndList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLAttributeLink', TUMLAttributeLinkList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLComment', TUMLCommentList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLConstraint', TUMLConstraintList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLEvent', TUMLEventList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLExtensionPoint', TUMLExtensionPointList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLFeature', TUMLFeatureList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLGuard', TUMLGuardList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLInstance', TUMLInstanceList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLInteraction', TUMLInteractionList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLLink', TUMLLinkList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLLinkEnd', TUMLLinkEndList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLMessage', TUMLMessageList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLNamespace', TUMLNamespaceList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLParameter', TUMLParameterList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLPartition', TUMLPartitionList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLRelationship', TUMLRelationshipList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLStateMachine', TUMLStateMachineList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLStateVertex', TUMLStateVertexList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLStimulus', TUMLStimulusList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLTaggedValue', TUMLTaggedValueList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLTransition', TUMLTransitionList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLActionSequence', TUMLActionSequenceList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLCallAction', TUMLCallActionList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLCreateAction', TUMLCreateActionList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLDestroyAction', TUMLDestroyActionList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLReturnAction', TUMLReturnActionList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLSendAction', TUMLSendActionList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLTerminateAction', TUMLTerminateActionList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLUninterpretedAction', TUMLUninterpretedActionList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLAssociationEndRole', TUMLAssociationEndRoleList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLCallEvent', TUMLCallEventList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLChangeEvent', TUMLChangeEventList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLSignalEvent', TUMLSignalEventList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLTimeEvent', TUMLTimeEventList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLBehavioralFeature', TUMLBehavioralFeatureList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLStructuralFeature', TUMLStructuralFeatureList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLComponentInstance', TUMLComponentInstanceList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLDataValue', TUMLDataValueList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLNodeInstance', TUMLNodeInstanceList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLObject', TUMLObjectList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLUseCaseInstance', TUMLUseCaseInstanceList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLGeneralizableElement', TUMLGeneralizableElementList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLDependency', TUMLDependencyList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLExtend', TUMLExtendList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLFlow', TUMLFlowList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLGeneralization', TUMLGeneralizationList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLInclude', TUMLIncludeList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLActivityGraph', TUMLActivityGraphList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLPseudostate', TUMLPseudostateList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLState', TUMLStateList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLStubState', TUMLStubStateList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLSynchState', TUMLSynchStateList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLMethod', TUMLMethodList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLOperation', TUMLOperationList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLReception', TUMLReceptionList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLAttribute', TUMLAttributeList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLAssociation', TUMLAssociationList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLClassifier', TUMLClassifierList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLCollaboration', TUMLCollaborationList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLPackage', TUMLPackageList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLStereotype', TUMLStereotypeList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLAbstraction', TUMLAbstractionList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLBinding', TUMLBindingList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLPermission', TUMLPermissionList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLUsage', TUMLUsageList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLCompositeState', TUMLCompositeStateList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLFinalState', TUMLFinalStateList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLSimpleState', TUMLSimpleStateList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLAssociationRole', TUMLAssociationRoleList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLActor', TUMLActorList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLClass', TUMLClassList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLClassifierInState', TUMLClassifierInStateList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLClassifierRole', TUMLClassifierRoleList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLComponent', TUMLComponentList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLDataType', TUMLDataTypeList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLInterface', TUMLInterfaceList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLNode', TUMLNodeList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLSignal', TUMLSignalList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLUseCase', TUMLUseCaseList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLModel', TUMLModelList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLSubsystem', TUMLSubsystemList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLSubmachineState', TUMLSubmachineStateList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLActionState', TUMLActionStateList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLObjectFlowState', TUMLObjectFlowStateList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLException', TUMLExceptionList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLSubactivityState', TUMLSubactivityStateList); // do not localize - BoldObjectListClasses.AddObjectEntry('UMLCallState', TUMLCallStateList); // do not localize + BoldObjectListClasses.AddObjectEntry('UMLModelRoot', TUMLModelRootList); + BoldObjectListClasses.AddObjectEntry('Argumentstimulus1', Targumentstimulus1List); + BoldObjectListClasses.AddObjectEntry('AssociationEndRoleavailableQualifier', TassociationEndRoleavailableQualifierList); + BoldObjectListClasses.AddObjectEntry('ClassifierclassifierRole_', TclassifierclassifierRole_List); + BoldObjectListClasses.AddObjectEntry('ClassifierInStateinState', TclassifierInStateinStateList); + BoldObjectListClasses.AddObjectEntry('ClassifierRole_availableFeature', TclassifierRole_availableFeatureList); + BoldObjectListClasses.AddObjectEntry('ClassifierRoleavailableContents', TclassifierRoleavailableContentsList); + BoldObjectListClasses.AddObjectEntry('ClientclientDependency', TclientclientDependencyList); + BoldObjectListClasses.AddObjectEntry('CollaborationconstrainingElement', TcollaborationconstrainingElementList); + BoldObjectListClasses.AddObjectEntry('CommentannotatedElement', TcommentannotatedElementList); + BoldObjectListClasses.AddObjectEntry('ConstrainedElementconstraint', TconstrainedElementconstraintList); + BoldObjectListClasses.AddObjectEntry('Contentspartition', TcontentspartitionList); + BoldObjectListClasses.AddObjectEntry('ContextraisedSignal', TcontextraisedSignalList); + BoldObjectListClasses.AddObjectEntry('DeploymentLocationresident', TdeploymentLocationresidentList); + BoldObjectListClasses.AddObjectEntry('UMLElement', TUMLElementList); + BoldObjectListClasses.AddObjectEntry('UMLElementImport', TUMLElementImportList); + BoldObjectListClasses.AddObjectEntry('UMLElementResidence', TUMLElementResidenceList); + BoldObjectListClasses.AddObjectEntry('ExtensionPointextend', TextensionPointextendList); + BoldObjectListClasses.AddObjectEntry('Instanceclassifier', TinstanceclassifierList); + BoldObjectListClasses.AddObjectEntry('Parameterstate', TparameterstateList); + BoldObjectListClasses.AddObjectEntry('Participantspecification', TparticipantspecificationList); + BoldObjectListClasses.AddObjectEntry('Predecessormessage3', Tpredecessormessage3List); + BoldObjectListClasses.AddObjectEntry('UMLPresentationElement', TUMLPresentationElementList); + BoldObjectListClasses.AddObjectEntry('Presentationsubject', TpresentationsubjectList); + BoldObjectListClasses.AddObjectEntry('SourceFlowsource', TsourceFlowsourceList); + BoldObjectListClasses.AddObjectEntry('StatedeferrableEvent', TstatedeferrableEventList); + BoldObjectListClasses.AddObjectEntry('SuppliersupplierDependency', TsuppliersupplierDependencyList); + BoldObjectListClasses.AddObjectEntry('TargetFlowtarget', TtargetFlowtargetList); + BoldObjectListClasses.AddObjectEntry('UMLTemplateParameter', TUMLTemplateParameterList); + BoldObjectListClasses.AddObjectEntry('Validator', TValidatorList); + BoldObjectListClasses.AddObjectEntry('Violation', TViolationList); + BoldObjectListClasses.AddObjectEntry('UMLModelElement', TUMLModelElementList); + BoldObjectListClasses.AddObjectEntry('UMLAction', TUMLActionList); + BoldObjectListClasses.AddObjectEntry('UMLArgument', TUMLArgumentList); + BoldObjectListClasses.AddObjectEntry('UMLAssociationEnd', TUMLAssociationEndList); + BoldObjectListClasses.AddObjectEntry('UMLAttributeLink', TUMLAttributeLinkList); + BoldObjectListClasses.AddObjectEntry('UMLComment', TUMLCommentList); + BoldObjectListClasses.AddObjectEntry('UMLConstraint', TUMLConstraintList); + BoldObjectListClasses.AddObjectEntry('UMLEvent', TUMLEventList); + BoldObjectListClasses.AddObjectEntry('UMLExtensionPoint', TUMLExtensionPointList); + BoldObjectListClasses.AddObjectEntry('UMLFeature', TUMLFeatureList); + BoldObjectListClasses.AddObjectEntry('UMLGuard', TUMLGuardList); + BoldObjectListClasses.AddObjectEntry('UMLInstance', TUMLInstanceList); + BoldObjectListClasses.AddObjectEntry('UMLInteraction', TUMLInteractionList); + BoldObjectListClasses.AddObjectEntry('UMLLink', TUMLLinkList); + BoldObjectListClasses.AddObjectEntry('UMLLinkEnd', TUMLLinkEndList); + BoldObjectListClasses.AddObjectEntry('UMLMessage', TUMLMessageList); + BoldObjectListClasses.AddObjectEntry('UMLNamespace', TUMLNamespaceList); + BoldObjectListClasses.AddObjectEntry('UMLParameter', TUMLParameterList); + BoldObjectListClasses.AddObjectEntry('UMLPartition', TUMLPartitionList); + BoldObjectListClasses.AddObjectEntry('UMLRelationship', TUMLRelationshipList); + BoldObjectListClasses.AddObjectEntry('UMLStateMachine', TUMLStateMachineList); + BoldObjectListClasses.AddObjectEntry('UMLStateVertex', TUMLStateVertexList); + BoldObjectListClasses.AddObjectEntry('UMLStimulus', TUMLStimulusList); + BoldObjectListClasses.AddObjectEntry('UMLTaggedValue', TUMLTaggedValueList); + BoldObjectListClasses.AddObjectEntry('UMLTransition', TUMLTransitionList); + BoldObjectListClasses.AddObjectEntry('UMLActionSequence', TUMLActionSequenceList); + BoldObjectListClasses.AddObjectEntry('UMLCallAction', TUMLCallActionList); + BoldObjectListClasses.AddObjectEntry('UMLCreateAction', TUMLCreateActionList); + BoldObjectListClasses.AddObjectEntry('UMLDestroyAction', TUMLDestroyActionList); + BoldObjectListClasses.AddObjectEntry('UMLReturnAction', TUMLReturnActionList); + BoldObjectListClasses.AddObjectEntry('UMLSendAction', TUMLSendActionList); + BoldObjectListClasses.AddObjectEntry('UMLTerminateAction', TUMLTerminateActionList); + BoldObjectListClasses.AddObjectEntry('UMLUninterpretedAction', TUMLUninterpretedActionList); + BoldObjectListClasses.AddObjectEntry('UMLAssociationEndRole', TUMLAssociationEndRoleList); + BoldObjectListClasses.AddObjectEntry('UMLCallEvent', TUMLCallEventList); + BoldObjectListClasses.AddObjectEntry('UMLChangeEvent', TUMLChangeEventList); + BoldObjectListClasses.AddObjectEntry('UMLSignalEvent', TUMLSignalEventList); + BoldObjectListClasses.AddObjectEntry('UMLTimeEvent', TUMLTimeEventList); + BoldObjectListClasses.AddObjectEntry('UMLBehavioralFeature', TUMLBehavioralFeatureList); + BoldObjectListClasses.AddObjectEntry('UMLStructuralFeature', TUMLStructuralFeatureList); + BoldObjectListClasses.AddObjectEntry('UMLComponentInstance', TUMLComponentInstanceList); + BoldObjectListClasses.AddObjectEntry('UMLDataValue', TUMLDataValueList); + BoldObjectListClasses.AddObjectEntry('UMLNodeInstance', TUMLNodeInstanceList); + BoldObjectListClasses.AddObjectEntry('UMLObject', TUMLObjectList); + BoldObjectListClasses.AddObjectEntry('UMLUseCaseInstance', TUMLUseCaseInstanceList); + BoldObjectListClasses.AddObjectEntry('UMLGeneralizableElement', TUMLGeneralizableElementList); + BoldObjectListClasses.AddObjectEntry('UMLDependency', TUMLDependencyList); + BoldObjectListClasses.AddObjectEntry('UMLExtend', TUMLExtendList); + BoldObjectListClasses.AddObjectEntry('UMLFlow', TUMLFlowList); + BoldObjectListClasses.AddObjectEntry('UMLGeneralization', TUMLGeneralizationList); + BoldObjectListClasses.AddObjectEntry('UMLInclude', TUMLIncludeList); + BoldObjectListClasses.AddObjectEntry('UMLActivityGraph', TUMLActivityGraphList); + BoldObjectListClasses.AddObjectEntry('UMLPseudostate', TUMLPseudostateList); + BoldObjectListClasses.AddObjectEntry('UMLState', TUMLStateList); + BoldObjectListClasses.AddObjectEntry('UMLStubState', TUMLStubStateList); + BoldObjectListClasses.AddObjectEntry('UMLSynchState', TUMLSynchStateList); + BoldObjectListClasses.AddObjectEntry('UMLMethod', TUMLMethodList); + BoldObjectListClasses.AddObjectEntry('UMLOperation', TUMLOperationList); + BoldObjectListClasses.AddObjectEntry('UMLReception', TUMLReceptionList); + BoldObjectListClasses.AddObjectEntry('UMLAttribute', TUMLAttributeList); + BoldObjectListClasses.AddObjectEntry('UMLAssociation', TUMLAssociationList); + BoldObjectListClasses.AddObjectEntry('UMLClassifier', TUMLClassifierList); + BoldObjectListClasses.AddObjectEntry('UMLCollaboration', TUMLCollaborationList); + BoldObjectListClasses.AddObjectEntry('UMLPackage', TUMLPackageList); + BoldObjectListClasses.AddObjectEntry('UMLStereotype', TUMLStereotypeList); + BoldObjectListClasses.AddObjectEntry('UMLAbstraction', TUMLAbstractionList); + BoldObjectListClasses.AddObjectEntry('UMLBinding', TUMLBindingList); + BoldObjectListClasses.AddObjectEntry('UMLPermission', TUMLPermissionList); + BoldObjectListClasses.AddObjectEntry('UMLUsage', TUMLUsageList); + BoldObjectListClasses.AddObjectEntry('UMLCompositeState', TUMLCompositeStateList); + BoldObjectListClasses.AddObjectEntry('UMLFinalState', TUMLFinalStateList); + BoldObjectListClasses.AddObjectEntry('UMLSimpleState', TUMLSimpleStateList); + BoldObjectListClasses.AddObjectEntry('UMLAssociationRole', TUMLAssociationRoleList); + BoldObjectListClasses.AddObjectEntry('UMLActor', TUMLActorList); + BoldObjectListClasses.AddObjectEntry('UMLClass', TUMLClassList); + BoldObjectListClasses.AddObjectEntry('UMLClassifierInState', TUMLClassifierInStateList); + BoldObjectListClasses.AddObjectEntry('UMLClassifierRole', TUMLClassifierRoleList); + BoldObjectListClasses.AddObjectEntry('UMLComponent', TUMLComponentList); + BoldObjectListClasses.AddObjectEntry('UMLDataType', TUMLDataTypeList); + BoldObjectListClasses.AddObjectEntry('UMLInterface', TUMLInterfaceList); + BoldObjectListClasses.AddObjectEntry('UMLNode', TUMLNodeList); + BoldObjectListClasses.AddObjectEntry('UMLSignal', TUMLSignalList); + BoldObjectListClasses.AddObjectEntry('UMLUseCase', TUMLUseCaseList); + BoldObjectListClasses.AddObjectEntry('UMLModel', TUMLModelList); + BoldObjectListClasses.AddObjectEntry('UMLSubsystem', TUMLSubsystemList); + BoldObjectListClasses.AddObjectEntry('UMLSubmachineState', TUMLSubmachineStateList); + BoldObjectListClasses.AddObjectEntry('UMLActionState', TUMLActionStateList); + BoldObjectListClasses.AddObjectEntry('UMLObjectFlowState', TUMLObjectFlowStateList); + BoldObjectListClasses.AddObjectEntry('UMLException', TUMLExceptionList); + BoldObjectListClasses.AddObjectEntry('UMLSubactivityState', TUMLSubactivityStateList); + BoldObjectListClasses.AddObjectEntry('UMLCallState', TUMLCallStateList); end; procedure InstallBusinessClasses(BoldObjectClasses: TBoldGeneratedClassList); begin - BoldObjectClasses.AddObjectEntry('UMLModelRoot', TUMLModelRoot); // do not localize - BoldObjectClasses.AddObjectEntry('Argumentstimulus1', Targumentstimulus1); // do not localize - BoldObjectClasses.AddObjectEntry('AssociationEndRoleavailableQualifier', TassociationEndRoleavailableQualifier); // do not localize - BoldObjectClasses.AddObjectEntry('ClassifierclassifierRole_', TclassifierclassifierRole_); // do not localize - BoldObjectClasses.AddObjectEntry('ClassifierInStateinState', TclassifierInStateinState); // do not localize - BoldObjectClasses.AddObjectEntry('ClassifierRole_availableFeature', TclassifierRole_availableFeature); // do not localize - BoldObjectClasses.AddObjectEntry('ClassifierRoleavailableContents', TclassifierRoleavailableContents); // do not localize - BoldObjectClasses.AddObjectEntry('ClientclientDependency', TclientclientDependency); // do not localize - BoldObjectClasses.AddObjectEntry('CollaborationconstrainingElement', TcollaborationconstrainingElement); // do not localize - BoldObjectClasses.AddObjectEntry('CommentannotatedElement', TcommentannotatedElement); // do not localize - BoldObjectClasses.AddObjectEntry('ConstrainedElementconstraint', TconstrainedElementconstraint); // do not localize - BoldObjectClasses.AddObjectEntry('Contentspartition', Tcontentspartition); // do not localize - BoldObjectClasses.AddObjectEntry('ContextraisedSignal', TcontextraisedSignal); // do not localize - BoldObjectClasses.AddObjectEntry('DeploymentLocationresident', TdeploymentLocationresident); // do not localize - BoldObjectClasses.AddObjectEntry('UMLElement', TUMLElement); // do not localize - BoldObjectClasses.AddObjectEntry('UMLElementImport', TUMLElementImport); // do not localize - BoldObjectClasses.AddObjectEntry('UMLElementResidence', TUMLElementResidence); // do not localize - BoldObjectClasses.AddObjectEntry('ExtensionPointextend', TextensionPointextend); // do not localize - BoldObjectClasses.AddObjectEntry('Instanceclassifier', Tinstanceclassifier); // do not localize - BoldObjectClasses.AddObjectEntry('Parameterstate', Tparameterstate); // do not localize - BoldObjectClasses.AddObjectEntry('Participantspecification', Tparticipantspecification); // do not localize - BoldObjectClasses.AddObjectEntry('Predecessormessage3', Tpredecessormessage3); // do not localize - BoldObjectClasses.AddObjectEntry('UMLPresentationElement', TUMLPresentationElement); // do not localize - BoldObjectClasses.AddObjectEntry('Presentationsubject', Tpresentationsubject); // do not localize - BoldObjectClasses.AddObjectEntry('SourceFlowsource', TsourceFlowsource); // do not localize - BoldObjectClasses.AddObjectEntry('StatedeferrableEvent', TstatedeferrableEvent); // do not localize - BoldObjectClasses.AddObjectEntry('SuppliersupplierDependency', TsuppliersupplierDependency); // do not localize - BoldObjectClasses.AddObjectEntry('TargetFlowtarget', TtargetFlowtarget); // do not localize - BoldObjectClasses.AddObjectEntry('UMLTemplateParameter', TUMLTemplateParameter); // do not localize - BoldObjectClasses.AddObjectEntry('Validator', TValidator); // do not localize - BoldObjectClasses.AddObjectEntry('Violation', TViolation); // do not localize - BoldObjectClasses.AddObjectEntry('UMLModelElement', TUMLModelElement); // do not localize - BoldObjectClasses.AddObjectEntry('UMLAction', TUMLAction); // do not localize - BoldObjectClasses.AddObjectEntry('UMLArgument', TUMLArgument); // do not localize - BoldObjectClasses.AddObjectEntry('UMLAssociationEnd', TUMLAssociationEnd); // do not localize - BoldObjectClasses.AddObjectEntry('UMLAttributeLink', TUMLAttributeLink); // do not localize - BoldObjectClasses.AddObjectEntry('UMLComment', TUMLComment); // do not localize - BoldObjectClasses.AddObjectEntry('UMLConstraint', TUMLConstraint); // do not localize - BoldObjectClasses.AddObjectEntry('UMLEvent', TUMLEvent); // do not localize - BoldObjectClasses.AddObjectEntry('UMLExtensionPoint', TUMLExtensionPoint); // do not localize - BoldObjectClasses.AddObjectEntry('UMLFeature', TUMLFeature); // do not localize - BoldObjectClasses.AddObjectEntry('UMLGuard', TUMLGuard); // do not localize - BoldObjectClasses.AddObjectEntry('UMLInstance', TUMLInstance); // do not localize - BoldObjectClasses.AddObjectEntry('UMLInteraction', TUMLInteraction); // do not localize - BoldObjectClasses.AddObjectEntry('UMLLink', TUMLLink); // do not localize - BoldObjectClasses.AddObjectEntry('UMLLinkEnd', TUMLLinkEnd); // do not localize - BoldObjectClasses.AddObjectEntry('UMLMessage', TUMLMessage); // do not localize - BoldObjectClasses.AddObjectEntry('UMLNamespace', TUMLNamespace); // do not localize - BoldObjectClasses.AddObjectEntry('UMLParameter', TUMLParameter); // do not localize - BoldObjectClasses.AddObjectEntry('UMLPartition', TUMLPartition); // do not localize - BoldObjectClasses.AddObjectEntry('UMLRelationship', TUMLRelationship); // do not localize - BoldObjectClasses.AddObjectEntry('UMLStateMachine', TUMLStateMachine); // do not localize - BoldObjectClasses.AddObjectEntry('UMLStateVertex', TUMLStateVertex); // do not localize - BoldObjectClasses.AddObjectEntry('UMLStimulus', TUMLStimulus); // do not localize - BoldObjectClasses.AddObjectEntry('UMLTaggedValue', TUMLTaggedValue); // do not localize - BoldObjectClasses.AddObjectEntry('UMLTransition', TUMLTransition); // do not localize - BoldObjectClasses.AddObjectEntry('UMLActionSequence', TUMLActionSequence); // do not localize - BoldObjectClasses.AddObjectEntry('UMLCallAction', TUMLCallAction); // do not localize - BoldObjectClasses.AddObjectEntry('UMLCreateAction', TUMLCreateAction); // do not localize - BoldObjectClasses.AddObjectEntry('UMLDestroyAction', TUMLDestroyAction); // do not localize - BoldObjectClasses.AddObjectEntry('UMLReturnAction', TUMLReturnAction); // do not localize - BoldObjectClasses.AddObjectEntry('UMLSendAction', TUMLSendAction); // do not localize - BoldObjectClasses.AddObjectEntry('UMLTerminateAction', TUMLTerminateAction); // do not localize - BoldObjectClasses.AddObjectEntry('UMLUninterpretedAction', TUMLUninterpretedAction); // do not localize - BoldObjectClasses.AddObjectEntry('UMLAssociationEndRole', TUMLAssociationEndRole); // do not localize - BoldObjectClasses.AddObjectEntry('UMLCallEvent', TUMLCallEvent); // do not localize - BoldObjectClasses.AddObjectEntry('UMLChangeEvent', TUMLChangeEvent); // do not localize - BoldObjectClasses.AddObjectEntry('UMLSignalEvent', TUMLSignalEvent); // do not localize - BoldObjectClasses.AddObjectEntry('UMLTimeEvent', TUMLTimeEvent); // do not localize - BoldObjectClasses.AddObjectEntry('UMLBehavioralFeature', TUMLBehavioralFeature); // do not localize - BoldObjectClasses.AddObjectEntry('UMLStructuralFeature', TUMLStructuralFeature); // do not localize - BoldObjectClasses.AddObjectEntry('UMLComponentInstance', TUMLComponentInstance); // do not localize - BoldObjectClasses.AddObjectEntry('UMLDataValue', TUMLDataValue); // do not localize - BoldObjectClasses.AddObjectEntry('UMLNodeInstance', TUMLNodeInstance); // do not localize - BoldObjectClasses.AddObjectEntry('UMLObject', TUMLObject); // do not localize - BoldObjectClasses.AddObjectEntry('UMLUseCaseInstance', TUMLUseCaseInstance); // do not localize - BoldObjectClasses.AddObjectEntry('UMLGeneralizableElement', TUMLGeneralizableElement); // do not localize - BoldObjectClasses.AddObjectEntry('UMLDependency', TUMLDependency); // do not localize - BoldObjectClasses.AddObjectEntry('UMLExtend', TUMLExtend); // do not localize - BoldObjectClasses.AddObjectEntry('UMLFlow', TUMLFlow); // do not localize - BoldObjectClasses.AddObjectEntry('UMLGeneralization', TUMLGeneralization); // do not localize - BoldObjectClasses.AddObjectEntry('UMLInclude', TUMLInclude); // do not localize - BoldObjectClasses.AddObjectEntry('UMLActivityGraph', TUMLActivityGraph); // do not localize - BoldObjectClasses.AddObjectEntry('UMLPseudostate', TUMLPseudostate); // do not localize - BoldObjectClasses.AddObjectEntry('UMLState', TUMLState); // do not localize - BoldObjectClasses.AddObjectEntry('UMLStubState', TUMLStubState); // do not localize - BoldObjectClasses.AddObjectEntry('UMLSynchState', TUMLSynchState); // do not localize - BoldObjectClasses.AddObjectEntry('UMLMethod', TUMLMethod); // do not localize - BoldObjectClasses.AddObjectEntry('UMLOperation', TUMLOperation); // do not localize - BoldObjectClasses.AddObjectEntry('UMLReception', TUMLReception); // do not localize - BoldObjectClasses.AddObjectEntry('UMLAttribute', TUMLAttribute); // do not localize - BoldObjectClasses.AddObjectEntry('UMLAssociation', TUMLAssociation); // do not localize - BoldObjectClasses.AddObjectEntry('UMLClassifier', TUMLClassifier); // do not localize - BoldObjectClasses.AddObjectEntry('UMLCollaboration', TUMLCollaboration); // do not localize - BoldObjectClasses.AddObjectEntry('UMLPackage', TUMLPackage); // do not localize - BoldObjectClasses.AddObjectEntry('UMLStereotype', TUMLStereotype); // do not localize - BoldObjectClasses.AddObjectEntry('UMLAbstraction', TUMLAbstraction); // do not localize - BoldObjectClasses.AddObjectEntry('UMLBinding', TUMLBinding); // do not localize - BoldObjectClasses.AddObjectEntry('UMLPermission', TUMLPermission); // do not localize - BoldObjectClasses.AddObjectEntry('UMLUsage', TUMLUsage); // do not localize - BoldObjectClasses.AddObjectEntry('UMLCompositeState', TUMLCompositeState); // do not localize - BoldObjectClasses.AddObjectEntry('UMLFinalState', TUMLFinalState); // do not localize - BoldObjectClasses.AddObjectEntry('UMLSimpleState', TUMLSimpleState); // do not localize - BoldObjectClasses.AddObjectEntry('UMLAssociationRole', TUMLAssociationRole); // do not localize - BoldObjectClasses.AddObjectEntry('UMLActor', TUMLActor); // do not localize - BoldObjectClasses.AddObjectEntry('UMLClass', TUMLClass); // do not localize - BoldObjectClasses.AddObjectEntry('UMLClassifierInState', TUMLClassifierInState); // do not localize - BoldObjectClasses.AddObjectEntry('UMLClassifierRole', TUMLClassifierRole); // do not localize - BoldObjectClasses.AddObjectEntry('UMLComponent', TUMLComponent); // do not localize - BoldObjectClasses.AddObjectEntry('UMLDataType', TUMLDataType); // do not localize - BoldObjectClasses.AddObjectEntry('UMLInterface', TUMLInterface); // do not localize - BoldObjectClasses.AddObjectEntry('UMLNode', TUMLNode); // do not localize - BoldObjectClasses.AddObjectEntry('UMLSignal', TUMLSignal); // do not localize - BoldObjectClasses.AddObjectEntry('UMLUseCase', TUMLUseCase); // do not localize - BoldObjectClasses.AddObjectEntry('UMLModel', TUMLModel); // do not localize - BoldObjectClasses.AddObjectEntry('UMLSubsystem', TUMLSubsystem); // do not localize - BoldObjectClasses.AddObjectEntry('UMLSubmachineState', TUMLSubmachineState); // do not localize - BoldObjectClasses.AddObjectEntry('UMLActionState', TUMLActionState); // do not localize - BoldObjectClasses.AddObjectEntry('UMLObjectFlowState', TUMLObjectFlowState); // do not localize - BoldObjectClasses.AddObjectEntry('UMLException', TUMLException); // do not localize - BoldObjectClasses.AddObjectEntry('UMLSubactivityState', TUMLSubactivityState); // do not localize - BoldObjectClasses.AddObjectEntry('UMLCallState', TUMLCallState); // do not localize + BoldObjectClasses.AddObjectEntry('UMLModelRoot', TUMLModelRoot); + BoldObjectClasses.AddObjectEntry('Argumentstimulus1', Targumentstimulus1); + BoldObjectClasses.AddObjectEntry('AssociationEndRoleavailableQualifier', TassociationEndRoleavailableQualifier); + BoldObjectClasses.AddObjectEntry('ClassifierclassifierRole_', TclassifierclassifierRole_); + BoldObjectClasses.AddObjectEntry('ClassifierInStateinState', TclassifierInStateinState); + BoldObjectClasses.AddObjectEntry('ClassifierRole_availableFeature', TclassifierRole_availableFeature); + BoldObjectClasses.AddObjectEntry('ClassifierRoleavailableContents', TclassifierRoleavailableContents); + BoldObjectClasses.AddObjectEntry('ClientclientDependency', TclientclientDependency); + BoldObjectClasses.AddObjectEntry('CollaborationconstrainingElement', TcollaborationconstrainingElement); + BoldObjectClasses.AddObjectEntry('CommentannotatedElement', TcommentannotatedElement); + BoldObjectClasses.AddObjectEntry('ConstrainedElementconstraint', TconstrainedElementconstraint); + BoldObjectClasses.AddObjectEntry('Contentspartition', Tcontentspartition); + BoldObjectClasses.AddObjectEntry('ContextraisedSignal', TcontextraisedSignal); + BoldObjectClasses.AddObjectEntry('DeploymentLocationresident', TdeploymentLocationresident); + BoldObjectClasses.AddObjectEntry('UMLElement', TUMLElement); + BoldObjectClasses.AddObjectEntry('UMLElementImport', TUMLElementImport); + BoldObjectClasses.AddObjectEntry('UMLElementResidence', TUMLElementResidence); + BoldObjectClasses.AddObjectEntry('ExtensionPointextend', TextensionPointextend); + BoldObjectClasses.AddObjectEntry('Instanceclassifier', Tinstanceclassifier); + BoldObjectClasses.AddObjectEntry('Parameterstate', Tparameterstate); + BoldObjectClasses.AddObjectEntry('Participantspecification', Tparticipantspecification); + BoldObjectClasses.AddObjectEntry('Predecessormessage3', Tpredecessormessage3); + BoldObjectClasses.AddObjectEntry('UMLPresentationElement', TUMLPresentationElement); + BoldObjectClasses.AddObjectEntry('Presentationsubject', Tpresentationsubject); + BoldObjectClasses.AddObjectEntry('SourceFlowsource', TsourceFlowsource); + BoldObjectClasses.AddObjectEntry('StatedeferrableEvent', TstatedeferrableEvent); + BoldObjectClasses.AddObjectEntry('SuppliersupplierDependency', TsuppliersupplierDependency); + BoldObjectClasses.AddObjectEntry('TargetFlowtarget', TtargetFlowtarget); + BoldObjectClasses.AddObjectEntry('UMLTemplateParameter', TUMLTemplateParameter); + BoldObjectClasses.AddObjectEntry('Validator', TValidator); + BoldObjectClasses.AddObjectEntry('Violation', TViolation); + BoldObjectClasses.AddObjectEntry('UMLModelElement', TUMLModelElement); + BoldObjectClasses.AddObjectEntry('UMLAction', TUMLAction); + BoldObjectClasses.AddObjectEntry('UMLArgument', TUMLArgument); + BoldObjectClasses.AddObjectEntry('UMLAssociationEnd', TUMLAssociationEnd); + BoldObjectClasses.AddObjectEntry('UMLAttributeLink', TUMLAttributeLink); + BoldObjectClasses.AddObjectEntry('UMLComment', TUMLComment); + BoldObjectClasses.AddObjectEntry('UMLConstraint', TUMLConstraint); + BoldObjectClasses.AddObjectEntry('UMLEvent', TUMLEvent); + BoldObjectClasses.AddObjectEntry('UMLExtensionPoint', TUMLExtensionPoint); + BoldObjectClasses.AddObjectEntry('UMLFeature', TUMLFeature); + BoldObjectClasses.AddObjectEntry('UMLGuard', TUMLGuard); + BoldObjectClasses.AddObjectEntry('UMLInstance', TUMLInstance); + BoldObjectClasses.AddObjectEntry('UMLInteraction', TUMLInteraction); + BoldObjectClasses.AddObjectEntry('UMLLink', TUMLLink); + BoldObjectClasses.AddObjectEntry('UMLLinkEnd', TUMLLinkEnd); + BoldObjectClasses.AddObjectEntry('UMLMessage', TUMLMessage); + BoldObjectClasses.AddObjectEntry('UMLNamespace', TUMLNamespace); + BoldObjectClasses.AddObjectEntry('UMLParameter', TUMLParameter); + BoldObjectClasses.AddObjectEntry('UMLPartition', TUMLPartition); + BoldObjectClasses.AddObjectEntry('UMLRelationship', TUMLRelationship); + BoldObjectClasses.AddObjectEntry('UMLStateMachine', TUMLStateMachine); + BoldObjectClasses.AddObjectEntry('UMLStateVertex', TUMLStateVertex); + BoldObjectClasses.AddObjectEntry('UMLStimulus', TUMLStimulus); + BoldObjectClasses.AddObjectEntry('UMLTaggedValue', TUMLTaggedValue); + BoldObjectClasses.AddObjectEntry('UMLTransition', TUMLTransition); + BoldObjectClasses.AddObjectEntry('UMLActionSequence', TUMLActionSequence); + BoldObjectClasses.AddObjectEntry('UMLCallAction', TUMLCallAction); + BoldObjectClasses.AddObjectEntry('UMLCreateAction', TUMLCreateAction); + BoldObjectClasses.AddObjectEntry('UMLDestroyAction', TUMLDestroyAction); + BoldObjectClasses.AddObjectEntry('UMLReturnAction', TUMLReturnAction); + BoldObjectClasses.AddObjectEntry('UMLSendAction', TUMLSendAction); + BoldObjectClasses.AddObjectEntry('UMLTerminateAction', TUMLTerminateAction); + BoldObjectClasses.AddObjectEntry('UMLUninterpretedAction', TUMLUninterpretedAction); + BoldObjectClasses.AddObjectEntry('UMLAssociationEndRole', TUMLAssociationEndRole); + BoldObjectClasses.AddObjectEntry('UMLCallEvent', TUMLCallEvent); + BoldObjectClasses.AddObjectEntry('UMLChangeEvent', TUMLChangeEvent); + BoldObjectClasses.AddObjectEntry('UMLSignalEvent', TUMLSignalEvent); + BoldObjectClasses.AddObjectEntry('UMLTimeEvent', TUMLTimeEvent); + BoldObjectClasses.AddObjectEntry('UMLBehavioralFeature', TUMLBehavioralFeature); + BoldObjectClasses.AddObjectEntry('UMLStructuralFeature', TUMLStructuralFeature); + BoldObjectClasses.AddObjectEntry('UMLComponentInstance', TUMLComponentInstance); + BoldObjectClasses.AddObjectEntry('UMLDataValue', TUMLDataValue); + BoldObjectClasses.AddObjectEntry('UMLNodeInstance', TUMLNodeInstance); + BoldObjectClasses.AddObjectEntry('UMLObject', TUMLObject); + BoldObjectClasses.AddObjectEntry('UMLUseCaseInstance', TUMLUseCaseInstance); + BoldObjectClasses.AddObjectEntry('UMLGeneralizableElement', TUMLGeneralizableElement); + BoldObjectClasses.AddObjectEntry('UMLDependency', TUMLDependency); + BoldObjectClasses.AddObjectEntry('UMLExtend', TUMLExtend); + BoldObjectClasses.AddObjectEntry('UMLFlow', TUMLFlow); + BoldObjectClasses.AddObjectEntry('UMLGeneralization', TUMLGeneralization); + BoldObjectClasses.AddObjectEntry('UMLInclude', TUMLInclude); + BoldObjectClasses.AddObjectEntry('UMLActivityGraph', TUMLActivityGraph); + BoldObjectClasses.AddObjectEntry('UMLPseudostate', TUMLPseudostate); + BoldObjectClasses.AddObjectEntry('UMLState', TUMLState); + BoldObjectClasses.AddObjectEntry('UMLStubState', TUMLStubState); + BoldObjectClasses.AddObjectEntry('UMLSynchState', TUMLSynchState); + BoldObjectClasses.AddObjectEntry('UMLMethod', TUMLMethod); + BoldObjectClasses.AddObjectEntry('UMLOperation', TUMLOperation); + BoldObjectClasses.AddObjectEntry('UMLReception', TUMLReception); + BoldObjectClasses.AddObjectEntry('UMLAttribute', TUMLAttribute); + BoldObjectClasses.AddObjectEntry('UMLAssociation', TUMLAssociation); + BoldObjectClasses.AddObjectEntry('UMLClassifier', TUMLClassifier); + BoldObjectClasses.AddObjectEntry('UMLCollaboration', TUMLCollaboration); + BoldObjectClasses.AddObjectEntry('UMLPackage', TUMLPackage); + BoldObjectClasses.AddObjectEntry('UMLStereotype', TUMLStereotype); + BoldObjectClasses.AddObjectEntry('UMLAbstraction', TUMLAbstraction); + BoldObjectClasses.AddObjectEntry('UMLBinding', TUMLBinding); + BoldObjectClasses.AddObjectEntry('UMLPermission', TUMLPermission); + BoldObjectClasses.AddObjectEntry('UMLUsage', TUMLUsage); + BoldObjectClasses.AddObjectEntry('UMLCompositeState', TUMLCompositeState); + BoldObjectClasses.AddObjectEntry('UMLFinalState', TUMLFinalState); + BoldObjectClasses.AddObjectEntry('UMLSimpleState', TUMLSimpleState); + BoldObjectClasses.AddObjectEntry('UMLAssociationRole', TUMLAssociationRole); + BoldObjectClasses.AddObjectEntry('UMLActor', TUMLActor); + BoldObjectClasses.AddObjectEntry('UMLClass', TUMLClass); + BoldObjectClasses.AddObjectEntry('UMLClassifierInState', TUMLClassifierInState); + BoldObjectClasses.AddObjectEntry('UMLClassifierRole', TUMLClassifierRole); + BoldObjectClasses.AddObjectEntry('UMLComponent', TUMLComponent); + BoldObjectClasses.AddObjectEntry('UMLDataType', TUMLDataType); + BoldObjectClasses.AddObjectEntry('UMLInterface', TUMLInterface); + BoldObjectClasses.AddObjectEntry('UMLNode', TUMLNode); + BoldObjectClasses.AddObjectEntry('UMLSignal', TUMLSignal); + BoldObjectClasses.AddObjectEntry('UMLUseCase', TUMLUseCase); + BoldObjectClasses.AddObjectEntry('UMLModel', TUMLModel); + BoldObjectClasses.AddObjectEntry('UMLSubsystem', TUMLSubsystem); + BoldObjectClasses.AddObjectEntry('UMLSubmachineState', TUMLSubmachineState); + BoldObjectClasses.AddObjectEntry('UMLActionState', TUMLActionState); + BoldObjectClasses.AddObjectEntry('UMLObjectFlowState', TUMLObjectFlowState); + BoldObjectClasses.AddObjectEntry('UMLException', TUMLException); + BoldObjectClasses.AddObjectEntry('UMLSubactivityState', TUMLSubactivityState); + BoldObjectClasses.AddObjectEntry('UMLCallState', TUMLCallState); end; var CodeDescriptor: TBoldGeneratedCodeDescriptor; initialization - CodeDescriptor := GeneratedCodes.AddGeneratedCodeDescriptorWithFunc('BoldUMLModel', InstallBusinessClasses, InstallObjectListClasses, GeneratedCodeCRC); // do not localize + CodeDescriptor := GeneratedCodes.AddGeneratedCodeDescriptorWithFunc('BoldUMLModel', InstallBusinessClasses, InstallObjectListClasses, GeneratedCodeCRC); finalization GeneratedCodes.Remove(CodeDescriptor); end. - - diff --git a/Source/UMLModel/Core/BoldUMLModelConverter.pas b/Source/UMLModel/Core/BoldUMLModelConverter.pas index 8a00e2b9..3028d6f3 100644 --- a/Source/UMLModel/Core/BoldUMLModelConverter.pas +++ b/Source/UMLModel/Core/BoldUMLModelConverter.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLModelConverter; interface @@ -49,8 +52,7 @@ implementation BoldMetaSupport, BoldDefaultTaggedValues, BoldUMLModelSupport, - BoldUMLTypes, - UMLConsts; + BoldUMLTypes; class function TBoldModelConverter.UMLModelToMold(UMLModel: TUMLModel): TMoldModel; var @@ -62,7 +64,7 @@ class function TBoldModelConverter.UMLModelToMold(UMLModel: TUMLModel): TMoldMod begin MoldModel := TMoldModel.Create(nil, UMLModel.Name); UMLElementToMoldElement(UMLModel, MoldModel); - BoldLog.StartLog(sConvertingModelToMold); + BoldLog.StartLog('Converting UMLModel to Mold'); BoldLog.ProgressMax := UMLModel.Classes.Count + UMLModel.Associations.Count; UMLRootClass := UMLModelGetUniqueRootClass(UMLModel); @@ -191,7 +193,6 @@ class procedure TBoldModelConverter.UMLAttributeToMoldQualifier(UMLAttribute: TU with MoldQualifier do begin BoldType := UMLAttribute.typeName; - // FIXME more properties end; end; @@ -289,7 +290,7 @@ class procedure TBoldModelConverter.MoldModelToUMLModel(MoldModel: TMoldModel; U UMLAssociation: TUMLAssociation; begin MoldElementToUMLElement(MoldModel, UMLModel); - BoldLog.StartLog(sConvertingModelToUML); + BoldLog.StartLog('Converting MoldModel to UML'); BoldLog.ProgressMax := MoldModel.Classes.Count + MoldModel.Associations.Count; BoldInstalledQueue.DeactivateDisplayQueue; TBoldUMLBoldify.SetRootClassName(UMLModel, MoldModel.RootClass.Name); @@ -304,7 +305,6 @@ class procedure TBoldModelConverter.MoldModelToUMLModel(MoldModel: TMoldModel; U for i := 0 to MoldModel.Associations.Count-1 do begin - // ska alltd skapa ny!!!!! UMLAssociation := GetUMLAssociationByName(MoldModel.Associations[i].name, UMLModel); MoldAssociationToUMLAssociation(MoldModel.Associations[i], UMLAssociation); BoldLog.ProgressStep; @@ -426,7 +426,7 @@ class procedure TBoldModelConverter.MoldMethodToUMLOperation(MoldMethod: TMoldMe begin ReturnUMLParameter := TUMLParameter.Create(UMLOperation.BoldSystem); Parameter.Add(ReturnUMLParameter); - ReturnUMLParameter.Name := 'return'; // do not localize + ReturnUMLParameter.Name := 'return'; ReturnUMLParameter.kind := pdReturn; ReturnUMLParameter.typeName := MoldMethod.ReturnType; ReturnUMLParameter.SetBoldTV(TAG_DELPHINAME, TV_NAME); @@ -443,7 +443,6 @@ class procedure TBoldModelConverter.MoldRoleToUMLAssociationEnd(MoldRole: TMoldR MoldElementToUMLElement(MoldRole, UMLAssociationEnd); with UMLAssociationEnd do begin - // Fixa här if Assigned(MoldRole.OtherEnd.MoldClass) then Type_ := GetUMLClassByName(MoldRole.OtherEnd.MoldClass.name, Association.model) else @@ -469,7 +468,6 @@ class procedure TBoldModelConverter.MoldQualifierToUMLAttribute(MoldQualifier: T with UMLAttribute do begin typeName := MoldQualifier.BoldType; - // FIXME set more properties end; end; @@ -524,4 +522,6 @@ class function TBoldModelConverter.GetUMLAssociationByName(const name: string; U UMLModel.OwnedElement.Add(Result); end; +initialization + end. diff --git a/Source/UMLModel/Core/BoldUMLModelDataModule.dfm b/Source/UMLModel/Core/BoldUMLModelDataModule.dfm index 960666ec..e9756df5 100644 --- a/Source/UMLModel/Core/BoldUMLModelDataModule.dfm +++ b/Source/UMLModel/Core/BoldUMLModelDataModule.dfm @@ -1,7 +1,5 @@ object dmModelEdit: TdmModelEdit OldCreateOrder = True - Left = 186 - Top = 140 Height = 479 Width = 741 object bmlUMLModel: TBoldModel @@ -88,50 +86,6 @@ object dmModelEdit: TdmModelEdit #9#9#9')' #9#9')' #9#9'(Class' - #9#9#9'"Include"' - #9#9#9'"Relationship"' - #9#9#9'TRUE' - #9#9#9'FALSE' - #9#9#9'""' - #9#9#9'""' - - #9#9#9'"_BoldInternal.toolId=35FDD6900154,persistence=persistent,_Bo' + - 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + - 'Elements.Use_Cases,Bold.DelphiName=TUML,Bold.ExpressionNam' + - 'e=UML,Bold.TableName=UML_"' - #9#9#9'(Attributes' - #9#9#9')' - #9#9#9'(Methods' - #9#9#9')' - #9#9')' - #9#9'(Class' - #9#9#9'"ExtensionPoint"' - #9#9#9'"ModelElement"' - #9#9#9'TRUE' - #9#9#9'FALSE' - #9#9#9'""' - #9#9#9'""' - - #9#9#9'"_BoldInternal.toolId=362661700208,persistence=persistent,_Bo' + - 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + - 'Elements.Use_Cases,Bold.DelphiName=TUML,Bold.ExpressionNam' + - 'e=UML,Bold.TableName=UML_"' - #9#9#9'(Attributes' - #9#9#9#9'(Attribute' - #9#9#9#9#9'"location"' - #9#9#9#9#9'"LocationReference"' - #9#9#9#9#9'FALSE' - #9#9#9#9#9'""' - #9#9#9#9#9'""' - #9#9#9#9#9'2' - #9#9#9#9#9'""' - #9#9#9#9#9'"_BoldInternal.toolId=3634E53A00DC,persistence=Persistent"' - #9#9#9#9')' - #9#9#9')' - #9#9#9'(Methods' - #9#9#9')' - #9#9')' - #9#9'(Class' #9#9#9'"ModelElement"' #9#9#9'"Element"' #9#9#9'TRUE' @@ -311,6 +265,67 @@ object dmModelEdit: TdmModelEdit #9#9#9')' #9#9')' #9#9'(Class' + #9#9#9'"Element"' + #9#9#9'"UMLModelRoot"' + #9#9#9'TRUE' + #9#9#9'FALSE' + #9#9#9'""' + #9#9#9'""' + + #9#9#9'"_BoldInternal.toolId=3C5A96DE0300,persistence=persistent,_Bo' + + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + + 'Core,Bold.DelphiName=TUML,Bold.ExpressionName=UML,Bo' + + 'ld.TableName=UML_"' + #9#9#9'(Attributes' + #9#9#9')' + #9#9#9'(Methods' + #9#9#9')' + #9#9')' + #9#9'(Class' + #9#9#9'"Include"' + #9#9#9'"Relationship"' + #9#9#9'TRUE' + #9#9#9'FALSE' + #9#9#9'""' + #9#9#9'""' + + #9#9#9'"_BoldInternal.toolId=35FDD6900154,persistence=persistent,_Bo' + + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + + 'Elements.Use_Cases,Bold.DelphiName=TUML,Bold.ExpressionNam' + + 'e=UML,Bold.TableName=UML_"' + #9#9#9'(Attributes' + #9#9#9')' + #9#9#9'(Methods' + #9#9#9')' + #9#9')' + #9#9'(Class' + #9#9#9'"ExtensionPoint"' + #9#9#9'"ModelElement"' + #9#9#9'TRUE' + #9#9#9'FALSE' + #9#9#9'""' + #9#9#9'""' + + #9#9#9'"_BoldInternal.toolId=362661700208,persistence=persistent,_Bo' + + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + + 'Elements.Use_Cases,Bold.DelphiName=TUML,Bold.ExpressionNam' + + 'e=UML,Bold.TableName=UML_"' + #9#9#9'(Attributes' + #9#9#9#9'(Attribute' + #9#9#9#9#9'"location"' + #9#9#9#9#9'"LocationReference"' + #9#9#9#9#9'FALSE' + #9#9#9#9#9'""' + #9#9#9#9#9'""' + #9#9#9#9#9'2' + #9#9#9#9#9'""' + #9#9#9#9#9'"_BoldInternal.toolId=3634E53A00DC,persistence=Persistent"' + #9#9#9#9')' + #9#9#9')' + #9#9#9'(Methods' + #9#9#9')' + #9#9')' + #9#9'(Class' #9#9#9'"UseCase"' #9#9#9'"Classifier"' #9#9#9'TRUE' @@ -377,6 +392,70 @@ object dmModelEdit: TdmModelEdit #9#9#9')' #9#9')' #9#9'(Class' + #9#9#9'"GeneralizableElement"' + #9#9#9'"Namespace"' + #9#9#9'TRUE' + #9#9#9'TRUE' + #9#9#9'""' + #9#9#9'""' + + #9#9#9'"_BoldInternal.toolId=327A810D03C0,persistence=persistent,_Bo' + + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + + 'Core,Bold.DelphiName=TUML,Bold.ExpressionName=UML,Bo' + + 'ld.TableName=UML_"' + #9#9#9'(Attributes' + #9#9#9#9'(Attribute' + #9#9#9#9#9'"isRoot"' + #9#9#9#9#9'"Boolean"' + #9#9#9#9#9'FALSE' + #9#9#9#9#9'""' + #9#9#9#9#9'""' + #9#9#9#9#9'2' + #9#9#9#9#9'""' + #9#9#9#9#9'"_BoldInternal.toolId=327A877801CC,persistence=Persistent"' + #9#9#9#9')' + #9#9#9#9'(Attribute' + #9#9#9#9#9'"isLeaf"' + #9#9#9#9#9'"Boolean"' + #9#9#9#9#9'FALSE' + #9#9#9#9#9'""' + #9#9#9#9#9'""' + #9#9#9#9#9'2' + #9#9#9#9#9'""' + #9#9#9#9#9'"_BoldInternal.toolId=327A877E006E,persistence=Persistent"' + #9#9#9#9')' + #9#9#9#9'(Attribute' + #9#9#9#9#9'"isAbstract"' + #9#9#9#9#9'"Boolean"' + #9#9#9#9#9'FALSE' + #9#9#9#9#9'""' + #9#9#9#9#9'""' + #9#9#9#9#9'2' + #9#9#9#9#9'""' + #9#9#9#9#9'"_BoldInternal.toolId=327A878400D2,persistence=Persistent"' + #9#9#9#9')' + #9#9#9')' + #9#9#9'(Methods' + #9#9#9')' + #9#9')' + #9#9'(Class' + #9#9#9'"Namespace"' + #9#9#9'"ModelElement"' + #9#9#9'TRUE' + #9#9#9'TRUE' + #9#9#9'""' + #9#9#9'""' + + #9#9#9'"_BoldInternal.toolId=32B69F3A0118,persistence=persistent,_Bo' + + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + + 'Core,Bold.DelphiName=TUML,Bold.ExpressionName=UML,Bo' + + 'ld.TableName=UML_"' + #9#9#9'(Attributes' + #9#9#9')' + #9#9#9'(Methods' + #9#9#9')' + #9#9')' + #9#9'(Class' #9#9#9'"Actor"' #9#9#9'"Classifier"' #9#9#9'TRUE' @@ -1140,6 +1219,46 @@ object dmModelEdit: TdmModelEdit #9#9#9')' #9#9')' #9#9'(Class' + #9#9#9'"Feature"' + #9#9#9'"ModelElement"' + #9#9#9'TRUE' + #9#9#9'TRUE' + #9#9#9'""' + #9#9#9'""' + + #9#9#9'"_BoldInternal.toolId=32989F9700FE,persistence=persistent,_Bo' + + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + + 'Core,Bold.DelphiName=TUML,Bold.ExpressionName=UML,Bo' + + 'ld.TableName=UML_,\"Bold.DerivationExpressions=qualifyingO' + + 'wner=if owner->notEmpty then owner else namespace endif\""' + #9#9#9'(Attributes' + #9#9#9#9'(Attribute' + #9#9#9#9#9'"ownerScope"' + #9#9#9#9#9'"ScopeKind"' + #9#9#9#9#9'FALSE' + #9#9#9#9#9'""' + #9#9#9#9#9'""' + #9#9#9#9#9'2' + #9#9#9#9#9'"instance"' + #9#9#9#9#9'"_BoldInternal.toolId=31653E23032A,persistence=Persistent"' + #9#9#9#9')' + #9#9#9')' + #9#9#9'(Methods' + #9#9#9#9'(Method' + #9#9#9#9#9'"ExpandedExpressionName"' + #9#9#9#9#9'""' + #9#9#9#9#9'FALSE' + #9#9#9#9#9'"String"' + #9#9#9#9#9'"Bold"' + #9#9#9#9#9'2' + #9#9#9#9#9'""' + + #9#9#9#9#9'"_BoldInternal.toolId=3C16140103C2,Bold.OperationKind=Overr' + + 'ide"' + #9#9#9#9')' + #9#9#9')' + #9#9')' + #9#9'(Class' #9#9#9'"Argument"' #9#9#9'"ModelElement"' #9#9#9'TRUE' @@ -1332,53 +1451,6 @@ object dmModelEdit: TdmModelEdit #9#9#9')' #9#9')' #9#9'(Class' - #9#9#9'"GeneralizableElement"' - #9#9#9'"Namespace"' - #9#9#9'TRUE' - #9#9#9'TRUE' - #9#9#9'""' - #9#9#9'""' - - #9#9#9'"_BoldInternal.toolId=327A810D03C0,persistence=persistent,_Bo' + - 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + - 'Core,Bold.DelphiName=TUML,Bold.ExpressionName=UML,Bo' + - 'ld.TableName=UML_"' - #9#9#9'(Attributes' - #9#9#9#9'(Attribute' - #9#9#9#9#9'"isRoot"' - #9#9#9#9#9'"Boolean"' - #9#9#9#9#9'FALSE' - #9#9#9#9#9'""' - #9#9#9#9#9'""' - #9#9#9#9#9'2' - #9#9#9#9#9'""' - #9#9#9#9#9'"_BoldInternal.toolId=327A877801CC,persistence=Persistent"' - #9#9#9#9')' - #9#9#9#9'(Attribute' - #9#9#9#9#9'"isLeaf"' - #9#9#9#9#9'"Boolean"' - #9#9#9#9#9'FALSE' - #9#9#9#9#9'""' - #9#9#9#9#9'""' - #9#9#9#9#9'2' - #9#9#9#9#9'""' - #9#9#9#9#9'"_BoldInternal.toolId=327A877E006E,persistence=Persistent"' - #9#9#9#9')' - #9#9#9#9'(Attribute' - #9#9#9#9#9'"isAbstract"' - #9#9#9#9#9'"Boolean"' - #9#9#9#9#9'FALSE' - #9#9#9#9#9'""' - #9#9#9#9#9'""' - #9#9#9#9#9'2' - #9#9#9#9#9'""' - #9#9#9#9#9'"_BoldInternal.toolId=327A878400D2,persistence=Persistent"' - #9#9#9#9')' - #9#9#9')' - #9#9#9'(Methods' - #9#9#9')' - #9#9')' - #9#9'(Class' #9#9#9'"AssociationRole"' #9#9#9'"Association"' #9#9#9'TRUE' @@ -1953,23 +2025,6 @@ object dmModelEdit: TdmModelEdit #9#9#9')' #9#9')' #9#9'(Class' - #9#9#9'"Namespace"' - #9#9#9'"ModelElement"' - #9#9#9'TRUE' - #9#9#9'TRUE' - #9#9#9'""' - #9#9#9'""' - - #9#9#9'"_BoldInternal.toolId=32B69F3A0118,persistence=persistent,_Bo' + - 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + - 'Core,Bold.DelphiName=TUML,Bold.ExpressionName=UML,Bo' + - 'ld.TableName=UML_"' - #9#9#9'(Attributes' - #9#9#9')' - #9#9#9'(Methods' - #9#9#9')' - #9#9')' - #9#9'(Class' #9#9#9'"Attribute"' #9#9#9'"StructuralFeature"' #9#9#9'TRUE' @@ -2121,63 +2176,6 @@ object dmModelEdit: TdmModelEdit #9#9#9')' #9#9')' #9#9'(Class' - #9#9#9'"Feature"' - #9#9#9'"ModelElement"' - #9#9#9'TRUE' - #9#9#9'TRUE' - #9#9#9'""' - #9#9#9'""' - - #9#9#9'"_BoldInternal.toolId=32989F9700FE,persistence=persistent,_Bo' + - 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + - 'Core,Bold.DelphiName=TUML,Bold.ExpressionName=UML,Bo' + - 'ld.TableName=UML_,\"Bold.DerivationExpressions=qualifyingO' + - 'wner=if owner->notEmpty then owner else namespace endif\""' - #9#9#9'(Attributes' - #9#9#9#9'(Attribute' - #9#9#9#9#9'"ownerScope"' - #9#9#9#9#9'"ScopeKind"' - #9#9#9#9#9'FALSE' - #9#9#9#9#9'""' - #9#9#9#9#9'""' - #9#9#9#9#9'2' - #9#9#9#9#9'"instance"' - #9#9#9#9#9'"_BoldInternal.toolId=31653E23032A,persistence=Persistent"' - #9#9#9#9')' - #9#9#9')' - #9#9#9'(Methods' - #9#9#9#9'(Method' - #9#9#9#9#9'"ExpandedExpressionName"' - #9#9#9#9#9'""' - #9#9#9#9#9'FALSE' - #9#9#9#9#9'"String"' - #9#9#9#9#9'"Bold"' - #9#9#9#9#9'2' - #9#9#9#9#9'""' - - #9#9#9#9#9'"_BoldInternal.toolId=3C16140103C2,Bold.OperationKind=Overr' + - 'ide"' - #9#9#9#9')' - #9#9#9')' - #9#9')' - #9#9'(Class' - #9#9#9'"Element"' - #9#9#9'"UMLModelRoot"' - #9#9#9'TRUE' - #9#9#9'FALSE' - #9#9#9'""' - #9#9#9'""' - - #9#9#9'"_BoldInternal.toolId=3C5A96DE0300,persistence=persistent,_Bo' + - 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + - 'Core,Bold.DelphiName=TUML,Bold.ExpressionName=UML,Bo' + - 'ld.TableName=UML_"' - #9#9#9'(Attributes' - #9#9#9')' - #9#9#9'(Methods' - #9#9#9')' - #9#9')' - #9#9'(Class' #9#9#9'"Generalization"' #9#9#9'"Relationship"' #9#9#9'TRUE' @@ -3125,7 +3123,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=35FDD9A30168,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=35FDD9A30168,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Use_Cases,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -3168,7 +3166,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=362661DA01D6,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=362661DA01D6,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Use_Cases,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -3211,7 +3209,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3626B0DA0104,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3626B0DA0104,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Use_Cases,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -3254,7 +3252,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=35FDD86301E0,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=35FDD86301E0,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Use_Cases,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -3297,7 +3295,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=35FDD86B006E,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=35FDD86B006E,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Use_Cases,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -3340,7 +3338,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=35FDD992037A,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=35FDD992037A,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Use_Cases,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -3383,7 +3381,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33377C0D0208,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33377C0D0208,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.State_Machines,_Boldify.noName=True,Bold.DelphiName="' @@ -3427,7 +3425,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=328902D000D2,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=328902D000D2,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.State_Machines,_Boldify.noName=True,Bold.DelphiName="' @@ -3471,7 +3469,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3288E5390226,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3288E5390226,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.State_Machines,_Boldify.noName=True,Bold.DelphiName="' @@ -3519,7 +3517,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3288D8C4023A,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3288D8C4023A,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.State_Machines,_Boldify.noName=True,Bold.DelphiName="' @@ -3563,7 +3561,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3288E53D029E,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3288E53D029E,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.State_Machines,_Boldify.noName=True,Bold.DelphiName="' @@ -3607,7 +3605,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3288D725037A,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3288D725037A,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.State_Machines,_Boldify.noName=True,Bold.DelphiName="' @@ -3651,7 +3649,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3403125E0140,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3403125E0140,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.State_Machines,_Boldify.noName=True,Bold.DelphiName="' @@ -3695,7 +3693,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=364987D1017D,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=364987D1017D,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.State_Machines,_Boldify.noName=True,Bold.DelphiName="' @@ -3739,7 +3737,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=32890282014A,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=32890282014A,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.State_Machines,_Boldify.noName=True,Bold.DelphiName="' @@ -3783,7 +3781,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3289028C03D4,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3289028C03D4,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.State_Machines,_Boldify.noName=True,Bold.DelphiName="' @@ -3827,7 +3825,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3369606C0000,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3369606C0000,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.State_Machines,Bold.DelphiName="' #9#9#9'FALSE' @@ -3870,7 +3868,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3369912001A4,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3369912001A4,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.State_Machines,_Boldify.noName=True,Bold.DelphiName="' @@ -3914,7 +3912,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=333784B400AA,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=333784B400AA,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.State_Machines,_Boldify.noName=True,Bold.DelphiName="' @@ -3960,7 +3958,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3337AF9B02A8,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3337AF9B02A8,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.State_Machines,Bold.DelphiName="' #9#9#9'FALSE' @@ -4003,7 +4001,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=336A39BE0136,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=336A39BE0136,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.State_Machines,_Boldify.noName=True,Bold.DelphiName="' @@ -4047,7 +4045,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33FA3ABF0122,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33FA3ABF0122,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.State_Machines,_Boldify.noName=True,Bold.DelphiName="' @@ -4091,7 +4089,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=32B598420168,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=32B598420168,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.State_Machines,_Boldify.noName=True,Bold.DelphiName="' @@ -4135,7 +4133,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33CF8BD300A0,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33CF8BD300A0,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.State_Machines,_Boldify.noName=True,Bold.DelphiName="' @@ -4181,7 +4179,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33EBFA1C0078,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33EBFA1C0078,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.State_Machines,_Boldify.noName=True,Bold.DelphiName="' @@ -4225,7 +4223,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33FA37050118,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33FA37050118,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,_Boldify.noName=True,Bold.DelphiName="' @@ -4269,7 +4267,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33DBC1A200B4,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33DBC1A200B4,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,_Boldify.noName=True,Bold.DelphiName="' @@ -4313,7 +4311,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33DBC16D0190,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33DBC16D0190,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,_Boldify.noName=True,Bold.DelphiName="' @@ -4357,7 +4355,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33FF4EF7029E,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33FF4EF7029E,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,_Boldify.noName=True,Bold.DelphiName="' @@ -4401,7 +4399,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=328A5BB20280,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=328A5BB20280,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,_Boldify.noName=True,Bold.DelphiName="' @@ -4445,7 +4443,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33FFD9830014,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33FFD9830014,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,_Boldify.noName=True,Bold.DelphiName="' @@ -4489,7 +4487,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33FF558A01AE,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33FF558A01AE,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,_Boldify.noName=True,Bold.DelphiName="' @@ -4537,7 +4535,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33CFD0A602F8,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33CFD0A602F8,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,Bold.DelphiName="' #9#9#9'FALSE' @@ -4580,7 +4578,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33CFA4B80334,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33CFA4B80334,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,_Boldify.noName=True,Bold.DelphiName="' @@ -4626,7 +4624,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3650F0CC0262,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3650F0CC0262,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,_Boldify.noName=True,Bold.DelphiName="' @@ -4670,7 +4668,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3650EE68008C,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3650EE68008C,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,_Boldify.noName=True,Bold.DelphiName="' @@ -4716,7 +4714,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3650ECD402C6,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3650ECD402C6,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,_Boldify.noName=True,Bold.DelphiName="' @@ -4760,7 +4758,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3742033C00F0,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3742033C00F0,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,_Boldify.noName=True,Bold.DelphiName="' @@ -4804,7 +4802,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C14A984017C,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C14A984017C,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,_Boldify.noName=True,Bold.DelphiName="' @@ -4848,7 +4846,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C14A52203C7,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C14A52203C7,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,_Boldify.noName=True,Bold.DelphiName="' @@ -4892,7 +4890,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C14955602A0,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C14955602A0,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,_Boldify.noName=True,Bold.DelphiName="' @@ -4936,7 +4934,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=34030E1501CC,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=34030E1501CC,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,_Boldify.noName=True,Bold.DelphiName="' @@ -4980,7 +4978,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=328A5C1F0118,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=328A5C1F0118,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,_Boldify.noName=True,Bold.DelphiName="' @@ -5024,7 +5022,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=328A598B00F0,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=328A598B00F0,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,_Boldify.noName=True,Bold.DelphiName="' @@ -5068,7 +5066,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=36266EA903C0,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=36266EA903C0,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,_Boldify.noName=True,Bold.DelphiName="' @@ -5112,7 +5110,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=364B65E8024E,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=364B65E8024E,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,Bold.DelphiName="' #9#9#9'FALSE' @@ -5157,7 +5155,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=364B65E4008C,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=364B65E4008C,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,Bold.DelphiName="' #9#9#9'FALSE' @@ -5202,7 +5200,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3635552000DC,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3635552000DC,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Common_Behavior,_Boldify.noName=True,Bold.DelphiName="' @@ -5246,7 +5244,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3388DE7600DC,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3388DE7600DC,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Collaborations,_Boldify.noName=True,Bold.DelphiName="' @@ -5290,7 +5288,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3388DD5C00E6,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3388DD5C00E6,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Collaborations,_Boldify.noName=True,Bold.DelphiName="' @@ -5336,7 +5334,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33CD50F90000,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33CD50F90000,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Collaborations,_Boldify.noName=True,Bold.DelphiName="' @@ -5380,7 +5378,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33CD57D201B8,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33CD57D201B8,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Collaborations,_Boldify.noName=True,Bold.DelphiName="' @@ -5428,7 +5426,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33CD511600AA,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33CD511600AA,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Collaborations,_Boldify.noName=True,Bold.DelphiName="' @@ -5472,7 +5470,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33D1394D00F0,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33D1394D00F0,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Collaborations,_Boldify.noName=True,Bold.DelphiName="' @@ -5516,7 +5514,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=36008FB50168,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=36008FB50168,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Collaborations,_Boldify.noName=True,Bold.DelphiName="' @@ -5564,7 +5562,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=35FEAB5D038E,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=35FEAB5D038E,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Collaborations,_Boldify.noName=True,Bold.DelphiName="' @@ -5610,7 +5608,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=36265CF80136,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=36265CF80136,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Collaborations,_Boldify.noName=True,Bold.DelphiName="' @@ -5656,7 +5654,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C14BC4101E8,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C14BC4101E8,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Collaborations,_Boldify.noName=True,Bold.DelphiName="' @@ -5700,7 +5698,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3650E6BD010E,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3650E6BD010E,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Collaborations,_Boldify.noName=True,Bold.DelphiName="' @@ -5748,7 +5746,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33FA39D50050,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33FA39D50050,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Collaborations,_Boldify.noName=True,Bold.DelphiName="' @@ -5792,7 +5790,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33D1470D01A4,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33D1470D01A4,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Collaborations,_Boldify.noName=True,Bold.DelphiName="' @@ -5836,7 +5834,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33D142DC0262,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33D142DC0262,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Collaborations,_Boldify.noName=True,Bold.DelphiName="' @@ -5880,7 +5878,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33D147100302,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33D147100302,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Collaborations,_Boldify.noName=True,Bold.DelphiName="' @@ -5924,7 +5922,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33DBBB45035C,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33DBBB45035C,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Collaborations,_Boldify.noName=True,Bold.DelphiName="' @@ -5968,7 +5966,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33DBBB2B0000,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33DBBB2B0000,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Collaborations,_Boldify.noName=True,Bold.DelphiName="' @@ -6012,7 +6010,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C14CA560322,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C14CA560322,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Activity_Graphs,_Boldify.noName=True,Bold.DelphiName="' @@ -6056,7 +6054,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C14CBCF01DA,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C14CBCF01DA,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Activity_Graphs,_Boldify.noName=True,Bold.DelphiName="' @@ -6100,7 +6098,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C14CD10031C,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C14CD10031C,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Activity_Graphs,_Boldify.noName=True,Bold.DelphiName="' @@ -6144,7 +6142,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C14C8D202A2,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C14C8D202A2,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Activity_Graphs,_Boldify.noName=True,Bold.DelphiName="' @@ -6188,7 +6186,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C14C9380321,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C14C9380321,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Activity_Graphs,_Boldify.noName=True,Bold.DelphiName="' @@ -6232,7 +6230,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C14C9FC0387,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C14C9FC0387,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Behavioral_' + 'Elements.Activity_Graphs,_Boldify.noName=True,Bold.DelphiName="' @@ -6276,7 +6274,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=36240CA3028A,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=36240CA3028A,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -6321,7 +6319,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=36240BF10028,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=36240BF10028,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -6368,7 +6366,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=362409A800BE,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=362409A800BE,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -6411,7 +6409,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3627D60D03C0,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3627D60D03C0,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -6454,7 +6452,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3627D5E8006E,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3627D5E8006E,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -6497,7 +6495,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=36241238028A,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=36241238028A,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -6542,7 +6540,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=335C0D770302,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=335C0D770302,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -6585,7 +6583,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33DBE5050028,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33DBE5050028,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -6628,7 +6626,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=335C14690334,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=335C14690334,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -6671,7 +6669,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=335C14A102DA,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=335C14A102DA,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -6714,7 +6712,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33EA67B702EE,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33EA67B702EE,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -6757,7 +6755,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33FFE57902A2,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33FFE57902A2,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -6800,7 +6798,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33F0EFAB0050,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33F0EFAB0050,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -6843,7 +6841,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C10E44700C4,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C10E44700C4,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -6886,7 +6884,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C10E42301C7,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C10E42301C7,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -6929,7 +6927,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C10E25D0386,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C10E25D0386,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -6972,7 +6970,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C5A72940135,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C5A72940135,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -7015,7 +7013,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C5A68F300AE,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C5A68F300AE,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -7058,7 +7056,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'"Bold"' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C14DDB20379,persistence=transient,deri' + + #9#9#9'"persistence=transient,_BoldInternal.toolId=3C14DDB20379,deri' + 'ved=True,_BoldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta' + '.Foundation.Core,Bold.DelphiName="' #9#9#9'TRUE' @@ -7105,7 +7103,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C10DA8E0219,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C10DA8E0219,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -7148,7 +7146,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=370E7E3B0138,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=370E7E3B0138,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -7191,7 +7189,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=36E96A860316,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=36E96A860316,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -7234,7 +7232,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=365EEE8103D4,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=365EEE8103D4,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -7277,7 +7275,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'"Bold"' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3BCC459C037B,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3BCC459C037B,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -7320,7 +7318,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'"Bold"' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3B9DE749014C,persistence=transient,deri' + + #9#9#9'"persistence=transient,_BoldInternal.toolId=3B9DE749014C,deri' + 'ved=True,_BoldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta' + '.Foundation.Core,Bold.DelphiName="' #9#9#9'TRUE' @@ -7365,7 +7363,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'"Bold"' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3B989D050114,persistence=transient,deri' + + #9#9#9'"persistence=transient,_BoldInternal.toolId=3B989D050114,deri' + 'ved=True,_BoldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta' + '.Foundation.Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'TRUE' @@ -7413,7 +7411,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3359946200F0,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3359946200F0,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -7456,7 +7454,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=32B6D9B302FD,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=32B6D9B302FD,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -7499,7 +7497,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33598CAA030C,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33598CAA030C,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -7542,7 +7540,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=32B5D7EE02FF,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=32B5D7EE02FF,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -7585,7 +7583,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=32A2A50C0084,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=32A2A50C0084,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Core,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -7628,7 +7626,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C10E89303D3,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C10E89303D3,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Extension_Mechanisms,_Boldify.noName=True,Bold.DelphiName=' + '"' @@ -7672,7 +7670,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=33E901DD001E,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=33E901DD001E,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Extension_Mechanisms,_Boldify.noName=True,Bold.DelphiName=' + '"' @@ -7726,7 +7724,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3AE6CACA0195,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3AE6CACA0195,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Extension_Mechanisms,_Boldify.noName=True,Bold.DelphiName=' + '"' @@ -7770,7 +7768,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C10E81D0080,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C10E81D0080,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Foundation.' + 'Extension_Mechanisms,_Boldify.noName=True,Bold.DelphiName=' + '"' @@ -7814,7 +7812,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'"Bold"' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C16032D01C9,persistence=transient,deri' + + #9#9#9'"persistence=transient,_BoldInternal.toolId=3C16032D01C9,deri' + 'ved=True,\"_BoldInternal.unflattenedNamespace=BoldUMLModel.UMLMe' + 'ta.Bold Specifics\",Bold.DelphiName="' #9#9#9'TRUE' @@ -7862,7 +7860,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'"Bold"' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C16037401A3,persistence=transient,deri' + + #9#9#9'"persistence=transient,_BoldInternal.toolId=3C16037401A3,deri' + 'ved=True,\"_BoldInternal.unflattenedNamespace=BoldUMLModel.UMLMe' + 'ta.Bold Specifics\",Bold.DelphiName="' #9#9#9'TRUE' @@ -7910,7 +7908,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'"Bold"' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C16030102A2,persistence=transient,deri' + + #9#9#9'"persistence=transient,_BoldInternal.toolId=3C16030102A2,deri' + 'ved=True,\"_BoldInternal.unflattenedNamespace=BoldUMLModel.UMLMe' + 'ta.Bold Specifics\",Bold.DelphiName="' #9#9#9'TRUE' @@ -7958,7 +7956,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C160E28029D,persistence=Persistent,\"_' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C160E28029D,\"_' + 'BoldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Bold Spec' + 'ifics\",_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -8005,7 +8003,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'"Bold"' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C160E2A021E,persistence=Persistent,\"_' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C160E2A021E,\"_' + 'BoldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Bold Spec' + 'ifics\",_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -8050,7 +8048,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'"Bold"' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C160DEB012D,persistence=Persistent,\"_' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C160DEB012D,\"_' + 'BoldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Bold Spec' + 'ifics\",_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -8098,7 +8096,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'"Bold"' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C1603D1025B,persistence=transient,deri' + + #9#9#9'"persistence=transient,_BoldInternal.toolId=3C1603D1025B,deri' + 'ved=True,\"_BoldInternal.unflattenedNamespace=BoldUMLModel.UMLMe' + 'ta.Bold Specifics\",Bold.DelphiName="' #9#9#9'TRUE' @@ -8146,7 +8144,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'"Bold"' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C16041703C4,persistence=transient,deri' + + #9#9#9'"persistence=transient,_BoldInternal.toolId=3C16041703C4,deri' + 'ved=True,\"_BoldInternal.unflattenedNamespace=BoldUMLModel.UMLMe' + 'ta.Bold Specifics\",Bold.DelphiName="' #9#9#9'TRUE' @@ -8195,7 +8193,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C14CE1102B7,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C14CE1102B7,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Model_Manag' + 'ement,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -8240,7 +8238,7 @@ object dmModelEdit: TdmModelEdit #9#9#9'""' #9#9#9'""' - #9#9#9'"_BoldInternal.toolId=3C14CE6403A7,persistence=Persistent,_Bo' + + #9#9#9'"persistence=Persistent,_BoldInternal.toolId=3C14CE6403A7,_Bo' + 'ldInternal.unflattenedNamespace=BoldUMLModel.UMLMeta.Model_Manag' + 'ement,_Boldify.noName=True,Bold.DelphiName="' #9#9#9'FALSE' @@ -8501,7 +8499,7 @@ object dmModelEdit: TdmModelEdit MapperName = 'TBoldPMInteger' Accessor = 'AsScopeKind' NativeType = 'TScopeKind' - UnitName = 'BoldUMLAttributes' + BoldUnitName = 'BoldUMLAttributes' end item ModelName = 'TableMapping' @@ -8511,7 +8509,7 @@ object dmModelEdit: TdmModelEdit MapperName = 'TBoldPMInteger' Accessor = 'AsTableMapping' NativeType = 'TTableMapping' - UnitName = 'BoldUMLAttributes' + BoldUnitName = 'BoldUMLAttributes' end item ModelName = 'ParameterDirectionKind' @@ -8521,7 +8519,7 @@ object dmModelEdit: TdmModelEdit MapperName = 'TBoldPMInteger' Accessor = 'AsParameterDirectionKind' NativeType = 'TBoldParameterDirectionKind' - UnitName = 'BoldUMLAttributes' + BoldUnitName = 'BoldUMLAttributes' end item ModelName = 'Severity' @@ -8531,7 +8529,7 @@ object dmModelEdit: TdmModelEdit MapperName = 'TBoldPMInteger' Accessor = 'AsSeverity' NativeType = 'TSeverity' - UnitName = 'BoldUMLAttributes' + BoldUnitName = 'BoldUMLAttributes' end item ModelName = 'Stereotype' @@ -8541,7 +8539,7 @@ object dmModelEdit: TdmModelEdit MapperName = 'TBoldPMInteger' Accessor = 'AsStereotype' NativeType = 'TBoldAttributeStereotype' - UnitName = 'BoldUMLAttributes' + BoldUnitName = 'BoldUMLAttributes' end item ModelName = 'DelphiFunctionType' @@ -8551,7 +8549,7 @@ object dmModelEdit: TdmModelEdit MapperName = 'TBoldPMInteger' Accessor = 'AsDelphiFunctionType' NativeType = 'TDelphiFunctionType' - UnitName = 'BoldUMLAttributes' + BoldUnitName = 'BoldUMLAttributes' end item ModelName = 'AggregationKind' @@ -8561,7 +8559,7 @@ object dmModelEdit: TdmModelEdit MapperName = 'TBoldPMInteger' Accessor = 'AsAggregationKind' NativeType = 'TAggregationKind' - UnitName = 'BoldUMLAttributes' + BoldUnitName = 'BoldUMLAttributes' end item ModelName = 'VisibilityKind' @@ -8571,7 +8569,7 @@ object dmModelEdit: TdmModelEdit MapperName = 'TBoldPMInteger' Accessor = 'AsVisibilityKind' NativeType = 'TVisibilityKind' - UnitName = 'BoldUMLAttributes' + BoldUnitName = 'BoldUMLAttributes' end item ModelName = 'ChangeableKind' @@ -8581,7 +8579,7 @@ object dmModelEdit: TdmModelEdit MapperName = 'TBoldPMInteger' Accessor = 'AsChangeableKind' NativeType = 'TChangeableKind' - UnitName = 'BoldUMLAttributes' + BoldUnitName = 'BoldUMLAttributes' end item ModelName = 'Constraint' @@ -8608,7 +8606,7 @@ object dmModelEdit: TdmModelEdit MapperName = 'TBoldPMInteger' Accessor = 'AsOrderingKind' NativeType = 'TOrderingKind' - UnitName = 'BoldUMLAttributes' + BoldUnitName = 'BoldUMLAttributes' end item ModelName = 'Multiplicity' @@ -8708,7 +8706,7 @@ object dmModelEdit: TdmModelEdit MapperName = 'TBoldPMInteger' Accessor = 'as' NativeType = 'T' - UnitName = 'BoldUMLAttributes' + BoldUnitName = 'BoldUMLAttributes' end item ModelName = 'CallConcurrencyKind' @@ -8718,7 +8716,7 @@ object dmModelEdit: TdmModelEdit MapperName = 'TBoldPMInteger' Accessor = 'as' NativeType = 'T' - UnitName = 'BoldUMLAttributes' + BoldUnitName = 'BoldUMLAttributes' end item ModelName = 'MessageDirectionKind' @@ -8728,7 +8726,7 @@ object dmModelEdit: TdmModelEdit MapperName = 'TBoldPMInteger' Accessor = 'as' NativeType = 'T' - UnitName = 'BoldUMLAttributes' + BoldUnitName = 'BoldUMLAttributes' end item ModelName = '__TBAString' diff --git a/Source/UMLModel/Core/BoldUMLModelDataModule.pas b/Source/UMLModel/Core/BoldUMLModelDataModule.pas index e57b4ea5..7068d095 100644 --- a/Source/UMLModel/Core/BoldUMLModelDataModule.pas +++ b/Source/UMLModel/Core/BoldUMLModelDataModule.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLModelDataModule; interface @@ -34,8 +37,7 @@ procedure EnsureModelEditDataModule; implementation uses - SysUtils, - BoldRev; + SysUtils; var DataModuleEnsured: Boolean = false; @@ -47,10 +49,10 @@ procedure EnsureModelEditDataModule; dmModelEdit := TdmModelEdit.Create(nil); DataModuleEnsured := true; end; -end; +end; {$R *.dfm} - + initialization finalization if DataModuleEnsured and assigned(dmModelEdit) then diff --git a/Source/UMLModel/Core/BoldUMLModelSupport.pas b/Source/UMLModel/Core/BoldUMLModelSupport.pas index 634e96a0..0322d728 100644 --- a/Source/UMLModel/Core/BoldUMLModelSupport.pas +++ b/Source/UMLModel/Core/BoldUMLModelSupport.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLModelSupport; interface @@ -14,7 +17,6 @@ interface BoldTaggedValueSupport; const - // tags for internal use TAG_TOOLID = 'toolId'; TAG_FLATTENED = 'flattened'; @@ -45,13 +47,12 @@ TBoldUMLSupport = class(TObject) class function GetEnsuredPackage(Package: TUMLPackage; QualifiedPackageName: String): TUMLPackage; public class function UMLModelNameToUMLName(const ModelName: string): string; - class procedure EnsureBoldTaggedValues(Element: TUMLModelElement); // Add missing tagged values + class procedure EnsureBoldTaggedValues(Element: TUMLModelElement); class procedure EnsureBoldTaggedValuesInModel(Model: TUMLModel); class procedure ManipulateAllOwnedElements(Model: TUMLModel; manipulator: TUMLModelElementManipulator); class function EnsuredTaggedValue(Element: TUMLModelElement; const Tag: string): TUMLTaggedValue; class procedure RemoveTaggedValue(Element: TUMLModelElement; const Tag: string); -// class procedure SetDefaultBoldTaggedValues(Element: TUMLModelElement); // Set all tagged values to default - class procedure RelinkSpecializations(GeneralizableElement: TUMLGeneralizableElement); // Give move all inheritance up one step. + class procedure RelinkSpecializations(GeneralizableElement: TUMLGeneralizableElement); class function UniqueName(Element: TUMLModelElement; const SuggestedName: String): String; class procedure AddQualifier(AssociationEnd: TUMLAssociationEnd; Qualifier: TUMLAttribute; const SuggestedName: String); class procedure AddToNamespace(NameSpace: TUMLNamespace; Element: TUMLModelElement; const SuggestedName: String); @@ -77,6 +78,7 @@ TBoldUMLBoldify = class(TPersistent) fMakeDerivedTransient: boolean; class procedure SetBoldifyTaggedValue(element: TUMLModelElement; const Tag: string; const value: string ); class function FullTag(const Tag: string): string; + class function FindClass(Model: TUMLModel; const AClassName: string): TUMLClass; public constructor Create; procedure Boldify(UMLModel: TUMLModel); @@ -100,7 +102,7 @@ TBoldUMLBoldify = class(TPersistent) end; { TBoldUMLOperationSupport } - TBoldUMLOperationSupport = class(TObject) // FIXME move to model editor. TO specific for support + TBoldUMLOperationSupport = class(TObject) public class procedure OverrideInClass(UMLClass: TUMLClassifier; UMLOperation: TUMLOperation); class procedure OverrideInAllSubclasses(UMLClass: TUMLClassifier;UMLOperation: TUMLOperation); @@ -116,8 +118,8 @@ implementation BoldSystemRT, BoldNameExpander, BoldUMLTaggedValues, - BoldGuard, - UMLConsts; + BoldDomainElement, + BoldGuard; { TBoldUMLSupport } @@ -143,7 +145,7 @@ class procedure TBoldUMLSupport.AddToolId(Element: TUMLModelElement; class function TBoldUMLSupport.AllModelParts( UMLModel: TUMLModel): TUMLModelElementList; begin - Result := UMLModel.EvaluateExpressionAsNewElement('UMLModelElement.allInstances->select(model=self)') as TUMLModelElementList // do not localize + Result := UMLModel.EvaluateExpressionAsNewElement('UMLModelElement.allInstances->select(model=self)') as TUMLModelElementList end; class function TBoldUMLSupport.ElementForToolId(UMLModel: TUMLModel; @@ -151,7 +153,7 @@ class function TBoldUMLSupport.ElementForToolId(UMLModel: TUMLModel; begin Result := UMLModel.EvaluateExpressionAsDirectElement ( - Format('UMLTaggedValue.allInstances->select((tag=''%s'') and (value=''%s'')).modelElement->select(model=self)->first', // do not localize + Format('UMLTaggedValue.allInstances->select((tag=''%s'') and (value=''%s'')).modelElement->select(model=self)->first', [BOLDINTERALTVPREFIX + TAG_TOOLID, ToolId]) ) as TUMLModelElement; end; @@ -202,11 +204,11 @@ class procedure TBoldUMLSupport.Flatten(UMLModel: TUMLModel); BoldGuard: IBoldGuard; begin BoldGuard := TBoldGuard.Create(List); - BoldLog.StartLog(sFlatteningModel); + BoldLog.StartLog('Flattening model'); try List := UMLModel.EvaluateExpressionAsNewElement ( - 'allOwnedElement->select(oclIsKindOf(UMLClass) or oclIsKindOf(UMLAssociation))' // do not localize + 'allOwnedElement->select(oclIsKindOf(UMLClass) or oclIsKindOf(UMLAssociation))' ) as TUMLModelElementList; BoldLog.ProgressMax := List.Count; for i := 0 to List.Count - 1 do @@ -286,7 +288,7 @@ class procedure TBoldUMLSupport.ManipulateAllOwnedElements( begin BoldGuard := TBoldGuard.Create(allOwnedElement); manipulator(model); - allOwnedElement:= Model.EvaluateExpressionAsNewElement('UMLModelElement.allInstances->select(model=self)') as TUMLModelElementList; // do not localize + allOwnedElement:= Model.EvaluateExpressionAsNewElement('UMLModelElement.allInstances->select(model=self)') as TUMLModelElementList; for i := 0 to allOwnedElement.Count - 1 do manipulator(allOwnedElement[i]); end; @@ -311,7 +313,6 @@ class procedure TBoldUMLSupport.RelinkSpecializations( Child: TUMLGeneralizableElement; s, g: integer; begin - // replace myself with all my superclasses in children for s := GeneralizableElement.specialization.Count - 1 downto 0 do begin Child := GeneralizableElement.specialization[s].child; @@ -355,7 +356,7 @@ class procedure TBoldUMLSupport.StripToolId(Model: TUMLModel); List := Model.EvaluateExpressionAsNewElement ( Format( - 'UMLTaggedValue.allInstances->select(model=self)->select(name=''%s'')', // do not localize + 'UMLTaggedValue.allInstances->select(model=self)->select(name=''%s'')', [BOLDINTERALTVPREFIX + TAG_TOOLID]) ) as TUMLModelElementList; for i := List.Count - 1 downto 0 do @@ -367,8 +368,7 @@ class procedure TBoldUMLSupport.SubscribeToAllMembers(UMLElement: TUMLModelEleme m: integer; MemberRTInfo: TBoldMemberRTInfo; OtherEnd, RoleRTInfo: TBoldRoleRTInfo; - IsTaggedValue, Subscribe: Boolean; -} + IsTaggedValue, Subscribe: Boolean;} begin UMLElement.AddSmallSubscription(subscriber, [beMemberChanged], breReEvaluate); { @@ -418,7 +418,7 @@ class procedure TBoldUMLSupport.SubscribeToEntireModel(UMLModel: TUMLModel; Subs class function TBoldUMLSupport.UMLModelNameToUMLName(const ModelName: string): string; begin - Result := Copy(ModelName, 4, MAXINT); // Names in UMLModel prefixed by UML. + Result := Copy(ModelName, 4, MAXINT); end; class procedure TBoldUMLSupport.UnFlatten(UMLModel: TUMLModel); @@ -432,9 +432,7 @@ class procedure TBoldUMLSupport.UnFlatten(UMLModel: TUMLModel); begin BoldGuard := TBoldGuard.Create(List); CurrentNameSpace := UMLModel; - List := TUMLModelElementList.Create; - // ordering by name will give topologial sort - List := UMLModel.EvaluateExpressionAsNewElement(Format('ownedElement->select(taggedValue->select(tag=''%s'')->notEmpty)->orderBy(taggedValue[''%s''].value)', // do not localize + List := UMLModel.EvaluateExpressionAsNewElement(Format('ownedElement->select(taggedValue->select(tag=''%s'')->notEmpty)->orderBy(taggedValue[''%s''].value)', [BOLDINTERALTVPREFIX + TAG_UNFLATTENEDNAMESPACE, BOLDINTERALTVPREFIX + TAG_UNFLATTENEDNAMESPACE])) as TUMLModelElementList; ; for i := 0 to List.Count - 1 do @@ -443,11 +441,9 @@ class procedure TBoldUMLSupport.UnFlatten(UMLModel: TUMLModel); UnflattenedNamespaceName := Element.taggedValue[BOLDINTERALTVPREFIX + TAG_UNFLATTENEDNAMESPACE].Value; if UnflattenedNamespaceName <> CurrentNameSpace.qualifiedName then begin - // remove the first part, it is the name of the model System.Delete(UnflattenedNameSpaceName, 1, pos('.', UnflattenedNamespaceName)); CurrentNameSpace := GetEnsuredPackage(UMLModel, UnflattenedNamespaceName); end; - // Set real namespace, and remove tagged value Element.namespace_ := CurrentNameSpace; RemoveTaggedValue(Element, BOLDINTERALTVPREFIX + TAG_UNFLATTENEDNAMESPACE); end; @@ -464,7 +460,7 @@ class function TBoldUMLSupport.UniqueName(Element: TUMLModelElement; const Sugge if i = 0 then Result := SuggestedName else - Result := Format('%s_%d', [SuggestedName, i]); // do not localize + Result := Format('%s_%d', [SuggestedName, i]); ConflictFound := False; if Assigned(Element.namespace_) then ConflictFound := NameInListExceptElement(Result, Element.namespace_.OwnedElement, Element); @@ -490,7 +486,7 @@ procedure TBoldUMLBoldify.Assign(source: TPersistent); DefaultNavigableMultiplicity := TBoldUMLBoldify(Source).DefaultNavigableMultiplicity; end else - raise EBold.Create('TBoldUMLBoldify.Assign'); // do not localize + raise EBold.Create('TBoldUMLBoldify.Assign'); end; procedure TBoldUMLBoldify.Boldify(UMLModel: TUMLModel); @@ -509,24 +505,27 @@ procedure TBoldUMLBoldify.Boldify(UMLModel: TUMLModel); UnnamedAssociationName: string; AssocEnd: TUMLAssociationEnd; RootClassImplicitlyNamed: Boolean; + /// START PATCH ////////////////////////////////////////////////////////////// + NewAttribute: TUMLAttribute; + NewColumnName: string; + /// END PATCH //////////////////////////////////////////////////////////////// begin TBoldUMLSupport.EnsureBoldTaggedValuesInModel(UMLModel); AllClasses := nil; AllAssociations := nil; - BoldLog.StartLog(sBoldifyingModel); + BoldLog.StartLog('Boldifying Model'); try SetBoldifyTaggedValue(UMLModel, TAG_BOLDIFIED, TV_TRUE); - // Create root class if it is missing RootClassName := UMLModel.GetBoldTV(TAG_ROOTCLASS); if RootClassName = '' then begin - RootClassName := 'BusinessClassesRoot'; // do not localize + RootClassName := 'BusinessClassesRoot'; RootClassImplicitlyNamed := true; end else RootClassImplicitlyNamed := false; - Rootclass := UMLModel.EvaluateExpressionAsDirectElement(Format('UMLClass.allInstances->select((model=self) and (name=''%s''))->first', [RootClassName])) as TUMLClass; // do not localize + Rootclass := UMLModel.EvaluateExpressionAsDirectElement(Format('UMLClass.allInstances->select((model=self) and (name=''%s''))->first', [RootClassName])) as TUMLClass; if not Assigned(RootClass) then begin RootClass := TUMLClass.Create(UMLModel.BoldSystem); @@ -543,7 +542,7 @@ procedure TBoldUMLBoldify.Boldify(UMLModel: TUMLModel); end; if Assigned(RootClass.SuperClass) then - raise EBold.Create(sCannotBoldifyIfRootClassHasSuperClass); + raise EBold.Create('Can''t boldify model where root class has superclass'); DefaultSuperClass := GetDefaultSuperClass(UMLModel); if not Assigned(DefaultSuperClass) then @@ -552,9 +551,7 @@ procedure TBoldUMLBoldify.Boldify(UMLModel: TUMLModel); DefaultLinkSuperClass := GetDefaultLinkSuperClass(UMLModel); if not Assigned(DefaultLinkSuperClass) then DefaultLinkSuperClass := RootClass; - - // Fixup Associations. Set default multiplicity, name unnamed associationends, create missing link-classes - AllAssociations := UMLModel.EvaluateExpressionAsNewElement('UMLAssociation.allInstances->select(model=self)') as TUMLAssociationList; // do not localize + AllAssociations := UMLModel.EvaluateExpressionAsNewElement('UMLAssociation.allInstances->select(model=self)') as TUMLAssociationList; BoldLog.ProgressMax := AllAssociations.Count; @@ -584,7 +581,6 @@ procedure TBoldUMLBoldify.Boldify(UMLModel: TUMLModel); AssocEnd.SetBoldTV(TAG_EMBED, TV_FALSE); SetBoldifyTaggedValue(AssocEnd, TAG_WASEMBEDED, TV_TRUE); end; - // Name unnamed associationends if AssocEnd.IsNavigable then begin if AssocEnd.name = '' then @@ -598,15 +594,13 @@ procedure TBoldUMLBoldify.Boldify(UMLModel: TUMLModel); UnnamedAssociationName := UnnamedAssociationName + AssocEnd.type_.name; end else - AssocEnd.name := Format('Role%d', [ConnectionIndex]); // do not localize + AssocEnd.name := Format('Role%d', [ConnectionIndex]); SetBoldifyTaggedValue(AssocEnd, TAG_NONAME, TV_TRUE); end else UnnamedAssociationName := UnnamedAssociationName + AssocEnd.name; end; end; - - // fix implicit names for non named non navigable roles for ConnectionIndex := 0 to Association.Connection.Count - 1 do begin AssocEnd := Association.Connection[ConnectionIndex]; @@ -622,8 +616,6 @@ procedure TBoldUMLBoldify.Boldify(UMLModel: TUMLModel); UnnamedAssociationName := UnnamedAssociationName + AssocEnd.Name; end; end; - - // make association transient if either end is transient if Association.persistent then begin for ConnectionIndex := 0 to Association.Connection.Count - 1 do @@ -637,22 +629,17 @@ procedure TBoldUMLBoldify.Boldify(UMLModel: TUMLModel); end; end; end; - - // make association transient if association class is transient if Association.persistent and assigned(association.class_) and not association.class_.persistent then begin Association.persistent := false; SetBoldifyTaggedValue(Association, TAG_WASPERSISTENT, TV_TRUE) end; - // Name association if unnamed - if Association.name = '' then begin Association.name := UnnamedAssociationName; SetBoldifyTaggedValue(Association, TAG_NONAME, TV_TRUE); end; - // Create link class if needed if not Association.Derived and ( (Association.Connection[0].Multi and Association.Connection[1].Multi) or @@ -664,12 +651,14 @@ procedure TBoldUMLBoldify.Boldify(UMLModel: TUMLModel); ) and not assigned(Association.Class_) then begin - // Note: allowing different names on association and linkclass is not strictly UML. LinkClassName := BoldExpandName(Association.getBoldTV(TAG_LINKCLASSNAME), Association.Name, xtDelphi, -1, TBoldTaggedValueSupport.StringToNationalCharConversion(UMLModel.GetBoldTV(TAG_NATIONALCHARCONVERSION))); if LinkClassName = '' then LinkClassName := Association.Name; - Association.Class_ := TUMLClass.Create(Association.BoldSystem); + Association.Class_ := FindClass(UMLModel, LinkClassName); + if not Assigned(Association.Class_) then + begin + Association.Class_ := TUMLClass.Create(UMLModel.BoldSystem); Association.Class_.namespace_ := Association.namespace_; Association.Class_.Association := Association; Association.Class_.persistent := Association.persistent; @@ -680,19 +669,59 @@ procedure TBoldUMLBoldify.Boldify(UMLModel: TUMLModel); Association.Class_.SetBoldTV(TAG_VERSIONED, TV_TRUE); SetBoldifyTaggedValue(Association.Class_, TAG_AUTOCREATED, TV_TRUE); if (LinkClassName = Association.name) then - Association.Class_.name := Association.name // Allow same name on class and association + Association.Class_.name := Association.name else Association.Class_.name := TBoldUMLSupport.UniqueName(Association.namespace_, LinkClassName); {will generate new name on collission} + end end; BoldLog.ProgressStep; end; - AllClasses := UMLModel.EvaluateExpressionAsNewElement('classes') as TUMLClassList; // do not localize + + AllClasses := UMLModel.EvaluateExpressionAsNewElement('classes') as TUMLClassList; BoldLog.ProgressMax := AllClasses.count; for ClassIndex := 0 to AllClasses.Count - 1 do begin iClass := AllClasses[ClassIndex]; + /// START PATCH ////////////////////////////////////////////////////////// + (************************************************************************* + * Generate buddy for persistent derivied attribute + * - Clone + * - Original: Persistent=false, WasPersistent=True PersistenBuddy=NewName + * - New: Derived=false, Name=p_Originalname, Columnname=OriginalColname + * BoldifyAutoCreate=True, Visibility=Private + *************************************************************************) + for FeatureIndex := 0 to iClass.feature.Count - 1 do + begin + Feature := iClass.feature[FeatureIndex]; + if (Feature is TUMLAttribute) then + with Feature as TUMLAttribute do + if persistent and derived then + begin + NewAttribute := TBoldCopyAndClone.BoldClone(Feature, bcmDeep) as TUMLAttribute; + NewAttribute.owner := iClass; + NewAttribute.name := 'p_'+Feature.name; + NewAttribute.type_ := type_; + //Original + persistent := false; + SetBoldifyTaggedValue(Feature, TAG_WASPERSISTENT, TV_TRUE); + //PersistenBuddy=NewName + //New Clone + SetBoldifyTaggedValue(NewAttribute, TAG_AUTOCREATED, TV_TRUE); + SetBoldifyTaggedValue(NewAttribute, 'persistentClone', Feature.name); + NewAttribute.persistent := true; + NewAttribute.derived := False; + NewAttribute.visibility := vkPrivate; + NewColumnName := NewAttribute.GetBoldTV(TAG_COLUMNNAME); + if NewColumnName=TV_NAME then + NewColumnName := Feature.GetBoldTV(TAG_COLUMNNAME); + if NewColumnName=TV_NAME then + NewColumnName := Feature.name; + NewAttribute.SetBoldTV(TAG_COLUMNNAME, NewColumnName); + end; + end; + /// END PATCH //////////////////////////////////////////////////////////// for FeatureIndex := 0 to iClass.feature.Count - 1 do begin Feature := iClass.feature[FeatureIndex]; @@ -704,8 +733,6 @@ procedure TBoldUMLBoldify.Boldify(UMLModel: TUMLModel); SetBoldifyTaggedValue(Feature, TAG_WASPERSISTENT, TV_TRUE) end; end; - - // Fixup inheritance if not Assigned(iClass.superclass) and (iClass <> RootClass) then begin if iClass.isAssociationClass then @@ -728,12 +755,17 @@ procedure TBoldUMLBoldify.Boldify(UMLModel: TUMLModel); constructor TBoldUMLBoldify.Create; begin fPluralSuffix := ''; - fDefaultNonNavigableMultiplicity := '0..*'; // do not localize - fDefaultNavigableMultiplicity := '0..1'; // do not localize + fDefaultNonNavigableMultiplicity :='0..*'; + fDefaultNavigableMultiplicity := '0..1'; fUnembedMulti := True; fMakeDerivedTransient := True; end; +class function TBoldUMLBoldify.FindClass(Model: TUMLModel; const AClassName: string): TUMLClass; +begin + result := Model.EvaluateExpressionAsDirectElement(Format('UMLClass.allInstances->select((model=self) and (name=''%s''))->first', [AClassName])) as TUMLClass; +end; + class function TBoldUMLBoldify.FullTag(const Tag: string): string; begin Result := BOLDBOLDIFYPREFIX + Tag; @@ -752,28 +784,26 @@ class function TBoldUMLBoldify.GetBoldifyTaggedValue(element: TUMLModelElement; class function TBoldUMLBoldify.GetDefaultLinkSuperClass( Model: TUMLModel): TUMLClass; -begin -{ TODO : change name to fullname when package support done. } - Result := model.EvaluateExpressionAsDirectElement(Format('UMLClass.allInstances->select((model=self) and (name=''%s''))->first', [model.GetBoldTV(TAG_DEFAULTLINKCLASSSUPERCLASS)])) as TUMLClass; // do not localize +begin + Result := model.EvaluateExpressionAsDirectElement(Format('UMLClass.allInstances->select((model=self) and (name=''%s''))->first', [model.GetBoldTV(TAG_DEFAULTLINKCLASSSUPERCLASS)])) as TUMLClass; if not Assigned(Result) then Result := GetDefaultSuperClass(model); end; class function TBoldUMLBoldify.GetDefaultSuperClass( Model: TUMLModel): TUMLClass; -begin -{ TODO : change name to fullname when package support done. } +begin Result := model.EvaluateExpressionAsDirectElement ( - Format('UMLClass.allInstances->select((model=self) and (name=''%s''))->first', [model.GetBoldTV(TAG_DEFAULTSUPERCLASS)]) // do not localize + Format('UMLClass.allInstances->select((model=self) and (name=''%s''))->first', [model.GetBoldTV(TAG_DEFAULTSUPERCLASS)]) ) as TUMLClass; end; class function TBoldUMLBoldify.GetRootClass(Model: TUMLModel): TUMLClass; begin if not IsBoldified(model) then - raise EBold.Create(sCanOnlyBeCalledIfBoldified); - Result := model.EvaluateExpressionAsDirectElement('UMLClass.allInstances->select((model=self) and (generalization->isEmpty))->first') as TUMLClass; // do not localize + raise EBold.Create('TBoldUMLBoldify.GetRootClass: can only be called on boldified model'); + Result := model.EvaluateExpressionAsDirectElement('UMLClass.allInstances->select((model=self) and (generalization->isEmpty))->first') as TUMLClass; end; class function TBoldUMLBoldify.IsAutoCreated( @@ -822,9 +852,9 @@ class procedure TBoldUMLBoldify.UnBoldify(model: TUMLModel); var expr: string; begin - expr := format('%s.allInstances->select(model=self)', [classname]); // do not localize + expr := format('%s.allInstances->select(model=self)', [classname]); if TaggedValue <> '' then - expr := expr + format('->select(taggedValue[''%s''].value=''%s'')', [TaggedValue, Value]); // do not localize + expr := expr + format('->select(taggedValue[''%s''].value=''%s'')', [TaggedValue, Value]); result := model.EvaluateExpressionAsNewElement(expr) as TUMLModelElementList; end; begin @@ -836,15 +866,9 @@ class procedure TBoldUMLBoldify.UnBoldify(model: TUMLModel); AttributesToMakePersistent); SetRootClassname(model, GetRootClass(Model).name); - - // Remove all autocreated elements - TempList := GetNewList('UMLModelElement', BOLDBOLDIFYPREFIX + TAG_AUTOCREATED, TV_TRUE); // do not localize - - // the result of the OCL-expression is immutable. Copy it to a new list + TempList := GetNewList('UMLModelElement', BOLDBOLDIFYPREFIX + TAG_AUTOCREATED, TV_TRUE); ToRemove := TUMLModelElementList.Create; ToRemove.AddList(TempList); - - // Autocreated classes that have been modified should not be removed. for i := ToRemove.Count-1 downto 0 do begin if ToRemove[i] is TUMLClass then @@ -861,7 +885,7 @@ class procedure TBoldUMLBoldify.UnBoldify(model: TUMLModel); while ToRemove.Count > 0 do ToRemove[ToRemove.Count - 1].Delete; - ToUnname := GetNewList('UMLModelElement', BOLDBOLDIFYPREFIX + TAG_NONAME, TV_TRUE); // do not localize + ToUnname := GetNewList('UMLModelElement', BOLDBOLDIFYPREFIX + TAG_NONAME, TV_TRUE); for i := 0 to ToUnname.Count - 1 do begin @@ -869,21 +893,22 @@ class procedure TBoldUMLBoldify.UnBoldify(model: TUMLModel); RemoveBoldifyTaggedValue(ToUnname[i], TAG_NONAME); end; - AssociationsToMakePersistent := GetNewlist('UMLAssociation', BOLDBOLDIFYPREFIX + TAG_WASPERSISTENT, TV_TRUE) as TUMLAssociationList; // do not localize + AssociationsToMakePersistent := GetNewlist('UMLAssociation', BOLDBOLDIFYPREFIX + TAG_WASPERSISTENT, TV_TRUE) as TUMLAssociationList; for i := 0 to AssociationsToMakePersistent.Count - 1 do begin AssociationsToMakePersistent[i].persistent := True; - RemoveBoldifyTaggedValue(AssociationsToMakePersistent[i], TAG_WASPERSISTENT); //!! Skall vara + //RemoveBoldifyTaggedValue(AttributesToMakePersistent[i], TAG_WASPERSISTENT); + RemoveBoldifyTaggedValue(AssociationsToMakePersistent[i], TAG_WASPERSISTENT); end; - AttributesToMakePersistent := GetNewList('UMLAttribute', BOLDBOLDIFYPREFIX + TAG_WASPERSISTENT, TV_TRUE) as TUMLAttributeList; // do not localize + AttributesToMakePersistent := GetNewList('UMLAttribute', BOLDBOLDIFYPREFIX + TAG_WASPERSISTENT, TV_TRUE) as TUMLAttributeList; for i := 0 to AttributesToMakePersistent.Count - 1 do begin AttributesToMakePersistent[i].persistent := True; RemoveBoldifyTaggedValue(AttributesToMakePersistent[i], TAG_WASPERSISTENT); end; - AllAssociationEnds := GetNewList('UMLAssociationEnd') as TUMLAssociationEndList; // do not localize + AllAssociationEnds := GetNewList('UMLAssociationEnd') as TUMLAssociationEndList; for i := 0 to AllAssociationEnds.Count - 1 do begin AssociationEnd := AllAssociationEnds[i]; @@ -915,11 +940,12 @@ class function TBoldCopyAndClone.BoldClone(SourceObject: TBoldObject; Mode: TBol end; class procedure TBoldCopyAndClone.BoldCopy(DestinationObject, SourceObject: TBoldObject; Mode: TBoldCopyMode; StripToolId: Boolean); - - // Note, parameter Mode used in subprocedures procedure CopyAttribute(DestinationAttr, SourceAttr: TBoldAttribute); begin - DestinationAttr.Assign(SourceAttr); + if SourceAttr.IsNull and not DestinationAttr.IsNull and not DestinationAttr.CanSetToNull(nil) then + DestinationAttr.AsIBoldValue[bdepContents].AssignContent(SourceAttr.AsIBoldValue[bdepContents]) + else + DestinationAttr.Assign(SourceAttr); end; procedure CopySingleRole(DestinationRole, SourceRole: TBoldObjectReference); @@ -930,13 +956,13 @@ class procedure TBoldCopyAndClone.BoldCopy(DestinationObject, SourceObject: TBol DestinationRtInfo := DestinationRole.BoldRoleRTInfo; case mode of bcmAttributes: - ; // no action + ; bcmShallow: if (DestinationRtInfo.Aggregation <> akComposite) and DestinationRtInfo.RoleRTInfoOfOtherEnd.IsMultiRole then DestinationRole.BoldObject := SourceRole.BoldObject; bcmDeep: if DestinationRtInfo.Aggregation = akComposite then - DestinationRole.BoldObject := BoldClone(SourceRole.BoldObject, bcmDeep, StripToolId) + DestinationRole.BoldObject := BoldClone(SourceRole.BoldObject, bcmDeep, StripToolId); else if DestinationRtInfo.RoleRTInfoOfOtherEnd.IsMultiRole then DestinationRole.BoldObject := SourceRole.BoldObject; end; @@ -958,7 +984,7 @@ class procedure TBoldCopyAndClone.BoldCopy(DestinationObject, SourceObject: TBol DestinationRtInfo := DestinationRole.BoldRoleRTInfo; case mode of bcmAttributes: - ; // no action + ; bcmShallow: if (DestinationRtInfo.Aggregation <> akComposite) and DestinationRtInfo.RoleRTInfoOfOtherEnd.IsMultiRole then DestinationRole.AddList(SourceRole); @@ -970,7 +996,6 @@ class procedure TBoldCopyAndClone.BoldCopy(DestinationObject, SourceObject: TBol begin SourceSubObject := SourceRole[i]; if (SourceSubObject is TUMLTaggedValue) and (TUMLTaggedValue(SourceSubObject).Tag = BOLDINTERALTVPREFIX + TAG_TOOLID) then - // do nothing, i.e. don't include toolid tag. else DestinationRole.Add(BoldClone(SourceSubObject, bcmDeep, StripToolId)); end; @@ -1003,20 +1028,24 @@ class procedure TBoldCopyAndClone.BoldCopy(DestinationObject, SourceObject: TBol DestinationMember := DestinationObject.BoldMembers[m]; SourceMember := SourceObject.BoldMembers[m]; if SourceMemberRtInfo.IsAttribute then - CopyAttribute(DestinationMember as TBoldAttribute, SourceMember as TBoldAttribute) - else if SourceMemberRTInfo.IsRole then + begin + if DestinationMember.Mutable and not DestinationMember.IsReadOnly then + CopyAttribute(DestinationMember as TBoldAttribute, SourceMember as TBoldAttribute) + else + DestinationMember.AsIBoldValue[bdepContents].AssignContent(SourceMember.AsIBoldValue[bdepContents]); + end + else + if SourceMemberRTInfo.IsRole then begin SourceRoleRTInfo := SourceMemberRTInfo as TBoldRoleRTInfo; - if SourceRoleRTInfo.RoleType = rtRole then + if (SourceRoleRTInfo.RoleType = rtRole) and (mode <> bcmAttributes) then begin if SourceRoleRTInfo.IsSingleRole then CopySingleRole(DestinationMember as TBoldObjectReference, SourceMember as TBoldObjectReference) else if SourceMemberRtInfo.IsMultiRole then CopyMultiRole(DestinationMember as TBoldObjectList, SourceMember as TBoldObjectList) end; - end - else - raise EBoldInternal.CreateFmt(sUnknownTypeOfMember, [classname, SourceMember.DisplayName, SourceMember.Boldtype.ExpressionName]); + end; end; end; end; @@ -1028,7 +1057,6 @@ class function TBoldUMLOperationSupport.ClassHasOperation( Index, Index2: Integer; Operation: TUMLOperation; begin - // kala 990709 returns true if the name and signature are the same. Result := False; for Index := 0 to UMLClass.Feature.Count - 1 do begin @@ -1038,13 +1066,13 @@ class function TBoldUMLOperationSupport.ClassHasOperation( if SameText(Operation.Name, MethodName) then begin if (ParamTypes.Count = Operation.Parameter.Count) or - (ParamTypes.Count = Operation.Parameter.Count - 1) then // -1 special case if there is a return-param, return-params does not affect overloading. kala 990708 + (ParamTypes.Count = Operation.Parameter.Count - 1) then begin Result := True; for Index2 := 0 to ParamTypes.Count - 1 do begin if (UpperCase(ParamTypes[Index2]) <> UpperCase(Operation.Parameter[Index2].typeName)) and - (UpperCase(Operation.Parameter[Index2].typeName) <> UpperCase('Return')) then // CHECKME // do not localize + (UpperCase(Operation.Parameter[Index2].typeName) <> UpperCase('Return')) then begin Result := False; Exit; @@ -1092,4 +1120,6 @@ class procedure TBoldUMLOperationSupport.OverrideInClass( end; end; +initialization + end. diff --git a/Source/UMLModel/Core/BoldUMLModelUpdater.pas b/Source/UMLModel/Core/BoldUMLModelUpdater.pas index ece3245c..5f4dcb61 100644 --- a/Source/UMLModel/Core/BoldUMLModelUpdater.pas +++ b/Source/UMLModel/Core/BoldUMLModelUpdater.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLModelUpdater; interface @@ -32,9 +35,9 @@ class procedure TBoldUMLModelUpdater.UpdateModel(ModelToUpdate: TUMLModel); var aList: TUMLModelElementList; begin - aList := ModelToUpdate.BoldSystem.ClassByExpressionName['UMLAssociation'] as TUMLModelElementList; // do not localize + aList := ModelToUpdate.BoldSystem.ClassByExpressionName['UMLAssociation'] as TUMLModelElementList; UpdatePersistentTVs(aList); - aList := ModelToUpdate.BoldSystem.ClassByExpressionName['UMLAttribute'] as TUMLModelElementList; // do not localize + aList := ModelToUpdate.BoldSystem.ClassByExpressionName['UMLAttribute'] as TUMLModelElementList; UpdatePersistentTVs(aList); end; @@ -59,4 +62,6 @@ class procedure TBoldUMLModelUpdater.UpdatePersistentTVs(aList: TUMLModelElement end; end; +initialization + end. diff --git a/Source/UMLModel/Core/BoldUMLModelValidator.pas b/Source/UMLModel/Core/BoldUMLModelValidator.pas index 690f8f1e..68d07c1e 100644 --- a/Source/UMLModel/Core/BoldUMLModelValidator.pas +++ b/Source/UMLModel/Core/BoldUMLModelValidator.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLModelValidator; interface @@ -47,9 +50,6 @@ TBoldUMLModelValidator = class(TBoldUMLAbstractModelValidator) property TypeNameDictionary: TBoldTypeNameDictionary read fTypeNameDictionary; end; -const - beModelValidated = 1024; - implementation uses @@ -60,7 +60,9 @@ implementation BoldPMappers, BoldDefaultTaggedValues, BoldDefaultStreamNames, - BoldUMLTypes; + BoldUMLTypes, + BoldUMLModelEditForm, + BoldAttributes; resourcestring // Validator errors @@ -99,6 +101,8 @@ implementation sUMVAttributeUnknownType = 'Attribute "%s" has unknown type (%s)'; sUMVAttributeUnknownMapper = 'Attribute "%s" has unknown persistence mapper (%s)'; sUMVAttributeCantStore = 'Attribute "%s" can''t be stored, incompatible persistence mapper'; + sUMVOperationVirtualOperationMissing = 'Overridden operation "%s" has no virtual operation in superclass'; + sUMVOperationVisibilityChanged = 'Overridden operation "%s" has different visibility than the inherited operation in superclass'; sUMVAssociationEndIsMultiWithOtherEndComposite = 'Association end "%s" is multi, but other end is composite'; sUMVAssociationEndUnknownClass = 'Association end "%s" in association "%s" not associated with any class'; sUMVAssociationEndUnknownMapper = 'Unknown association end persistence mapper (%s) in association "%s"'; @@ -106,7 +110,7 @@ implementation sUMVInvalidAssociationEndIndirectAndEmbed = 'Association end "%s" in association "%s" is indirect and embedded'; sUMVInvalidAssociationEndMultiAndEmbed = 'Association end "%s" in association "%s" is multi and embedded'; sUMVInvalidAssociationEndOrderedandSingle = 'Association end "%s" in association "%s" is non-multi and ordered'; - sUMVSingleAssociationEndsEmbeddedInBothEnds = 'Association "%s"s both ends are embedded and single-single ends.'; + sUMVSingleAssociationEndsEmbeddedInBothEnds = 'SingleLink between %s - %s both ends have Embed=True meaning both are persisted in database. Set one side to Embed=False'; sUMVAssociationNeedsTwoRoles = 'Association "%s" must have two assocationEnds'; sUMVAssociationEndNeedsType = 'AssociationEnd "%s" is not assocatied with any class'; sUMVDerivedAssociationCanNotHaveClass = 'Derived association "%s" can not have an association class'; @@ -133,6 +137,7 @@ implementation sUMVRootClassMustHaveName = 'Root class must have name'; sUMVLinkClassWithSuperClassAsEnd = 'LinkClass (%s) must not inherit from any of the ends (%s)'; sUMVAssociationAndClassNotEquallyPersistent = 'Association (%s) and its association class are not equally persistent'; + sUMVClassNameClashWithAttribute = 'Class "%s" has same name as Attribute type'; function IsValidDelphiIdentifier(const Ident: string): Boolean; const @@ -142,9 +147,9 @@ function IsValidDelphiIdentifier(const Ident: string): Boolean; I: Integer; begin Result := False; - if (Length(Ident) = 0) or not (Ident[1] in Alpha) then + if (Length(Ident) = 0) or not CharInSet(Ident[1], Alpha) then Exit; - for I := 2 to Length(Ident) do if not (Ident[I] in AlphaNumeric) then + for I := 2 to Length(Ident) do if not CharInSet(Ident[I], AlphaNumeric) then Exit; Result := True; end; @@ -157,9 +162,9 @@ function IsValidCppIdentifier(const Ident: string): Boolean; I: Integer; begin Result := False; - if (Length(Ident) = 0) or not (Ident[1] in Alpha) then + if (Length(Ident) = 0) or not CharInSet(Ident[1], Alpha) then Exit; - for I := 2 to Length(Ident) do if not (Ident[I] in AlphaNumeric) then + for I := 2 to Length(Ident) do if not CharInSet(Ident[I], AlphaNumeric) then Exit; Result := True; end; @@ -179,9 +184,9 @@ function IsValidSQLIdentifier(const Ident: string): Boolean; I: Integer; begin Result := False; - if (Length(Ident) = 0) or not (Ident[1] in Alpha) then + if (Length(Ident) = 0) or not CharInSet(Ident[1], Alpha) then Exit; - for I := 2 to Length(Ident) do if not (Ident[I] in AlphaNumeric) then + for I := 2 to Length(Ident) do if not CharInSet(Ident[I], AlphaNumeric) then Exit; Result := True; end; @@ -331,100 +336,104 @@ procedure TBoldUMLModelValidator.Validate(TypeNameDictionary: TBoldTypeNameDicti if not(TBoldUMLBoldify.IsBoldified(UMLModel) and TBoldUMLSupport.IsFlattened(UMLModel)) then raise EBoldInternal.Create('Model not Boldified and flattened'); - fTypeNameDictionary := TypeNameDictionary; - - ClearViolations; BoldLog.StartLog('Validating the model'); + BoldModel.StartValidation; + try + fTypeNameDictionary := TypeNameDictionary; - if not assigned(TypeNameDictionary) then - addError('No TypeNameDictionary available', [], UMLModel); + ClearViolations; - if Assigned(UMLModel) then - begin - with UMLModel do - begin - if Name = '' then - AddError(sUMVModelNameEmpty, [], UMLModel); + if not assigned(TypeNameDictionary) then + addError('No TypeNameDictionary available', [], UMLModel); - ValidateNames(UMLModel, UMLModel.Name); + if Assigned(UMLModel) then + begin + with UMLModel do + begin + if Name = '' then + AddError(sUMVModelNameEmpty, [], UMLModel); - Mapper := GetBoldTV(TAG_PMAPPERNAME); + ValidateNames(UMLModel, UMLModel.Name); - if not SameText(Mapper, DEFAULTNAME) and CheckDbStuff then - begin - if not Assigned(BoldSystemPersistenceMappers.DescriptorByName[Mapper]) then - AddError(sUMVModelUnknownMapper, [Mapper, Name], UMLModel); - end; + Mapper := GetBoldTV(TAG_PMAPPERNAME); - Names := TStringList.Create; - SourceCodeNames := TStringList.Create; - ExpressionNames := TStringList.Create; - TableNames := TStringList.Create; + if not SameText(Mapper, DEFAULTNAME) and CheckDbStuff then + begin + if not Assigned(BoldSystemPersistenceMappers.DescriptorByName[Mapper]) then + AddError(sUMVModelUnknownMapper, [Mapper, Name], UMLModel); + end; - for I := 0 to Classes.Count - 1 do - begin - Names.AddObject(AnsiUpperCase(Classes[i].Name), Classes[i]); - SourceCodeNames.AddObject(AnsiUpperCase(ExpandedSourceName(Classes[i])), Classes[i]); - ExpressionNames.AddObject(AnsiUpperCase(Classes[i].ExpandedExpressionName), Classes[i]); - if CheckDBStuff and Classes[i].Persistent then - TableNames.AddObject(AnsiUpperCase(ExpandedDBName(Classes[i])), Classes[i]); - end; - Names.Sort; - SourceCodeNames.Sort; - ExpressionNames.Sort; - TableNames.Sort; - for i := 0 to Classes.Count-2 do - begin - if Names[i] = Names[i + 1] then - AddError(sUMVClassNameExists, [(Names.Objects[i] as TUMLClass).Name], Names.Objects[i] as TUMLClass); + Names := TStringList.Create; + SourceCodeNames := TStringList.Create; + ExpressionNames := TStringList.Create; + TableNames := TStringList.Create; - if (Language <> mvslNone) and (SourceCodeNames[i] = SourceCodeNames[i + 1]) then + for I := 0 to Classes.Count - 1 do begin - case Language of - mvslDelphi: ErrorStr := sUMVDelphiNameExists; - mvslCpp: ErrorStr := sUMVCppNameExists - else ErrorStr := 'Unknown source language in validator'; - end; - AddError(ErrorStr, [ExpandedSourceName(SourceCodeNames.Objects[i] as TUMLClass), - (SourceCodeNames.Objects[i] as TUMLClass).Name], - SourceCodeNames.Objects[i] as TUMLClass) + Names.AddObject(AnsiUpperCase(Classes[i].Name), Classes[i]); + SourceCodeNames.AddObject(AnsiUpperCase(ExpandedSourceName(Classes[i])), Classes[i]); + ExpressionNames.AddObject(AnsiUpperCase(Classes[i].ExpandedExpressionName), Classes[i]); + if CheckDBStuff and Classes[i].Persistent then + TableNames.AddObject(AnsiUpperCase(ExpandedDBName(Classes[i])), Classes[i]); end; + Names.Sort; + SourceCodeNames.Sort; + ExpressionNames.Sort; + TableNames.Sort; + for i := 0 to Classes.Count-2 do + begin + if Names[i] = Names[i + 1] then + AddError(sUMVClassNameExists, [(Names.Objects[i] as TUMLClass).Name], Names.Objects[i] as TUMLClass); + + if (Language <> mvslNone) and (SourceCodeNames[i] = SourceCodeNames[i + 1]) then + begin + case Language of + mvslDelphi: ErrorStr := sUMVDelphiNameExists; + mvslCpp: ErrorStr := sUMVCppNameExists + else ErrorStr := 'Unknown source language in validator'; + end; + AddError(ErrorStr, [ExpandedSourceName(SourceCodeNames.Objects[i] as TUMLClass), + (SourceCodeNames.Objects[i] as TUMLClass).Name], + SourceCodeNames.Objects[i] as TUMLClass) + end; - if ExpressionNames[i] = ExpressionNames[i + 1] then - AddError(sUMVExpressionNameExists, [(ExpressionNames.Objects[i] as TUMLClass).ExpandedExpressionName, - (ExpressionNames.Objects[i] as TUMLClass).Name], - ExpressionNames.Objects[i] as TUMLClass); + if ExpressionNames[i] = ExpressionNames[i + 1] then + AddError(sUMVExpressionNameExists, [(ExpressionNames.Objects[i] as TUMLClass).ExpandedExpressionName, + (ExpressionNames.Objects[i] as TUMLClass).Name], + ExpressionNames.Objects[i] as TUMLClass); - if (i < TableNames.Count - 1) and (TableNames[i] = TableNames[i + 1]) and CheckDbStuff then - AddError(sUMVTableNameExists, - [ExpandedDBName(TableNames.Objects[i] as TUMLClass), - (TableNames.Objects[i] as TUMLClass).Name, - (TableNames.Objects[i + 1] as TUMLClass).Name], - TableNames.Objects[i] as TUMLClass); - end; - Names.Free; - SourceCodeNames.Free; - ExpressionNames.Free; - TableNames.Free; + if (i < TableNames.Count - 1) and (TableNames[i] = TableNames[i + 1]) and CheckDbStuff then + AddError(sUMVTableNameExists, + [ExpandedDBName(TableNames.Objects[i] as TUMLClass), + (TableNames.Objects[i] as TUMLClass).Name, + (TableNames.Objects[i + 1] as TUMLClass).Name], + TableNames.Objects[i] as TUMLClass); + end; + Names.Free; + SourceCodeNames.Free; + ExpressionNames.Free; + TableNames.Free; - BoldLog.ProgressMax := UMLModel.Classes.Count + UMLModel.Associations.Count; + BoldLog.ProgressMax := UMLModel.Classes.Count + UMLModel.Associations.Count; - for I := 0 to UMLModel.Classes.Count - 1 do - begin - ValidateClass(UMLModel.Classes[I]); - BoldLog.ProgressStep; - end; - for I := 0 to UMLModel.Associations.Count - 1 do - begin - ValidateAssociation(UMLModel.Associations[I]); - BoldLog.ProgressStep; + for I := 0 to UMLModel.Classes.Count - 1 do + begin + ValidateClass(UMLModel.Classes[I]); + BoldLog.ProgressStep; + end; + for I := 0 to UMLModel.Associations.Count - 1 do + begin + ValidateAssociation(UMLModel.Associations[I]); + BoldLog.ProgressStep; + end; + ValidateDuplicates(UMLModel); end; - ValidateDuplicates(UMLModel); end; + finally + BoldLog.EndLog; + BoldModel.EndValidation; end; - BoldLog.EndLog; - UMLModel.SendEvent(beModelValidated); end; procedure TBoldUMLModelValidator.ValidateAttribute(attribute: TUMLAttribute); @@ -435,6 +444,8 @@ procedure TBoldUMLModelValidator.ValidateAttribute(attribute: TUMLAttribute); Mappername: String; TypeDescriptor: TBoldMemberTypeDescriptor; Mapping: TBoldTypeNameMapping; + Length: Integer; + aValueSet: TBAValueSet; begin ValidateFeature(attribute); if attribute.Name = '' then @@ -478,6 +489,33 @@ procedure TBoldUMLModelValidator.ValidateAttribute(attribute: TUMLAttribute); if CheckDbStuff and Attribute.Derived and Attribute.EffectivePersistent then AddHint(sUMVAttributeDerivedAndPersistent, [Owner.Name + '.' + Name], Attribute); + Length := StrToIntDef(GetBoldTV(TAG_LENGTH), 0); + if Length <= 0 then begin + if SameText(DelphiTypeName, 'TBAString') or + SameText(DelphiTypeName, 'TBAWideString') or + SameText(DelphiTypeName, 'TBAAnsiString') or + SameText(DelphiTypeName, 'TBAUnicodeString') or + SameText(DelphiTypeName, 'TBATrimmedString') then + begin + AddHint('%s: String has no fixed length. For unlimited length use Text instead', [Owner.Name + '.' + Name], attribute); + end; + end; + + if Assigned(MemberClass) and MemberClass.InheritsFrom(TBAValueSet) then begin + aValueSet := MemberClass.Create as TBAValueSet; + try + if (aValueSet.Values.GetFirstValue <> nil) and + (aValueSet.Values.GetFirstValue.StringRepresentationCount <= 2) then + begin + AddHint('%s: ValueSet %s is not comparable without second String Representation', [Owner.Name + '.' + Name, delphiTypeName], attribute); + end; + finally + aValueSet.Free; + end; + end; + +// if attribute.columnIndex and not attribute.persistent then +// AddHint('%s: An index for the column %s was set, but this attribute isn''t persistent', [owner.name, attribute.name], attribute); end; end; end; @@ -497,14 +535,13 @@ procedure TBoldUMLModelValidator.ValidateClass(aClass: TUMLClass); for I := 0 to aClass.Feature.Count - 1 do if aClass.Feature[i] is TUMLAttribute then begin - attr := aClass.Feature[I] as TUMLAttribute; - if Attr.EffectivePersistent and TVIsFalse(Attr.GetBoldTV(TAG_ALLOWNULL)) then - result := true; - end; + attr := aClass.Feature[I] as TUMLAttribute; + if Attr.EffectivePersistent and TVIsFalse(Attr.GetBoldTV(TAG_ALLOWNULL)) then + result := true; + end; end; begin - // check model name if aClass.Name = '' then begin AddError(sUMVClassNameEmpty, [], aClass); @@ -512,6 +549,9 @@ procedure TBoldUMLModelValidator.ValidateClass(aClass: TUMLClass); end; ValidateNames(aClass, aClass.Name); + if Assigned(BoldMemberTypes.DescriptorByDelphiName[aClass.Name]) then + AddError(sUMVClassNameClashWithAttribute, [aClass.name], AClass); + if aClass.Persistent and CheckDBStuff then begin if (aClass.GetBoldTV(TAG_TABLEMAPPING) = TV_TABLEMAPPING_IMPORTED) and @@ -638,7 +678,7 @@ procedure CheckAndAddAssociationEnd(AssoEnd: TUMLAssociationEnd); mvslDelphi: CheckAndAddName(SourceNames, aClass.Name, ExpandedSourceName(aClass.Feature[i]), aClass.Feature[i], sUMVDelphiNameExists2, reported, false); mvslCpp: CheckAndAddName(SourceNames, aClass.Name, ExpandedSourceName(aClass.Feature[i]), aClass.Feature[i], sUMVCppNameExists2, reported, false); end; - + if (aClass.Feature[i] is TUMLAttribute) and (aClass.Feature[i] as TUMLAttribute).EffectivePersistent and CheckDbStuff and @@ -726,10 +766,9 @@ procedure TBoldUMLModelValidator.ValidateAssociation(association: TUMLAssociatio if end0.Name = end1.Name then AddError(sUMVDuplicateAssociationEndName, [Association.Name, end0.Name], Association); - if CheckDbStuff and (not (end0.Multi or end1.Multi)) and - TVIsTrue(end0.GetBoldTV('Embed')) and - TVIsTrue(end1.GetBoldTV('Embed')) then - AddHint(sUMVSingleAssociationEndsEmbeddedInBothEnds, [Association.name], Association); + if not Derived and persistent and CheckDbStuff and (not (end0.Multi or end1.Multi)) and + TVIsTrue(end0.GetBoldTV('Embed')) and TVIsTrue(end1.GetBoldTV('Embed')) then + AddError(sUMVSingleAssociationEndsEmbeddedInBothEnds, [end0.AsString, end1.AsString], Association); for I := 0 to Connection.Count - 1 do ValidateAssociationEnd(Connection[I] as TUMLAssociationEnd); @@ -739,10 +778,59 @@ procedure TBoldUMLModelValidator.ValidateAssociation(association: TUMLAssociatio procedure TBoldUMLModelValidator.ValidateOperation(operation: TUMLOperation); var i: Integer; + bInheritedOperationFound: Boolean; + aClass: TUMLClassifier; + aFeature: TUMLFeature; begin ValidateFeature(operation); for i := 0 to operation.Parameter.Count - 1 do ValidateParameter(operation.Parameter[i] as TUMLParameter); + + if operation.GetBoldTV(TAG_DELPHIOPERATIONKIND) = + TV_DELPHIOPERATIONKIND_OVERRIDE then + begin + bInheritedOperationFound := False; + aClass := operation.owner.superclass; + aFeature := nil; + while Assigned(aClass) and not bInheritedOperationFound do begin + for i := 0 to aClass.feature.Count - 1 do begin + aFeature := aClass.feature[i]; + if (aFeature is TUMLOperation) and + BoldAnsiEqual(aFeature.name, operation.name) then + begin + bInheritedOperationFound := True; + Break; + end; + end; + aClass := aClass.superclass; + end; + if bInheritedOperationFound then begin + if operation.visibility <> aFeature.visibility then begin + AddHint(sUMVOperationVisibilityChanged, + [Operation.owner.name + '.' + Operation.name], Operation); + end; + end else begin + // Search for framework method + for i := 0 to Length(FrameworkMethods) - 1 do begin + if BoldAnsiEqual(TBoldModelEditFrm.GetMethodName(FrameworkMethods[i]), + operation.name) then + begin + if TBoldModelEditFrm.GetMethodVisibility(FrameworkMethods[i]) <> + operation.visibility then + begin + AddHint(sUMVOperationVisibilityChanged, + [Operation.owner.name + '.' + Operation.name], Operation); + end; + bInheritedOperationFound := True; + Break; + end; + end; + if not bInheritedOperationFound then begin + AddWarning(sUMVOperationVirtualOperationMissing, + [Operation.owner.name + '.' + Operation.name], Operation); + end; + end; + end; end; procedure TBoldUMLModelValidator.ValidateParameter(parameter: TUMLParameter); @@ -786,8 +874,9 @@ procedure TBoldUMLModelValidator.ValidateAssociationEnd(associationEnd: TUMLAsso if associationEnd.IsNavigable and associationEnd.Multi and (associationEnd.OtherEnd.Aggregation = akComposite) then AddError(sUMVAssociationEndIsMultiWithOtherEndComposite, [associationEnd.Name], AssociationEnd); - if not associationEnd.Multi and not associationEnd.IsNavigable then - AddHint(sUMVAssociationEndIsSingleAndNotNavigable, [associationEnd.Name], AssociationEnd); + // not really needed, it blows up the validation result +// if not associationEnd.Multi and not associationEnd.IsNavigable then +// AddHint(sUMVAssociationEndIsSingleAndNotNavigable, [associationEnd.Name], AssociationEnd); if not associationEnd.Multi and associationEnd.isOrdered then addHint(sUMVInvalidAssociationEndOrderedandSingle, [associationEnd.Name, @@ -915,7 +1004,7 @@ procedure TBoldUMLModelValidator.ValidateNames(Element: TUMLModelElement; Elemen end; stored := stored and (element.GetBoldTV(TAG_STORAGE) <> TV_STORAGE_EXTERNAL); - + if Stored and CheckDBStuff then begin if element is TUMLClass then @@ -952,7 +1041,7 @@ function TBoldUMLModelValidator.CheckDBStuff: Boolean; function TBoldUMLModelValidator.CheckAnsiSQLStuff: Boolean; begin - result := CheckDBStuff; // FIXME add info to SQLDatabaseConfig for this? + result := CheckDBStuff; end; function TBoldUMLModelValidator.NationalCharConversion: TBoldNationalCharConversion; @@ -995,4 +1084,6 @@ destructor TBoldUMLModelValidator.Destroy; inherited; end; +initialization + end. diff --git a/Source/UMLModel/Core/BoldUMLModel_Interface.inc b/Source/UMLModel/Core/BoldUMLModel_Interface.inc index f56973c0..4d920536 100644 --- a/Source/UMLModel/Core/BoldUMLModel_Interface.inc +++ b/Source/UMLModel/Core/BoldUMLModel_Interface.inc @@ -2,7 +2,7 @@ (* This file is autogenerated *) (* Any manual changes will be LOST! *) (*****************************************) -(* Generated 2002-06-19 17:13:58 *) +(* Generated 1.9.2016 23:18:13 *) (*****************************************) (* This file should be stored in the *) (* same directory as the form/datamodule *) @@ -487,16 +487,16 @@ type private function _Get_M_visibility: TBAVisibilityKind; function _Getvisibility: TVisibilityKind; - procedure _Setvisibility(NewValue: TVisibilityKind); + procedure _Setvisibility(const NewValue: TVisibilityKind); function _Get_M_alias: TBAString; function _Getalias: String; - procedure _Setalias(NewValue: String); + procedure _Setalias(const NewValue: String); function _Getpackage: TUMLPackage; function _Get_M_package: TBoldObjectReference; - procedure _Setpackage(value: TUMLPackage); + procedure _Setpackage(const value: TUMLPackage); function _GetmodelElement: TUMLModelElement; function _Get_M_modelElement: TBoldObjectReference; - procedure _SetmodelElement(value: TUMLModelElement); + procedure _SetmodelElement(const value: TUMLModelElement); protected public property M_visibility: TBAVisibilityKind read _Get_M_visibility; @@ -513,13 +513,13 @@ type private function _Get_M_visibility: TBAVisibilityKind; function _Getvisibility: TVisibilityKind; - procedure _Setvisibility(NewValue: TVisibilityKind); + procedure _Setvisibility(const NewValue: TVisibilityKind); function _GetresidentElement: TUMLComponent; function _Get_M_residentElement: TBoldObjectReference; - procedure _SetresidentElement(value: TUMLComponent); + procedure _SetresidentElement(const value: TUMLComponent); function _Getresidence: TUMLModelElement; function _Get_M_residence: TBoldObjectReference; - procedure _Setresidence(value: TUMLModelElement); + procedure _Setresidence(const value: TUMLModelElement); protected public property M_visibility: TBAVisibilityKind read _Get_M_visibility; @@ -686,13 +686,13 @@ type private function _GetmodelElement2: TUMLModelElement; function _Get_M_modelElement2: TBoldObjectReference; - procedure _SetmodelElement2(value: TUMLModelElement); + procedure _SetmodelElement2(const value: TUMLModelElement); function _GetmodelElement: TUMLModelElement; function _Get_M_modelElement: TBoldObjectReference; - procedure _SetmodelElement(value: TUMLModelElement); + procedure _SetmodelElement(const value: TUMLModelElement); function _GetdefaultElement: TUMLModelElement; function _Get_M_defaultElement: TBoldObjectReference; - procedure _SetdefaultElement(value: TUMLModelElement); + procedure _SetdefaultElement(const value: TUMLModelElement); protected public property M_modelElement2: TBoldObjectReference read _Get_M_modelElement2; @@ -710,11 +710,10 @@ type function _GetViolation: TViolationList; function _GetUMLModel: TUMLModel; function _Get_M_UMLModel: TBoldObjectReference; - procedure _SetUMLModel(value: TUMLModel); + procedure _SetUMLModel(const value: TUMLModel); protected procedure _HighestSeverity_DeriveAndSubscribe(DerivedObject: TObject; Subscriber: TBoldSubscriber); virtual; - function GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; override; - function GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; override; + function GetDeriveMethodForMember(MemberIndex: Integer): TBoldDeriveAndResubscribe; override; public property M_HighestSeverity: TBASeverity read _Get_M_HighestSeverity; property M_Violation: TViolationList read _GetViolation; @@ -728,16 +727,16 @@ type private function _Get_M_Description: TBAString; function _GetDescription: String; - procedure _SetDescription(NewValue: String); + procedure _SetDescription(const NewValue: String); function _Get_M_Severity: TBASeverity; function _GetSeverity: TSeverity; - procedure _SetSeverity(NewValue: TSeverity); + procedure _SetSeverity(const NewValue: TSeverity); function _GetValidator: TValidator; function _Get_M_Validator: TBoldObjectReference; - procedure _SetValidator(value: TValidator); + procedure _SetValidator(const value: TValidator); function _GetModelElement: TUMLModelElement; function _Get_M_ModelElement: TBoldObjectReference; - procedure _SetModelElement(value: TUMLModelElement); + procedure _SetModelElement(const value: TUMLModelElement); protected public property M_Description: TBAString read _Get_M_Description; @@ -754,23 +753,23 @@ type private function _Get_M_name: TBAString; function _Getname: String; - procedure _Setname(NewValue: String); + procedure _Setname(const NewValue: String); function _Get_M_visibility: TBAVisibilityKind; function _Getvisibility: TVisibilityKind; - procedure _Setvisibility(NewValue: TVisibilityKind); + procedure _Setvisibility(const NewValue: TVisibilityKind); function _Get_M_isSpecification: TBABoolean; function _GetisSpecification: boolean; - procedure _SetisSpecification(NewValue: boolean); + procedure _SetisSpecification(const NewValue: boolean); function _Get_M_qualifiedName: TBAString; function _GetqualifiedName: String; function _Get_M_stereotypeName: TBAString; function _GetstereotypeName: String; - procedure _SetstereotypeName(NewValue: String); + procedure _SetstereotypeName(const NewValue: String); function _Get_M_documentation: TBAString; function _Getdocumentation: String; function _Get_M_derived: TBABoolean; function _Getderived: boolean; - procedure _Setderived(NewValue: boolean); + procedure _Setderived(const NewValue: boolean); function _Getbehavior: TUMLStateMachineList; function _Getcollaboration: TUMLCollaborationList; function _GetcollaborationcollaborationconstrainingElement: TcollaborationconstrainingElementList; @@ -786,7 +785,7 @@ type function _GettargetFlowtargetFlowtarget: TtargetFlowtargetList; function _Getbinding: TUMLBinding; function _Get_M_binding: TBoldObjectReference; - procedure _Setbinding(value: TUMLBinding); + procedure _Setbinding(const value: TUMLBinding); function _GetsupplierDependency: TUMLDependencyList; function _GetsupplierDependencysuppliersupplierDependency: TsuppliersupplierDependencyList; function _Getconstraint: TUMLConstraintList; @@ -800,36 +799,36 @@ type function _GetcommentcommentannotatedElement: TcommentannotatedElementList; function _Getnamespace_: TUMLNamespace; function _Get_M_namespace_: TBoldObjectReference; - procedure _Setnamespace_(value: TUMLNamespace); + procedure _Setnamespace_(const value: TUMLNamespace); function _GettaggedValue: TUMLTaggedValueList; function _Get_Q_taggedValue(tag: String): TUMLTaggedValue; function _Getstereotype: TUMLStereotype; function _Get_M_stereotype: TBoldObjectReference; - procedure _Setstereotype(value: TUMLStereotype); + procedure _Setstereotype(const value: TUMLStereotype); function _Getmodel: TUMLModel; function _Get_M_model: TBoldObjectReference; - procedure _Setmodel(value: TUMLModel); + procedure _Setmodel(const value: TUMLModel); function _GetqualifyingOwner: TUMLModelElement; function _Get_M_qualifyingOwner: TBoldObjectReference; - procedure _SetqualifyingOwner(value: TUMLModelElement); + procedure _SetqualifyingOwner(const value: TUMLModelElement); function _GetelementImport: TUMLElementImportList; - function FindTaggedValue(TagName: String): TUMLTaggedValue; + function FindTaggedValue(TagName: String): TUMLTaggedValue; protected procedure _stereotypeName_DeriveAndSubscribe(DerivedObject: TObject; Subscriber: TBoldSubscriber); virtual; procedure _stereotypeName_ReverseDerive(DerivedObject: TObject); virtual; procedure _documentation_DeriveAndSubscribe(DerivedObject: TObject; Subscriber: TBoldSubscriber); virtual; procedure _derived_DeriveAndSubscribe(DerivedObject: TObject; Subscriber: TBoldSubscriber); virtual; procedure _derived_ReverseDerive(DerivedObject: TObject); virtual; - function GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; override; - function GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; override; - public - function ExpandedExpressionName: String; virtual; - function GetTaggedValue(TagName: String): String; - procedure SetTaggedValue(TagName: String; Value: String); - procedure DeleteTaggedValue(TagName: String); - procedure EnsureTaggedValue(TagName: String; DefaultValue: String); - function GetBoldTV(const TagName: String): String; - procedure SetBoldTV(const TagName: String; const Value: String); + function GetDeriveMethodForMember(MemberIndex: Integer): TBoldDeriveAndResubscribe; override; + function GetReverseDeriveMethodForMember(MemberIndex: Integer): TBoldReverseDerive; override; + public + function expandedExpressionName: String; virtual; + function GetTaggedValue(TagName: String): String; + procedure SetTaggedValue(TagName: String; Value: String); + procedure DeleteTaggedValue(TagName: String); + procedure EnsureTaggedValue(TagName: String; DefaultValue: String); + function GetBoldTV(const TagName: String): String; + procedure SetBoldTV(const TagName: String; const Value: String); property M_name: TBAString read _Get_M_name; property M_visibility: TBAVisibilityKind read _Get_M_visibility; property M_isSpecification: TBABoolean read _Get_M_isSpecification; @@ -912,24 +911,24 @@ type private function _Get_M_recurrence: TBAString; function _Getrecurrence: String; - procedure _Setrecurrence(NewValue: String); + procedure _Setrecurrence(const NewValue: String); function _Get_M_target: TBAString; function _Gettarget: String; - procedure _Settarget(NewValue: String); + procedure _Settarget(const NewValue: String); function _Get_M_isAsynchronous: TBABoolean; function _GetisAsynchronous: boolean; - procedure _SetisAsynchronous(NewValue: boolean); + procedure _SetisAsynchronous(const NewValue: boolean); function _Get_M_script: TBAString; function _Getscript: String; - procedure _Setscript(NewValue: String); + procedure _Setscript(const NewValue: String); function _Gettransition: TUMLTransition; function _Get_M_transition: TBoldObjectReference; - procedure _Settransition(value: TUMLTransition); + procedure _Settransition(const value: TUMLTransition); function _GetactualArgument: TUMLArgumentList; function _Getstimulus: TUMLStimulusList; function _GetactionSequence: TUMLActionSequence; function _Get_M_actionSequence: TBoldObjectReference; - procedure _SetactionSequence(value: TUMLActionSequence); + procedure _SetactionSequence(const value: TUMLActionSequence); function _Getmessage_: TUMLMessageList; protected public @@ -957,10 +956,10 @@ type private function _Get_M_value: TBAString; function _Getvalue: String; - procedure _Setvalue(NewValue: String); + procedure _Setvalue(const NewValue: String); function _Getaction: TUMLAction; function _Get_M_action: TBoldObjectReference; - procedure _Setaction(value: TUMLAction); + procedure _Setaction(const value: TUMLAction); protected public property M_value: TBAString read _Get_M_value; @@ -973,29 +972,29 @@ type private function _Get_M_isNavigable: TBABoolean; function _GetisNavigable: boolean; - procedure _SetisNavigable(NewValue: boolean); + procedure _SetisNavigable(const NewValue: boolean); function _Get_M_ordering: TBAOrderingKind; function _Getordering: TOrderingKind; - procedure _Setordering(NewValue: TOrderingKind); + procedure _Setordering(const NewValue: TOrderingKind); function _Get_M_aggregation: TBAAggregationKind; function _Getaggregation: TAggregationKind; - procedure _Setaggregation(NewValue: TAggregationKind); + procedure _Setaggregation(const NewValue: TAggregationKind); function _Get_M_targetScope: TBAScopeKind; function _GettargetScope: TScopeKind; - procedure _SettargetScope(NewValue: TScopeKind); + procedure _SettargetScope(const NewValue: TScopeKind); function _Get_M_multiplicity: TBAString; function _Getmultiplicity: String; - procedure _Setmultiplicity(NewValue: String); + procedure _Setmultiplicity(const NewValue: String); function _Get_M_changeability: TBAChangeableKind; function _Getchangeability: TChangeableKind; - procedure _Setchangeability(NewValue: TChangeableKind); + procedure _Setchangeability(const NewValue: TChangeableKind); function _Get_M_multi: TBABoolean; function _Getmulti: boolean; function _Get_M_mandatory: TBABoolean; function _Getmandatory: boolean; function _Get_M_isOrdered: TBABoolean; function _GetisOrdered: boolean; - procedure _SetisOrdered(NewValue: boolean); + procedure _SetisOrdered(const NewValue: boolean); function _GetlinkEnd: TUMLLinkEndList; function _GetassociationEndRole: TUMLAssociationEndRoleList; function _Getqualifier: TUMLAttributeList; @@ -1003,23 +1002,23 @@ type function _Getparticipantspecification: TparticipantspecificationList; function _Gettype_: TUMLClassifier; function _Get_M_type_: TBoldObjectReference; - procedure _Settype_(value: TUMLClassifier); + procedure _Settype_(const value: TUMLClassifier); function _GetotherEnd: TUMLAssociationEnd; function _Get_M_otherEnd: TBoldObjectReference; - procedure _SetotherEnd(value: TUMLAssociationEnd); + procedure _SetotherEnd(const value: TUMLAssociationEnd); function _Getassociation: TUMLAssociation; function _Get_M_association: TBoldObjectReference; - procedure _Setassociation(value: TUMLAssociation); + procedure _Setassociation(const value: TUMLAssociation); protected procedure _multi_DeriveAndSubscribe(DerivedObject: TObject; Subscriber: TBoldSubscriber); virtual; procedure _mandatory_DeriveAndSubscribe(DerivedObject: TObject; Subscriber: TBoldSubscriber); virtual; procedure _isOrdered_DeriveAndSubscribe(DerivedObject: TObject; Subscriber: TBoldSubscriber); virtual; procedure _isOrdered_ReverseDerive(DerivedObject: TObject); virtual; - function GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; override; - function GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; override; + function GetDeriveMethodForMember(MemberIndex: Integer): TBoldDeriveAndResubscribe; override; + function GetReverseDeriveMethodForMember(MemberIndex: Integer): TBoldReverseDerive; override; public - function GetOtherEnd: TUMLAssociationEnd; - function GetQualifierByName(InName: String): TUMLAttribute; + function GetOtherEnd: TUMLAssociationEnd; + function GetQualifierByName(InName: String): TUMLAttribute; function ExpandedExpressionName: String; override; property M_isNavigable: TBABoolean read _Get_M_isNavigable; property M_ordering: TBAOrderingKind read _Get_M_ordering; @@ -1061,16 +1060,16 @@ type private function _Getvalue: TUMLInstance; function _Get_M_value: TBoldObjectReference; - procedure _Setvalue(value: TUMLInstance); + procedure _Setvalue(const value: TUMLInstance); function _Getattribute: TUMLAttribute; function _Get_M_attribute: TBoldObjectReference; - procedure _Setattribute(value: TUMLAttribute); + procedure _Setattribute(const value: TUMLAttribute); function _Getinstance: TUMLInstance; function _Get_M_instance: TBoldObjectReference; - procedure _Setinstance(value: TUMLInstance); + procedure _Setinstance(const value: TUMLInstance); function _GetlinkEnd: TUMLLinkEnd; function _Get_M_linkEnd: TBoldObjectReference; - procedure _SetlinkEnd(value: TUMLLinkEnd); + procedure _SetlinkEnd(const value: TUMLLinkEnd); protected public property M_value: TBoldObjectReference read _Get_M_value; @@ -1099,12 +1098,12 @@ type private function _Get_M_body: TBAString; function _Getbody: String; - procedure _Setbody(NewValue: String); + procedure _Setbody(const NewValue: String); function _GetconstrainedElement: TUMLModelElementList; function _GetconstrainedElementconstrainedElementconstraint: TconstrainedElementconstraintList; function _GetconstrainedElement2: TUMLStereotype; function _Get_M_constrainedElement2: TBoldObjectReference; - procedure _SetconstrainedElement2(value: TUMLStereotype); + procedure _SetconstrainedElement2(const value: TUMLStereotype); protected public property M_body: TBAString read _Get_M_body; @@ -1139,10 +1138,10 @@ type private function _Get_M_location: TBAString; function _Getlocation: String; - procedure _Setlocation(NewValue: String); + procedure _Setlocation(const NewValue: String); function _GetuseCase: TUMLUseCase; function _Get_M_useCase: TBoldObjectReference; - procedure _SetuseCase(value: TUMLUseCase); + procedure _SetuseCase(const value: TUMLUseCase); function _Getextend: TUMLExtendList; function _GetextensionPointextend: TextensionPointextendList; protected @@ -1161,15 +1160,13 @@ type private function _Get_M_ownerScope: TBAScopeKind; function _GetownerScope: TScopeKind; - procedure _SetownerScope(NewValue: TScopeKind); + procedure _SetownerScope(const NewValue: TScopeKind); function _GetclassifierRole_: TUMLClassifierRoleList; function _GetclassifierRole_availableFeature: TclassifierRole_availableFeatureList; function _Getowner: TUMLClassifier; function _Get_M_owner: TBoldObjectReference; - procedure _Setowner(value: TUMLClassifier); + procedure _Setowner(const value: TUMLClassifier); protected - function GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; override; - function GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; override; public function ExpandedExpressionName: String; override; property M_ownerScope: TBAScopeKind read _Get_M_ownerScope; @@ -1186,10 +1183,10 @@ type private function _Get_M_expression: TBAString; function _Getexpression: String; - procedure _Setexpression(NewValue: String); + procedure _Setexpression(const NewValue: String); function _Gettransition: TUMLTransition; function _Get_M_transition: TBoldObjectReference; - procedure _Settransition(value: TUMLTransition); + procedure _Settransition(const value: TUMLTransition); protected public property M_expression: TBAString read _Get_M_expression; @@ -1211,7 +1208,7 @@ type function _Getstimulus3: TUMLStimulusList; function _GetcomponentInstance: TUMLComponentInstance; function _Get_M_componentInstance: TBoldObjectReference; - procedure _SetcomponentInstance(value: TUMLComponentInstance); + procedure _SetcomponentInstance(const value: TUMLComponentInstance); protected public property M_attributeLink: TUMLAttributeLinkList read _GetattributeLink; @@ -1240,7 +1237,7 @@ type private function _Getcontext: TUMLCollaboration; function _Get_M_context: TBoldObjectReference; - procedure _Setcontext(value: TUMLCollaboration); + procedure _Setcontext(const value: TUMLCollaboration); function _Getmessage_: TUMLMessageList; protected public @@ -1254,11 +1251,11 @@ type private function _Getassociation: TUMLAssociation; function _Get_M_association: TBoldObjectReference; - procedure _Setassociation(value: TUMLAssociation); + procedure _Setassociation(const value: TUMLAssociation); function _GetStimulus: TUMLStimulusList; function _Getxobject: TUMLObject; function _Get_M_xobject: TBoldObjectReference; - procedure _Setxobject(value: TUMLObject); + procedure _Setxobject(const value: TUMLObject); function _Getconnection: TUMLLinkEndList; protected public @@ -1277,13 +1274,13 @@ type function _GetqualifiedValue: TUMLAttributeLinkList; function _Getinstance: TUMLInstance; function _Get_M_instance: TBoldObjectReference; - procedure _Setinstance(value: TUMLInstance); + procedure _Setinstance(const value: TUMLInstance); function _GetassociationEnd: TUMLAssociationEnd; function _Get_M_associationEnd: TBoldObjectReference; - procedure _SetassociationEnd(value: TUMLAssociationEnd); + procedure _SetassociationEnd(const value: TUMLAssociationEnd); function _Getlink: TUMLLink; function _Get_M_link: TBoldObjectReference; - procedure _Setlink(value: TUMLLink); + procedure _Setlink(const value: TUMLLink); protected public property M_qualifiedValue: TUMLAttributeLinkList read _GetqualifiedValue; @@ -1300,13 +1297,13 @@ type private function _Getinteraction: TUMLInteraction; function _Get_M_interaction: TBoldObjectReference; - procedure _Setinteraction(value: TUMLInteraction); + procedure _Setinteraction(const value: TUMLInteraction); function _GetcommunicationConnection: TUMLAssociationRole; function _Get_M_communicationConnection: TBoldObjectReference; - procedure _SetcommunicationConnection(value: TUMLAssociationRole); + procedure _SetcommunicationConnection(const value: TUMLAssociationRole); function _Getaction: TUMLAction; function _Get_M_action: TBoldObjectReference; - procedure _Setaction(value: TUMLAction); + procedure _Setaction(const value: TUMLAction); function _Getpredecessor: TUMLMessageList; function _Getpredecessorpredecessormessage3: Tpredecessormessage3List; function _Getmessage3: TUMLMessageList; @@ -1314,13 +1311,13 @@ type function _Getmessage4: TUMLMessageList; function _Getactivator: TUMLMessage; function _Get_M_activator: TBoldObjectReference; - procedure _Setactivator(value: TUMLMessage); + procedure _Setactivator(const value: TUMLMessage); function _Getreceiver: TUMLClassifierRole; function _Get_M_receiver: TBoldObjectReference; - procedure _Setreceiver(value: TUMLClassifierRole); + procedure _Setreceiver(const value: TUMLClassifierRole); function _Getsender: TUMLClassifierRole; function _Get_M_sender: TBoldObjectReference; - procedure _Setsender(value: TUMLClassifierRole); + procedure _Setsender(const value: TUMLClassifierRole); protected public property M_interaction: TBoldObjectReference read _Get_M_interaction; @@ -1369,29 +1366,29 @@ type private function _Get_M_defaultValue: TBAString; function _GetdefaultValue: String; - procedure _SetdefaultValue(NewValue: String); + procedure _SetdefaultValue(const NewValue: String); function _Get_M_kind: TBAParameterDirectionKind; function _Getkind: TBoldParameterDirectionKind; - procedure _Setkind(NewValue: TBoldParameterDirectionKind); + procedure _Setkind(const NewValue: TBoldParameterDirectionKind); function _Get_M_typeName: TBAString; function _GettypeName: String; - procedure _SettypeName(NewValue: String); + procedure _SettypeName(const NewValue: String); function _Getevent: TUMLEvent; function _Get_M_event: TBoldObjectReference; - procedure _Setevent(value: TUMLEvent); + procedure _Setevent(const value: TUMLEvent); function _Getstate: TUMLObjectFlowStateList; function _Getparameterstate: TparameterstateList; function _Gettype_: TUMLClassifier; function _Get_M_type_: TBoldObjectReference; - procedure _Settype_(value: TUMLClassifier); + procedure _Settype_(const value: TUMLClassifier); function _GetbehavioralFeature: TUMLBehavioralFeature; function _Get_M_behavioralFeature: TBoldObjectReference; - procedure _SetbehavioralFeature(value: TUMLBehavioralFeature); + procedure _SetbehavioralFeature(const value: TUMLBehavioralFeature); protected procedure _typeName_DeriveAndSubscribe(DerivedObject: TObject; Subscriber: TBoldSubscriber); virtual; procedure _typeName_ReverseDerive(DerivedObject: TObject); virtual; - function GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; override; - function GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; override; + function GetDeriveMethodForMember(MemberIndex: Integer): TBoldDeriveAndResubscribe; override; + function GetReverseDeriveMethodForMember(MemberIndex: Integer): TBoldReverseDerive; override; public property M_defaultValue: TBAString read _Get_M_defaultValue; property M_kind: TBAParameterDirectionKind read _Get_M_kind; @@ -1417,7 +1414,7 @@ type function _Getcontentscontentspartition: TcontentspartitionList; function _GetactivityGraph: TUMLActivityGraph; function _Get_M_activityGraph: TBoldObjectReference; - procedure _SetactivityGraph(value: TUMLActivityGraph); + procedure _SetactivityGraph(const value: TUMLActivityGraph); protected public property M_contents: TUMLModelElementList read _Getcontents; @@ -1443,10 +1440,10 @@ type function _GetsubMachineState: TUMLSubmachineStateList; function _Getcontext: TUMLModelElement; function _Get_M_context: TBoldObjectReference; - procedure _Setcontext(value: TUMLModelElement); + procedure _Setcontext(const value: TUMLModelElement); function _Gettop: TUMLState; function _Get_M_top: TBoldObjectReference; - procedure _Settop(value: TUMLState); + procedure _Settop(const value: TUMLState); protected public property M_transitions: TUMLTransitionList read _Gettransitions; @@ -1463,7 +1460,7 @@ type private function _Getcontainer: TUMLCompositeState; function _Get_M_container: TBoldObjectReference; - procedure _Setcontainer(value: TUMLCompositeState); + procedure _Setcontainer(const value: TUMLCompositeState); function _Getoutgoing: TUMLTransitionList; function _Getincoming: TUMLTransitionList; protected @@ -1482,16 +1479,16 @@ type function _Getargumentstimulus1: Targumentstimulus1List; function _GetdispatchAction: TUMLAction; function _Get_M_dispatchAction: TBoldObjectReference; - procedure _SetdispatchAction(value: TUMLAction); + procedure _SetdispatchAction(const value: TUMLAction); function _GetcommunicationLink: TUMLLink; function _Get_M_communicationLink: TBoldObjectReference; - procedure _SetcommunicationLink(value: TUMLLink); + procedure _SetcommunicationLink(const value: TUMLLink); function _Getreceiver: TUMLInstance; function _Get_M_receiver: TBoldObjectReference; - procedure _Setreceiver(value: TUMLInstance); + procedure _Setreceiver(const value: TUMLInstance); function _Getsender: TUMLInstance; function _Get_M_sender: TBoldObjectReference; - procedure _Setsender(value: TUMLInstance); + procedure _Setsender(const value: TUMLInstance); protected public property M_argument: TUMLInstanceList read _Getargument; @@ -1512,16 +1509,16 @@ type private function _Get_M_tag: TBAString; function _Gettag: String; - procedure _Settag(NewValue: String); + procedure _Settag(const NewValue: String); function _Get_M_value: TBAString; function _Getvalue: String; - procedure _Setvalue(NewValue: String); + procedure _Setvalue(const NewValue: String); function _GetmodelElement: TUMLModelElement; function _Get_M_modelElement: TBoldObjectReference; - procedure _SetmodelElement(value: TUMLModelElement); + procedure _SetmodelElement(const value: TUMLModelElement); function _Getstereotype_: TUMLStereotype; function _Get_M_stereotype_: TBoldObjectReference; - procedure _Setstereotype_(value: TUMLStereotype); + procedure _Setstereotype_(const value: TUMLStereotype); protected public property M_tag: TBAString read _Get_M_tag; @@ -1538,25 +1535,25 @@ type private function _GetState: TUMLState; function _Get_M_State: TBoldObjectReference; - procedure _SetState(value: TUMLState); + procedure _SetState(const value: TUMLState); function _Gettrigger: TUMLEvent; function _Get_M_trigger: TBoldObjectReference; - procedure _Settrigger(value: TUMLEvent); + procedure _Settrigger(const value: TUMLEvent); function _Geteffect: TUMLAction; function _Get_M_effect: TBoldObjectReference; - procedure _Seteffect(value: TUMLAction); + procedure _Seteffect(const value: TUMLAction); function _GetstateMachine: TUMLStateMachine; function _Get_M_stateMachine: TBoldObjectReference; - procedure _SetstateMachine(value: TUMLStateMachine); + procedure _SetstateMachine(const value: TUMLStateMachine); function _Getsource: TUMLStateVertex; function _Get_M_source: TBoldObjectReference; - procedure _Setsource(value: TUMLStateVertex); + procedure _Setsource(const value: TUMLStateVertex); function _Gettarget: TUMLStateVertex; function _Get_M_target: TBoldObjectReference; - procedure _Settarget(value: TUMLStateVertex); + procedure _Settarget(const value: TUMLStateVertex); function _Getguard: TUMLGuard; function _Get_M_guard: TBoldObjectReference; - procedure _Setguard(value: TUMLGuard); + procedure _Setguard(const value: TUMLGuard); protected public property M_State: TBoldObjectReference read _Get_M_State; @@ -1588,7 +1585,7 @@ type private function _Getoperation: TUMLOperation; function _Get_M_operation: TBoldObjectReference; - procedure _Setoperation(value: TUMLOperation); + procedure _Setoperation(const value: TUMLOperation); protected public property M_operation: TBoldObjectReference read _Get_M_operation; @@ -1599,7 +1596,7 @@ type private function _Getinstantiation: TUMLClassifier; function _Get_M_instantiation: TBoldObjectReference; - procedure _Setinstantiation(value: TUMLClassifier); + procedure _Setinstantiation(const value: TUMLClassifier); protected public property M_instantiation: TBoldObjectReference read _Get_M_instantiation; @@ -1622,7 +1619,7 @@ type private function _Getsignal: TUMLSignal; function _Get_M_signal: TBoldObjectReference; - procedure _Setsignal(value: TUMLSignal); + procedure _Setsignal(const value: TUMLSignal); protected public property M_signal: TBoldObjectReference read _Get_M_signal; @@ -1645,10 +1642,10 @@ type private function _Get_M_collaborationMultiplicity: TBAString; function _GetcollaborationMultiplicity: String; - procedure _SetcollaborationMultiplicity(NewValue: String); + procedure _SetcollaborationMultiplicity(const NewValue: String); function _Getbase: TUMLAssociationEnd; function _Get_M_base: TBoldObjectReference; - procedure _Setbase(value: TUMLAssociationEnd); + procedure _Setbase(const value: TUMLAssociationEnd); function _GetavailableQualifier: TUMLAttributeList; function _GetassociationEndRoleavailableQualifier: TassociationEndRoleavailableQualifierList; property M_collaborationMultiplicity: TBAString read _Get_M_collaborationMultiplicity; @@ -1667,7 +1664,7 @@ type private function _Getoperation: TUMLOperation; function _Get_M_operation: TBoldObjectReference; - procedure _Setoperation(value: TUMLOperation); + procedure _Setoperation(const value: TUMLOperation); protected public property M_operation: TBoldObjectReference read _Get_M_operation; @@ -1678,7 +1675,7 @@ type private function _Get_M_changeExpression: TBAString; function _GetchangeExpression: String; - procedure _SetchangeExpression(NewValue: String); + procedure _SetchangeExpression(const NewValue: String); protected public property M_changeExpression: TBAString read _Get_M_changeExpression; @@ -1689,7 +1686,7 @@ type private function _Getsignal: TUMLSignal; function _Get_M_signal: TBoldObjectReference; - procedure _Setsignal(value: TUMLSignal); + procedure _Setsignal(const value: TUMLSignal); protected public property M_signal: TBoldObjectReference read _Get_M_signal; @@ -1700,7 +1697,7 @@ type private function _Get_M_when: TBAString; function _Getwhen: String; - procedure _Setwhen(NewValue: String); + procedure _Setwhen(const NewValue: String); protected public property M_when: TBAString read _Get_M_when; @@ -1711,7 +1708,7 @@ type private function _Get_M_isQuery: TBABoolean; function _GetisQuery: boolean; - procedure _SetisQuery(NewValue: boolean); + procedure _SetisQuery(const NewValue: boolean); function _GetraisedSignal: TUMLSignalList; function _GetcontextraisedSignal: TcontextraisedSignalList; function _Getparameter: TUMLParameterList; @@ -1731,24 +1728,24 @@ type private function _Get_M_multiplicity: TBAString; function _Getmultiplicity: String; - procedure _Setmultiplicity(NewValue: String); + procedure _Setmultiplicity(const NewValue: String); function _Get_M_changeability: TBAChangeableKind; function _Getchangeability: TChangeableKind; - procedure _Setchangeability(NewValue: TChangeableKind); + procedure _Setchangeability(const NewValue: TChangeableKind); function _Get_M_targetScope: TBAScopeKind; function _GettargetScope: TScopeKind; - procedure _SettargetScope(NewValue: TScopeKind); + procedure _SettargetScope(const NewValue: TScopeKind); function _Get_M_typeName: TBAString; function _GettypeName: String; - procedure _SettypeName(NewValue: String); + procedure _SettypeName(const NewValue: String); function _Gettype_: TUMLClassifier; function _Get_M_type_: TBoldObjectReference; - procedure _Settype_(value: TUMLClassifier); + procedure _Settype_(const value: TUMLClassifier); protected procedure _typeName_DeriveAndSubscribe(DerivedObject: TObject; Subscriber: TBoldSubscriber); virtual; procedure _typeName_ReverseDerive(DerivedObject: TObject); virtual; - function GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; override; - function GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; override; + function GetDeriveMethodForMember(MemberIndex: Integer): TBoldDeriveAndResubscribe; override; + function GetReverseDeriveMethodForMember(MemberIndex: Integer): TBoldReverseDerive; override; public property M_multiplicity: TBAString read _Get_M_multiplicity; property M_changeability: TBAChangeableKind read _Get_M_changeability; @@ -1767,7 +1764,7 @@ type function _Getresident_: TUMLInstanceList; function _GetnodeInstance: TUMLNodeInstance; function _Get_M_nodeInstance: TBoldObjectReference; - procedure _SetnodeInstance(value: TUMLNodeInstance); + procedure _SetnodeInstance(const value: TUMLNodeInstance); protected public property M_resident_: TUMLInstanceList read _Getresident_; @@ -1795,7 +1792,7 @@ type private function _Getlink: TUMLLink; function _Get_M_link: TBoldObjectReference; - procedure _Setlink(value: TUMLLink); + procedure _Setlink(const value: TUMLLink); protected public property M_link: TBoldObjectReference read _Get_M_link; @@ -1812,13 +1809,13 @@ type private function _Get_M_isRoot: TBABoolean; function _GetisRoot: boolean; - procedure _SetisRoot(NewValue: boolean); + procedure _SetisRoot(const NewValue: boolean); function _Get_M_isLeaf: TBABoolean; function _GetisLeaf: boolean; - procedure _SetisLeaf(NewValue: boolean); + procedure _SetisLeaf(const NewValue: boolean); function _Get_M_isAbstract: TBABoolean; function _GetisAbstract: boolean; - procedure _SetisAbstract(NewValue: boolean); + procedure _SetisAbstract(const NewValue: boolean); function _Getspecialization: TUMLGeneralizationList; function _Getgeneralization: TUMLGeneralizationList; protected @@ -1857,15 +1854,15 @@ type private function _Get_M_condition: TBAString; function _Getcondition: String; - procedure _Setcondition(NewValue: String); + procedure _Setcondition(const NewValue: String); function _GetextensionPoint: TUMLExtensionPointList; function _GetextensionPointextend: TextensionPointextendList; function _Getbase: TUMLUseCase; function _Get_M_base: TBoldObjectReference; - procedure _Setbase(value: TUMLUseCase); + procedure _Setbase(const value: TUMLUseCase); function _Getextension: TUMLUseCase; function _Get_M_extension: TBoldObjectReference; - procedure _Setextension(value: TUMLUseCase); + procedure _Setextension(const value: TUMLUseCase); protected public property M_condition: TBAString read _Get_M_condition; @@ -1902,16 +1899,16 @@ type private function _Get_M_discriminator: TBAString; function _Getdiscriminator: String; - procedure _Setdiscriminator(NewValue: String); + procedure _Setdiscriminator(const NewValue: String); function _Getparent: TUMLGeneralizableElement; function _Get_M_parent: TBoldObjectReference; - procedure _Setparent(value: TUMLGeneralizableElement); + procedure _Setparent(const value: TUMLGeneralizableElement); function _Getchild: TUMLGeneralizableElement; function _Get_M_child: TBoldObjectReference; - procedure _Setchild(value: TUMLGeneralizableElement); + procedure _Setchild(const value: TUMLGeneralizableElement); function _Getpowertype: TUMLClassifier; function _Get_M_powertype: TBoldObjectReference; - procedure _Setpowertype(value: TUMLClassifier); + procedure _Setpowertype(const value: TUMLClassifier); protected public property M_discriminator: TBAString read _Get_M_discriminator; @@ -1928,10 +1925,10 @@ type private function _Getbase: TUMLUseCase; function _Get_M_base: TBoldObjectReference; - procedure _Setbase(value: TUMLUseCase); + procedure _Setbase(const value: TUMLUseCase); function _Getaddition: TUMLUseCase; function _Get_M_addition: TBoldObjectReference; - procedure _Setaddition(value: TUMLUseCase); + procedure _Setaddition(const value: TUMLUseCase); protected public property M_base: TBoldObjectReference read _Get_M_base; @@ -1953,7 +1950,7 @@ type private function _Get_M_kind: TBAPseudostateKind; function _Getkind: TPseudostateKind; - procedure _Setkind(NewValue: TPseudostateKind); + procedure _Setkind(const NewValue: TPseudostateKind); protected public property M_kind: TBAPseudostateKind read _Get_M_kind; @@ -1964,19 +1961,19 @@ type private function _Getentry: TUMLAction; function _Get_M_entry: TBoldObjectReference; - procedure _Setentry(value: TUMLAction); + procedure _Setentry(const value: TUMLAction); function _GetinternalTransition: TUMLTransitionList; function _GetdoActivity: TUMLAction; function _Get_M_doActivity: TBoldObjectReference; - procedure _SetdoActivity(value: TUMLAction); + procedure _SetdoActivity(const value: TUMLAction); function _Getexit: TUMLAction; function _Get_M_exit: TBoldObjectReference; - procedure _Setexit(value: TUMLAction); + procedure _Setexit(const value: TUMLAction); function _GetdeferrableEvent: TUMLEventList; function _GetstatedeferrableEvent: TstatedeferrableEventList; function _GetstateMachine: TUMLStateMachine; function _Get_M_stateMachine: TBoldObjectReference; - procedure _SetstateMachine(value: TUMLStateMachine); + procedure _SetstateMachine(const value: TUMLStateMachine); function _GetclassifierInState: TUMLClassifierInStateList; function _GetclassifierInStateinState: TclassifierInStateinStateList; protected @@ -2005,7 +2002,7 @@ type private function _Get_M_referenceState: TBAString; function _GetreferenceState: String; - procedure _SetreferenceState(NewValue: String); + procedure _SetreferenceState(const NewValue: String); protected public property M_referenceState: TBAString read _Get_M_referenceState; @@ -2016,7 +2013,7 @@ type private function _Get_M_bound: TBAString; function _Getbound: String; - procedure _Setbound(NewValue: String); + procedure _Setbound(const NewValue: String); protected public property M_bound: TBAString read _Get_M_bound; @@ -2027,10 +2024,10 @@ type private function _Get_M_body: TBAString; function _Getbody: String; - procedure _Setbody(NewValue: String); + procedure _Setbody(const NewValue: String); function _Getspecification: TUMLOperation; function _Get_M_specification: TBoldObjectReference; - procedure _Setspecification(value: TUMLOperation); + procedure _Setspecification(const value: TUMLOperation); protected public property M_body: TBAString read _Get_M_body; @@ -2043,19 +2040,19 @@ type private function _Get_M_concurrency: TBACallConcurrencyKind; function _Getconcurrency: TCallConcurrencyKind; - procedure _Setconcurrency(NewValue: TCallConcurrencyKind); + procedure _Setconcurrency(const NewValue: TCallConcurrencyKind); function _Get_M_isRoot: TBABoolean; function _GetisRoot: boolean; - procedure _SetisRoot(NewValue: boolean); + procedure _SetisRoot(const NewValue: boolean); function _Get_M_isLeaf: TBABoolean; function _GetisLeaf: boolean; - procedure _SetisLeaf(NewValue: boolean); + procedure _SetisLeaf(const NewValue: boolean); function _Get_M_isAbstract: TBABoolean; function _GetisAbstract: boolean; - procedure _SetisAbstract(NewValue: boolean); + procedure _SetisAbstract(const NewValue: boolean); function _Get_M_specification: TBAString; function _Getspecification: String; - procedure _Setspecification(NewValue: String); + procedure _Setspecification(const NewValue: String); function _Getoccurrences: TUMLCallEventList; function _GetcallAction: TUMLCallActionList; function _Getcollaboration_: TUMLCollaborationList; @@ -2086,19 +2083,19 @@ type private function _Get_M_specification: TBAString; function _Getspecification: String; - procedure _Setspecification(NewValue: String); + procedure _Setspecification(const NewValue: String); function _Get_M_isRoot: TBABoolean; function _GetisRoot: boolean; - procedure _SetisRoot(NewValue: boolean); + procedure _SetisRoot(const NewValue: boolean); function _Get_M_isLeaf: TBABoolean; function _GetisLeaf: boolean; - procedure _SetisLeaf(NewValue: boolean); + procedure _SetisLeaf(const NewValue: boolean); function _Get_M_isAbstract: TBABoolean; function _GetisAbstract: boolean; - procedure _SetisAbstract(NewValue: boolean); + procedure _SetisAbstract(const NewValue: boolean); function _Getsignal: TUMLSignal; function _Get_M_signal: TBoldObjectReference; - procedure _Setsignal(value: TUMLSignal); + procedure _Setsignal(const value: TUMLSignal); protected public property M_specification: TBAString read _Get_M_specification; @@ -2117,24 +2114,24 @@ type private function _Get_M_initialValue: TBAString; function _GetinitialValue: String; - procedure _SetinitialValue(NewValue: String); + procedure _SetinitialValue(const NewValue: String); function _Get_M_persistent: TBABoolean; function _Getpersistent: boolean; - procedure _Setpersistent(NewValue: boolean); + procedure _Setpersistent(const NewValue: boolean); function _GetattributeLink: TUMLAttributeLinkList; function _GetassociationEndRole: TUMLAssociationEndRoleList; function _GetassociationEndRoleavailableQualifier: TassociationEndRoleavailableQualifierList; function _GetassociationEnd: TUMLAssociationEnd; function _Get_M_associationEnd: TBoldObjectReference; - procedure _SetassociationEnd(value: TUMLAssociationEnd); + procedure _SetassociationEnd(const value: TUMLAssociationEnd); protected procedure _persistent_DeriveAndSubscribe(DerivedObject: TObject; Subscriber: TBoldSubscriber); virtual; procedure _persistent_ReverseDerive(DerivedObject: TObject); virtual; - function GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; override; - function GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; override; + function GetDeriveMethodForMember(MemberIndex: Integer): TBoldDeriveAndResubscribe; override; + function GetReverseDeriveMethodForMember(MemberIndex: Integer): TBoldReverseDerive; override; public - function isQualifier: Boolean; - function EffectivePersistent: Boolean; + function isQualifier: Boolean; + function EffectivePersistent: Boolean; property M_initialValue: TBAString read _Get_M_initialValue; property M_persistent: TBABoolean read _Get_M_persistent; property M_attributeLink: TUMLAttributeLinkList read _GetattributeLink; @@ -2153,22 +2150,22 @@ type private function _Get_M_persistent: TBABoolean; function _Getpersistent: boolean; - procedure _Setpersistent(NewValue: boolean); + procedure _Setpersistent(const NewValue: boolean); function _Get_M_isAssociationClass: TBABoolean; function _GetisAssociationClass: boolean; function _Getlink: TUMLLinkList; function _GetassociationRole: TUMLAssociationRoleList; function _Getclass_: TUMLClass; function _Get_M_class_: TBoldObjectReference; - procedure _Setclass_(value: TUMLClass); + procedure _Setclass_(const value: TUMLClass); function _Getconnection: TUMLAssociationEndList; protected procedure _persistent_DeriveAndSubscribe(DerivedObject: TObject; Subscriber: TBoldSubscriber); virtual; procedure _persistent_ReverseDerive(DerivedObject: TObject); virtual; - function GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; override; - function GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; override; + function GetDeriveMethodForMember(MemberIndex: Integer): TBoldDeriveAndResubscribe; override; + function GetReverseDeriveMethodForMember(MemberIndex: Integer): TBoldReverseDerive; override; public - function EffectivePersistent: Boolean; + function EffectivePersistent: Boolean; property M_persistent: TBABoolean read _Get_M_persistent; property M_isAssociationClass: TBABoolean read _Get_M_isAssociationClass; property M_link: TUMLLinkList read _Getlink; @@ -2187,7 +2184,7 @@ type private function _Get_M_persistent: TBABoolean; function _Getpersistent: boolean; - procedure _Setpersistent(NewValue: boolean); + procedure _Setpersistent(const NewValue: boolean); function _GetcreateAction: TUMLCreateActionList; function _Getinstance: TUMLInstanceList; function _Getinstanceclassifier: TinstanceclassifierList; @@ -2201,7 +2198,7 @@ type function _Getsubclasses: TUMLClassifierList; function _Getsuperclass: TUMLClassifier; function _Get_M_superclass: TBoldObjectReference; - procedure _Setsuperclass(value: TUMLClassifier); + procedure _Setsuperclass(const value: TUMLClassifier); function _GetassociationEnd: TUMLAssociationEndList; function _GetpowertypeRange: TUMLGeneralizationList; function _GetallFeature: TUMLFeatureList; @@ -2209,11 +2206,11 @@ type protected procedure _persistent_DeriveAndSubscribe(DerivedObject: TObject; Subscriber: TBoldSubscriber); virtual; procedure _persistent_ReverseDerive(DerivedObject: TObject); virtual; - function GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; override; - function GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; override; + function GetDeriveMethodForMember(MemberIndex: Integer): TBoldDeriveAndResubscribe; override; + function GetReverseDeriveMethodForMember(MemberIndex: Integer): TBoldReverseDerive; override; public - procedure GetAllOverrideableMethods(Methods: TList); - procedure SetFirstParent(parent: TUMLClassifier); + procedure GetAllOverrideableMethods(Methods: TList); + procedure SetFirstParent(parent: TUMLClassifier); property M_persistent: TBABoolean read _Get_M_persistent; property M_createAction: TUMLCreateActionList read _GetcreateAction; property M_instance: TUMLInstanceList read _Getinstance; @@ -2257,10 +2254,10 @@ type function _GetconstrainingElementcollaborationconstrainingElement: TcollaborationconstrainingElementList; function _GetrepresentedClassifier: TUMLClassifier; function _Get_M_representedClassifier: TBoldObjectReference; - procedure _SetrepresentedClassifier(value: TUMLClassifier); + procedure _SetrepresentedClassifier(const value: TUMLClassifier); function _GetrepresentedOperation: TUMLOperation; function _Get_M_representedOperation: TBoldObjectReference; - procedure _SetrepresentedOperation(value: TUMLOperation); + procedure _SetrepresentedOperation(const value: TUMLOperation); protected public property M_interaction: TUMLInteractionList read _Getinteraction; @@ -2288,16 +2285,16 @@ type private function _Get_M_icon: TBAString; function _Geticon: String; - procedure _Seticon(NewValue: String); + procedure _Seticon(const NewValue: String); function _Get_M_baseClass: TBAString; function _GetbaseClass: String; - procedure _SetbaseClass(NewValue: String); + procedure _SetbaseClass(const NewValue: String); function _GetstereotypeConstraint: TUMLConstraintList; function _GetextendedElement: TUMLModelElementList; function _GetrequiredTag: TUMLTaggedValueList; protected public - class function FindStereotypeByName(aName: String; aSystem: TBoldSystem): TUMLStereotype; + class function FindStereotypeByName(aName: String; aSystem: TBoldSystem): TUMLStereotype; property M_icon: TBAString read _Get_M_icon; property M_baseClass: TBAString read _Get_M_baseClass; property M_stereotypeConstraint: TUMLConstraintList read _GetstereotypeConstraint; @@ -2314,7 +2311,7 @@ type private function _Get_M_mapping: TBAString; function _Getmapping: String; - procedure _Setmapping(NewValue: String); + procedure _Setmapping(const NewValue: String); protected public property M_mapping: TBAString read _Get_M_mapping; @@ -2349,7 +2346,7 @@ type private function _Get_M_isConcurrent: TBABoolean; function _GetisConcurrent: boolean; - procedure _SetisConcurrent(NewValue: boolean); + procedure _SetisConcurrent(const NewValue: boolean); function _Getsubvertex: TUMLStateVertexList; protected public @@ -2375,10 +2372,10 @@ type private function _Get_M_multiplicity: TBAString; function _Getmultiplicity: String; - procedure _Setmultiplicity(NewValue: String); + procedure _Setmultiplicity(const NewValue: String); function _Getbase: TUMLAssociation; function _Get_M_base: TBoldObjectReference; - procedure _Setbase(value: TUMLAssociation); + procedure _Setbase(const value: TUMLAssociation); function _Getmessage_: TUMLMessageList; protected public @@ -2400,15 +2397,13 @@ type private function _Get_M_isActive: TBABoolean; function _GetisActive: boolean; - procedure _SetisActive(NewValue: boolean); + procedure _SetisActive(const NewValue: boolean); function _Get_M_isAssociationClass: TBABoolean; function _GetisAssociationClass: boolean; function _Getassociation: TUMLAssociation; function _Get_M_association: TBoldObjectReference; - procedure _Setassociation(value: TUMLAssociation); + procedure _Setassociation(const value: TUMLAssociation); protected - function GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; override; - function GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; override; public function ExpandedExpressionName: String; override; property M_isActive: TBABoolean read _Get_M_isActive; @@ -2423,7 +2418,7 @@ type private function _Gettype_: TUMLClassifier; function _Get_M_type_: TBoldObjectReference; - procedure _Settype_(value: TUMLClassifier); + procedure _Settype_(const value: TUMLClassifier); function _GetinState: TUMLStateList; function _GetclassifierInStateinState: TclassifierInStateinStateList; protected @@ -2440,7 +2435,7 @@ type private function _Get_M_multiplicity: TBAString; function _Getmultiplicity: String; - procedure _Setmultiplicity(NewValue: String); + procedure _Setmultiplicity(const NewValue: String); function _GetavailableFeature: TUMLFeatureList; function _GetclassifierRole_availableFeature: TclassifierRole_availableFeatureList; function _GetavailableContents: TUMLModelElementList; @@ -2556,12 +2551,10 @@ type private function _GetValidator: TValidator; function _Get_M_Validator: TBoldObjectReference; - procedure _SetValidator(value: TValidator); + procedure _SetValidator(const value: TValidator); protected - function GetDeriveMethodForMember(Member: TBoldMember): TBoldDeriveAndResubscribe; override; - function GetReverseDeriveMethodForMember(Member: TBoldMember): TBoldReverseDerive; override; public - procedure Clear; + procedure Clear; procedure CompleteCreate; override; property M_Validator: TBoldObjectReference read _Get_M_Validator; property Validator: TValidator read _GetValidator write _SetValidator; @@ -2571,7 +2564,7 @@ type private function _Get_M_isInstantiable: TBABoolean; function _GetisInstantiable: boolean; - procedure _SetisInstantiable(NewValue: boolean); + procedure _SetisInstantiable(const NewValue: boolean); protected public property M_isInstantiable: TBABoolean read _Get_M_isInstantiable; @@ -2582,7 +2575,7 @@ type private function _Getsubmachine: TUMLStateMachine; function _Get_M_submachine: TBoldObjectReference; - procedure _Setsubmachine(value: TUMLStateMachine); + procedure _Setsubmachine(const value: TUMLStateMachine); protected public property M_submachine: TBoldObjectReference read _Get_M_submachine; @@ -2593,13 +2586,13 @@ type private function _Get_M_isDynamic: TBABoolean; function _GetisDynamic: boolean; - procedure _SetisDynamic(NewValue: boolean); + procedure _SetisDynamic(const NewValue: boolean); function _Get_M_dynamicArguments: TBAString; function _GetdynamicArguments: String; - procedure _SetdynamicArguments(NewValue: String); + procedure _SetdynamicArguments(const NewValue: String); function _Get_M_dynamicMultiplicity: TBAString; function _GetdynamicMultiplicity: String; - procedure _SetdynamicMultiplicity(NewValue: String); + procedure _SetdynamicMultiplicity(const NewValue: String); protected public property M_isDynamic: TBABoolean read _Get_M_isDynamic; @@ -2614,10 +2607,10 @@ type private function _Get_M_isSynch: TBABoolean; function _GetisSynch: boolean; - procedure _SetisSynch(NewValue: boolean); + procedure _SetisSynch(const NewValue: boolean); function _Gettype_: TUMLClassifier; function _Get_M_type_: TBoldObjectReference; - procedure _Settype_(value: TUMLClassifier); + procedure _Settype_(const value: TUMLClassifier); function _Getparameter: TUMLParameterList; function _Getparameterstate: TparameterstateList; protected @@ -2642,13 +2635,13 @@ type private function _Get_M_isDynamic: TBABoolean; function _GetisDynamic: boolean; - procedure _SetisDynamic(NewValue: boolean); + procedure _SetisDynamic(const NewValue: boolean); function _Get_M_dynamicArguments: TBAString; function _GetdynamicArguments: String; - procedure _SetdynamicArguments(NewValue: String); + procedure _SetdynamicArguments(const NewValue: String); function _Get_M_dynamicMultiplicity: TBAString; function _GetdynamicMultiplicity: String; - procedure _SetdynamicMultiplicity(NewValue: String); + procedure _SetdynamicMultiplicity(const NewValue: String); property M_dynamicMultiplicity: TBAString read _Get_M_dynamicMultiplicity; property dynamicMultiplicity: String read _GetdynamicMultiplicity write _SetdynamicMultiplicity; protected @@ -4274,4 +4267,3 @@ uses BoldGeneratedCodeDictionary; {$ENDIF} - diff --git a/Source/UMLModel/Core/BoldUMLOCLValidator.pas b/Source/UMLModel/Core/BoldUMLOCLValidator.pas index c0caee0f..dd2ad6de 100644 --- a/Source/UMLModel/Core/BoldUMLOCLValidator.pas +++ b/Source/UMLModel/Core/BoldUMLOCLValidator.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLOCLValidator; interface @@ -19,11 +22,12 @@ TOCLValidityChecker = class; { TOCLValidityChecker } TOCLValidityChecker = class private + fBoldModel: TBoldModel; fUMLModel: TUMLModel; fTypeNameDictionary: TBoldTypeNameDictionary; fSystemTypeInfo: TBoldSystemTypeInfo; fOclEvaluator: TBoldOCL; - function ExtractSystemTypeInfo(UMLMOdel: TUMLModel): TBoldSystemTypeInfo; + function ExtractSystemTypeInfo(BoldModel: TBoldModel): TBoldSystemTypeInfo; function GetOCLEvaluator: TBoldOCL; function AttributeTypeInfoFromUMLAttribute(UMLAttribute: TUMLAttribute): TBoldAttributeTypeInfo; function ElementTypeInfoFromUMLAssociationEnd(UMLAssociationEnd: TUMLAssociationEnd): TBoldElementTypeInfo; @@ -39,9 +43,12 @@ TOCLValidityChecker = class procedure ValidateExpression(const ScopeName: string; Element, Context: TUMLModelElement; const Expression: string; ElementTypeInfo: TBoldElementTypeInfo); property SystemTypeInfo: TBoldSystemTypeInfo read fSystemTypeInfo; property OCLEvaluator: TBoldOCL read GetOCLEvaluator; + property UMLModel: TUMLModel read fUMLModel; + property BoldModel: TBoldModel read fBoldModel; public constructor Create(aTypeNameDictionary: TBoldTypeNameDictionary); - procedure ValidateModel(UMLModel: TUMLModel); + destructor Destroy; override; + procedure ValidateModel(BoldModel: TBoldModel); property TypeNameDictionary: TBoldTypeNameDictionary read fTypeNameDictionary; end; @@ -56,6 +63,7 @@ implementation BoldDefaultTaggedValues, BoldOCLClasses, BoldOCLError, + BoldUMLAbstractModelValidator, BoldGuard; { TOCLValidityChecker } @@ -65,16 +73,15 @@ constructor TOCLValidityChecker.Create(aTypeNameDictionary: TBoldTypeNameDiction fTypeNameDictionary := aTypeNameDictionary; end; -function TOCLValidityChecker.ExtractSystemTypeInfo(UMLModel: TUMLModel): TBoldSystemTypeInfo; -var - MoldModel: TMoldModel; +destructor TOCLValidityChecker.Destroy; begin - MoldModel := TBoldModelConverter.UMLModelToMold(UMLModel); - try - Result := TBoldSystemTypeInfo.Create(MoldModel, false, false, fTypeNameDictionary); - finally - MoldModel.Free; - end; + FreeAndNil(fSystemTypeInfo); + inherited; +end; + +function TOCLValidityChecker.ExtractSystemTypeInfo(BoldModel: TBoldModel): TBoldSystemTypeInfo; +begin + Result := TBoldSystemTypeInfo.Create(BoldModel.MoldModel, false, false, fTypeNameDictionary); end; function TOCLValidityChecker.GetOCLEvaluator: TBoldOCL; @@ -86,15 +93,13 @@ function TOCLValidityChecker.GetOCLEvaluator: TBoldOCL; procedure TOCLValidityChecker.ValidateAssociationEnd(UMLAssociationEnd: TUMLAssociationEnd); begin - // DerivationExpression if UMLAssociationEnd.GetBoldTV(TAG_DERIVATIONOCL) <> '' then begin if UMLAssociationEnd.Association.Derived then ValidateExpression('DerivationOCL', UMLAssociationEnd, UMLAssociationEnd.otherEnd.type_, UMLAssociationEnd.GetBoldTV(TAG_DERIVATIONOCL), ElementTypeInfoFromUMLAssociationEnd(UMLAssociationEnd)) else - AddViolation(sHint, UMLAssociationEnd, 'Derivation expression specified for non-derived association'); + AddViolation(sHint, UMLAssociationEnd, 'Derivation expression specified for non-derived associationEnd'+ UMLAssociationEnd.GetOtherEnd.Type_.name + '.' + UMLAssociationEnd.Name); end; - // Constraints ValidateConstraints(UMLAssociationEnd, UMLAssociationEnd.type_, UMLAssociationEnd.constraint); end; @@ -102,7 +107,6 @@ procedure TOCLValidityChecker.ValidateAssociation(UMLAssociation: TUMLAssociatio var Context: TUMLModelElement; begin - // Constraints if Assigned(UMLAssociation.class_) then Context := UMLAssociation.class_ else @@ -114,15 +118,13 @@ procedure TOCLValidityChecker.ValidateAssociation(UMLAssociation: TUMLAssociatio procedure TOCLValidityChecker.ValidateAttribute(UMLAttribute: TUMLAttribute); begin - // Derivation expression if UMLAttribute.GetBoldTV(TAG_DERIVATIONOCL) <> '' then begin if UMLAttribute.Derived then ValidateExpression('DerivationOCL', UMLAttribute, UMLAttribute.owner, UMLAttribute.GetBoldTV(TAG_DERIVATIONOCL), AttributeTypeInfoFromUMLAttribute(UMLAttribute)) else - AddViolation(sHint, UMLAttribute, 'Derivation expression specified for non-derived attribute'); + AddViolation(sHint, UMLAttribute, 'Derivation expression specified for non-derived attribute: ' + UmlAttribute.owner.name + '.' + UMLAttribute.Name); end; - // Constraints ValidateConstraints(UMLAttribute, UMLAttribute.owner, UMLAttribute.constraint); end; @@ -130,23 +132,16 @@ procedure TOCLValidityChecker.ValidateClass(UMLClass: TUMLClass); var i: integer; begin - // Default string representation if UMLClass.GetBoldTV(TAG_DEFAULTSTRINGREPRESENTATION) <> '' then ValidateExpression('DefaultStringRepresentation', UMLClass, UMLClass, UMLClass.GetBoldTV(TAG_DEFAULTSTRINGREPRESENTATION), OCLEvaluator.SymbolTable.Help.StringType); - // Members for i := 0 to UMLClass.feature.Count - 1 do begin if UMLClass.Feature[i] is TUMLAttribute then ValidateAttribute(TUMLAttribute(UMLClass.Feature[i])); end; - - // AssociationEnds for i := 0 to UMLClass.associationEnd.Count - 1 do ValidateAssociationEnd(TUMLAssociationEnd(UMLClass.associationEnd[i])); - - // Constraints ValidateConstraints(UMLCLass, UMLClass, UMLClass.constraint); - // Derivation expressions ValidateDerivationExpressions(UMLClass, UMLClass.taggedValue['Bold.DerivationExpressions']); end; @@ -166,7 +161,7 @@ procedure TOCLValidityChecker.ValidateExpression(const ScopeName: string; Elemen ValidationContext: TBoldElementTypeInfo; Mapping: TBoldTypeNameMapping; begin - ErrorHeader := 'Invalid ' + ScopeName + ': '; + ErrorHeader := 'Invalid ' + ScopeName + ': ' + Element.name + ': ' + Expression + ': '; ValidationContext := nil; if context is TUMLClass then ValidationContext := SystemTypeInfo.ClassTypeInfoByModelName[Context.Name] @@ -206,19 +201,25 @@ procedure TOCLValidityChecker.ValidateExpression(const ScopeName: string; Elemen AddViolation(sError, Element, ErrorHeader + Format(' Type mismatch: Expected %s got %s', [ElementTypeInfo.ExpressionName, Result.ExpressionName])); end; -procedure TOCLValidityChecker.ValidateModel(UMLModel: TUMLModel); +procedure TOCLValidityChecker.ValidateModel(BoldModel: TBoldModel); var i: integer; begin - fUMLModel := UMLModel; - fSystemTypeInfo := ExtractSystemTypeInfo(UMLModel); + fBoldModel := BoldModel; + fUMLModel := BoldModel.EnsuredUMLModel; + BoldModel.StartValidation; BoldLog.StartLog('Validating OCL in model'); - ClearViolations; - for i := 0 to UMLModel.Classes.Count - 1 do - ValidateClass(UMLModel.Classes[i]); - for i := 0 to UMLModel.associations.Count - 1 do - ValidateAssociation(UMLModel.associations[i]); - BoldLog.EndLog; + try + fSystemTypeInfo := ExtractSystemTypeInfo(BoldModel); + ClearViolations; + for i := 0 to UMLModel.Classes.Count - 1 do + ValidateClass(UMLModel.Classes[i]); + for i := 0 to UMLModel.associations.Count - 1 do + ValidateAssociation(UMLModel.associations[i]); + finally + BoldModel.EndValidation; + BoldLog.EndLog; + end; end; procedure TOCLValidityChecker.ValidateDerivationExpressions(UMLClass: TUMLClass; UMLTaggedValue: TUMLTaggedValue); @@ -273,9 +274,9 @@ function LocateModelElement(const FeatureName: string): TUMLModelElement; begin UMLAttribute := TUMLAttribute(UMLModelElement); if not UMLAttribute.Derived then - AddViolation(sHint, UMLAttribute, 'Derivation expression respecified for non-derived attribute') + AddViolation(sHint, UMLAttribute, 'Derivation expression respecified for non-derived attribute' + UmlAttribute.owner.name + '.' + UMLAttribute.Name) else if UMLAttribute.GetBoldTV(TAG_DERIVATIONOCL) = '' then - AddViolation(sHint, UMLAttribute, 'Derivation expression respecified for code-derived attribute') + AddViolation(sHint, UMLAttribute, 'Derivation expression respecified for code-derived attribute' + UmlAttribute.owner.name + '.' + UMLAttribute.Name) else ValidateExpression('DerivationExpression', UMLClass, UMLClass, StringList.Values[StringList.Names[i]], AttributeTypeInfoFromUMLAttribute(UMLAttribute)) end; @@ -284,9 +285,9 @@ function LocateModelElement(const FeatureName: string): TUMLModelElement; begin UMLAssociationEnd := TUMLAssociationEnd(UMLModelElement); if not UMLAssociationEnd.association.derived then - AddViolation(sHint, UMLAssociationEnd, 'Derivation expression respecified for non-derived association') + AddViolation(sHint, UMLAssociationEnd, 'Derivation expression respecified for non-derived association'+ UMLAssociationEnd.GetOtherEnd.Type_.name + '.' + UMLAssociationEnd.Name) else if UMLAssociationEnd.GetBoldTV(TAG_DERIVATIONOCL) = '' then - AddViolation(sHint, UMLAssociationEnd, 'Derivation expression respecified for code-derived association end') + AddViolation(sHint, UMLAssociationEnd, 'Derivation expression respecified for code-derived association end'+ UMLAssociationEnd.GetOtherEnd.Type_.name + '.' + UMLAssociationEnd.Name) else ValidateExpression('DerivationExpression', UMLClass, UMLClass, StringList.Values[StringList.Names[i]], ElementTypeInfoFromUMLAssociationEnd(UMLAssociationEnd)); end; @@ -321,6 +322,9 @@ procedure TOCLValidityChecker.AddViolation(Severity: TSeverity; element: TUMLMod Violation := fUMLModel.Validator.Violation.AddNew; Violation.Severity := Severity; Violation.ModelElement := Element; + if Length(Msg) > 255 then + Violation.Description := Copy(Msg, 0, 200) + ' ...' + else Violation.Description := Msg; end; @@ -328,8 +332,16 @@ procedure TOCLValidityChecker.ClearViolations; var i: integer; begin - for i := fUMLModel.Validator.Violation.count - 1 downto 0 do - fUMLModel.Validator.Violation[i].Delete + fUMLModel.BoldSystem.StartTransaction(); + try + for i := fUMLModel.Validator.Violation.count - 1 downto 0 do + fUMLModel.Validator.Violation[i].Delete; + fUMLModel.BoldSystem.CommitTransaction(); + except + fUMLModel.BoldSystem.RollbackTransaction(); + end; end; +initialization + end. diff --git a/Source/UMLModel/Core/BoldUMLUtils.pas b/Source/UMLModel/Core/BoldUMLUtils.pas index 080dd7ff..f76b5989 100644 --- a/Source/UMLModel/Core/BoldUMLUtils.pas +++ b/Source/UMLModel/Core/BoldUMLUtils.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLUtils; interface @@ -33,4 +36,3 @@ function SQLDataBaseConfigforModel(BoldModel: TBoldModel): TBoldSQLDataBaseConfi end; end. - diff --git a/Source/UMLModel/Editor/BoldDerivationExpressionsEditor.pas b/Source/UMLModel/Editor/BoldDerivationExpressionsEditor.pas index 769318e8..d8c1800c 100644 --- a/Source/UMLModel/Editor/BoldDerivationExpressionsEditor.pas +++ b/Source/UMLModel/Editor/BoldDerivationExpressionsEditor.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDerivationExpressionsEditor; interface diff --git a/Source/UMLModel/Editor/BoldDragObject.pas b/Source/UMLModel/Editor/BoldDragObject.pas index 990e56f5..0c9db3b4 100644 --- a/Source/UMLModel/Editor/BoldDragObject.pas +++ b/Source/UMLModel/Editor/BoldDragObject.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDragObject; interface @@ -201,7 +204,7 @@ function GetControlAccepter(Target: TWinControl): TWinControl; begin while assigned(Target) and (not (csAcceptsControls in Target.ControlStyle)) do Target := Target.Parent; - Result := Target; + Result := Target; end; @@ -234,7 +237,6 @@ function TBoldDTDragObject.AllowDrop(Control: TControl): boolean; (BoldGUIHandler.DraggedObjects[0] is TUMLModelElement); if Result then begin - // Allow dropping on designer form if we have a matching provider. UMLElement := BoldGUIHandler.DraggedObjects[0] as TUMLModelElement; Result := ControlProviderList.MatchingProvider(UMLElement) <> nil; end; @@ -276,12 +278,9 @@ procedure TBoldDTDragObject.PerformDrop(Target: TWinControl; x, y: integer); (BoldGUIHandler.DraggedObjects.Count > 0) and (BoldGUIHandler.DraggedObjects[0] is TUMLModelElement) then begin - // At this point any component can be created on the form. GetCursorPos(p); p := Target.ScreenToClient(p); UMLElement := BoldGUIHandler.DraggedObjects[0] as TUMLModelElement; - - //Check we have a matching provider and then invoke it ControlProvider := ControlProviderList.MatchingProvider(UMLElement); if Assigned(ControlProvider) then ControlProvider.MakeComponent(UMLElement, Target, p); @@ -302,7 +301,7 @@ procedure TBoldControlProvider.CreateLabel; aLabel.Left := fPoint.x; aLabel.Caption := fUMLElement.Name; - aLabel.Name := UniqueName('lbl' + fUMLElement.ExpandedExpressionName); // do not localize + aLabel.Name := UniqueName('lbl' + fUMLElement.ExpandedExpressionName); if fControl is TWinControl then aLabel.FocusControl := fControl as TWinControl; end; @@ -326,10 +325,9 @@ function TBoldControlProvider.GetEnsuredHandle: TBoldHandle; function TBoldControlProvider.GetHandleClass: TBoldHandleClass; begin - // This method may be abstract when the mechanism is in place. - // The theory is that we should try to find the best matching provider or - // create a new handle of type HandleClass. - // Returning nil just avoids a compiler warning. + + + Result := nil; end; @@ -417,7 +415,7 @@ function TBoldControlProviderList.MatchingProvider( function TBoldControlProviderForClass.GetComponentName: string; begin - Result := PrefixedUMLName('grd'); // do not localize + Result := PrefixedUMLName('grd'); end; function TBoldControlProviderForClass.GetControlClass: TControlClass; @@ -442,7 +440,7 @@ function TBoldControlProviderForAttribute.IsMatch(UMLElement: TUMLModelElement): function TBoldControlProviderForStringAttribute.GetComponentName: string; begin - Result := PrefixedUMLName('txt'); // do not localize + Result := PrefixedUMLName('txt'); end; function TBoldControlProviderForStringAttribute.GetControlClass: TControlClass; @@ -466,7 +464,7 @@ function TBoldControlProviderForAssociationEnd.IsMatch(UMLElement: TUMLModelElem function TBoldControlProviderForAssociationEndMulti.GetComponentName: string; begin - Result := PrefixedUMLName('lbx'); // do not localize + Result := PrefixedUMLName('lbx'); end; function TBoldControlProviderForAssociationEndMulti.GetControlClass: TControlClass; @@ -484,7 +482,7 @@ function TBoldControlProviderForAssociationEndMulti.IsMatch(UMLElement: TUMLMode function TBoldControlProviderForAssociationEndSingle.GetComponentName: string; begin - Result := PrefixedUMLName('txt'); // do not localize + Result := PrefixedUMLName('txt'); end; function TBoldControlProviderForAssociationEndSingle.GetControlClass: TControlClass; @@ -502,7 +500,7 @@ function TBoldControlProviderForAssociationEndSingle.IsMatch(UMLElement: TUMLMod function TBoldControlProviderForMemoAttribute.GetComponentName: string; begin - Result := PrefixedUMLName('mmo'); // do not localize + Result := PrefixedUMLName('mmo'); end; function TBoldControlProviderForMemoAttribute.GetControlClass: TControlClass; @@ -514,14 +512,14 @@ function TBoldControlProviderForMemoAttribute.IsMatch( UMLElement: TUMLModelElement): boolean; begin Result := inherited IsMatch(UMLElement) and - (AnsiCompareStr((UMLElement as TUMLAttribute).typeName, 'Blob') = 0); // do not localize + (AnsiCompareStr((UMLElement as TUMLAttribute).typeName, 'Blob') = 0); end; { TBoldControlProviderForImageAttribute } function TBoldControlProviderForImageAttribute.GetComponentName: string; begin - Result := PrefixedUMLName('img'); // do not localize + Result := PrefixedUMLName('img'); end; function TBoldControlProviderForImageAttribute.GetControlClass: TControlClass; @@ -533,8 +531,8 @@ function TBoldControlProviderForImageAttribute.IsMatch( UMLElement: TUMLModelElement): boolean; begin Result := inherited IsMatch(UMLElement) and - ((AnsiCompareStr((UMLElement as TUMLAttribute).typeName, 'BlobImageBMP') = 0) or // do not localize - (AnsiCompareStr((UMLElement as TUMLAttribute).typeName, 'BlobImageJPEG') = 0)); // do not localize + ((AnsiCompareStr((UMLElement as TUMLAttribute).typeName, 'BlobImageBMP') = 0) or + (AnsiCompareStr((UMLElement as TUMLAttribute).typeName, 'BlobImageJPEG') = 0)); end; { TBoldControlProviderForBooleanAttribute } @@ -546,7 +544,7 @@ function TBoldControlProviderForBooleanAttribute.GetAddLabel: boolean; function TBoldControlProviderForBooleanAttribute.GetComponentName: string; begin - Result := PrefixedUMLName('cbx'); // do not localize + Result := PrefixedUMLName('cbx'); end; function TBoldControlProviderForBooleanAttribute.GetControlClass: TControlClass; @@ -558,7 +556,7 @@ function TBoldControlProviderForBooleanAttribute.IsMatch( UMLElement: TUMLModelElement): boolean; begin Result := inherited IsMatch(UMLElement) and - (AnsiCompareStr((UMLElement as TUMLAttribute).typeName, 'Boolean') = 0); // do not localize + (AnsiCompareStr((UMLElement as TUMLAttribute).typeName, 'Boolean') = 0); end; { TBoldControlProviderForOperation } @@ -570,7 +568,7 @@ function TBoldControlProviderForOperation.GetAddLabel: boolean; function TBoldControlProviderForOperation.GetComponentName: string; begin - Result := PrefixedUMLName('btn'); // do not localize + Result := PrefixedUMLName('btn'); end; function TBoldControlProviderForOperation.GetControlClass: TControlClass; @@ -586,12 +584,11 @@ function TBoldControlProviderForOperation.IsMatch(UMLElement: TUMLModelElement): procedure TBoldControlProviderForOperation.SetupComponent; begin inherited; - (fControl as TButton).Caption := fUMLElement.Name; + (fControl as TButton).Caption := fUMLElement.Name; end; initialization - // Note: Order important. List is traversed in reverse order, - // so less general should be added later in the list. + ControlProviderList.Add(TBoldControlProviderForClass.Create); ControlProviderList.Add(TBoldControlProviderForOperation.Create); ControlProviderList.Add(TBoldControlProviderForAssociationEndMulti.Create); @@ -605,6 +602,3 @@ finalization FreeAndNil(G_BoldControlProviderList); end. - - - diff --git a/Source/UMLModel/Editor/BoldUMLAddTV.pas b/Source/UMLModel/Editor/BoldUMLAddTV.pas index 39bf5541..39f3713c 100644 --- a/Source/UMLModel/Editor/BoldUMLAddTV.pas +++ b/Source/UMLModel/Editor/BoldUMLAddTV.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLAddTV; interface diff --git a/Source/UMLModel/Editor/BoldUMLConstraintEditor.pas b/Source/UMLModel/Editor/BoldUMLConstraintEditor.pas index ad3691bc..51116c17 100644 --- a/Source/UMLModel/Editor/BoldUMLConstraintEditor.pas +++ b/Source/UMLModel/Editor/BoldUMLConstraintEditor.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLConstraintEditor; interface @@ -59,7 +62,6 @@ implementation SysUtils, BoldDefs, BoldQueue, - BoldRev, BoldUMLModelSupport; {$R *.dfm} diff --git a/Source/UMLModel/Editor/BoldUMLModelEdit.pas b/Source/UMLModel/Editor/BoldUMLModelEdit.pas index 97ebc359..36b07268 100644 --- a/Source/UMLModel/Editor/BoldUMLModelEdit.pas +++ b/Source/UMLModel/Editor/BoldUMLModelEdit.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLModelEdit; interface @@ -39,10 +42,9 @@ implementation uses SysUtils, - BoldRev, BoldRegistry, Controls, - BoldUMLModelDataModule, + BoldUMLModelDataModule, BoldGuard; var G_ModelEditor: TModelEdit = nil; @@ -69,9 +71,8 @@ constructor TModelEdit.Create; destructor TModelEdit.Destroy; begin while EditForms.Count > 0 do - TBoldModelEditFrm(EditForms.Items[EditForms.Count - 1]).Free; // Will remove from list through notification + TBoldModelEditFrm(EditForms.Items[EditForms.Count - 1]).Free; FreeAndNil(FEditForms); - // The plugins are freed in the finalization part of BoldUMLPlugins.pas. FreeAndNil(FPlugInList); inherited; end; @@ -117,20 +118,19 @@ class procedure TModelEdit.SaveFormsettingsToRegistry(aForm: TBoldModelEditFrm); try with BoldRegistry do begin - OpenKey('\UMLModel'); // do not localize - WriteInteger('Width', aForm.Width); // do not localize - WriteInteger('Height', aForm.Height); // do not localize - WriteInteger('Left', aForm.Left); // do not localize - WriteInteger('Top', aForm.Top); // do not localize - WriteInteger('TreeViewWidth', aForm.BoldTreeView1.Width); // do not localize - WriteInteger('ModelHeight', aForm.sbModel.Height); // do not localize - WriteInteger('ClassHeight', aForm.sbClass.Height); // do not localize - WriteInteger('OperationHeight', aForm.sbOperation.Height); // do not localize - WriteInteger('AssociationHeight', aForm.sbAssociation.Height); // do not localize - WriteInteger('AssociationEndHeight', aForm.sbAssociationEnd.Height); // do not localize + OpenKey('\UMLModel'); + WriteInteger('Width', aForm.Width); + WriteInteger('Height', aForm.Height); + WriteInteger('Left', aForm.Left); + WriteInteger('Top', aForm.Top); + WriteInteger('TreeViewWidth', aForm.BoldTreeView1.Width); + WriteInteger('ModelHeight', aForm.sbModel.Height); + WriteInteger('ClassHeight', aForm.sbClass.Height); + WriteInteger('OperationHeight', aForm.sbOperation.Height); + WriteInteger('AssociationHeight', aForm.sbAssociation.Height); + WriteInteger('AssociationEndHeight', aForm.sbAssociationEnd.Height); end; except - // Silently discard exceptions end; end; @@ -144,21 +144,20 @@ class procedure TModelEdit.LoadFormsettingsFromRegistry(aForm: TBoldModelEditFrm BoldRegistry := TBoldRegistry.Create; with BoldRegistry do begin - OpenKey('\UMLModel'); // do not localize - aForm.Width := ReadInteger('Width', 800); // do not localize - aForm.Height := ReadInteger('Height', 600); // do not localize - aForm.Left := ReadInteger('Left', 0); // do not localize - aForm.Top := ReadInteger('Top', 0); // do not localize - - aForm.BoldTreeView1.Width := ReadInteger('TreeViewWidth', aForm.BoldTreeView1.Width); // do not localize - aForm.sbModel.Height := ReadInteger('ModelHeight', aForm.sbModel.Height); // do not localize - aForm.sbClass.Height := ReadInteger('ClassHeight', aForm.sbClass.Height); // do not localize - aForm.sbOperation.Height := ReadInteger('OperationHeight', aForm.sbOperation.Height); // do not localize - aForm.sbAssociation.Height := ReadInteger('AssociationHeight', aForm.sbAssociation.Height); // do not localize - aForm.sbAssociationEnd.Height := ReadInteger('AssociationEndHeight', aForm.sbAssociationEnd.Height); // do not localize + OpenKey('\UMLModel'); + aForm.Width := ReadInteger('Width', 800); + aForm.Height := ReadInteger('Height', 600); + aForm.Left := ReadInteger('Left', 0); + aForm.Top := ReadInteger('Top', 0); + + aForm.BoldTreeView1.Width := ReadInteger('TreeViewWidth', aForm.BoldTreeView1.Width); + aForm.sbModel.Height := ReadInteger('ModelHeight', aForm.sbModel.Height); + aForm.sbClass.Height := ReadInteger('ClassHeight', aForm.sbClass.Height); + aForm.sbOperation.Height := ReadInteger('OperationHeight', aForm.sbOperation.Height); + aForm.sbAssociation.Height := ReadInteger('AssociationHeight', aForm.sbAssociation.Height); + aForm.sbAssociationEnd.Height := ReadInteger('AssociationEndHeight', aForm.sbAssociationEnd.Height); end; except - //Silently discard exception end; end; diff --git a/Source/UMLModel/Editor/BoldUMLModelEditForm.pas b/Source/UMLModel/Editor/BoldUMLModelEditForm.pas index 387a4495..bb8b15a6 100644 --- a/Source/UMLModel/Editor/BoldUMLModelEditForm.pas +++ b/Source/UMLModel/Editor/BoldUMLModelEditForm.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLModelEditForm; interface @@ -19,6 +22,7 @@ interface BoldModel, BoldGrid, BoldUMLModel, + BoldUMLTypes, StdCtrls, ComCtrls, BoldXCVTreeView, @@ -48,7 +52,9 @@ interface BoldTreeView, Commctrl, BoldSmallLogFrame, - BoldDragObject, BoldDerivedHandle, BoldPropertiesController, + BoldDragObject, + BoldDerivedHandle, + BoldPropertiesController, AppEvnts; type @@ -487,14 +493,9 @@ TBoldModelEditFrm = class(TForm, IUnknown, IUMLModelPlugInContext) AddSubclass1: TMenuItem; AddSubclass2: TMenuItem; apeHintCatcher: TApplicationEvents; - function bcrAutoCreatedGetAsCheckBoxState( - Element: TBoldElement; Representation: Integer; - Expression: String): TCheckBoxState; - procedure bcrAutoCreatedSetAsCheckBoxState( - Element: TBoldElement; newValue: TCheckBoxState; - Representation: Integer; Expression: String); - procedure bsrRedOnAutocreatedSetColor(Element: TBoldElement; - var AColor: TColor; Representation: Integer; Expression: String); + function bcrAutoCreatedGetAsCheckBoxState(aFollower: TBoldFollower): TCheckBoxState; + procedure bcrAutoCreatedSetAsCheckBoxState(aFollower: TBoldFollower; newValue: TCheckBoxState); + procedure bsrRedOnAutocreatedSetColor(aFollower: TBoldFollower; var AColor: TColor); procedure Boldifymodel1Click(Sender: TObject); procedure FlattenClick(Sender: TObject); procedure Loggform1Click(Sender: TObject); @@ -539,36 +540,21 @@ TBoldModelEditFrm = class(TForm, IUnknown, IUMLModelPlugInContext) procedure mnuOverrideInAllSubclassesClick(Sender: TObject); procedure btInterfaceUsesClick(Sender: TObject); procedure btImplementationUsesClick(Sender: TObject); - function bsrNiceCRRendererGetAsString(Element: TBoldElement; - Representation: Integer; Expression: String): String; - procedure bsrNiceCRRendererSubscribe(Element: TBoldElement; - Representation: Integer; Expression: String; - Subscriber: TBoldSubscriber); + function bsrNiceCRRendererGetAsString(aFollower: TBoldFollower): String; + procedure bsrNiceCRRendererSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); procedure Splitter2CanResize(Sender: TObject; var NewSize: Integer; var Accept: Boolean); procedure BoldTreeView1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure Contents1Click(Sender: TObject); procedure BoldTreeView1Expanded(Sender: TObject; Node: TTreeNode); - function bcrGetSetGetAsCheckBoxState(Element: TBoldElement; - Representation: Integer; Expression: String): TCheckBoxState; - procedure bcrGetSetSubscribe(Element: TBoldElement; - Representation: Integer; Expression: String; - Subscriber: TBoldSubscriber); - function bcrGetSetMayModify(Element: TBoldElement; - Representation: Integer; Expression: String; - Subscriber: TBoldSubscriber): Boolean; - procedure bcrBooleanToCheckBoxSubscribe(Element: TBoldElement; - Representation: Integer; Expression: String; - Subscriber: TBoldSubscriber); - function bcrBooleanToCheckBoxGetAsCheckBoxState(Element: TBoldElement; - Representation: Integer; Expression: String): TCheckBoxState; - procedure bcrBooleanToCheckBoxSetAsCheckBoxState(Element: TBoldElement; - newValue: TCheckBoxState; Representation: Integer; - Expression: String); - procedure bcrGetSetSetAsCheckBoxState(Element: TBoldElement; - newValue: TCheckBoxState; Representation: Integer; - Expression: String); + function bcrGetSetGetAsCheckBoxState(aFollower: TBoldFollower): TCheckBoxState; + procedure bcrGetSetSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); + function bcrGetSetMayModify(aFollower: TBoldFollower): Boolean; + procedure bcrBooleanToCheckBoxSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); + function bcrBooleanToCheckBoxGetAsCheckBoxState(aFollower: TBoldFollower): TCheckBoxState; + procedure bcrBooleanToCheckBoxSetAsCheckBoxState(aFollower: TBoldFollower; newValue: TCheckBoxState); + procedure bcrGetSetSetAsCheckBoxState(aFollower: TBoldFollower; newValue: TCheckBoxState); procedure btModelConstraintEditorClick(Sender: TObject); procedure btShowDerivationExpressionsEditorClick(Sender: TObject); procedure N3Click(Sender: TObject); @@ -586,9 +572,7 @@ TBoldModelEditFrm = class(TForm, IUnknown, IUMLModelPlugInContext) procedure NewDatatype1Click(Sender: TObject); procedure NewPackage1Click(Sender: TObject); procedure InsertSuperclass1Click(Sender: TObject); - function bcrBooleanToCheckBoxMayModify(Element: TBoldElement; - Representation: Integer; Expression: String; - Subscriber: TBoldSubscriber): Boolean; + function bcrBooleanToCheckBoxMayModify(aFollower: TBoldFollower): Boolean; procedure BoldTreeView1EndDrag(Sender, Target: TObject; X, Y: Integer); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure FormActivate(Sender: TObject); @@ -598,7 +582,6 @@ TBoldModelEditFrm = class(TForm, IUnknown, IUMLModelPlugInContext) private { Private declarations } fModelChangedSubscriber: TBoldPassthroughSubscriber; - fModelValidationSubscriber: TBoldPassthroughSubscriber; fModelSubscriptionsValid: Boolean; fIgnoreModelChanges: Boolean; fShowAttribKindFeaturesSubscriber: TBoldPassThroughSubscriber; @@ -612,7 +595,6 @@ TBoldModelEditFrm = class(TForm, IUnknown, IUMLModelPlugInContext) fModelNeedsValidation: Boolean; fModelHandle: TBoldModel; procedure SetCheckBoxHints; - procedure ModelValidatedReceive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); procedure EditOclExpression(Element: TUMLModelElement; TaggedValue: String; Context: TUMLModelElement); function GetUMLObjectToCopyOrMove: TUMLModelElement; procedure SetUMLObjectToCopyOrMove(const Value: TUMLModelElement); @@ -630,7 +612,6 @@ TBoldModelEditFrm = class(TForm, IUnknown, IUMLModelPlugInContext) procedure CreateModelMethodItems(UMLClass: TUMLClass); procedure CreateFrameworkMethodItems(UMLClass: TUMLClass); procedure ClearMenuItems(var MenuItem: TMenuItem); - function GetMethodName(Method: String): String; procedure GetParamNames(Method: String; ResultList: TStringList); procedure GetParamTypes(Method: String; ResultList: TStringList); function GetReturnType(Method: String): String; @@ -710,6 +691,8 @@ TBoldModelEditFrm = class(TForm, IUnknown, IUMLModelPlugInContext) function CloseThisForm: TCloseAction; property ModelNeedsValidation: Boolean read FModelNeedsValidation write SetModelNeedsValidation; procedure EnsureFlattenedAndBoldified; + class function GetMethodName(Method: String): String; static; + class function GetMethodVisibility(Method: String): TVisibilityKind; static; end; //var @@ -719,29 +702,38 @@ TBoldModelEditFrm = class(TForm, IUnknown, IUMLModelPlugInContext) // kala 990707 It should not be ',' as separator between param-names. {$IFDEF BOLD_DELPHI} - FrameworkMethods: array[0..12] of String = ( + FrameworkMethods: array[0..20] of String = ( 'function GetStringRepresentation(Representation: TBoldRepresentation): string; virtual;', - 'procedure SetStringRepresentation(Representation: TBoldRepresentation; Value: string); virtual;', + 'procedure SetStringRepresentation(Representation: TBoldRepresentation; const Value: string); virtual;', 'procedure SubscribeToStringRepresentation(Representation: TBoldRepresentation; Subscriber: TBoldSubscriber; RequestedEvent: TBoldEvent); virtual;', - 'function ValidateCharacter(C: AnsiChar; Representation: TBoldRepresentation): Boolean; virtual;', - 'function ValidateString(Value: string; Representation: TBoldRepresentation): Boolean; virtual;', + 'function ValidateCharacter(C: Char; Representation: TBoldRepresentation): Boolean; virtual;', + 'function ValidateString(const Value: string; Representation: TBoldRepresentation): Boolean; virtual;', 'function CompareToAs(CompareType: TBoldCompareType; BoldDirectElement: TBoldElement): Integer; virtual;', - 'procedure ReceiveEventFromOwned(Originator: TObject; OriginalEvent: TBoldEvent); virtual;', + 'procedure ReceiveEventFromOwned(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const); virtual;', 'function ReceiveQueryFromOwned(Originator: TObject; OriginalEvent: TBoldEvent; const Args: array of const; Subscriber: TBoldSubscriber): Boolean; virtual;', 'procedure Assign(Source: TBoldElement); virtual;', 'procedure CompleteCreate; virtual;', + 'procedure CompleteRecreate; virtual;', + 'procedure CompleteUpdate; virtual;', + 'procedure AfterConstruction; virtual;', + 'procedure BeforeDestruction; virtual;', 'function MayDelete: Boolean; virtual;', 'function MayUpdate: Boolean; virtual;', - 'procedure PrepareDelete; virtual;' + 'procedure PrepareDelete; virtual;', + 'procedure PrepareDiscard; virtual;', + 'procedure PrepareUpdate; virtual;', + 'procedure InternalPrepareDeleteOrDeleteByDiscard; virtual;', + 'function InternalCanDeleteObject: Boolean; virtual;' ); {$ENDIF} {$IFDEF BOLD_BCB} + // TODO: BCB Methods not updated, adjust from the Delphi list above FrameworkMethods: array[0..12] of String = ( - 'function GetStringRepresentation(Representation: int): AnsiString; virtual;', - 'procedure SetStringRepresentation(Representation: int; Value: AnsiString); virtual;', + 'function GetStringRepresentation(Representation: int): String; virtual;', + 'procedure SetStringRepresentation(Representation: int; const Value: String); virtual;', 'procedure SubscribeToStringRepresentation(Representation: int; Subscriber: TBoldSubscriber*; RequestedEvent: int); virtual;', - 'function ValidateCharacter(C: AnsiChar; Representation: int): Boolean; virtual;', - 'function ValidateString(Value: AnsiString; Representation: int): Boolean; virtual;', + 'function ValidateCharacter(C: Char; Representation: int): Boolean; virtual;', + 'function ValidateString(Value: String; Representation: int): Boolean; virtual;', 'function CompareToAs(CompareType: TBoldCompareType; BoldDirectElement: TBoldElement*): Integer; virtual;', 'procedure ReceiveEventFromOwned(Originator: TObject*; OriginalEvent: int); virtual;', 'function ReceiveQueryFromOwned(Originator: TObject*; OriginalEvent: int; Args: const TVarRec*; Subscriber: TBoldSubscriber*): Boolean; virtual;', @@ -757,7 +749,6 @@ TBoldModelEditFrm = class(TForm, IUnknown, IUMLModelPlugInContext) implementation uses - BoldRev, BoldDefaultTaggedValues, BoldUMLAttributes, BoldUMLModelConverter, @@ -767,14 +758,13 @@ implementation BoldCursorGuard, BoldSystem, BoldAttributes, - BoldUMLTypes, BoldUMLModelValidator, BoldUMLModelLink, BoldLogHandler, //BoldSystemDebuggerForm, BoldPMapperLists, BoldDefs, - BoldDefsDT, +// BoldDefsDT, BoldGUI, BoldQueue, BoldUMLUsesEditorForm, @@ -787,7 +777,8 @@ implementation BoldDerivationExpressionsEditor, BoldUMLOCLEditor, BoldUMLModelSupport, - BoldUMLPluginCallBacks; + BoldUMLPluginCallBacks, + BoldUMLAbstractModelValidator; {$R *.dfm} @@ -1068,7 +1059,6 @@ procedure TBoldModelEditFrm.mnuConsistencycheckClick(Sender: TObject); ValidationForm.ValidationProc := TBoldUMLModelValidatorCallBack.Validate; ValidationForm.Show; ValidationForm.Validate; - ModelNeedsValidation := False; end; function TBoldModelEditFrm.GetCurrentModel: TUMLModel; @@ -1341,12 +1331,11 @@ procedure TBoldModelEditFrm.FormCreate(Sender: TObject); SetCheckBoxHints; popTree.AutoHotkeys := maManual; - HelpFile := MODELEDITORHELPFILE; +// HelpFile := MODELEDITORHELPFILE; CutOrCopy := cckNone; fModelChangedSubscriber := TBoldPassthroughSubscriber.Create(ModelChangedRecieve); - fModelValidationSubscriber := TBoldPassthroughSubscriber.Create(ModelValidatedReceive); FShowAttribKindFeaturesSubscriber := TBoldPassthroughSubscriber.Create(ShowAttribKindFeaturesRecieve); for Index := 0 to pcModelEdit.PageCount - 1 do @@ -1546,12 +1535,13 @@ procedure TBoldModelEditFrm.pcModelEditChange(Sender: TObject); procedure TBoldModelEditFrm.ModelChangedRecieve(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); begin + if GetCurrentModelHandle.IsValidating then + exit; fModelSubscriptionsValid := false; if not fIgnoreModelChanges then ModelNeedsValidation := True; end; - procedure TBoldModelEditFrm.FormShow(Sender: TObject); var Index: Integer; @@ -1765,7 +1755,7 @@ procedure TBoldModelEditFrm.DroppedOnUMLOperation(Dropped: TUMLParameter; Target Target.Parameter.Add(Dropped); end; -function TBoldModelEditFrm.GetMethodName(Method: String): String; +class function TBoldModelEditFrm.GetMethodName(Method: String): String; var StartPos, EndPos: Integer; begin StartPos := 0; @@ -1787,6 +1777,27 @@ function TBoldModelEditFrm.GetMethodName(Method: String): String; Result := Trim(Copy(Method, StartPos, EndPos - StartPos)); end; +class function TBoldModelEditFrm.GetMethodVisibility(Method: String): + TVisibilityKind; +var + EndPos: Integer; + sVisibility: string; +begin + EndPos := Pos('function', Method); + if EndPos = 0 then begin + EndPos := Pos('procedure', Method); + end; + + sVisibility := Copy(Method, 1, EndPos - 2); + if BoldAnsiEqual(sVisibility, 'private') then begin + Result := vkPrivate; + end else if BoldAnsiEqual(sVisibility, 'protected') then begin + Result := vkProtected; + end else begin + Result := vkPublic; + end; +end; + procedure TBoldModelEditFrm.GetParamNames(Method: String; ResultList: TStringList); var StartPos, EndPos, FinalPos: Integer; NameWithKind: String; @@ -2031,6 +2042,7 @@ procedure TBoldModelEditFrm.OverrideModelMethod(MethodName: String); TBoldUMLSupport.EnsureBoldTaggedValues(NewOperation); NewOperation.owner := Class_; NewOperation.name := OldOperation.Name; + NewOperation.visibility := OldOperation.Visibility; NewOperation.SetBoldTV(TAG_DELPHIOPERATIONKIND, TV_DELPHIOPERATIONKIND_OVERRIDE); for Index := 0 to OldOperation.Parameter.Count - 1 do begin @@ -2109,13 +2121,11 @@ procedure TBoldModelEditFrm.btImplementationUsesClick(Sender: TObject); TfrmUsesEditor.CreateEditorWithParams('Implementation Uses Editor', behModel.Value, tbxModelImplementationUses.BoldProperties.Expression); end; -function TBoldModelEditFrm.bsrNiceCRRendererGetAsString( - Element: TBoldElement; Representation: Integer; - Expression: String): String; +function TBoldModelEditFrm.bsrNiceCRRendererGetAsString(aFollower: TBoldFollower): String; begin - if Assigned(Element) then + if Assigned(aFollower.Value) then begin - Result := Element.EvaluateExpressionAsString(Expression, Representation); + Result := aFollower.Value.AsString; while Pos(BOLDCRLF, Result) > 0 do Delete(Result, Pos(BOLDCRLF, Result), 2); end @@ -2123,11 +2133,9 @@ function TBoldModelEditFrm.bsrNiceCRRendererGetAsString( Result := ''; end; -procedure TBoldModelEditFrm.bsrNiceCRRendererSubscribe( - Element: TBoldElement; Representation: Integer; Expression: String; - Subscriber: TBoldSubscriber); +procedure TBoldModelEditFrm.bsrNiceCRRendererSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); begin - Element.SubscribeToExpression(Expression, Subscriber, False); + aFollower.Element.SubscribeToExpression(aFollower.Controller.Expression, Subscriber, False); end; procedure TBoldModelEditFrm.Splitter2CanResize(Sender: TObject; @@ -2162,47 +2170,37 @@ procedure TBoldModelEditFrm.BoldTreeView1Expanded(Sender: TObject; BoldTreeView1.Items[0].Selected := True; end; -function TBoldModelEditFrm.bcrGetSetGetAsCheckBoxState( - Element: TBoldElement; Representation: Integer; - Expression: String): TCheckBoxState; +function TBoldModelEditFrm.bcrGetSetGetAsCheckBoxState(aFollower: TBoldFollower): TCheckBoxState; begin Result := cbGrayed; - if Assigned(Element) then - Result := bcrBooleanToCheckBoxGetAsCheckBoxState(Element, Representation, Expression); + if Assigned(aFollower.Element) then + Result := bcrBooleanToCheckBoxGetAsCheckBoxState(aFollower); end; -procedure TBoldModelEditFrm.bcrGetSetSubscribe(Element: TBoldElement; - Representation: Integer; Expression: String; - Subscriber: TBoldSubscriber); +procedure TBoldModelEditFrm.bcrGetSetSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); begin - (Element as TUMLAttribute).M_StereotypeName.DefaultSubscribe(Subscriber, breReEvaluate); - Element.SubscribeToExpression(Expression, Subscriber, False); + (aFollower.Element as TUMLAttribute).M_StereotypeName.DefaultSubscribe(Subscriber, breReEvaluate); + aFollower.Element.SubscribeToExpression(aFollower.Controller.Expression, Subscriber, False); end; -function TBoldModelEditFrm.bcrGetSetMayModify(Element: TBoldElement; - Representation: Integer; Expression: String; - Subscriber: TBoldSubscriber): Boolean; +function TBoldModelEditFrm.bcrGetSetMayModify(aFollower: TBoldFollower): Boolean; begin - Result := (Element as TUMLAttribute).GetBoldTV(TAG_ATTRIBUTEKIND) = TV_ATTRIBUTEKIND_DELPHI; + Result := (aFollower.Element as TUMLAttribute).GetBoldTV(TAG_ATTRIBUTEKIND) = TV_ATTRIBUTEKIND_DELPHI; end; -procedure TBoldModelEditFrm.bcrBooleanToCheckBoxSubscribe( - Element: TBoldElement; Representation: Integer; Expression: String; - Subscriber: TBoldSubscriber); +procedure TBoldModelEditFrm.bcrBooleanToCheckBoxSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); begin - Element.SubscribeToExpression(Expression, Subscriber, False); + aFollower.Element.SubscribeToExpression(aFollower.Controller.Expression, Subscriber, False); end; -function TBoldModelEditFrm.bcrBooleanToCheckBoxGetAsCheckBoxState( - Element: TBoldElement; Representation: Integer; - Expression: String): TCheckBoxState; +function TBoldModelEditFrm.bcrBooleanToCheckBoxGetAsCheckBoxState(aFollower: TBoldFollower): TCheckBoxState; var anElement: TBoldElement; begin Result := cbGrayed; - if Assigned(Element) then + if Assigned(aFollower.Element) then begin - anElement := Element.EvaluateExpressionAsDirectElement(Expression); + anElement := aFollower.Value; if Assigned(anElement) then begin if TVIsTrue(anElement.AsString)then @@ -2213,18 +2211,14 @@ function TBoldModelEditFrm.bcrBooleanToCheckBoxGetAsCheckBoxState( end; end; -procedure TBoldModelEditFrm.bcrBooleanToCheckBoxSetAsCheckBoxState( - Element: TBoldElement; newValue: TCheckBoxState; Representation: Integer; - Expression: String); +procedure TBoldModelEditFrm.bcrBooleanToCheckBoxSetAsCheckBoxState(aFollower: TBoldFollower; newValue: TCheckBoxState); begin - Element.EvaluateExpressionAsDirectElement(Expression).AsString := BooleanToString(NewValue = cbChecked); + aFollower.Value.AsString := BooleanToString(NewValue = cbChecked); end; -procedure TBoldModelEditFrm.bcrGetSetSetAsCheckBoxState( - Element: TBoldElement; newValue: TCheckBoxState; Representation: Integer; - Expression: String); +procedure TBoldModelEditFrm.bcrGetSetSetAsCheckBoxState(aFollower: TBoldFollower; newValue: TCheckBoxState); begin - bcrBooleanToCheckBoxSetAsCheckBoxState(Element, newValue, Representation, Expression); + bcrBooleanToCheckBoxSetAsCheckBoxState(aFollower, newValue); end; procedure TBoldModelEditFrm.ShowAttribKindFeaturesRecieve(Originator: TObject; OriginalEvent: TBoldEvent; @@ -2277,7 +2271,6 @@ procedure TBoldModelEditFrm.FormDestroy(Sender: TObject); FreeItemsInMenu(mnuOverrideModelMethods); EnsureFreeConstraintEditor; FreeAndNil(fModelChangedSubscriber); - FreeAndNil(fModelValidationSubscriber); FreeAndNil(FShowAttribKindFeaturesSubscriber); end; @@ -2362,13 +2355,20 @@ procedure TBoldModelEditFrm.BoldTreeView1StartDrag(Sender: TObject; procedure TBoldModelEditFrm.EditOclExpression(Element: TUMLModelElement; TaggedValue: String; Context: TUMLModelElement); var res: String; + lPrevIgnoreModelChanges: Boolean; begin EnsureFlattenedAndBoldified; - res := BoldUMLOclEditor_.EditOcl( - ModelHandle, - Context, - Element.GetBoldTV(TaggedValue)); - Element.SetBoldTV(TaggedValue, res); + lPrevIgnoreModelChanges := IgnoreModelChanges; + IgnoreModelChanges := true; + try + res := BoldUMLOclEditor_.EditOcl( + ModelHandle, + Context, + Element.GetBoldTV(TaggedValue)); + finally + IgnoreModelChanges := lPrevIgnoreModelChanges; + Element.SetBoldTV(TaggedValue, res); + end; end; procedure TBoldModelEditFrm.btClassDefaultStringRepClick(Sender: TObject); @@ -2472,29 +2472,23 @@ function TBoldModelEditFrm.GetCurrentModelIsBoldified: Boolean; Result := (behBoldified.Value as TBABoolean).AsBoolean = true; end; -function TBoldModelEditFrm.bcrAutoCreatedGetAsCheckBoxState( - Element: TBoldElement; Representation: Integer; - Expression: String): TCheckBoxState; +function TBoldModelEditFrm.bcrAutoCreatedGetAsCheckBoxState(aFollower: TBoldFollower): TCheckBoxState; begin - if Assigned(Element) and TBoldUMLBoldify.IsAutocreated(Element as TUMLModelElement) then + if Assigned(aFollower.Element) and TBoldUMLBoldify.IsAutocreated(aFollower.Element as TUMLModelElement) then Result := cbChecked else Result := cbUnchecked end; -procedure TBoldModelEditFrm.bcrAutoCreatedSetAsCheckBoxState( - Element: TBoldElement; newValue: TCheckBoxState; Representation: Integer; - Expression: String); +procedure TBoldModelEditFrm.bcrAutoCreatedSetAsCheckBoxState(aFollower: TBoldFollower; newValue: TCheckBoxState); begin - if assigned(Element) and (newValue= cbUnchecked) then - TBoldUMLBoldify.RemoveBoldifyTaggedValue(Element as TUMLModelElement, TAG_AUTOCREATED); + if assigned(aFollower.Element) and (newValue= cbUnchecked) then + TBoldUMLBoldify.RemoveBoldifyTaggedValue(aFollower.Element as TUMLModelElement, TAG_AUTOCREATED); end; -procedure TBoldModelEditFrm.bsrRedOnAutocreatedSetColor( - Element: TBoldElement; var AColor: TColor; Representation: Integer; - Expression: String); +procedure TBoldModelEditFrm.bsrRedOnAutocreatedSetColor(aFollower: TBoldFollower; var AColor: TColor); begin - if Assigned(Element) and TBoldUMLBoldify.IsAutocreated(Element as TUMLModelElement) then + if Assigned(aFollower.Element) and TBoldUMLBoldify.IsAutocreated(aFollower.Element as TUMLModelElement) then aColor := clRed; end; @@ -2717,15 +2711,13 @@ procedure TBoldModelEditFrm.ApplyGUI; TBoldQueueable.ApplyAll; end; -function TBoldModelEditFrm.bcrBooleanToCheckBoxMayModify( - Element: TBoldElement; Representation: Integer; Expression: String; - Subscriber: TBoldSubscriber): Boolean; +function TBoldModelEditFrm.bcrBooleanToCheckBoxMayModify(aFollower: TBoldFollower): Boolean; var ValueElement: TBoldElement; begin - ValueElement := Element.EvaluateExpressionAsDirectElement(Expression); + ValueElement := aFollower.Value; if Assigned(ValueElement) then - Result := ValueElement.ObserverMayModify(subscriber) + Result := ValueElement.ObserverMayModify(aFollower.subscriber) else Result := false; end; @@ -2752,11 +2744,6 @@ procedure TBoldModelEditFrm.FormClose(Sender: TObject; var Action: TCloseAction) Action := caFree; end; -procedure TBoldModelEditFrm.ModelValidatedReceive(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); -begin - ModelNeedsValidation := false; -end; - procedure TBoldModelEditFrm.FormActivate(Sender: TObject); begin G_ValidationFormDefaultOwner := Self; @@ -2819,20 +2806,23 @@ function TBoldModelEditFrm.GetCurrentTypeNameDictionary: TBoldTypeNameDictionary procedure TBoldModelEditFrm.SetModelHandle(const Value: TBoldModel); begin - Value.FreeNotification(Self); - fModelHandle := Value; - brhTreeRoot.Value := ModelHandle.EnsuredUMLModel; - if assigned(CurrentModel) then + if FModelHandle <> Value then begin - EnsureTypesFromTypeNameHandle(nil); - TBoldUMLSupport.EnsureBoldTaggedVAlues(CurrentModel); - end - else - raise EBoldInternal.CreateFmt('%s.SetRoot: Root must be part of Model', [ClassName]); - ModelNeedsValidation := True; - CurrentModel.AddSubscription(fModelValidationSubscriber, beModelValidated, beModelValidated); - - EnsureValidationForm(GetCurrentModelHandle, self, JumpToElement); + BoldInstalledQueue.DeActivateDisplayQueue; + Value.FreeNotification(Self); + fModelHandle := Value; + brhTreeRoot.Value := ModelHandle.EnsuredUMLModel; + if assigned(CurrentModel) then + begin + EnsureTypesFromTypeNameHandle(nil); + TBoldUMLSupport.EnsureBoldTaggedVAlues(CurrentModel); + end + else + raise EBoldInternal.CreateFmt('%s.SetRoot: Root must be part of Model', [ClassName]); + ModelNeedsValidation := True; + EnsureValidationForm(GetCurrentModelHandle, self, JumpToElement); + BoldInstalledQueue.ActivateDisplayQueue; + end; end; procedure TBoldModelEditFrm.Notification(AComponent: TComponent; @@ -2863,8 +2853,4 @@ procedure TBoldModelEditFrm.SetCheckBoxHints; TBoldCheckBox(Components[i]).Hint := StripHotkey(TBoldCheckBox(Components[i]).Caption); end; -initialization - end. - - diff --git a/Source/UMLModel/Editor/BoldUMLModelValidationForm.pas b/Source/UMLModel/Editor/BoldUMLModelValidationForm.pas index c4e5620c..33cdd7fb 100644 --- a/Source/UMLModel/Editor/BoldUMLModelValidationForm.pas +++ b/Source/UMLModel/Editor/BoldUMLModelValidationForm.pas @@ -1,8 +1,12 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLModelValidationForm; interface uses + {$IFDEF MSWINDOWS} Windows, Messages, Graphics, @@ -12,6 +16,7 @@ interface StdCtrls, Grids, ComCtrls, + {$ENDIF} ClipBrd, ToolWin, Classes, @@ -29,9 +34,11 @@ interface BoldStringcontrolPack, BoldSystem, BoldModel, + BoldElements, + BoldPlaceableSubscriber, Menus, ExtCtrls, - ImgList, BoldElements, BoldPlaceableSubscriber; + ImgList; type TBoldUMLElementClickedEvent = procedure (sender: TComponent; element: TUMLModelElement) of object; @@ -63,13 +70,12 @@ TfrmValidation = class(TForm) procedure Cut1Click(Sender: TObject); procedure Copy1Click(Sender: TObject); procedure Paste1Click(Sender: TObject); - procedure BoldPlaceableSubscriber1Receive( - sender: TBoldPlaceableSubscriber; Originator: TObject; OriginalEvent, - RequestedEvent: Integer); + procedure BoldPlaceableSubscriber1Receive(sender: TBoldPlaceableSubscriber; + Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: Integer); private FOnElementClick: TBoldUMLElementClickedEvent; fValidationProc: TBoldValidationCallBack; - fModelComponent: TBoldModel; + fBoldModel: TBoldModel; function GetUMLModel: TUMLModel; protected procedure Notification(AComponent: TComponent; Operation: TOperation); override; @@ -77,13 +83,13 @@ TfrmValidation = class(TForm) constructor CreateWithModel(ModelComponent: TBoldModel; Owner: TComponent); destructor Destroy; override; procedure Validate; - property UMLModel: TUMLModel read GetUMLModel; - property ModelComponent: TBoldModel read fModelComponent; + property BoldModel: TBoldModel read fBoldModel; + property UmlModel: TUMLModel read GetUMLModel; property OnElementClick: TBoldUMLElementClickedEvent read FOnElementClick; property ValidationProc: TBoldValidationCallBack read fValidationProc write fValidationProc; end; - function EnsureValidationForm(ModelComponent: TBoldModel; Owner: TComponent; OnElementClick: TBoldUMLElementClickedEvent): TfrmValidation; + function EnsureValidationForm(ABoldModel: TBoldModel; Owner: TComponent; OnElementClick: TBoldUMLElementClickedEvent): TfrmValidation; var G_ValidationFormDefaultOwner: TComponent; @@ -92,7 +98,6 @@ implementation uses SysUtils, - BoldRev, BoldQueue, BoldEnvironment, BoldUtils, @@ -103,15 +108,15 @@ implementation {$R *.dfm} -function EnsureValidationForm(ModelComponent: TBoldModel; Owner: TComponent; OnElementClick: TBoldUMLElementClickedEvent): TfrmValidation; +function EnsureValidationForm(ABoldModel: TBoldModel; Owner: TComponent; OnElementClick: TBoldUMLElementClickedEvent): TfrmValidation; begin - if assigned(G_ValidationForm) and (G_ValidationForm.ModelComponent <> ModelComponent) then + if assigned(G_ValidationForm) and (G_ValidationForm.BoldModel <> ABoldModel) then begin G_ValidationForm.Release; G_ValidationForm := nil; end; if not Assigned(G_ValidationForm) then - G_ValidationForm := TfrmValidation.CreateWithModel(ModelComponent, Owner); + G_ValidationForm := TfrmValidation.CreateWithModel(ABoldModel, Owner); Result := G_ValidationForm; if assigned(OnElementClick) then result.fOnElementClick := OnElementclick; @@ -143,6 +148,14 @@ procedure TfrmValidation.btStayOnTopClick(Sender: TObject); FormStyle := fsNormal; end; +procedure TfrmValidation.BoldPlaceableSubscriber1Receive( + sender: TBoldPlaceableSubscriber; Originator: TObject; + OriginalEvent: TBoldEvent; RequestedEvent: Integer); +begin + if blhViolations.Count > 0 then + show; +end; + procedure TfrmValidation.btReCheckClick(Sender: TObject); begin Validate; @@ -151,7 +164,7 @@ procedure TfrmValidation.btReCheckClick(Sender: TObject); procedure TfrmValidation.Validate; begin if Assigned(ValidationProc) then - ValidationProc(ModelComponent) + ValidationProc(BoldModel) else raise EBold.Create('No validator registered'); @@ -162,11 +175,9 @@ procedure TfrmValidation.Validate; constructor TfrmValidation.CreateWithModel(ModelComponent: TBoldModel; Owner: Tcomponent); begin inherited create(Owner); - // Workaround - Setting the handle in designtime causes an AV in inherited Create BoldGrid1.BoldHandle := blhViolations; - // EndWorkaround - fModelComponent := ModelComponent; - fModelComponent.FreeNotification(Self); + fBoldModel := ModelComponent; + fBoldModel.FreeNotification(Self); behModel.Value := ModelComponent.EnsuredUMLModel; end; @@ -177,7 +188,10 @@ procedure TfrmValidation.mnuCopyLogtoClipBoardClick(Sender: TObject); function TfrmValidation.GetUMLModel: TUMLModel; begin - result := ModelComponent.EnsuredUMLModel; + if Assigned(BoldModel) then + result := BoldModel.EnsuredUMLModel + else + result := nil; end; procedure TfrmValidation.Cut1Click(Sender: TObject); @@ -198,27 +212,18 @@ procedure TfrmValidation.Paste1Click(Sender: TObject); SendMessage(ActiveControl.handle, WM_PASTE, 0, 0); end; -destructor TfrmValidation.destroy; +destructor TfrmValidation.Destroy; begin if G_ValidationForm = self then G_ValidationForm := nil; inherited; end; -procedure TfrmValidation.BoldPlaceableSubscriber1Receive( - sender: TBoldPlaceableSubscriber; Originator: TObject; OriginalEvent, - RequestedEvent: Integer); -begin - if blhViolations.Count > 0 then - show; -end; - procedure TfrmValidation.Notification(AComponent: TComponent; Operation: TOperation); begin inherited; - if (aComponent = fModelComponent) and (operation = opRemove) then - fModelComponent := nil; + if (aComponent = BoldModel) and (operation = opRemove) then + fBoldModel := nil; end; -initialization end. diff --git a/Source/UMLModel/Editor/BoldUMLOCLEditor.pas b/Source/UMLModel/Editor/BoldUMLOCLEditor.pas index 2343059e..5d0d4404 100644 --- a/Source/UMLModel/Editor/BoldUMLOCLEditor.pas +++ b/Source/UMLModel/Editor/BoldUMLOCLEditor.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLOCLEditor; interface @@ -28,9 +31,8 @@ implementation uses SysUtils, - Controls, // mr_OK - BoldDefs, - BoldRev, + Controls, + BoldDefs, BoldTypeNameDictionary; var diff --git a/Source/UMLModel/Editor/BoldUMLTaggedValuesEditor.pas b/Source/UMLModel/Editor/BoldUMLTaggedValuesEditor.pas index 1c7a6440..b6c6b987 100644 --- a/Source/UMLModel/Editor/BoldUMLTaggedValuesEditor.pas +++ b/Source/UMLModel/Editor/BoldUMLTaggedValuesEditor.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLTaggedValuesEditor; interface @@ -68,17 +71,15 @@ TfrmBoldUMLTaggedValuesEditor = class(TForm) RootValue: TBoldElement; ResultElement: TBoldIndirectElement; Subscriber: TBoldSubscriber); procedure tcToolsChange(Sender: TObject); - function BoldAsStringRenderer1GetAsString(Element: TBoldElement; - Representation: Integer; Expression: String): String; - procedure BoldAsStringRenderer1Subscribe(Element: TBoldElement; - Representation: Integer; Expression: String; - Subscriber: TBoldSubscriber); procedure FormCreate(Sender: TObject); procedure btAddTVClick(Sender: TObject); procedure btDeleteTVClick(Sender: TObject); procedure Copy1Click(Sender: TObject); procedure Cut1Click(Sender: TObject); procedure Paste1Click(Sender: TObject); + function BoldAsStringRenderer1GetAsString(aFollower: TBoldFollower): string; + procedure BoldAsStringRenderer1Subscribe(aFollower: TBoldFollower; + Subscriber: TBoldSubscriber); private fRootSubscriber: TBoldPassThroughSubscriber; PreviousSelectedTab: Integer; @@ -91,7 +92,7 @@ TfrmBoldUMLTaggedValuesEditor = class(TForm) procedure RefreshGUI(var Message: TMessage); message WM_REFRESHGUI; procedure DoMessage(Control: TControl; Msg: Cardinal); public - destructor Destroy; override; + destructor destroy; override; procedure SwitchMode(ReadOnly: Boolean); end; @@ -102,7 +103,6 @@ implementation uses SysUtils, BoldUtils, - BoldRev, BoldUMLModelDataModule, BoldUMLAddTV; @@ -231,21 +231,20 @@ procedure TfrmBoldUMLTaggedValuesEditor.tcToolsChange(Sender: TObject); end; function TfrmBoldUMLTaggedValuesEditor.BoldAsStringRenderer1GetAsString( - Element: TBoldElement; Representation: Integer; - Expression: String): String; + aFollower: TBoldFollower): string; begin Result := ''; - if Assigned(Element) then + if Assigned(aFollower.Element) then begin - Result := GetTagName((Element as TUMLTaggedValue).Tag); + Result := GetTagName((aFollower.Element as TUMLTaggedValue).Tag); end; end; + procedure TfrmBoldUMLTaggedValuesEditor.BoldAsStringRenderer1Subscribe( - Element: TBoldElement; Representation: Integer; Expression: String; - Subscriber: TBoldSubscriber); + aFollower: TBoldFollower; Subscriber: TBoldSubscriber); begin - (Element as TUMLTaggedValue).M_Tag.DefaultSubscribe(Subscriber, breReEvaluate); + (aFollower.Element as TUMLTaggedValue).M_Tag.DefaultSubscribe(Subscriber, breReEvaluate); end; procedure TfrmBoldUMLTaggedValuesEditor.PlaceSubscriptions; @@ -267,7 +266,6 @@ procedure TfrmBoldUMLTaggedValuesEditor.RecieveRootChanged( breReSubscribe: PlaceSubscriptions; end; PostMessage(Handle, WM_REFRESHGUI, 0, 0); - //CreateTabs; end; procedure TfrmBoldUMLTaggedValuesEditor.FormCreate(Sender: TObject); diff --git a/Source/UMLModel/Editor/BoldUMLUsesEditorForm.pas b/Source/UMLModel/Editor/BoldUMLUsesEditorForm.pas index 86871036..054b7305 100644 --- a/Source/UMLModel/Editor/BoldUMLUsesEditorForm.pas +++ b/Source/UMLModel/Editor/BoldUMLUsesEditorForm.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLUsesEditorForm; interface @@ -52,7 +55,6 @@ implementation uses SysUtils, BoldUtils, - BoldRev, BoldQueue; {$R *.dfm} diff --git a/Source/UMLModel/Handles/BoldModel.pas b/Source/UMLModel/Handles/BoldModel.pas index 2af6ac51..b137cdfe 100644 --- a/Source/UMLModel/Handles/BoldModel.pas +++ b/Source/UMLModel/Handles/BoldModel.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldModel; interface @@ -21,6 +24,7 @@ TBoldModelList = class; TUMLModelMode = (ummNone, ummDesignTime, ummRunTime); { TBoldModel } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldModel = class(TBoldAbstractModel) private FUMLModelExposed: Boolean; @@ -31,16 +35,17 @@ TBoldModel = class(TBoldAbstractModel) fSystemHandle: TBoldSystemHandle; fModelChangedSubscriber: TBoldPassthroughSubscriber; fEditableModel: boolean; + fValidateNesting: integer; procedure SetBoldify(const Value: TBoldUMLBoldify); procedure EnsureUMLModel; procedure AssertDesignTime; procedure ReadUMLModelAsString(Reader: TReader); procedure WriteUMLModelAsString(Writer: TWriter); - function UMLModelToString: string; procedure UMLModelFromString(ModelAsString: string); function GetEnsuredUMLModel: TUMLModel; function GetUMLModel: TUMLModel; procedure UMLModelChangedRecieve(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); + function GetIsValidating: boolean; protected procedure DefineProperties(Filer: TFiler); override; procedure SubscribeToUMLModel; @@ -54,8 +59,12 @@ TBoldModel = class(TBoldAbstractModel) constructor Create(owner: TComponent); override; destructor Destroy; override; procedure EnsureTypes; + function UMLModelToString: string; + procedure StartValidation; + procedure EndValidation; property UMLModel: TUMLModel read GetUMLModel; property EnsuredUMLModel: TUMLModel read GetEnsuredUMLModel; + property IsValidating: boolean read GetIsValidating; published property UMLModelMode: TUMLModelMode read fUMLModelMode write fUMLModelMode; property Boldify: TBoldUMLBoldify read FBoldify write SetBoldify; @@ -83,7 +92,7 @@ function TheModelList: TBoldModelList; implementation uses - BoldUMLModelDataModule, // Circular dependency + BoldUMLModelDataModule, SysUtils, BoldLogHandler, BoldUMLModelStreamer, @@ -93,6 +102,7 @@ implementation BoldUMLAttributes, BoldUMLModelConverter, BoldUMLModelValidator, + BoldUMLUtils, BoldGuard; var @@ -117,7 +127,7 @@ constructor TBoldModel.Create(owner: TComponent); procedure TBoldModel.DefineProperties(Filer: TFiler); begin inherited DefineProperties(Filer); - Filer.DefineProperty('UMLModelAsString', ReadUMLModelAsString, WriteUMLModelAsString, UMLModelMode <> ummNone); // do not localize + Filer.DefineProperty('UMLModelAsString', ReadUMLModelAsString, WriteUMLModelAsString, UMLModelMode <> ummNone); end; destructor TBoldModel.Destroy; @@ -168,7 +178,6 @@ procedure TBoldModel.EnsureTypes; for Index := 0 to Count - 1 do begin if Mapping[index].ModelName = DEFAULTNAME then - // ignore else if Assigned(BoldMemberTypeList.DescriptorByDelphiName[Mapping[Index].ExpandedDelphiName]) then begin if BoldMemberTypeList.DescriptorByDelphiName[Mapping[index].ExpandedDelphiName].AbstractionLevel = alConcrete then @@ -187,6 +196,11 @@ function TBoldModel.GetEnsuredUMLModel: TUMLModel; MarkUMLModelExposed; end; +function TBoldModel.GetIsValidating: boolean; +begin + result := fValidateNesting > 0; +end; + procedure TBoldModel.ReadUMLModelAsString(Reader: TReader); begin fUMLModelAsString := Reader.ReadString; @@ -217,7 +231,7 @@ procedure TBoldModel.EnsureUMLModel; end; ummRunTime: UMLModelFromString(fUMLModelAsString); end; - fUMLModelAsString := ''; // Reclaim memory. Saving will be straight from UMLModel + fUMLModelAsString := ''; end; end; @@ -226,6 +240,16 @@ procedure TBoldModel.SetBoldify(const Value: TBoldUMLBoldify); Boldify.Assign(Value); end; +procedure TBoldModel.StartValidation; +begin + Inc(fValidateNesting); +end; + +procedure TBoldModel.EndValidation; +begin + Dec(fValidateNesting); +end; + procedure TBoldModel.UMLModelFromString(ModelAsString: string); begin if ModelAsString <> '' then @@ -235,9 +259,8 @@ procedure TBoldModel.UMLModelFromString(ModelAsString: string); fUMLModel.Delete; fUMLModel := nil; end; - // Model always freshly created at this point. TUMLModelStreamer.FillSystemFromString(fSystemHandle.System, ModelAsString, fSystemHandle.SystemTypeInfoHandle.BoldModel.MoldModel); - fUMLModel := fSystemHandle.System.EvaluateExpressionAsDirectElement('UMLModel.allInstances->first') as TUMLModel; // do not localize + fUMLModel := fSystemHandle.System.EvaluateExpressionAsDirectElement('UMLModel.allInstances->first') as TUMLModel; if not Assigned(fUMLModel) then raise EBold.Create('Bad string format for UMLModel'); end; @@ -308,7 +331,7 @@ procedure TBoldModel.EnsureMoldModelCurrent; Errors := TStringList.Create; - Validator := TBoldUMLModelValidator.Create(UMLModel); + Validator := TBoldUMLModelValidator.Create(self, SQLDataBaseConfigforModel(self)); Validator.Validate(TypeNameDictionary); @@ -319,9 +342,8 @@ procedure TBoldModel.EnsureMoldModelCurrent; MoldModel := TBoldModelConverter.UMLModelToMold(UMLModel); MoldModel.TVByName[BOLDINTERALTVPREFIX + TV_MODELERRORS] := Errors.CommaText; - SetFromModel(MoldModel); // hands over ownership of MoldModel + SetFromModel(MoldModel); - // Restore UML model state if not FlattenState then TBoldUMLSupport.UnFlatten(UMLModel); @@ -341,6 +363,8 @@ function TBoldModel.GetUMLModel: TUMLModel; procedure TBoldModel.UMLModelChangedRecieve(Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: TBoldRequestedEvent); begin + if IsValidating then + exit; UnSubscribeToUMLModel; SendEvent(self, beModelChanged); UpdateDesigner; @@ -351,7 +375,7 @@ procedure TBoldModel.SubscribeToUMLModel; Assert(Assigned(fUMLModel)); Assert(not Assigned(fModelChangedSubscriber)); fModelChangedSubscriber := TBoldPassthroughSubscriber.Create(UMLModelChangedRecieve); - TBoldUMLSupport.SubscribeToEntireModel(fUMLModel, fModelChangedSubscriber); // note fUMLModel to stop loops + TBoldUMLSupport.SubscribeToEntireModel(fUMLModel, fModelChangedSubscriber); end; procedure TBoldModel.UnSubscribeToUMLModel; diff --git a/Source/UMLModel/Handles/BoldUMLModelStreamer.pas b/Source/UMLModel/Handles/BoldUMLModelStreamer.pas index 2bb4765b..3c51340a 100644 --- a/Source/UMLModel/Handles/BoldUMLModelStreamer.pas +++ b/Source/UMLModel/Handles/BoldUMLModelStreamer.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLModelStreamer; interface @@ -13,22 +16,47 @@ TUMLModelStreamer = class class function SystemAsString(BoldSystem: TBoldSystem; MoldModel: TMoldModel): string; end; + implementation uses - MSXML_TLB, + {$IFDEF OXML}OXmlPDOM, OTextReadWrite{$ELSE}Bold_MSXML_TLB{$ENDIF}, BoldXMLStreaming, BoldDefaultXMLStreaming, BoldDomainElement, BoldGuard, BoldDefs, BoldValueSpaceInterfaces, - BoldID; + BoldID, + BoldRev; { TUMLModelStreamer } class procedure TUMLModelStreamer.FillSystemFromString(BoldSystem: TBoldSystem; const UMLModelAsString: string; MoldModel: TMoldModel); +{$IFDEF OXML} +var + anXMLDoc: TXMLDocument; + aMgr: TBoldDefaultXMLStreamManager; + aNode: TBoldXMLNode; + ParseError: IOTextParseError; + BoldGuard: IBoldGuard; +begin + BoldGuard := TBoldGuard.Create(aMgr, aNode); + anXMLDoc := TXMLDocument.Create; + aMgr := TBoldDefaultXMLStreamManager.Create(TBoldDefaultXMLStreamerRegistry.MainStreamerRegistry, MoldModel); + + aMgr.IgnorePersistenceState := True; + aMgr.PersistenceStatesToOverWrite := [bvpsInvalid, bvpsModified, bvpsTransient, bvpsCurrent]; + anXMLDoc.LoadFromXML(UMLModelAsString); + + ParseError := anXMLDoc.ParseError; + if Assigned(ParseError) and (ParseError.ErrorCode <> 0) then + raise EBold.Create('Error reading/parsing XML file'); + aNode := aMgr.GetRootNode(anXMLDoc, 'ValueSpace'); // do not localize + aMgr.ReadValueSpace(BoldSystem.AsIBoldvalueSpace[bdepPMIn], aNode); +end; +{$ELSE} var anXMLDoc: TDomDocument; aMgr: TBoldDefaultXMLStreamManager; @@ -48,11 +76,33 @@ class procedure TUMLModelStreamer.FillSystemFromString(BoldSystem: TBoldSystem; ParseError := anXMLDoc.parseError; if Assigned(ParseError) and (ParseError.errorCode <> 0) then raise EBold.Create('Error reading/parsing XML file'); - aNode := aMgr.GetRootNode(anXMLDoc, 'ValueSpace'); // do not localize + aNode := aMgr.GetRootNode(anXMLDoc, 'ValueSpace'); aMgr.ReadValueSpace(BoldSystem.AsIBoldvalueSpace[bdepPMIn], aNode); end; +{$ENDIF} class function TUMLModelStreamer.SystemAsString(BoldSystem: TBoldSystem; MoldModel: TMoldModel): string; +{$IFDEF OXML} +var + anXMLDoc: TXMLDocument; + aMgr: TBoldDefaultXMLStreamManager; + aNode: TBoldXMLNode; + anIdList: TBoldObjectIdList; + BoldGuard: IBoldGuard; +begin + BoldGuard := TBoldGuard.Create(aNode, aMgr, anIDList); + anXMLDoc := TXMLDocument.Create; + aMgr := TBoldDefaultXMLStreamManager.Create(TBoldDefaultXMLStreamerRegistry.MainStreamerRegistry, MoldModel); + aMgr.IgnorePersistenceState := True; + aMgr.PersistenceStatesToBeStreamed := [bvpsInvalid, bvpsModified, bvpsTransient, bvpsCurrent]; + aNode := aMgr.NewRootNode(anXMLDoc, 'ValueSpace'); // do not localize + anIdList := TBoldObjectIdList.Create; + + BoldSystem.AsIBoldValueSpace[bdepPMOut].AllObjectIds(anIdList, True); + aMgr.WriteValueSpace(BoldSystem.AsIBoldValueSpace[bdepPMOut], anIdList, nil, aNode); + Result := anXMLDoc.XML; +end; +{$ELSE} var anXMLDoc: TDomDocument; aMgr: TBoldDefaultXMLStreamManager; @@ -65,12 +115,15 @@ class function TUMLModelStreamer.SystemAsString(BoldSystem: TBoldSystem; MoldMod aMgr := TBoldDefaultXMLStreamManager.Create(TBoldDefaultXMLStreamerRegistry.MainStreamerRegistry, MoldModel); aMgr.IgnorePersistenceState := True; aMgr.PersistenceStatesToBeStreamed := [bvpsInvalid, bvpsModified, bvpsTransient, bvpsCurrent]; - aNode := aMgr.NewRootNode(anXMLDoc, 'ValueSpace'); // do not localize + aNode := aMgr.NewRootNode(anXMLDoc, 'ValueSpace'); anIdList := TBoldObjectIdList.Create; BoldSystem.AsIBoldValueSpace[bdepPMOut].AllObjectIds(anIdList, True); aMgr.WriteValueSpace(BoldSystem.AsIBoldValueSpace[bdepPMOut], anIdList, nil, aNode); Result := anXMLDoc.documentElement.xml; end; +{$ENDIF} + +initialization end. diff --git a/Source/UMLModel/Ide/BoldUMLModelEditReg.pas b/Source/UMLModel/Ide/BoldUMLModelEditReg.pas index 6281f994..725b48ae 100644 --- a/Source/UMLModel/Ide/BoldUMLModelEditReg.pas +++ b/Source/UMLModel/Ide/BoldUMLModelEditReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLModelEditReg; interface @@ -14,6 +17,7 @@ implementation Classes, BoldCursorGuard, BoldSmallLogFrame, + BoldLogHandlerForm, BoldUMLModel, BoldDefsDT, BoldUMLModelEdit, @@ -119,7 +123,7 @@ function TUMLModelComponentEditor.GetCurrentElement: TUMLModelElement; procedure Register; begin RegisterComponentEditor(TBoldModel, TUMLModelComponentEditor); - RegisterPropertyEditor(TypeInfo(Boolean), TBoldModel, 'EditableModel', TUMLModelPropertyEditor); //do not localize + RegisterPropertyEditor(TypeInfo(Boolean), TBoldModel, 'EditableModel', TUMLModelPropertyEditor); end; constructor TUMLModelComponentEditor.Create(AComponent: TComponent; ADesigner: IDesigner); @@ -156,7 +160,7 @@ procedure TUMLModelPropertyEditor.Edit; function TUMLModelPropertyEditor.GetAttributes: TPropertyAttributes; begin - Result := inherited GetAttributes + [paDialog, paReadOnly] - [paMultiSelect]; + Result := inherited GetAttributes + [paDialog, paReadOnly] - [paMultiSelect]; end; function TUMLModelPropertyEditor.GetValue: string; @@ -164,5 +168,6 @@ function TUMLModelPropertyEditor.GetValue: string; Result := '(Open model editor)'; end; -end. +initialization +end. diff --git a/Source/UMLModel/Ide/BoldUMLModelHandleReg.pas b/Source/UMLModel/Ide/BoldUMLModelHandleReg.pas index d5a18674..35022651 100644 --- a/Source/UMLModel/Ide/BoldUMLModelHandleReg.pas +++ b/Source/UMLModel/Ide/BoldUMLModelHandleReg.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLModelHandleReg; interface @@ -6,13 +9,14 @@ procedure Register; implementation +{$R BoldUMLModelHandleReg.res} + uses SysUtils, Classes, BoldIDEConsts, BoldModel; -{$R BoldUMLModelHandleReg.res} procedure RegisterComponentsOnPalette; begin diff --git a/Source/UMLModel/Ide/BoldUMLModelHandleReg.res b/Source/UMLModel/Ide/BoldUMLModelHandleReg.res new file mode 100644 index 00000000..f7aa5635 Binary files /dev/null and b/Source/UMLModel/Ide/BoldUMLModelHandleReg.res differ diff --git a/Source/UMLModel/ModelLinks/Bld/BoldUMLBldLink.pas b/Source/UMLModel/ModelLinks/Bld/BoldUMLBldLink.pas index 9320e200..2ffb2e52 100644 --- a/Source/UMLModel/ModelLinks/Bld/BoldUMLBldLink.pas +++ b/Source/UMLModel/ModelLinks/Bld/BoldUMLBldLink.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLBldLink; interface @@ -19,9 +22,13 @@ TBoldUMLBldLink = class(TBoldUMLModelLink) function GetDisplayName: string; override; function GetFileName: string; override; procedure SetFileName(const Value: string); override; + function SortCompare(Index1, Index2: integer): integer; + procedure SortExchange(Index1, Index2: integer); public function ExportModel(UMLModel: TUMLModel): Boolean; override; function ImportModel(UMLModel: TUMLModel): Boolean; override; + class function getSortStatus: Boolean; + class procedure setSortStatus(sortStatus: Boolean); published property FileName; property BoldModel; @@ -42,24 +49,80 @@ implementation BoldLogHandler, BoldMeta, BoldBld, - BoldUMLModelConverter; + BoldUMLModelConverter, + BoldSorter; + +var + msort: Boolean; + MoldModel: TMoldModel; { TBoldUMLBldLink } function TBoldUMLBldLink.ExportModel(UMLModel: TUMLModel): Boolean; var ModelAsStrings: TStringList; - MoldModel: TMoldModel; + vToolId1, vToolID2:String; G: IBoldGuard; + i,j: integer; begin Result := True; G := TBoldGuard.Create(MoldModel, ModelAsStrings); MoldModel := TBoldModelConverter.UMLModelToMold(UMLModel); + if getSortStatus then + BoldSort(0, MoldModel.Classes.Count-1, SortCompare, SortExchange); ModelAsStrings := TStringList.Create; TMoldBLDrw.ModelToStrings(MoldModel, ModelAsStrings); ModelAsStrings.SaveToFile(FileName); end; +{ 25-10-05 Bero + Tried to implement BoldSort() + It works but it don't sort the same way as bubblesort above + Also experimenting with BoldElement.CompareTo() without success... + } +function TBoldUMLBldLink.SortCompare(Index1, Index2: integer): integer; +var + vToolId1, vToolId2: string; +begin + Result := 0; + vToolId1 := MoldModel.Classes[Index1].NonDefaultTaggedValuesCommaText; + vToolId1:=copy(vToolId1,1,Ansipos(',',vToolId1)-1); + if (Length(vToolId1)>0) and (Ansipos('persistent',vToolId1)=0) + and (Ansipos('transient',vToolId1)=0) then + begin + vToolId1:=copy(vToolId1,AnsiPos('=',vToolId1)+1,Length(vToolId1)); + vToolId2 := MoldModel.Classes[Index2].NonDefaultTaggedValuesCommaText; + vToolId2:=copy(vToolId2,1,Ansipos(',',vToolId2)-1); + + if (Length(vToolId2)>0) and (Ansipos('persistent',vToolId2)=0) + and (Ansipos('transient',vToolId2)=0) then + begin + vToolId2:=copy(vToolId2,AnsiPos('=',vToolId2)+1,Length(vToolId2)); + if (Length(vToolId1) >= Length(vToolId2)) and (('$' + vToolId1)<('$' + vToolId2)) then + Result := 1; + end; + end; +end; + +procedure TBoldUMLBldLink.SortExchange(Index1, Index2: integer); +begin + MoldModel.Classes.Exchange(Index1,Index2); +end; + +{:Static method, no need for a classinstance. Get the status of the sort flag +@return true-sorted false-unsorted} +class function TBoldUMLBldLink.getSortStatus: Boolean; +begin + Result := msort; +end; + +{:Static method, no need for a classinstance. Set the status of the sort flag +@param sortstatus true-sorted false-unsorted} +class procedure TBoldUMLBldLink.setSortStatus(sortStatus: Boolean); +begin + msort := sortStatus; +end; + function TBoldUMLBldLink.GetCanExport: Boolean; begin Result := True; diff --git a/Source/UMLModel/ModelLinks/Core/BoldUMLModelLink.pas b/Source/UMLModel/ModelLinks/Core/BoldUMLModelLink.pas index 8ec1eaaa..b5fe3152 100644 --- a/Source/UMLModel/ModelLinks/Core/BoldUMLModelLink.pas +++ b/Source/UMLModel/ModelLinks/Core/BoldUMLModelLink.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLModelLink; interface @@ -33,8 +36,8 @@ TBoldUMLModelLink = class(TBoldHandle) procedure SetFileName(const Value: string); virtual; function GetHandledObject: TObject; override; public - constructor Create(owner: TComponent); override; - destructor Destroy; override; + constructor create(owner: TComponent); override; + destructor destroy; override; function ExportModel(UMLModel: TUMLModel): Boolean; virtual; abstract; function ImportModel(UMLModel: TUMLModel): Boolean; virtual; abstract; property CanExport: Boolean read GetCanExport; diff --git a/Source/UMLModel/ModelLinks/Core/BoldUMLModelLinkSupport.pas b/Source/UMLModel/ModelLinks/Core/BoldUMLModelLinkSupport.pas index 9d267ed7..1d6498b3 100644 --- a/Source/UMLModel/ModelLinks/Core/BoldUMLModelLinkSupport.pas +++ b/Source/UMLModel/ModelLinks/Core/BoldUMLModelLinkSupport.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLModelLinkSupport; interface @@ -100,4 +103,6 @@ class procedure TBoldUMLModelLinkSupport.StringToConstraints(Element: TUMLModelE end; end; +initialization + end. diff --git a/Source/UMLModel/ModelLinks/ModelMaker/Link/BoldMMLinkReg.pas b/Source/UMLModel/ModelLinks/ModelMaker/Link/BoldMMLinkReg.pas index fcc5b162..85bc1488 100644 --- a/Source/UMLModel/ModelLinks/ModelMaker/Link/BoldMMLinkReg.pas +++ b/Source/UMLModel/ModelLinks/ModelMaker/Link/BoldMMLinkReg.pas @@ -1,6 +1,9 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldMMLinkreg; -interface +interface procedure Register; @@ -12,16 +15,15 @@ implementation TypInfo, SysUtils, BoldIDESupport, - BoldIDEConsts, BoldUtils, BoldDefs, + BoldGuard, + BoldIDEConsts, BoldAbstractPropertyEditors, BoldPropertyEditors, BoldAbstractModel, BoldUMLMMLink; -{$R *.res} - type { forward declarations } TBoldUMLMMFileNameProperty = class; @@ -36,7 +38,7 @@ TBoldUMLMMFileNameProperty = class(TBoldFileNameProperty) { TBoldUMLMMFileNameProperty } function TBoldUMLMMFileNameProperty.FileFilter: string; begin - Result := Format('%s (*%s)|*%1:s', [MM_LINKDESC, MM_LINKEXTENSION]); //do not localize + Result := Format('%s (*%s)|*%1:s', [MM_LINKDESC, MM_LINKEXTENSION]); end; function TBoldUMLMMFileNameProperty.IsValid: boolean; @@ -61,13 +63,12 @@ procedure RegisterComponentsOnPalette; procedure RegisterEditors; begin - RegisterPropertyEditor(TypeInfo(String), TBoldUMLMMLink, 'Filename', TBoldUMLMMFileNameProperty); //do not localize - RegisterPropertyEditor(TypeInfo(TBoldAbstractModel), TBoldUMLMMLink, 'BoldModel', TBoldComponentPropertyIndicateMissing); //do not localize + RegisterPropertyEditor(TypeInfo(String), TBoldUMLMMLink, 'Filename', TBoldUMLMMFileNameProperty); + RegisterPropertyEditor(TypeInfo(TBoldAbstractModel), TBoldUMLMMLink, 'BoldModel', TBoldComponentPropertyIndicateMissing); end; procedure Register; begin - RemovePackageFromDisabledPackagesRegistry(format('BoldMMLink%s', [LIBSUFFIX])); // do not localize RegisterComponentsOnPalette; RegisterEditors; end; diff --git a/Source/UMLModel/ModelLinks/ModelMaker/Link/BoldModelMaker_TLB.pas b/Source/UMLModel/ModelLinks/ModelMaker/Link/BoldModelMaker_TLB.pas index 8ccee7e3..bc63d90b 100644 --- a/Source/UMLModel/ModelLinks/ModelMaker/Link/BoldModelMaker_TLB.pas +++ b/Source/UMLModel/ModelLinks/ModelMaker/Link/BoldModelMaker_TLB.pas @@ -1,50 +1,46 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldModelMaker_TLB; -// ************************************************************************ // -// WARNING -// ------- -// The types declared in this file were generated from data read from a -// Type Library. If this type library is explicitly or indirectly (via -// another type library referring to this type library) re-imported, or the -// 'Refresh' command of the Type Library Editor activated while editing the -// Type Library, the contents of this file will be regenerated and all -// manual modifications will be lost. -// ************************************************************************ // - -// PASTLWTR : 1.1 -// File generated on 12/5/2001 9:07:15 AM from Type Library described below. - -// *************************************************************************// -// NOTE: -// Items guarded by $IFDEF_LIVE_SERVER_AT_DESIGN_TIME are used by properties -// which return objects that may need to be explicitly created via a function -// call prior to any access via the property. These items have been disabled -// in order to prevent accidental use from within the object inspector. You -// may enable them by defining LIVE_SERVER_AT_DESIGN_TIME or by selectively -// removing them from the $IFDEF blocks. However, such items must still be -// programmatically created via a method of the appropriate CoClass before -// they can be used. -// ************************************************************************ // -// Type Lib: E:\MM32\AutoServer\ModelMaker.tlb (1) -// IID\LCID: {D077CEC0-83F0-11D5-A1D2-00C0DFE529B9}\0 -// Helpfile: -// DepndLst: -// (1) v2.0 stdole, (C:\WINNT\System32\stdole2.tlb) -// ************************************************************************ // -{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. + + + + + + + + + + + + + + + + + + + + + + + + + + + +{$TYPEDADDRESS OFF} interface uses Windows, ActiveX, Classes, Graphics, OleServer, OleCtrls, StdVCL; -// *********************************************************************// -// GUIDS declared in the TypeLibrary. Following prefixes are used: -// Type Libraries : LIBID_xxxx -// CoClasses : CLASS_xxxx -// DISPInterfaces : DIID_xxxx -// Non-DISP interfaces: IID_xxxx -// *********************************************************************// + + + + + const - // TypeLibrary Major and minor versions ModelMakerMajorVersion = 1; ModelMakerMinorVersion = 0; @@ -54,61 +50,47 @@ interface CLASS_App: TGUID = '{D077CEC3-83F0-11D5-A1D2-00C0DFE529B9}'; type -// *********************************************************************// -// Forward declaration of types defined in TypeLibrary -// *********************************************************************// + IApp = interface; IAppDisp = dispinterface; -// *********************************************************************// -// Declaration of CoClasses defined in Type Library -// (NOTE: Here we map each CoClass to its Default Interface) -// *********************************************************************// + + App = IApp; -// *********************************************************************// -// Interface: IApp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {D077CEC1-83F0-11D5-A1D2-00C0DFE529B9} -// *********************************************************************// + + IApp = interface(IDispatch) ['{D077CEC1-83F0-11D5-A1D2-00C0DFE529B9}'] function GetExpert(const ExpertID: WideString): IDispatch; safecall; end; -// *********************************************************************// -// DispIntf: IAppDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {D077CEC1-83F0-11D5-A1D2-00C0DFE529B9} -// *********************************************************************// + + + IAppDisp = dispinterface ['{D077CEC1-83F0-11D5-A1D2-00C0DFE529B9}'] function GetExpert(const ExpertID: WideString): IDispatch; dispid 1; end; -// *********************************************************************// -// The Class CoApp provides a Create and CreateRemote method to -// create instances of the default interface IApp exposed by -// the CoClass App. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoApp = class class function Create: IApp; class function CreateRemote(const MachineName: string): IApp; end; -// *********************************************************************// -// OLE Server Proxy class declaration -// Server Object : TApp -// Help String : ModelMaker Object -// Default Interface: IApp -// Def. Intf. DISP? : No -// Event Interface: -// TypeFlags : (2) CanCreate -// *********************************************************************// + + + + + + {$IFDEF LIVE_SERVER_AT_DESIGN_TIME} TAppProperties= class; {$ENDIF} @@ -137,12 +119,11 @@ TApp = class(TOleServer) end; {$IFDEF LIVE_SERVER_AT_DESIGN_TIME} -// *********************************************************************// -// OLE Server Properties Proxy Class -// Server Object : TApp -// (This object is used by the IDE's Property Inspector to allow editing -// of the properties of this server) -// *********************************************************************// + + + + + TAppProperties = class(TPersistent) private FServer: TApp; diff --git a/Source/UMLModel/ModelLinks/ModelMaker/Link/BoldUMLMMLink.pas b/Source/UMLModel/ModelLinks/ModelMaker/Link/BoldUMLMMLink.pas index 3488425d..5d0b4485 100644 --- a/Source/UMLModel/ModelLinks/ModelMaker/Link/BoldUMLMMLink.pas +++ b/Source/UMLModel/ModelLinks/ModelMaker/Link/BoldUMLMMLink.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLMMLink; {$WARN SYMBOL_PLATFORM OFF} @@ -41,7 +44,7 @@ implementation SysUtils, Classes, BoldModelmaker_TLB, - BoldMMPlugin_TLB, + BoldMMPlugin_TLB, BoldDefs, BoldUtils, BoldGuard, @@ -51,9 +54,6 @@ implementation BoldBld, BoldUMLModelConverter; -const - BoldExpertName = 'BoldSoft.BoldExpert'; - { TBoldUMLMMLink } function TBoldUMLMMLink.ExportModel(UMLModel: TUMLModel): Boolean; @@ -70,11 +70,11 @@ function TBoldUMLMMLink.ExportModel(UMLModel: TUMLModel): Boolean; App := CoApp.Create; if not Assigned(App) then raise EBold.Create('Failed to Launch ModelMaker'); - Expert := App.GetExpert(BoldExpertName) as IBoldExpertDisp; + Expert := App.GetExpert('BoldSoft.BoldExpert') as IBoldExpertDisp; if not Assigned(Expert) then begin Sleep(10); - Expert := App.GetExpert(BoldExpertName) as IBoldExpertDisp; + Expert := App.GetExpert('BoldSoft.BoldExpert') as IBoldExpertDisp; end; if not Assigned(Expert) then raise EBold.Create('Bold Expert not installed in ModelMaker. Make sure the file BoldMMPlugin.dll is in the ModelMaker\Experts directory, and register the DLL using RegSvr32.exe'); @@ -96,7 +96,7 @@ function TBoldUMLMMLink.ExportModel(UMLModel: TUMLModel): Boolean; if ResultString <> '' then raise EBold.Createfmt(' Error during export: %s', [ResultString]) else - Expert.SaveProject(False); + Expert.SaveProject(False); end; function TBoldUMLMMLink.GetCanExport: Boolean; @@ -126,11 +126,11 @@ function TBoldUMLMMLink.ImportModel(UMLModel: TUMLModel): Boolean; App := CoApp.Create; if not Assigned(App) then raise EBoldImport.Create('Failed to Launch ModelMaker'); - Expert := App.GetExpert(BoldExpertName) as IBoldExpertDisp; + Expert := App.GetExpert('BoldSoft.BoldExpert') as IBoldExpertDisp; if not Assigned(Expert) then begin - Sleep(10); - Expert := App.GetExpert(BoldExpertName) as IBoldExpertDisp; + Sleep(10); + Expert := App.GetExpert('BoldSoft.BoldExpert') as IBoldExpertDisp; end; if not Assigned(Expert) then raise EBoldImport.Create('Bold Expert not installed in ModelMaker. Make sure the file BoldMMPlugin.dll is in the ModelMaker\Experts directory, and register the DLL using RegSvr32.exe'); diff --git a/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMExpert.pas b/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMExpert.pas index 5b7185a9..d5e599ca 100644 --- a/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMExpert.pas +++ b/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMExpert.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldMMExpert; interface @@ -61,7 +64,6 @@ procedure TBoldMMExpert.Destroyed; procedure TBoldMMExpert.Execute(Index: Integer); begin - // the menu item was clicked: perform associated action here case Index of 0: SaveModelToFile; @@ -74,7 +76,6 @@ procedure TBoldMMExpert.Execute(Index: Integer); function TBoldMMExpert.GetMenuPositions(Index: Integer): TMMMenuPosition; begin - // Define to which ModelMaker sub-menu should each verb be added case Index of 0, 1: Result := mpToolsMenu; else @@ -95,7 +96,6 @@ function TBoldMMExpert.GetVerbCount: Integer; function TBoldMMExpert.GetVerbs(Index: Integer): WideString; begin - // Return menu items Captions here case Index of 0: Result := 'Save in Bold format'; 1: Result := 'Bold tagged value editor'; @@ -125,7 +125,6 @@ function TBoldMMExpert.GetModelAsDelphiString: string; MoldModel: TMoldModel; ModelAsStrings: TStrings; begin - // Stream in .bld format for the time being. G := TBoldGuard.Create(Importer, Boldify, MoldModel); EnsureModelEditDataModule; UMLModel := TUMLModel.Create(dmModelEdit.bshUMLModel.System); diff --git a/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMPlugin_TLB.pas b/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMPlugin_TLB.pas index 8a0bf440..b2e06692 100644 --- a/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMPlugin_TLB.pas +++ b/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMPlugin_TLB.pas @@ -1,46 +1,41 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldMMPlugin_TLB; -// ************************************************************************ // -// WARNING -// ------- -// The types declared in this file were generated from data read from a -// Type Library. If this type library is explicitly or indirectly (via -// another type library referring to this type library) re-imported, or the -// 'Refresh' command of the Type Library Editor activated while editing the -// Type Library, the contents of this file will be regenerated and all -// manual modifications will be lost. -// ************************************************************************ // - -// PASTLWTR : 1.2 -// File generated on 8/12/2002 10:25:54 AM from Type Library described below. - -// ************************************************************************ // -// Type Lib: C:\vss\Development\BfD\Source\UMLModel\ModelLinks\ModelMaker\MMPlugin\BoldMMPlugin.tlb (1) -// LIBID: {08A3186D-598D-4595-8B1C-76D9FFDF952A} -// LCID: 0 -// Helpfile: -// HelpString: TypeLib1 Library -// DepndLst: -// (1) v2.0 stdole, (C:\WINDOWS\System32\stdole2.tlb) -// ************************************************************************ // -{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. + + + + + + + + + + + + + + + + + + + +{$TYPEDADDRESS OFF} {$WARN SYMBOL_PLATFORM OFF} {$WRITEABLECONST ON} {$VARPROPSETTER ON} interface uses Windows, ActiveX, Classes, Graphics, StdVCL, Variants; - - -// *********************************************************************// -// GUIDS declared in the TypeLibrary. Following prefixes are used: -// Type Libraries : LIBID_xxxx -// CoClasses : CLASS_xxxx -// DISPInterfaces : DIID_xxxx -// Non-DISP interfaces: IID_xxxx -// *********************************************************************// + + + + + + const - // TypeLibrary Major and minor versions BoldMMPluginMajorVersion = 1; BoldMMPluginMinorVersion = 0; @@ -50,24 +45,17 @@ interface CLASS_CBoldExpert: TGUID = '{72789CDE-7A9C-475D-B935-ABF9283D9400}'; type -// *********************************************************************// -// Forward declaration of types defined in TypeLibrary -// *********************************************************************// + IBoldExpert = interface; IBoldExpertDisp = dispinterface; -// *********************************************************************// -// Declaration of CoClasses defined in Type Library -// (NOTE: Here we map each CoClass to its Default Interface) -// *********************************************************************// + + CBoldExpert = IBoldExpert; -// *********************************************************************// -// Interface: IBoldExpert -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {4BBAE613-E7D6-4924-B2C3-43BB849EEC79} -// *********************************************************************// + + IBoldExpert = interface(IDispatch) ['{4BBAE613-E7D6-4924-B2C3-43BB849EEC79}'] function GetModelAsString: WideString; safecall; @@ -79,11 +67,9 @@ interface property ProjectFileName: WideString read Get_ProjectFileName; end; -// *********************************************************************// -// DispIntf: IBoldExpertDisp -// Flags: (4416) Dual OleAutomation Dispatchable -// GUID: {4BBAE613-E7D6-4924-B2C3-43BB849EEC79} -// *********************************************************************// + + + IBoldExpertDisp = dispinterface ['{4BBAE613-E7D6-4924-B2C3-43BB849EEC79}'] function GetModelAsString: WideString; dispid 1; @@ -94,13 +80,11 @@ interface procedure SaveProject(SaveAs: WordBool); dispid 6; end; -// *********************************************************************// -// The Class CoCBoldExpert provides a Create and CreateRemote method to -// create instances of the default interface IBoldExpert exposed by -// the CoClass CBoldExpert. The functions are intended to be used by -// clients wishing to automate the CoClass objects exposed by the -// server of this typelibrary. -// *********************************************************************// + + + + + CoCBoldExpert = class class function Create: IBoldExpert; class function CreateRemote(const MachineName: string): IBoldExpert; diff --git a/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMTVDefGen.pas b/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMTVDefGen.pas index f9351c32..d5b98584 100644 --- a/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMTVDefGen.pas +++ b/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMTVDefGen.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldMMTVDefGen; interface @@ -5,7 +8,7 @@ interface uses BoldDefaultTaggedValues, BoldUMLTaggedValues, - MSXML_TLB, + Bold_MSXML_TLB, BoldTaggedValueList; type @@ -54,7 +57,7 @@ procedure TBoldMMTVDefGen.Generate(FileName: string); ModelDefElement: IXMLDOMElement; begin fDoc := TDOMDocument.Create(nil); - fDoc.documentElement := fDoc.createElement('TagDefinitions'); // do not localize + fDoc.documentElement := fDoc.createElement('TagDefinitions'); RootElement := fDoc.documentElement; fEnumDefElement := AddElement(NODENAME_ENUMS, RootElement); @@ -64,40 +67,39 @@ procedure TBoldMMTVDefGen.Generate(FileName: string); MethodDefElement := AddElement(NODENAME_METHODTAGS, RootElement); ModelDefElement := AddElement(NODENAME_MODELTAGS, RootElement); - AddEnumDef('Boolean', 'True, False'); // do not localize - AddEnumDef('AttributeKindSet', TV_ATTRIBUTEKIND_BOLD + ', ' + TV_ATTRIBUTEKIND_DELPHI); // do not localize - AddEnumDef('BoldOperationKindSet', TV_DELPHIOPERATIONKIND_NORMAL + ', ' + // do not localize + AddEnumDef('Boolean', 'True, False'); + AddEnumDef('AttributeKindSet', TV_ATTRIBUTEKIND_BOLD + ', ' + TV_ATTRIBUTEKIND_DELPHI); + AddEnumDef('BoldOperationKindSet', TV_DELPHIOPERATIONKIND_NORMAL + ', ' + TV_DELPHIOPERATIONKIND_VIRTUAL + ', ' + TV_DELPHIOPERATIONKIND_ABSTRACTVIRTUAL + ', ' + TV_DELPHIOPERATIONKIND_DYNAMIC + ', ' + TV_DELPHIOPERATIONKIND_OVERRIDE); -// AddEnumDef('ChangeabilityKind', TV_CHANGEABILITY_ADDONLY + ', ' + -// TV_CHANGEABILITY_CHANGEABLE + ', ' + -// TV_CHANGEABILITY_FROZEN); - AddEnumDef('DeleteActions', TV_DELETEACTION_DEFAULT + ', ' + // do not localize + + + AddEnumDef('DeleteActions', TV_DELETEACTION_DEFAULT + ', ' + TV_DELETEACTION_ALLOW + ', ' + TV_DELETEACTION_PROHIBIT + ', ' + TV_DELETEACTION_CASCADE); - AddEnumDef('DelphiPropertySet', TV_DPNONE + ', ' + // do not localize + AddEnumDef('DelphiPropertySet', TV_DPNONE + ', ' + TV_DPFIELD + ', ' + TV_DPPRIVATEMETHOD + ', ' + TV_DPPROTECTEDVIRTUALMETHOD); - AddEnumDef('EvolutionStateEnum', TV_EVOLUTIONSTATE_NORMAL + ', ' + // do not localize + AddEnumDef('EvolutionStateEnum', TV_EVOLUTIONSTATE_NORMAL + ', ' + TV_EVOLUTIONSTATE_TOBEREMOVED + ', ' + TV_EVOLUTIONSTATE_REMOVED); - AddEnumDef('NationalCharConversionEnum', TV_NATIONALCHARCONVERSION_DEFAULT + ', ' + // do not localize + AddEnumDef('NationalCharConversionEnum', TV_NATIONALCHARCONVERSION_DEFAULT + ', ' + TV_NATIONALCHARCONVERSION_TRUE + ', ' + TV_NATIONALCHARCONVERSION_FALSE); - AddEnumDef('OptimisticLockingSet', TV_OPTIMISTICLOCKING_DEFAULT + ', ' + // do not localize + AddEnumDef('OptimisticLockingSet', TV_OPTIMISTICLOCKING_DEFAULT + ', ' + TV_OPTIMISTICLOCKING_OFF + ', ' + TV_OPTIMISTICLOCKING_MODIFIEDMEMBERS + ', ' + TV_OPTIMISTICLOCKING_ALLMEMBERS + ', ' + TV_OPTIMISTICLOCKING_TIMESTAMP); - AddEnumDef('TableMappingSet', TV_TABLEMAPPING_OWN + ', ' + // do not localize + AddEnumDef('TableMappingSet', TV_TABLEMAPPING_OWN + ', ' + TV_TABLEMAPPING_PARENT + ', ' + TV_TABLEMAPPING_CHILDREN + ', ' + TV_TABLEMAPPING_IMPORTED); - AddEnumDef('DefaultRegionModeAssociationEnum', TV_DEFAULTREGIONMODE_ASSOCIATIONEND_DEFAULT + ', ' + // do not localize + AddEnumDef('DefaultRegionModeAssociationEnum', TV_DEFAULTREGIONMODE_ASSOCIATIONEND_DEFAULT + ', ' + TV_DEFAULTREGIONMODE_ASSOCIATIONEND_NONE + ', ' + TV_DEFAULTREGIONMODE_ASSOCIATIONEND_EXISTENCE + ', ' + TV_DEFAULTREGIONMODE_ASSOCIATIONEND_CASCADE + ', ' + @@ -113,23 +115,23 @@ procedure TBoldMMTVDefGen.Generate(FileName: string); AddEnumDef(ENUM_TAG_PERSISTENCE, TV_PERSISTENCE_PERSISTENT + ', ' + TV_PERSISTENCE_TRANSIENT); - GenTVList(ClassDefElement, BoldDefaultTaggedValueList.ListForClassName['Class'], BOLDTVPREFIX); // do not localize - GenTVList(AttrDefElement, BoldDefaultTaggedValueList.ListForClassName['Attribute'], BOLDTVPREFIX); // do not localize - GenTVList(AssocDefElement, BoldDefaultTaggedValueList.ListForClassName['Association'], BOLDTVPREFIX); // do not localize - GenTVList(AssocDefElement, BoldDefaultTaggedValueList.ListForClassName['AssociationEnd'], PREFIX_SOURCE_ASSOC_END + BOLDTVPREFIX); // do not localize - GenTVList(AssocDefElement, BoldDefaultTaggedValueList.ListForClassName['AssociationEnd'], PREFIX_TARGET_ASSOC_END + BOLDTVPREFIX); // do not localize - GenTVList(MethodDefElement, BoldDefaultTaggedValueList.ListForClassName['Operation'], BOLDTVPREFIX); // do not localize - GenTVList(ModelDefElement, BoldDefaultTaggedValueList.ListForClassName['Model'], PREFIX_MODEL + BOLDTVPREFIX); // do not localize - - GenTVList(ClassDefElement, UMLTaggedValueList.ListForClassName['Class'], ''); // do not localize - GenTVList(AttrDefElement, UMLTaggedValueList.ListForClassName['Attribute'], ''); // do not localize - GenTVList(AssocDefElement, UMLTaggedValueList.ListForClassName['Association'], ''); // do not localize - - GenTV(ClassDefElement, BOLDTVPREFIX + TAG_CONSTRAINTS, 'Text', ''); // do not localize - GenTV(AttrDefElement, BOLDTVPREFIX + TAG_CONSTRAINTS, 'Text', ''); // do not localize - GenTV(MethodDefElement, BOLDTVPREFIX + TAG_CONSTRAINTS, 'Text', ''); // do not localize - GenTV(AssocDefElement, PREFIX_SOURCE_ASSOC_END + BOLDTVPREFIX + TAG_CONSTRAINTS, 'Text', ''); // do not localize - GenTV(AssocDefElement, PREFIX_TARGET_ASSOC_END + BOLDTVPREFIX + TAG_CONSTRAINTS, 'Text', ''); // do not localize + GenTVList(ClassDefElement, BoldDefaultTaggedValueList.ListForClassName['Class'], BOLDTVPREFIX); + GenTVList(AttrDefElement, BoldDefaultTaggedValueList.ListForClassName['Attribute'], BOLDTVPREFIX); + GenTVList(AssocDefElement, BoldDefaultTaggedValueList.ListForClassName['Association'], BOLDTVPREFIX); + GenTVList(AssocDefElement, BoldDefaultTaggedValueList.ListForClassName['AssociationEnd'], PREFIX_SOURCE_ASSOC_END + BOLDTVPREFIX); + GenTVList(AssocDefElement, BoldDefaultTaggedValueList.ListForClassName['AssociationEnd'], PREFIX_TARGET_ASSOC_END + BOLDTVPREFIX); + GenTVList(MethodDefElement, BoldDefaultTaggedValueList.ListForClassName['Operation'], BOLDTVPREFIX); + GenTVList(ModelDefElement, BoldDefaultTaggedValueList.ListForClassName['Model'], PREFIX_MODEL + BOLDTVPREFIX); + + GenTVList(ClassDefElement, UMLTaggedValueList.ListForClassName['Class'], ''); + GenTVList(AttrDefElement, UMLTaggedValueList.ListForClassName['Attribute'], ''); + GenTVList(AssocDefElement, UMLTaggedValueList.ListForClassName['Association'], ''); + + GenTV(ClassDefElement, BOLDTVPREFIX + TAG_CONSTRAINTS, 'Text', ''); + GenTV(AttrDefElement, BOLDTVPREFIX + TAG_CONSTRAINTS, 'Text', ''); + GenTV(MethodDefElement, BOLDTVPREFIX + TAG_CONSTRAINTS, 'Text', ''); + GenTV(AssocDefElement, PREFIX_SOURCE_ASSOC_END + BOLDTVPREFIX + TAG_CONSTRAINTS, 'Text', ''); + GenTV(AssocDefElement, PREFIX_TARGET_ASSOC_END + BOLDTVPREFIX + TAG_CONSTRAINTS, 'Text', ''); fDoc.save(FileName); end; diff --git a/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMTVDefGenGUI.pas b/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMTVDefGenGUI.pas index 0506d792..0cb462ff 100644 --- a/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMTVDefGenGUI.pas +++ b/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMTVDefGenGUI.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldMMTVDefGenGUI; interface diff --git a/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMTVDefs.pas b/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMTVDefs.pas index b11c9cff..a2407bc9 100644 --- a/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMTVDefs.pas +++ b/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMTVDefs.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldMMTVDefs; interface diff --git a/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMTVEditor.pas b/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMTVEditor.pas index d8da4a92..e1a0b387 100644 --- a/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMTVEditor.pas +++ b/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMTVEditor.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldMMTVEditor; interface diff --git a/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMTVMemo.pas b/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMTVMemo.pas index 592439b5..c1e853d5 100644 --- a/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMTVMemo.pas +++ b/Source/UMLModel/ModelLinks/ModelMaker/MMPlugin/BoldMMTVMemo.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldMMTVMemo; interface diff --git a/Source/UMLModel/ModelLinks/ModelMaker/Support/BoldMMImporter.pas b/Source/UMLModel/ModelLinks/ModelMaker/Support/BoldMMImporter.pas index 8aff760e..bfdf3abe 100644 --- a/Source/UMLModel/ModelLinks/ModelMaker/Support/BoldMMImporter.pas +++ b/Source/UMLModel/ModelLinks/ModelMaker/Support/BoldMMImporter.pas @@ -1,7 +1,9 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldMMImporter; -interface - { TODO : Optimize datatype access in same way as roselink } +interface uses BoldUMLModel, @@ -14,7 +16,7 @@ interface aeTarget = 2; type - TPass = (PASS1, PASS2); // Pass1 = classes only, pass2 = attributes, inheritance and associations + TPass = (PASS1, PASS2); TMMModelImporter = class private @@ -45,12 +47,10 @@ implementation BoldDefaultTaggedValues, BoldTaggedValueSupport, BoldUMLTypes, - BoldUMLDelphiSupport, // Needs new version + BoldUMLDelphiSupport, BoldUMLModelLinkSupport ; -// Utility functions - function Prefix(name: string): string; begin result := Copy(name, 1, pos('.', name)); @@ -238,13 +238,10 @@ procedure TMMModelImporter.ImportAssociationProperty( TBoldUMLSupport.AddToolId(UMLAssociation, IntToStr(MMProperty.ID)); Name := MMProperty.Name; UMLAssociation.name := Name; - UMLAssociation.stereotypeName := MMProperty.Category; - {TODO : Persistance for Association. Add a tagged value, as in Rose} + UMLAssociation.stereotypeName := MMProperty.Category; UMLAssociation.visibility := UMLVisibility(MMProperty.Visibility); - // Create the two AssociationEnds, and pull information from the "visualisation" - // Treat ends separately + MMMemberVisualization := MMProperty as IMMMemberVisualization; - // Note! Order of source and target is important. Used when distributing TVs. SourceUMLAssociationEnd := UMLAssociation.connection.AddNew; TargetUMLAssociationEnd := UMLAssociation.connection.AddNew; GetTaggedValuesAndConstraints(MMProperty as IMMModelPart, UMLAssociation); @@ -325,8 +322,7 @@ procedure TMMModelImporter.ImportAttributeProperty(MMProperty: IMMProperty; Name := MMProperty.Name; UMLAttribute.name := Name; UMLAttribute.stereotypeName := MMProperty.Category; - GetTaggedValuesAndConstraints(MMProperty as IMMModelPart, UMLAttribute); - {TODO : Persistance for attributes. Add a tagged value, as in Rose} + GetTaggedValuesAndConstraints(MMProperty as IMMModelPart, UMLAttribute); UMLAttribute.typeName := MMProperty.DataName; if MMProperty.DefaultSpec = dsDefault then UMLAttribute.initialValue := MMProperty.DefaultSpecStr; @@ -341,7 +337,6 @@ procedure TMMModelImporter.ImportClass(MMClass: IMMClass; var i: integer; UMLClass: TUMLClass; -// MMV9ClassBase: IMMV9ClassBase; MMMember: IMMMember; name: string; begin @@ -359,11 +354,10 @@ procedure TMMModelImporter.ImportClass(MMClass: IMMClass; end; UMLClass.stereotypeName := MMClass.Category; UMLClass.isAbstract := MMClass.Options[classAbstract]; -// if MMClass.QueryInterface(IMMV9ClassBase, MMV9ClassBase) = S_OK then -// UMLClass.Persistent := MMV9ClassBase.IsPersistent; + GetTaggedValuesAndConstraints(MMClass as IMMModelPart, UMLClass); end - else // pass2 + else begin name := MMclass.Name; if name = 'TObject' then @@ -371,24 +365,24 @@ procedure TMMModelImporter.ImportClass(MMClass: IMMClass; name := 'BusinessClassesRoot'; end; - UMLClass := UMLPackage.EvaluateExpressionAsDirectElement(Format('classes->select(name=''%s'')->first', [Name])) as TUMLClass; { TODO : Locate by MM-id } + UMLClass := UMLPackage.EvaluateExpressionAsDirectElement(Format('classes->select(name=''%s'')->first', [Name])) as TUMLClass; Assert(Assigned(UMLClass)); if MMClass.Ancestor <> nil then - UMLClass.SetFirstParent(UMLPackage.EvaluateExpressionAsDirectElement(Format('classes->select(name=''%s'')->first', [MMClass.Ancestor.Name])) as TUMLClass); { TODO : Locate by MM-id } + UMLClass.SetFirstParent(UMLPackage.EvaluateExpressionAsDirectElement(Format('classes->select(name=''%s'')->first', [MMClass.Ancestor.Name])) as TUMLClass); for I := 0 to MMClass.MemberCount-1 do begin MMMember := MMClass.Members[i]; case MMMember.MemberType of cpResClause: - ; // Just ignore silently + ; cpField: - ; // Just ignore silently + ; cpMethod: ImportMethod(MMMember as IMMMethod, UMLClass); cpProperty: ImportProperty(MMMember as IMMProperty, UMLClass); cpEvent: - ; // Just ignore silently + ; else raise EBold.Create('Unknown Membertype'); end; @@ -404,7 +398,7 @@ procedure TMMModelImporter.ImportMethod(MMethod: IMMMethod; begin if (MMethod.MethodKind in [mkConstructor, mkDestructor]) or (MMethod.BindingKind = bkMessage) then - Exit; // Silently ignore constructors/destructors + Exit; UMLOperation := TUMLOperation.Create(UMLClass.BoldSystem); UMLOperation.owner := UMLClass; TBoldUMLSupport.EnsureBoldTaggedValues(UMLOperation); @@ -452,7 +446,7 @@ procedure TMMModelImporter.ImportProperty(MMProperty: IMMProperty; begin if Pass = PASS2 then begin - TypeAsUMLClass := UMLClass.namespace_.EvaluateExpressionAsDirectElement(Format('classes->select(name=''%s'')->first', [MMProperty.DataName])) as TUMLClass; { TODO : Locate by MM-id }; + TypeAsUMLClass := UMLClass.namespace_.EvaluateExpressionAsDirectElement(Format('classes->select(name=''%s'')->first', [MMProperty.DataName])) as TUMLClass; ; if Assigned(TypeAsUMLClass) then ImportAssociationProperty(MMProperty, UMLClass, TypeAsUMLClass) else @@ -469,7 +463,6 @@ procedure TMMModelImporter.ImportModel(MMModel: IMMCodeModel); begin ClassBase := MMModel.Classes[i]; if ClassBase.IsInterface then - // Nothing yet else ImportClass(ClassBase as IMMClass, fUMLModel) end; diff --git a/Source/UMLModel/ModelLinks/Rose98/BoldRose98TaggedValues.pas b/Source/UMLModel/ModelLinks/Rose98/BoldRose98TaggedValues.pas index 3ef1c6d2..2acfbf2f 100644 --- a/Source/UMLModel/ModelLinks/Rose98/BoldRose98TaggedValues.pas +++ b/Source/UMLModel/ModelLinks/Rose98/BoldRose98TaggedValues.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldRose98TaggedValues; interface @@ -30,59 +33,49 @@ TBoldRose98TaggedValueSupport = class function Rose98TaggedValueList: TBoldTaggedValuePerClassList; + implementation uses SysUtils, BoldDefaultTaggedValues, BoldDefs, - UMLConsts, - BoldUtils; + BoldUtils, + BoldRev; var G_Rose98TaggedValues: TBoldTaggedValuePerClassList = nil; procedure AddDefaultTaggedValues; begin -// Tagged values for Model - with G_Rose98TaggedValues.ListForClassName['Model'] do // do not localize + with G_Rose98TaggedValues.ListForClassName['Model'] do begin - Add('String', TAG_MODELNAME, 'BusinessClasses'); // do not localize - Add('Text', TAG_CONSTRAINTS, ''); // do not localize - Add('PTYVersionSet', // do not localize - 'PTYVersion', BOLDTVREV); // do not localize + Add('String', TAG_MODELNAME, 'BusinessClasses'); + Add('Text', TAG_CONSTRAINTS, ''); + Add('PTYVersionSet', + 'PTYVersion', BOLDTVREV); end; - -// Tagged values for Class - with G_Rose98TaggedValues.ListForClassName['Class'] do // do not localize + with G_Rose98TaggedValues.ListForClassName['Class'] do begin - Add('Text', TAG_CONSTRAINTS, ''); // do not localize + Add('Text', TAG_CONSTRAINTS, ''); end; - -// Tagged values for Association - with G_Rose98TaggedValues.ListForClassName['Association'] do // do not localize + with G_Rose98TaggedValues.ListForClassName['Association'] do begin end; - -// Tagged values for Attribute - with G_Rose98TaggedValues.ListForClassName['Attribute'] do // do not localize + with G_Rose98TaggedValues.ListForClassName['Attribute'] do begin - Add('Text', TAG_CONSTRAINTS, ''); // do not localize + Add('Text', TAG_CONSTRAINTS, ''); end; - -// Tagged values for AssociationEnd - with G_Rose98TaggedValues.ListForClassName['AssociationEnd'] do // do not localize + with G_Rose98TaggedValues.ListForClassName['AssociationEnd'] do begin - Add('ChangeabilityKind', // do not localize + Add('ChangeabilityKind', TAG_CHANGEABILITY, TV_CHANGEABILITY_CHANGEABLE); - Add('Text', TAG_CONSTRAINTS, ''); // do not localize + Add('Text', TAG_CONSTRAINTS, ''); end; - -// Tagged values for Operation - with G_Rose98TaggedValues.ListForClassName['Operation'] do // do not localize + with G_Rose98TaggedValues.ListForClassName['Operation'] do begin - Add('Text', TAG_CONSTRAINTS, ''); // do not localize - Add('Boolean', TAG_ISCLASSMETHOD, TV_FALSE); // do not localize + Add('Text', TAG_CONSTRAINTS, ''); + Add('Boolean', TAG_ISCLASSMETHOD, TV_FALSE); end; end; @@ -109,7 +102,7 @@ class function TBoldRose98TaggedValueSupport.ChangeableKindToString( ckAddOnly: Result := TV_CHANGEABILITY_ADDONLY; else - raise EBold.CreateFmt(sWrongValue, [ClassName, 'ChangeableKindToString']); // do not localize + raise EBold.CreateFmt('%s.ChangeableKindToString: Unknown TChangeableKind', [ClassName]); end; end; diff --git a/Source/UMLModel/ModelLinks/Rose98/BoldRose98ptyCreator.pas b/Source/UMLModel/ModelLinks/Rose98/BoldRose98ptyCreator.pas index ab687d86..dab59deb 100644 --- a/Source/UMLModel/ModelLinks/Rose98/BoldRose98ptyCreator.pas +++ b/Source/UMLModel/ModelLinks/Rose98/BoldRose98ptyCreator.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldRose98ptyCreator; interface @@ -15,7 +18,7 @@ TBoldRose98ptyCreator = class private fLeadingSpaces: integer; fList: TStrings; - fRoseEnums: TBoldTaggedValuePerClassList; // Slightly unorthodox reuse, ClassName=EnumName + fRoseEnums: TBoldTaggedValuePerClassList; procedure InitializeRoseEnums; procedure PutLine(const s: string); overload; procedure PutLine; overload; @@ -42,7 +45,7 @@ implementation sysutils, BoldDefaultTaggedValues, BoldUMLTaggedValues, - BoldUMLRose98Support, + BoldUMLRose98Support, BoldRose98TaggedValues; const @@ -67,131 +70,131 @@ constructor TBoldRose98ptyCreator.Create; procedure TBoldRose98ptyCreator.CreateContents; begin - PutLine('(object Petal version 40)'); // do not localize + PutLine('(object Petal version 40)'); PutLine; - PutLine('(list Attribute_Set'); // do not localize + PutLine('(list Attribute_Set'); Indent; - PutLine('(object Attribute tool "Bold" name "roseId" value "753117540")'); // do not localize - PutLine('(object Attribute tool "Bold" name "propertyId" value "809135966")'); // do not localize + PutLine('(object Attribute tool "Bold" name "roseId" value "753117540")'); + PutLine('(object Attribute tool "Bold" name "propertyId" value "809135966")'); - StartSection('Project', 'Model'); // do not localize - PutLine('## Enum Declarations'); // do not localize + StartSection('Project', 'Model'); + PutLine('## Enum Declarations'); PutLine; - PutEnumDefinition('OptimisticLockingSet'); // do not localize - PutEnumDefinition('NationalCharConversionEnum'); // do not localize + PutEnumDefinition('OptimisticLockingSet'); + PutEnumDefinition('NationalCharConversionEnum'); - PutLine('## Enum Declarations'); // do not localize + PutLine('## Enum Declarations'); PutLine; - PutLine('## This enum has only one value and is used to ensure the correct PTY-version when importing to BfD'); // do not localize - PutEnumDefinition('PTYVersionSet'); // do not localize + PutLine('## This enum has only one value and is used to ensure the correct PTY-version when importing to BfD'); + PutEnumDefinition('PTYVersionSet'); - PutTaggedValuesForClass('Model'); // do not localize - PutLine('## removed tagged values'); // do not localize - PutLine('## (object Attribute tool "Bold" name "DefaultMemberInfoClass" value "")'); // do not localize + PutTaggedValuesForClass('Model'); + PutLine('## removed tagged values'); + PutLine('## (object Attribute tool "Bold" name "DefaultMemberInfoClass" value "")'); EndSection; - PutSeparator('Class definitions'); // do not localize - PutLine('(object Attribute tool "Bold" name "default__Class" value'); // do not localize + PutSeparator('Class definitions'); + PutLine('(object Attribute tool "Bold" name "default__Class" value'); Indent; - PutLine('(list Attribute_Set'); // do not localize + PutLine('(list Attribute_Set'); Indent; PutLine; - PutLine('## Enum Declarations'); // do not localize + PutLine('## Enum Declarations'); PutLine; - PutEnumDefinition('EvolutionStateEnum'); // do not localize - PutEnumDefinition('TableMappingSet'); // do not localize - PutEnumDefinition('OptimisticLockingSet'); // do not localize + PutEnumDefinition('EvolutionStateEnum'); + PutEnumDefinition('TableMappingSet'); + PutEnumDefinition('OptimisticLockingSet'); PutEnumDefinition(ENUM_TAG_CLASS_STORAGE); - PutTaggedValuesForClass('Class'); // do not localize + PutTaggedValuesForClass('Class'); EndSection; - StartSection('Attribute', 'Attribute'); // do not localize - PutLine('## Enum Declarations'); // do not localize + StartSection('Attribute', 'Attribute'); + PutLine('## Enum Declarations'); PutLine; - PutEnumDefinition('AttributeKindSet'); // do not localize - PutEnumDefinition('DelphiPropertySet'); // do not localize - PutEnumDefinition('EvolutionStateEnum'); // do not localize + PutEnumDefinition('AttributeKindSet'); + PutEnumDefinition('DelphiPropertySet'); + PutEnumDefinition('EvolutionStateEnum'); PutEnumDefinition(ENUM_TAG_ATTRIBUTE_STORAGE); - PutTaggedValuesForClass('Attribute'); // do not localize - PutLine('## removed tagged values'); // do not localize - PutLine('## (object Attribute tool "Bold" name "MemberInfoClass" value "")'); // do not localize + PutTaggedValuesForClass('Attribute'); + PutLine('## removed tagged values'); + PutLine('## (object Attribute tool "Bold" name "MemberInfoClass" value "")'); EndSection; - PutSeparator('Attribute definitions STDUML'); // do not localize - PutLine(Format('(object Attribute tool "%s" name "roseId" value "753117540")', [BOLDSTDUMLTOOLNAME])); // do not localize - PutLine(Format('(object Attribute tool "%s" name "propertyId" value "809135966")', [BOLDSTDUMLTOOLNAME])); // do not localize + PutSeparator('Attribute definitions STDUML'); + PutLine(Format('(object Attribute tool "%s" name "roseId" value "753117540")', [BOLDSTDUMLTOOLNAME])); + PutLine(Format('(object Attribute tool "%s" name "propertyId" value "809135966")', [BOLDSTDUMLTOOLNAME])); PutLine; PutLine; - PutLine(Format('(object Attribute tool "%s" name "default__Attribute" value', [BOLDSTDUMLTOOLNAME])); // do not localize + PutLine(Format('(object Attribute tool "%s" name "default__Attribute" value', [BOLDSTDUMLTOOLNAME])); Indent; - PutLine('(list Attribute_Set'); // do not localize + PutLine('(list Attribute_Set'); PutLine; Indent; Indent; - PutLine('## Enum Declarations'); // do not localize + PutLine('## Enum Declarations'); PutLine; - PutLine(Format('(object Attribute tool "%s" name "PersistenceSet" value', [BOLDSTDUMLTOOLNAME])); // do not localize + PutLine(Format('(object Attribute tool "%s" name "PersistenceSet" value', [BOLDSTDUMLTOOLNAME])); Indent; - PutLine('(list Attribute_Set'); // do not localize - PutLine(Format(' (object Attribute tool "%s" name "%s" value 0)', [BOLDSTDUMLTOOLNAME, TV_PERSISTENCE_PERSISTENT])); // do not localize - PutLine(Format(' (object Attribute tool "%s" name "%s" value 1)', [BOLDSTDUMLTOOLNAME, TV_PERSISTENCE_TRANSIENT])); // do not localize + PutLine('(list Attribute_Set'); + PutLine(Format(' (object Attribute tool "%s" name "%s" value 0)', [BOLDSTDUMLTOOLNAME, TV_PERSISTENCE_PERSISTENT])); + PutLine(Format(' (object Attribute tool "%s" name "%s" value 1)', [BOLDSTDUMLTOOLNAME, TV_PERSISTENCE_TRANSIENT])); EndSection; PutLine; - PutLine(Format('(object Attribute tool "%s" name "%s" value ("PersistenceSet" 0))', [BOLDSTDUMLTOOLNAME, TAG_PERSISTENCE])); // do not localize + PutLine(Format('(object Attribute tool "%s" name "%s" value ("PersistenceSet" 0))', [BOLDSTDUMLTOOLNAME, TAG_PERSISTENCE])); EndSection; - StartSection('Association', 'Association'); // do not localize - PutLine('## Enum Declarations'); // do not localize - PutEnumDefinition('EvolutionStateEnum'); // do not localize + StartSection('Association', 'Association'); + PutLine('## Enum Declarations'); + PutEnumDefinition('EvolutionStateEnum'); PutEnumDefinition(ENUM_TAG_ASSOCIATION_STORAGE); - PutTaggedValuesForClass('Association'); // do not localize - PutLine('## removed tagged values:'); // do not localize - PutLine('## (object Attribute tool "Bold" name "LinkClassId" value -1)'); // do not localize + PutTaggedValuesForClass('Association'); + PutLine('## removed tagged values:'); + PutLine('## (object Attribute tool "Bold" name "LinkClassId" value -1)'); EndSection; - PutSeparator(' Association definitions STDUML'); // do not localize + PutSeparator(' Association definitions STDUML'); Indent; - PutLine(Format('(object Attribute tool "%s" name "roseId" value "753117540")', [BOLDSTDUMLTOOLNAME])); // do not localize - PutLine(Format('(object Attribute tool "%s" name "propertyId" value "809135966")', [BOLDSTDUMLTOOLNAME])); // do not localize + PutLine(Format('(object Attribute tool "%s" name "roseId" value "753117540")', [BOLDSTDUMLTOOLNAME])); + PutLine(Format('(object Attribute tool "%s" name "propertyId" value "809135966")', [BOLDSTDUMLTOOLNAME])); PutLine; - PutLine(Format('(object Attribute tool "%s" name "default__Association" value', [BOLDSTDUMLTOOLNAME])); // do not localize + PutLine(Format('(object Attribute tool "%s" name "default__Association" value', [BOLDSTDUMLTOOLNAME])); Indent; - PutLine('(list Attribute_Set'); // do not localize + PutLine('(list Attribute_Set'); Indent; - PutLine(Format('(object Attribute tool "%s" name "PersistenceSet" value', [BOLDSTDUMLTOOLNAME])); // do not localize + PutLine(Format('(object Attribute tool "%s" name "PersistenceSet" value', [BOLDSTDUMLTOOLNAME])); Indent; - PutLine('(list Attribute_Set'); // do not localize - PutLine(Format(' (object Attribute tool "%s" name "%s" value 0)', [BOLDSTDUMLTOOLNAME, TV_PERSISTENCE_PERSISTENT])); // do not localize - PutLine(Format(' (object Attribute tool "%s" name "%s" value 1)', [BOLDSTDUMLTOOLNAME, TV_PERSISTENCE_TRANSIENT])); // do not localize + PutLine('(list Attribute_Set'); + PutLine(Format(' (object Attribute tool "%s" name "%s" value 0)', [BOLDSTDUMLTOOLNAME, TV_PERSISTENCE_PERSISTENT])); + PutLine(Format(' (object Attribute tool "%s" name "%s" value 1)', [BOLDSTDUMLTOOLNAME, TV_PERSISTENCE_TRANSIENT])); EndSection; PutLine; - PutLine(Format('(object Attribute tool "%s" name "%s" value ("PersistenceSet" 0))', [BOLDSTDUMLTOOLNAME, TAG_PERSISTENCE])); // do not localize + PutLine(Format('(object Attribute tool "%s" name "%s" value ("PersistenceSet" 0))', [BOLDSTDUMLTOOLNAME, TAG_PERSISTENCE])); EndSection; - StartSection('Role', 'AssociationEnd'); // do not localize - PutEnumDefinition('DeleteActions'); // do not localize - PutEnumDefinition('ChangeabilityKind'); // do not localize - PutEnumDefinition('DefaultRegionModeAssociationEnum'); // do not localize - PutTaggedValuesForClass('AssociationEnd'); // do not localize + StartSection('Role', 'AssociationEnd'); + PutEnumDefinition('DeleteActions'); + PutEnumDefinition('ChangeabilityKind'); + PutEnumDefinition('DefaultRegionModeAssociationEnum'); + PutTaggedValuesForClass('AssociationEnd'); - PutLine('## removed tagged values'); // do not localize - PutLine('## (object Attribute tool "Bold" name "MemberInfoClass" value "")'); // do not localize + PutLine('## removed tagged values'); + PutLine('## (object Attribute tool "Bold" name "MemberInfoClass" value "")'); EndSection; - StartSection('Operation', 'Operation'); // do not localize - PutLine('## Enum Declarations'); // do not localize + StartSection('Operation', 'Operation'); + PutLine('## Enum Declarations'); PutLine; - PutEnumDefinition('BoldOperationKindSet'); // do not localize - PutTaggedValuesForClass('Operation'); // do not localize + PutEnumDefinition('BoldOperationKindSet'); + PutTaggedValuesForClass('Operation'); EndSection; - PutSeparator('Module definitions'); // do not localize - PutLine('(object Attribute tool "Bold" name "default__Module-Spec" value'); // do not localize + PutSeparator('Module definitions'); + PutLine('(object Attribute tool "Bold" name "default__Module-Spec" value'); Indent; - PutLine('(list Attribute_Set'); // do not localize + PutLine('(list Attribute_Set'); Indent; - PutLine('(object Attribute tool "Bold" name "CopyrightNotice" value "")'); // do not localize - PutLine('(object Attribute tool "Bold" name "FileName" value ".inc")'); // do not localize + PutLine('(object Attribute tool "Bold" name "CopyrightNotice" value "")'); + PutLine('(object Attribute tool "Bold" name "FileName" value ".inc")'); EndSection; Dedent; PutLine(')'); @@ -214,7 +217,7 @@ procedure TBoldRose98ptyCreator.Indent; Inc(fLeadingSpaces, INDENTSIZE); end; -procedure TBoldRose98ptyCreator.PutSeparator(const s: string); +procedure TBoldRose98ptyCreator.PutSeparator(const s: string); begin PutLine; PutLine(StringOfChar('#', 60)); @@ -227,7 +230,7 @@ procedure TBoldRose98ptyCreator.PutTaggedValuesForClass(const UMLName: string); var i: integer; begin - PutLine(Format('## Tagged values for %s', [UMLName])); // do not localize + PutLine(Format('## Tagged values for %s', [UMLName])); PutLine; with BoldDefaultTaggedValueList.ListForClassName[UMLName] do for i := 0 to Count - 1 do @@ -241,96 +244,96 @@ procedure TBoldRose98ptyCreator.PutTaggedValuesForClass(const UMLName: string); procedure TBoldRose98ptyCreator.InitializeRoseEnums; begin fRoseEnums := TBoldTaggedValuePerClassList.Create; - with fRoseEnums.ListForClassName['AttributeKindSet'] do // do not localize + with fRoseEnums.ListForClassName['AttributeKindSet'] do begin - Add('Integer', TV_ATTRIBUTEKIND_BOLD, '0'); // do not localize - Add('Integer', TV_ATTRIBUTEKIND_DELPHI, '1'); // do not localize + Add('Integer', TV_ATTRIBUTEKIND_BOLD, '0'); + Add('Integer', TV_ATTRIBUTEKIND_DELPHI, '1'); end; - with fRoseEnums.ListForClassName['BoldOperationKindSet'] do // do not localize + with fRoseEnums.ListForClassName['BoldOperationKindSet'] do begin - Add('Integer', TV_DELPHIOPERATIONKIND_NORMAL, '200'); // do not localize - Add('Integer', TV_DELPHIOPERATIONKIND_VIRTUAL, '201'); // do not localize - Add('Integer', TV_DELPHIOPERATIONKIND_ABSTRACTVIRTUAL, '204'); // do not localize - Add('Integer', TV_DELPHIOPERATIONKIND_DYNAMIC, '203'); // do not localize - Add('Integer', TV_DELPHIOPERATIONKIND_OVERRIDE, '202'); // do not localize + Add('Integer', TV_DELPHIOPERATIONKIND_NORMAL, '200'); + Add('Integer', TV_DELPHIOPERATIONKIND_VIRTUAL, '201'); + Add('Integer', TV_DELPHIOPERATIONKIND_ABSTRACTVIRTUAL, '204'); + Add('Integer', TV_DELPHIOPERATIONKIND_DYNAMIC, '203'); + Add('Integer', TV_DELPHIOPERATIONKIND_OVERRIDE, '202'); end; - with fRoseEnums.ListForClassName['ChangeabilityKind'] do // do not localize + with fRoseEnums.ListForClassName['ChangeabilityKind'] do begin - Add('Integer', TV_CHANGEABILITY_ADDONLY, '0'); // do not localize - Add('Integer', TV_CHANGEABILITY_CHANGEABLE, '1'); // do not localize - Add('Integer', TV_CHANGEABILITY_FROZEN, '2'); // do not localize + Add('Integer', TV_CHANGEABILITY_ADDONLY, '0'); + Add('Integer', TV_CHANGEABILITY_CHANGEABLE, '1'); + Add('Integer', TV_CHANGEABILITY_FROZEN, '2'); end; - with fRoseEnums.ListForClassName['DeleteActions'] do // do not localize + with fRoseEnums.ListForClassName['DeleteActions'] do begin - Add('Integer', TV_DELETEACTION_DEFAULT, '0'); // do not localize - Add('Integer', TV_DELETEACTION_ALLOW, '1'); // do not localize - Add('Integer', TV_DELETEACTION_PROHIBIT, '2'); // do not localize - Add('Integer', TV_DELETEACTION_CASCADE, '3'); // do not localize + Add('Integer', TV_DELETEACTION_DEFAULT, '0'); + Add('Integer', TV_DELETEACTION_ALLOW, '1'); + Add('Integer', TV_DELETEACTION_PROHIBIT, '2'); + Add('Integer', TV_DELETEACTION_CASCADE, '3'); end; - with fRoseEnums.ListForClassName['DelphiPropertySet'] do // do not localize + with fRoseEnums.ListForClassName['DelphiPropertySet'] do begin - Add('Integer', TV_DPNONE, '0'); // do not localize - Add('Integer', TV_DPFIELD, '1'); // do not localize - Add('Integer', TV_DPPRIVATEMETHOD, '2'); // do not localize - Add('Integer', TV_DPPROTECTEDVIRTUALMETHOD, '3'); // do not localize + Add('Integer', TV_DPNONE, '0'); + Add('Integer', TV_DPFIELD, '1'); + Add('Integer', TV_DPPRIVATEMETHOD, '2'); + Add('Integer', TV_DPPROTECTEDVIRTUALMETHOD, '3'); end; - with fRoseEnums.ListForClassName['EvolutionStateEnum'] do // do not localize + with fRoseEnums.ListForClassName['EvolutionStateEnum'] do begin - Add('Integer', TV_EVOLUTIONSTATE_NORMAL, '0'); // do not localize - Add('Integer', TV_EVOLUTIONSTATE_TOBEREMOVED, '1'); // do not localize - Add('Integer', TV_EVOLUTIONSTATE_REMOVED, '2'); // do not localize + Add('Integer', TV_EVOLUTIONSTATE_NORMAL, '0'); + Add('Integer', TV_EVOLUTIONSTATE_TOBEREMOVED, '1'); + Add('Integer', TV_EVOLUTIONSTATE_REMOVED, '2'); end; - with fRoseEnums.ListForClassName['NationalCharConversionEnum'] do // do not localize + with fRoseEnums.ListForClassName['NationalCharConversionEnum'] do begin - Add('Integer', TV_NATIONALCHARCONVERSION_DEFAULT, '0'); // do not localize - Add('Integer', TV_NATIONALCHARCONVERSION_TRUE, '1'); // do not localize - Add('Integer', TV_NATIONALCHARCONVERSION_FALSE, '2'); // do not localize + Add('Integer', TV_NATIONALCHARCONVERSION_DEFAULT, '0'); + Add('Integer', TV_NATIONALCHARCONVERSION_TRUE, '1'); + Add('Integer', TV_NATIONALCHARCONVERSION_FALSE, '2'); end; - with fRoseEnums.ListForClassName['OptimisticLockingSet'] do // do not localize + with fRoseEnums.ListForClassName['OptimisticLockingSet'] do begin - Add('Integer', TV_OPTIMISTICLOCKING_DEFAULT, '0'); // do not localize - Add('Integer', TV_OPTIMISTICLOCKING_OFF, '1'); // do not localize - Add('Integer', TV_OPTIMISTICLOCKING_MODIFIEDMEMBERS, '2'); // do not localize - Add('Integer', TV_OPTIMISTICLOCKING_ALLMEMBERS, '3'); // do not localize - Add('Integer', TV_OPTIMISTICLOCKING_TIMESTAMP, '4'); // do not localize + Add('Integer', TV_OPTIMISTICLOCKING_DEFAULT, '0'); + Add('Integer', TV_OPTIMISTICLOCKING_OFF, '1'); + Add('Integer', TV_OPTIMISTICLOCKING_MODIFIEDMEMBERS, '2'); + Add('Integer', TV_OPTIMISTICLOCKING_ALLMEMBERS, '3'); + Add('Integer', TV_OPTIMISTICLOCKING_TIMESTAMP, '4'); end; - with fRoseEnums.ListForClassName['TableMappingSet'] do // do not localize + with fRoseEnums.ListForClassName['TableMappingSet'] do begin - Add('Integer', TV_TABLEMAPPING_OWN, '0'); // do not localize - Add('Integer', TV_TABLEMAPPING_PARENT, '1'); // do not localize - Add('Integer', TV_TABLEMAPPING_CHILDREN, '2'); // do not localize - Add('Integer', TV_TABLEMAPPING_IMPORTED, '3'); // do not localize + Add('Integer', TV_TABLEMAPPING_OWN, '0'); + Add('Integer', TV_TABLEMAPPING_PARENT, '1'); + Add('Integer', TV_TABLEMAPPING_CHILDREN, '2'); + Add('Integer', TV_TABLEMAPPING_IMPORTED, '3'); end; - with fRoseEnums.ListForClassName['DefaultRegionModeAssociationEnum'] do // do not localize + with fRoseEnums.ListForClassName['DefaultRegionModeAssociationEnum'] do begin - Add('Integer', TV_DEFAULTREGIONMODE_ASSOCIATIONEND_DEFAULT, '0'); // do not localize - Add('Integer', TV_DEFAULTREGIONMODE_ASSOCIATIONEND_NONE, '1'); // do not localize - Add('Integer', TV_DEFAULTREGIONMODE_ASSOCIATIONEND_EXISTENCE, '2'); // do not localize - Add('Integer', TV_DEFAULTREGIONMODE_ASSOCIATIONEND_CASCADE, '3'); // do not localize - Add('Integer', TV_DEFAULTREGIONMODE_ASSOCIATIONEND_INDEPENDENTCASCADE, '4'); // do not localize + Add('Integer', TV_DEFAULTREGIONMODE_ASSOCIATIONEND_DEFAULT, '0'); + Add('Integer', TV_DEFAULTREGIONMODE_ASSOCIATIONEND_NONE, '1'); + Add('Integer', TV_DEFAULTREGIONMODE_ASSOCIATIONEND_EXISTENCE, '2'); + Add('Integer', TV_DEFAULTREGIONMODE_ASSOCIATIONEND_CASCADE, '3'); + Add('Integer', TV_DEFAULTREGIONMODE_ASSOCIATIONEND_INDEPENDENTCASCADE, '4'); end; - fRoseEnums.ListForClassName['PTYVersionSet'].Add('Integer', BOLDTVREV, '0'); // do not localize + fRoseEnums.ListForClassName['PTYVersionSet'].Add('Integer', BOLDTVREV, '0'); with fRoseEnums.ListForClassName[ENUM_TAG_CLASS_STORAGE] do begin - Add('Integer', TV_STORAGE_INTERNAL, '0'); // do not localize - Add('Integer', TV_STORAGE_PARTIALLYEXTERNAL, '1'); // do not localize - Add('Integer', TV_STORAGE_EXTERNAL, '2'); // do not localize + Add('Integer', TV_STORAGE_INTERNAL, '0'); + Add('Integer', TV_STORAGE_PARTIALLYEXTERNAL, '1'); + Add('Integer', TV_STORAGE_EXTERNAL, '2'); end; with fRoseEnums.ListForClassName[ENUM_TAG_ASSOCIATION_STORAGE] do begin - Add('Integer', TV_STORAGE_INTERNAL, '0'); // do not localize - Add('Integer', TV_STORAGE_EXTERNAL, '1'); // do not localize + Add('Integer', TV_STORAGE_INTERNAL, '0'); + Add('Integer', TV_STORAGE_EXTERNAL, '1'); end; with fRoseEnums.ListForClassName[ENUM_TAG_ATTRIBUTE_STORAGE] do begin - Add('Integer', TV_STORAGE_INTERNAL, '0'); // do not localize - Add('Integer', TV_STORAGE_EXTERNAL, '1'); // do not localize - Add('Integer', TV_STORAGE_EXTERNALKEY, '2'); // do not localize + Add('Integer', TV_STORAGE_INTERNAL, '0'); + Add('Integer', TV_STORAGE_EXTERNAL, '1'); + Add('Integer', TV_STORAGE_EXTERNALKEY, '2'); end; end; @@ -340,18 +343,18 @@ procedure TBoldRose98ptyCreator.PutRoseAttribute(TaggedValue: TBoldTaggedValueDe begin With TaggedValue do begin - if TypeName = 'String' then // do not localize + if TypeName = 'String' then ValueString := Format('"%s"', [DefaultValue]) - else if TypeName = 'Boolean' then // do not localize + else if TypeName = 'Boolean' then ValueString := UpperCase(DefaultValue) - else if TypeName = 'Integer' then // do not localize + else if TypeName = 'Integer' then ValueString := DefaultValue - else if TypeName = 'Text' then // do not localize - ValueString := Format('(value Text "%s")', [DefaultValue]) // do not localize + else if TypeName = 'Text' then + ValueString := Format('(value Text "%s")', [DefaultValue]) else - ValueString := Format('("%s" %s)', [TypeName, LookupRoseEnumValue(TypeName, DefaultValue)]); // do not localize + ValueString := Format('("%s" %s)', [TypeName, LookupRoseEnumValue(TypeName, DefaultValue)]); - PutLine(Format('(object Attribute tool "Bold" name %-33s value %s)', ['"' + Tag + '"', ValueString])); // do not localize + PutLine(Format('(object Attribute tool "Bold" name %-33s value %s)', ['"' + Tag + '"', ValueString])); end; end; @@ -375,9 +378,9 @@ procedure TBoldRose98ptyCreator.PutEnumDefinition(const EnumName: string); var i: integer; begin - PutLine(Format('(object Attribute tool "Bold" name "%s" value', [EnumName])); // do not localize + PutLine(Format('(object Attribute tool "Bold" name "%s" value', [EnumName])); Indent; - PutLine('(list Attribute_Set'); // do not localize + PutLine('(list Attribute_Set'); Indent; with fRoseEnums.ListForClassName[EnumName] do for i := 0 to Count - 1 do @@ -396,10 +399,10 @@ procedure TBoldRose98ptyCreator.EndSection; procedure TBoldRose98ptyCreator.StartSection(const RoseName, UMLName: string); begin - putSeparator(Format('%s definitions', [UMLName])); // do not localize - PutLine(Format('(object Attribute tool "Bold" name "default__%s" value', [RoseName])); // do not localize + putSeparator(Format('%s definitions', [UMLName])); + PutLine(Format('(object Attribute tool "Bold" name "default__%s" value', [RoseName])); Indent; - PutLine('(list Attribute_Set'); // do not localize + PutLine('(list Attribute_Set'); Indent; PutLine; end; @@ -409,4 +412,6 @@ procedure TBoldRose98ptyCreator.PutLine; PutLine(''); end; +initialization + end. diff --git a/Source/UMLModel/ModelLinks/Rose98/BoldUMLRose98Link.pas b/Source/UMLModel/ModelLinks/Rose98/BoldUMLRose98Link.pas index 97b9c1c3..17eafe4e 100644 --- a/Source/UMLModel/ModelLinks/Rose98/BoldUMLRose98Link.pas +++ b/Source/UMLModel/ModelLinks/Rose98/BoldUMLRose98Link.pas @@ -1,8 +1,8 @@ -unit BoldUMLRose98Link; -{ TODO : Use new signature support methods on import to. } -{ TODO : Write specific importer for Rose2K } -{$WARN SYMBOL_PLATFORM OFF} // WINDOWS only +{ Global compiler directives } +{$include bold.inc} +unit BoldUMLRose98Link; +{$WARN SYMBOL_PLATFORM OFF} interface @@ -28,6 +28,7 @@ TBoldUMLRose98Link = class; TRoseLinkPass = (Pass1, Pass2); { TBoldRoseLink } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldUMLRoseLink = class(TBoldUMLModelLink) private fFileName: string; @@ -43,7 +44,7 @@ TBoldUMLRoseLink = class(TBoldUMLModelLink) fImplicitRolesUMLCompliant: Boolean; fMapping: TBoldUMLRose98MappingUtils; fGetToolIdOnExport: Boolean; - function DefaultLogicalPackage: IRoseCategory; + function DefaultLogicalPackage: IRoseCategory; {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure EnsureModel; procedure ExportAssociation(UMLAssociation: TUMLAssociation; RoseAssociation : IRoseAssociation); procedure EnsureandExportAssociations(TheModel: TUMLModel); @@ -65,20 +66,20 @@ TBoldUMLRoseLink = class(TBoldUMLModelLink) procedure ImportQualifier(RoseAttribute: IRoseAttribute; UMLAssociationEnd: TUMLAssociationEnd); procedure ImportSignature(RoseOperation: IRoseOperation; UMLOperation: TUMLOperation); procedure ImportConstraints(RoseItem: IRoseItem; UMLElement: TUMLModelElement); - procedure SetLogicalPackages(Value: TStrings); - procedure SetTools(Value: TStrings); + procedure SetLogicalPackages(Value: TStrings); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetTools(Value: TStrings); {$IFDEF BOLD_INLINE} inline; {$ENDIF} property RoseModel: IRoseModel read fRoseModel; - function GetBoldSystem: TBoldSystem; + function GetBoldSystem: TBoldSystem; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function FindPackage(const UniqueId: String): TUMLPackage; procedure RefreshCache(var Cache: TStringList; FilterType: TClass); function FindInCache(Cache: TStringList; UniqueId: string): TUMLElement; - procedure ReadObsoleteProperty(Reader: TReader; const PropertyName, NewPropertyName: string); // Compatibility - procedure ReadObsoletePluralSuffix(Reader: TReader); // Compatibility - procedure ReadObsoletMultiplicityForRoles(Reader: TReader); // Compatibility - procedure ReadObsoleteMultiplicityForNonNavigableRoles(Reader: TReader); - function GetLogicalPackages: TStrings; - function GetIncludeSubPackages: Boolean; - procedure SetIncludeSubPackages(const Value: Boolean); + procedure ReadObsoleteProperty(Reader: TReader; const PropertyName, NewPropertyName: string); + procedure ReadObsoletePluralSuffix(Reader: TReader); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure ReadObsoletMultiplicityForRoles(Reader: TReader); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure ReadObsoleteMultiplicityForNonNavigableRoles(Reader: TReader); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetLogicalPackages: TStrings; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetIncludeSubPackages: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetIncludeSubPackages(const Value: Boolean); {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected function GetCanExport: Boolean; override; function GetDisplayName: string; override; @@ -106,9 +107,10 @@ TBoldUMLRoseLink = class(TBoldUMLModelLink) property GetToolIdOnExport: Boolean read fGetToolIdOnExport write fGetToolIdOnExport default true; end; - { TBoldUMLRose98Link } - TBoldUMLRose98Link = class(TBoldUMLRoseLink) - end; + { TBoldUMLRose98Link } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] + TBoldUMLRose98Link = class(TBoldUMLRoseLink) + end; const ROSE_LINKEXTENSION: string = '.mdl'; @@ -270,20 +272,16 @@ procedure TBoldUMLRoseLink.ImportAssociation(RoseAssociation: IRoseAssociation; TBoldUMLSupport.AddToolId(UMLAssociation, RoseAssociation.getUniqueId); RoseProp.GetTaggedValues(RoseItem, (UMLAssociation as TUMLModelElement), Tools); - - // "unroseify" the standard tagged values TVPersistence := taggedValue[BOLDSTDUMLTOOLNAME + '.' + TAG_PERSISTENCE ]; if not assigned(TVPersistence) then - TVPersistence := taggedValue[ BOLDSTDUMLTOOLNAME + '.' + 'Persistence' ]; // do not localize + TVPersistence := taggedValue[ BOLDSTDUMLTOOLNAME + '.' + 'Persistence' ]; if assigned(TVPersistence) then TVPersistence.tag := TAG_PERSISTENCE; - - // if both tagged values existed in the model, then remove the obsolete. - TVPersistence := taggedValue[ BOLDSTDUMLTOOLNAME + '.' + 'Persistence' ]; // do not localize + TVPersistence := taggedValue[ BOLDSTDUMLTOOLNAME + '.' + 'Persistence' ]; if assigned(TVPersistence) then TVPersistence.Delete; - TVPersistence := taggedValue[BOLDSTDUMLTOOLNAME + '.' + 'PersistenceSet']; // do not localize + TVPersistence := taggedValue[BOLDSTDUMLTOOLNAME + '.' + 'PersistenceSet']; if assigned(TVPersistence) then TVPersistence.Delete; @@ -316,19 +314,16 @@ procedure TBoldUMLRoseLink.ImportAttribute(RoseAttribute: IRoseAttribute; UMLAtt Name := RoseAttribute.Name; TBoldUMLSupport.AddToolId(UMLAttribute, RoseAttribute.getUniqueId); RoseProp.GetTaggedValues(RoseItem, (UMLAttribute as TUMLModelElement), Tools); - // "unroseify" the standard tagged values TVPersistence := taggedValue[ BOLDSTDUMLTOOLNAME + '.' + TAG_PERSISTENCE ]; if not assigned(TVPersistence) then - TVPersistence := taggedValue[ BOLDSTDUMLTOOLNAME + '.' + 'Persistence' ]; // do not localize + TVPersistence := taggedValue[ BOLDSTDUMLTOOLNAME + '.' + 'Persistence' ]; if assigned(TVPersistence) then TVPersistence.tag := TAG_PERSISTENCE; - - // if both tagged values existed in the model, then remove the obsolete. - TVPersistence := taggedValue[ BOLDSTDUMLTOOLNAME + '.' + 'Persistence' ]; // do not localize + TVPersistence := taggedValue[ BOLDSTDUMLTOOLNAME + '.' + 'Persistence' ]; if assigned(TVPersistence) then TVPersistence.Delete; - TVPersistence := taggedValue[BOLDSTDUMLTOOLNAME + '.' + 'PersistenceSet']; // do not localize + TVPersistence := taggedValue[BOLDSTDUMLTOOLNAME + '.' + 'PersistenceSet']; if assigned(TVPersistence) then TVPersistence.Delete; @@ -400,10 +395,10 @@ procedure TBoldUMLRoseLink.ImportClass(RoseClass: IRoseClass; UMLClass: TUMLClas ImportOperation(RoseOperation, UMLOperation); end; end - else // pass2 + else case RoseClass.GetSuperClasses.Count of 0: - ; // no action + ; 1: SetFirstParent(fMapping.FindClass(RoseClass.GetSuperClasses.GetAt(1).GetUniqueID)); else @@ -441,7 +436,7 @@ procedure TBoldUMLRoseLink.ImportOperation(RoseOperation: IRoseOperation; UMLOpe TBoldUMLSupport.EnsureBoldTaggedValues(NewParameter); with NewParameter do begin - name := 'return'; // do not localize + name := 'return'; kind := pdReturn; SetBoldTV(TAG_EXPRESSIONNAME, RoseProp.GetString(RoseItem, TAG_EXPRESSIONNAME, TV_NAME)); type_ := GetEnsuredUMLDataType(RoseOperation.ReturnType); @@ -451,10 +446,6 @@ procedure TBoldUMLRoseLink.ImportOperation(RoseOperation: IRoseOperation; UMLOpe end; procedure TBoldUMLRoseLink.ImportSignature(RoseOperation: IRoseOperation; UMLOperation: TUMLOperation); -const - var_var = 'VAR '; - var_out = 'OUT '; - var_const = 'CONST '; var Index: Integer; RoseParams: IRoseParameterCollection; @@ -474,27 +465,25 @@ procedure TBoldUMLRoseLink.ImportSignature(RoseOperation: IRoseOperation; UMLOpe TBoldUMLSupport.AddToolId(UMLParameter, RoseParam.getUniqueId); UMLParameter.StereotypeName := RoseParam.Stereotype; UMLParameter.type_ := GetEnsuredUMLDataType(RoseParam.Type_); - - //Check for occurence of "var" and "const"... ParamName := UMLParameter.Name; - if Pos(var_var, UpperCase(ParamName)) > 0 then + if Pos(UpperCase('var '), UpperCase(ParamName)) > 0 then begin UMLParameter.SetBoldTV(TAG_ISCONST, TV_FALSE); UMLParameter.kind := pdInOut; - Delete(ParamName, Pos(var_var, UpperCase(ParamName)), Length(var_var)); + Delete(ParamName, Pos(UpperCase('var '), UpperCase(ParamName)), Length('var ')); UMLParameter.Name := ParamName; end - else if Pos(var_out, UpperCase(ParamName)) > 0 then + else if Pos(UpperCase('out '), UpperCase(ParamName)) > 0 then begin UMLParameter.SetBoldTV(TAG_ISCONST, TV_FALSE); UMLParameter.kind := pdOut; - Delete(ParamName, Pos(var_out, UpperCase(ParamName)), Length(var_out)); + Delete(ParamName, Pos(UpperCase('out '), UpperCase(ParamName)), Length('out ')); UMLParameter.Name := ParamName; end - else if Pos(var_const, UpperCase(ParamName)) > 0 then + else if Pos(UpperCase('const '), UpperCase(ParamName)) > 0 then begin UMLParameter.SetBoldTV(TAG_ISCONST, TV_TRUE); - Delete(ParamName, Pos(var_const, UpperCase(ParamName)), Length(var_const)); + Delete(ParamName, Pos(UpperCase('const '), UpperCase(ParamName)), Length('const ')); UMLParameter.Name := ParamName; end; end; @@ -563,11 +552,9 @@ procedure SplitVersion(Version: string; var Major, Minor: string); Assert(UMLModel.Associations.Count = 0); BoldLog.ProgressMax := 2 * RoseModel.GetAllClasses.Count + RoseModel.GetAllAssociations.Count + RoseModel.GetAllCategories.Count; BoldLog.Progress := 0; - // import tagged values for the model first, to initialize what is overriden RoseProp.GetTaggedValues(RoseItem, UMLModel, Tools); ImportPackage(RoseModel.RootCategory, UMLModel, pass1); - // reimport the tagged values for the model since it is overwritten by the top-package... - // this is a workaround... why is the top rose package imported to the UMLModel? + RoseProp.GetTaggedValues(RoseItem, UMLModel, Tools); if not BoldLog.ProcessInterruption then ImportPackage(RoseModel.RootCategory, UMLModel, pass2); @@ -621,7 +608,7 @@ procedure TBoldUMLRoseLink.ImportRole(RoseRole: IRoseRole; OtherRole: IRoseRole; if AdjustEmbedFlag and (UMLAssociationEnd.Multi or assigned(UMLAssociationEnd.Association.Class_)) then UMLAssociationEnd.SetBoldTV(TAG_EMBED, TV_FALSE); - with RoseRole.Keys do // Rose seems to publish the qualifiers at the wrong end, compared to the UML + with RoseRole.Keys do for i := 1 to Count do ImportQualifier(GetAt(I), UMLAssociationEnd); end; end; @@ -713,7 +700,7 @@ procedure TBoldUMLRoseLink.ExportAssociation(UMLAssociation: TUMLAssociation; Ro RoseLinkClassName := RoseProp.GetString(RoseItem, TAG_LINKCLASSNAME, TV_NAME); if CompareText(BoldExpandName(RoseLinkClassName, RoseAssociation.Name, xtDelphi, -1, TBoldTaggedValueSupport.StringToNationalCharConversion(UMLAssociation.model.GetBoldTV(TAG_NATIONALCHARCONVERSION))), UMLAssociation.Class_.Name) <> 0 then - RoseProp.SetString(RoseItem, 'LinkClassName', TV_NAME, UMLAssociation.Class_.Name, LogName); // do not localize + RoseProp.SetString(RoseItem, 'LinkClassName', TV_NAME, UMLAssociation.Class_.Name, LogName); end else RoseAssociation.LinkClass := LinkClass; @@ -800,7 +787,6 @@ procedure TBoldUMLRoseLink.ExportClass(UMLClass: TUMLClass); RoseItem := RoseClass as IRoseItem; with UMLClass do begin - // properties RoseProp.SetTaggedValues(RoseItem, UMLClass, Tools); ExportConstraints(RoseItem, UMLClass); if RoseClass.Stereotype <> StereotypeName then @@ -823,7 +809,6 @@ procedure TBoldUMLRoseLink.ExportClass(UMLClass: TUMLClass); BoldLog.LogFmt('Setting %s.Persistence to %s', [LogName, BooleanToString(Persistent)]); RoseClass.Persistence := Persistent; end; - // Trim attributes RoseAttributes := RoseClass.Attributes; I := 1; while I <= RoseAttributes.Count do @@ -839,7 +824,6 @@ procedure TBoldUMLRoseLink.ExportClass(UMLClass: TUMLClass); I := 1; end; end; - // Trim operations RoseOperations := RoseClass.Operations; I := 1; while I <= RoseOperations.Count do @@ -873,7 +857,7 @@ procedure TBoldUMLRoseLink.ExportOperation(UMLOperation: TUMLOperation; RoseClas UMLReturnType: TUMLClassifier; begin LogName := TBoldUMLRose98Properties.LogName(UMLOperation); - UMLReturnType := UMLOperation.EvaluateExpressionAsDirectElement('parameter->select(kind=#return)->first.type->first') as TUMLClassifier; // do not localize + UMLReturnType := UMLOperation.EvaluateExpressionAsDirectElement('parameter->select(kind=#return)->first.type->first') as TUMLClassifier; if ASsigned(UMLReturnType) then ReturnTypeName := UMLReturnType.name else @@ -897,7 +881,7 @@ procedure TBoldUMLRoseLink.ExportOperation(UMLOperation: TUMLOperation; RoseClas ExportConstraints(RoseItem, UMLOperation); TBoldUMLRose98Support.SetExportControl(UMLOperation.Visibility, RoseOperation.ExportControl, UMLOperation.qualifiedName); RoseProp.SetTaggedValues(RoseItem, UMLOperation, Tools); - RoseProp.SetBoolean(RoseItem, 'IsClassMethod', False, UMLOperation.ownerScope = skClassifier, LogName); // do not localize + RoseProp.SetBoolean(RoseItem, 'IsClassMethod', False, UMLOperation.ownerScope = skClassifier, LogName); if CompareText(RoseOperation.ReturnType, ReturnTypeName) <> 0 then begin BoldLog.LogFmt('Setting %s.Type to %s', [LogName, ReturnTypeName]); @@ -948,7 +932,6 @@ function TBoldUMLRoseLink.ExportModel(UMLModel: TUMLModel): Boolean; RoseModel.Stereotype := UMLModel.StereotypeName; end; ExportConstraints(RoseItem, UMLModel); - // Remove all classes in Rose that are not in Bold RoseClasses := RoseModel.GetAllClasses; I := 1; BoldLog.ProgressMax := RoseClasses.Count - 1; @@ -968,7 +951,6 @@ function TBoldUMLRoseLink.ExportModel(UMLModel: TUMLModel): Boolean; else begin BoldLog.LogFmt('Deleting class %s', [RoseClass.Name]); - // we must remove all associations also or the model will be corrupt RoseAssociations := RoseClass.GetAssociations; while roseAssociations.count > 0 do begin @@ -984,8 +966,6 @@ function TBoldUMLRoseLink.ExportModel(UMLModel: TUMLModel): Boolean; else inc(i); end; - - // Remove all associations in Rose that are not in Bold RoseAssociations := RoseModel.GetAllAssociations; I := 1; BoldLog.ProgressMax := RoseAssociations.Count - 1; @@ -1049,7 +1029,7 @@ function TBoldUMLRoseLink.ExportModel(UMLModel: TUMLModel): Boolean; end; finally fRoseModel := nil; - end; + end; end; procedure TBoldUMLRoseLink.ExportSignature(UMLOperation: TUMLOperation; RoseOperation: IRoseOperation); @@ -1148,7 +1128,7 @@ procedure TBoldUMLRoseLink.ExportRole(UMLAssociationEnd: TUMLAssociationEnd; Ros TBoldUMLRose98Support.SetContainment(UMLAssociationEnd.Aggregation, RoseRole, OtherRoseRole, UMLAssociationEnd.qualifiedName); TBoldUMLRose98Support.SetExportControl(UMLAssociationEnd.visibility, RoseRole.ExportControl, UMLAssociationEnd.qualifiedName); - RoseProp.SetString(RoseItem, 'Changeability', 'Changeable', TBoldRose98TaggedValueSupport.ChangeableKindToString(UMLAssociationEnd.Changeability), LogName); // do not localize + RoseProp.SetString(RoseItem, 'Changeability', 'Changeable', TBoldRose98TaggedValueSupport.ChangeableKindToString(UMLAssociationEnd.Changeability), LogName); RoseProp.SetTaggedValues(RoseItem, UMLAssociationEnd, Tools); RoseProp.SetBoolean(RoseItem, TAG_ORDERED, False, UMLAssociationEnd.isOrdered, LogName); @@ -1157,8 +1137,6 @@ procedure TBoldUMLRoseLink.ExportRole(UMLAssociationEnd: TUMLAssociationEnd; Ros BoldLog.LogFmt('Setting %s.Navigable to %s', [LogName, BooleanToString(UMLAssociationEnd.isNavigable)]); RoseRole.Navigable := UMLAssociationEnd.isNavigable; end; - - // Trim qualifiers RoseAttributes := RoseRole.Keys; I := 1; while I <= RoseAttributes.Count do @@ -1299,8 +1277,7 @@ procedure TBoldUMLRoseLink.ExportConstraints(RoseItem: IRoseItem; UMLElement: TU begin ConstrString := TBoldUMLModelLinkSupport.ConstraintsAsString(UMLElement); RoseConstr := RoseProp.GetString(RoseItem, TAG_CONSTRAINTS, ''); - // if the Rose constraint does not end with CRLF then add that, this is because a CRLF - // should not affect the export. And empty strings should not affect anything + if (RoseConstr <> '') and (Copy(RoseConstr, Length(RoseConstr) - 2, MaxInt) <> BOLDCRLF) then RoseConstr := RoseConstr + BOLDCRLF; if ConstrString <> RoseConstr then @@ -1485,24 +1462,24 @@ function TBoldUMLRoseLink.FindInCache(Cache: TStringList; UniqueId: string): TUM procedure TBoldUMLRoseLink.DefineProperties(Filer: TFiler); begin inherited; - Filer.DefineProperty('PluralSuffix', ReadObsoletePluralSuffix, nil, False); // do not localize - Filer.DefineProperty('DefaultMultiplicityForRoles', ReadObsoletMultiplicityForRoles, nil, False); // do not localize - Filer.DefineProperty('DefaultMultiplicityForNonNavigableRoles', ReadObsoleteMultiplicityForNonNavigableRoles, nil, False); // do not localize + Filer.DefineProperty('PluralSuffix', ReadObsoletePluralSuffix, nil, False); + Filer.DefineProperty('DefaultMultiplicityForRoles', ReadObsoletMultiplicityForRoles, nil, False); + Filer.DefineProperty('DefaultMultiplicityForNonNavigableRoles', ReadObsoleteMultiplicityForNonNavigableRoles, nil, False); end; procedure TBoldUMLRoseLink.ReadObsoletePluralSuffix(Reader: TReader); begin - ReadObsoleteProperty(Reader, 'PluralSuffix', 'PluralSuffix'); // do not localize + ReadObsoleteProperty(Reader, 'PluralSuffix', 'PluralSuffix'); end; procedure TBoldUMLRoseLink.ReadObsoleteMultiplicityForNonNavigableRoles(Reader: TReader); begin - ReadObsoleteProperty(Reader, 'DefaultMultiplicityForNonNavigableRoles', 'DefaultNonNavigableMultiplicity'); // do not localize + ReadObsoleteProperty(Reader, 'DefaultMultiplicityForNonNavigableRoles', 'DefaultNonNavigableMultiplicity'); end; procedure TBoldUMLRoseLink.ReadObsoletMultiplicityForRoles(Reader: TReader); begin - ReadObsoleteProperty(Reader, 'DefaultMultiplicityForRoles', 'DefaultNavigableMultiplicity'); // do not localize + ReadObsoleteProperty(Reader, 'DefaultMultiplicityForRoles', 'DefaultNavigableMultiplicity'); end; procedure TBoldUMLRoseLink.ReadObsoleteProperty(Reader: TReader; const PropertyName, NewPropertyName: string); @@ -1534,6 +1511,7 @@ procedure TBoldUMLRoseLink.SetIncludeSubPackages(const Value: Boolean); fMapping.IncludeSubPackages := Value; end; + initialization BoldUMLModelLinkList.AddLink(ROSE_LINKEXTENSION, ROSE_LINKDESC, TBoldUMLRoseLink); RoseProp := TBoldUMLRose98Properties.Create(BOLDTOOLNAME); diff --git a/Source/UMLModel/ModelLinks/Rose98/BoldUMLRose98LinkReg.res b/Source/UMLModel/ModelLinks/Rose98/BoldUMLRose98LinkReg.res new file mode 100644 index 00000000..07448d18 Binary files /dev/null and b/Source/UMLModel/ModelLinks/Rose98/BoldUMLRose98LinkReg.res differ diff --git a/Source/UMLModel/ModelLinks/Rose98/BoldUMLRose98Linkreg.pas b/Source/UMLModel/ModelLinks/Rose98/BoldUMLRose98Linkreg.pas index 469c32f4..6a2d5a4f 100644 --- a/Source/UMLModel/ModelLinks/Rose98/BoldUMLRose98Linkreg.pas +++ b/Source/UMLModel/ModelLinks/Rose98/BoldUMLRose98Linkreg.pas @@ -1,11 +1,16 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLRose98Linkreg; -interface +interface procedure Register; implementation +{$R *.res} + uses SysUtils, BoldUtils, @@ -13,14 +18,13 @@ implementation DesignIntf, TypInfo, BoldDefs, + BoldGuard, BoldIDEConsts, BoldAbstractPropertyEditors, BoldPropertyEditors, BoldAbstractModel, BoldUMLRose98Link; -{$R *.res} - type { TBoldRoseFileNameProperty } @@ -33,7 +37,7 @@ TBoldUMLRoseFileNameProperty = class(TBoldFileNameProperty) { TBoldRose98FileNameProperty } function TBoldUMLRoseFileNameProperty.FileFilter: string; begin - Result := Format('%s (*%s)|*%1:s', [ROSE_LINKDESC, ROSE_LINKEXTENSION]); //do not localize + Result := Format('%s (*%s)|*%1:s', [ROSE_LINKDESC, ROSE_LINKEXTENSION]); end; function TBoldUMLRoseFileNameProperty.IsValid: boolean; @@ -59,8 +63,8 @@ procedure RegisterComponentsOnPalette; procedure RegisterEditors; begin - RegisterPropertyEditor(TypeInfo(String), TBoldUMLRoseLink, 'Filename', TBoldUMLRoseFileNameProperty); //do not localize - RegisterPropertyEditor(TypeInfo(TBoldAbstractModel), TBoldUMLRoseLink, 'BoldModel', TBoldComponentPropertyIndicateMissing); //do not localize + RegisterPropertyEditor(TypeInfo(String), TBoldUMLRoseLink, 'Filename', TBoldUMLRoseFileNameProperty); + RegisterPropertyEditor(TypeInfo(TBoldAbstractModel), TBoldUMLRoseLink, 'BoldModel', TBoldComponentPropertyIndicateMissing); end; procedure Register; diff --git a/Source/UMLModel/ModelLinks/Rose98/BoldUMLRose98MappingUtils.pas b/Source/UMLModel/ModelLinks/Rose98/BoldUMLRose98MappingUtils.pas index 669f5bdb..9830f2b6 100644 --- a/Source/UMLModel/ModelLinks/Rose98/BoldUMLRose98MappingUtils.pas +++ b/Source/UMLModel/ModelLinks/Rose98/BoldUMLRose98MappingUtils.pas @@ -1,8 +1,9 @@ -{$WARN SYMBOL_PLATFORM OFF} // This is WINDOWS only +{ Global compiler directives } +{$include bold.inc} unit BoldUMLRose98MappingUtils; -interface +interface uses Classes, @@ -31,8 +32,8 @@ TBoldUMLRose98MappingUtils = class fCachedAssociations: TStringList; fCachedElements: TSTringList; fUMLModelreadOnly: Boolean; - procedure SetLogicalPackages(Value: TStrings); - procedure SetUMLModel(const Value: TUMLModel); + procedure SetLogicalPackages(Value: TStrings); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetUMLModel(const Value: TUMLModel); {$IFDEF BOLD_INLINE} inline; {$ENDIF} public constructor Create; destructor Destroy; override; @@ -85,7 +86,6 @@ function TBoldUMLRose98MappingUtils.RoseClassForUMLClassifier(RoseModel: IRoseMo I: Integer; begin Result := nil; - // If UMLClassifier has toolid then only accept that, else search for name match if TBoldUMLSupport.GetToolId(UMLClassifier) <> '' then Result := RoseModel.FindClassWithID(TBoldUMLSupport.GetToolId(UMLClassifier)) else @@ -110,14 +110,13 @@ function TBoldUMLRose98MappingUtils.UMLClassifierForRoseClass(UMLModel: TUMLMode result := nil; if assigned(RoseClass) then begin - // Class is in UMLModel if toolid mathces, or if name matches class that lacks toolid Result := FindClass(RoseClass.GetUniqueID); if not Assigned(Result) then begin Result := UMLModel.EvaluateExpressionAsDirectElement ( - Format('UMLClassifier.allInstances->select(model=self)->select(name=''%s'')->first', //do not localize + Format('UMLClassifier.allInstances->select(model=self)->select(name=''%s'')->first', [RoseClass.Name]) ) as TUMLClassifier; if Assigned(Result) and (TBoldUMLSupport.GetToolId(Result) <> '') then @@ -131,18 +130,15 @@ function TBoldUMLRose98MappingUtils.UMLAssociationForRoseAssociation(UMLModel: T UMLClassifier1: TUMLClassifier; i: integer; begin - // Association is in UMLModel if toolid matches, or if role names and classes match Result := FindAssocation(RoseAssociation.GetUniqueID); if not Assigned(Result) then begin - // first try name Result := UMLModel.EvaluateExpressionAsDirectElement ( - Format('UMLAssociation.allInstances->select(model=self)->select(name=''%s'')->first', //do not localize + Format('UMLAssociation.allInstances->select(model=self)->select(name=''%s'')->first', [RoseAssociation.Name]) ) as TUMLAssociation; - // else match on classes and role names if not Assigned(Result) then begin UMLClassifier1 := UMLClassifierForRoseClass(UMLModel, RoseAssociation.Role1.Class_); @@ -176,7 +172,6 @@ function TBoldUMLRose98MappingUtils.RoseAssociationForUMLAssociation( I: Integer; begin Result := nil; - // If UMLAssociation has toolid then only accept that, else search for match if TBoldUMLSupport.GetToolId(UMLAssociation) <> '' then Result := RoseModel.GetAllAssociations.GetWithUniqueID(TBoldUMLSupport.GetToolId(UMLAssociation)) else @@ -202,14 +197,13 @@ function TBoldUMLRose98MappingUtils.RoseAssociationForUMLAssociation( function TBoldUMLRose98MappingUtils.UMLAttributeForRoseAttribute( UMLClass: TUMLClass; RoseAttribute: IRoseAttribute): TUMLAttribute; begin - // Try Toolid first, then name match Result := FindElement(RoseAttribute.GetUniqueID) as TUMLAttribute; if not Assigned(Result) or (Result.Owner <> UMLClass) then begin Result := UMLClass.EvaluateExpressionAsDirectElement ( - Format('feature->select((name=''%s'') and oclIsKindOf(UMLAttribute))->first', //do not localize + Format('feature->select((name=''%s'') and oclIsKindOf(UMLAttribute))->first', [RoseAttribute.Name]) ) as TUMLAttribute; if Assigned(Result) and (TBoldUMLSupport.GetToolId(Result) <> '') then @@ -221,7 +215,6 @@ function TBoldUMLRose98MappingUtils.RoseAttributeForUMLAttribute( RoseClass: IRoseClass; UMLAttribute: TUMLAttribute): IRoseAttribute; begin Result := nil; - // If UMLClassifier has toolid then only accept that, else search for name match if TBoldUMLSupport.GetToolId(UMLAttribute) <> '' then Result := RoseClass.Attributes.GetWithUniqueID(TBoldUMLSupport.GetToolId(UMLAttribute)) else @@ -232,7 +225,6 @@ function TBoldUMLRose98MappingUtils.RoseOperationForUMLOperation( RoseClass: IRoseClass; UMLOperation: TUMLOperation): IRoseOperation; begin Result := nil; - // If UMLClassifier has toolid then only accept that, else search for name match if TBoldUMLSupport.GetToolId(UMLOperation) <> '' then Result := RoseClass.Operations.GetWithUniqueID(TBoldUMLSupport.GetToolId(UMLOperation)) else @@ -242,14 +234,13 @@ function TBoldUMLRose98MappingUtils.RoseOperationForUMLOperation( function TBoldUMLRose98MappingUtils.UMLOperationForRoseOperation( UMLClass: TUMLClass; RoseOperation: IRoseOperation): TUMLOperation; begin - // Try Toolid first, then name match Result := FindElement(RoseOperation.GetUniqueID) as TUMLOperation; if not Assigned(Result) or (Result.Owner <> UMLClass) then begin Result := UMLClass.EvaluateExpressionAsDirectElement ( - Format('feature->select((name=''%s'') and oclIsKindOf(UMLOperation))->first', //do not localize + Format('feature->select((name=''%s'') and oclIsKindOf(UMLOperation))->first', [RoseOperation.Name]) ) as TUMLOperation; if Assigned(Result) and (TBoldUMLSupport.GetToolId(Result) <> '') then @@ -267,7 +258,7 @@ constructor TBoldUMLRose98MappingUtils.Create; destructor TBoldUMLRose98MappingUtils.Destroy; begin FreeAndNil(fLogicalPackages); - ClearCaches; // this will free the cache-lists. + ClearCaches; inherited; end; @@ -322,14 +313,13 @@ function TBoldUMLRose98MappingUtils.ClassInLogicalPackages( cat := RoseClass.ParentCategory; while assigned(cat) and not Cat.TopLevel do Cat := cat.ParentCategory; - // only include classes that are in the Rootcategory or subcategories. Result := assigned(Cat) and (Cat = RoseClass.Model.RootCategory); end else begin Cat := RoseClass.ParentCategory; if Cat.TopLevel then - Result := LogicalPackages.IndexOf('') <> -1 //do not localize + Result := LogicalPackages.IndexOf('') <> -1 else begin Result := LogicalPackages.IndexOf(Cat.Name) <> -1; @@ -394,7 +384,7 @@ function TBoldUMLRose98MappingUtils.FindClass(const UniqueId: String): TUMLClass Result := FindInCache(fCachedClasses, UniqueId) as TUMLClass; if not Assigned(Result) then begin - RefreshCache(fCachedClasses, 'Class'); //do not localize + RefreshCache(fCachedClasses, 'Class'); Result := FindInCache(fCachedClasses, UniqueId) as TUMLClass; end; end; @@ -425,7 +415,7 @@ procedure TBoldUMLRose98MappingUtils.RefreshCache(var Cache: TStringList; FreeAndNil(Cache); Cache := TStringList.Create; Elementlist := UMLModel.EvaluateExpressionAsNewElement( - Format('UML%s.allInstances->reject(oclIsKindOf(UMLTaggedValue))->select(model=self)', [FilterType])) as TUMLModelElementList; //do not localize + Format('UML%s.allInstances->reject(oclIsKindOf(UMLTaggedValue))->select(model=self)', [FilterType])) as TUMLModelElementList; try for i := 0 to Elementlist.Count-1 do begin @@ -450,7 +440,7 @@ function TBoldUMLRose98MappingUtils.FindAssocation(const UniqueId: String): TUML result := nil; if not Assigned(Result) then begin - RefreshCache(fCachedAssociations, 'Association'); //do not localize + RefreshCache(fCachedAssociations, 'Association'); Result := FindInCache(fCachedAssociations, UniqueId) as TUMLASsociation; end; end; @@ -460,9 +450,11 @@ function TBoldUMLRose98MappingUtils.FindElement(const UniqueId: String): TUMLEle Result := FindInCache(fCachedElements , UniqueId) as TUMLElement; if not Assigned(Result) then begin - RefreshCache(fCachedElements, 'ModelElement'); //do not localize + RefreshCache(fCachedElements, 'ModelElement'); Result := FindInCache(fCachedElements, UniqueId) as TUMLElement; end; end; +initialization + end. diff --git a/Source/UMLModel/ModelLinks/Rose98/BoldUMLRose98Support.pas b/Source/UMLModel/ModelLinks/Rose98/BoldUMLRose98Support.pas index 8b8b3dbe..34d3a758 100644 --- a/Source/UMLModel/ModelLinks/Rose98/BoldUMLRose98Support.pas +++ b/Source/UMLModel/ModelLinks/Rose98/BoldUMLRose98Support.pas @@ -1,6 +1,9 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLRose98Support; -{$WARN SYMBOL_PLATFORM OFF} // WINDOWS only +{$WARN SYMBOL_PLATFORM OFF} interface @@ -34,9 +37,9 @@ TBoldUMLRose98Properties = class(TBoldRose98Properties) procedure TaggedValueToElement(UmlElement: TUMLModelElement; RoseProp: IRoseProperty; Toolname: String); function GetEffectiveDefaults: TBoldTaggedValuePerClassList; function GetBoldDefaultsForClass(const UMLModelName: string; RoseItem: IRoseItem): TBoldTaggedValueList; - property EffectiveDefaults: TBoldTaggedValuePerClassList read GetEffectiveDefaults; + property EffectiveDefaults: TBoldTaggedValuePerClassList read GetEffectiveDefaults; public - destructor Destroy; override; + destructor destroy; override; procedure GetTaggedValues(RoseItem: IRoseItem; UMLElement: TUMLModelElement; AdditionalTools: TStrings); procedure SetTaggedValues(RoseItem: IRoseItem; UMLElement: TUMLModelElement; AdditionalTools: TStrings); procedure SetTaggedValuesAsDefaultProps(RoseItem: IRoseItem; UMLElement: TUMLModelElement; AdditionalTools: TStrings); @@ -73,7 +76,7 @@ class function TBoldUMLRose98Properties.LogName(UMLElement: TUMLModelElement): s if Assocation.connection.Count = 2 then Result := EffectiveName(Assocation.connection[0]) + EffectiveName(Assocation.connection[1]) else - Result := ''; + Result := ''; end else if (UMLElement is TUMLAssociationEnd) then begin @@ -118,7 +121,6 @@ procedure TBoldUMLRose98Properties.GetTaggedValuesForTool(RoseItem: IRoseItem; U else begin PropCollection := GetToolProps(RoseItem, aToolName); -// aToolName := aToolName + '.'; for Index := 1 to PropCollection.Count do TaggedValueToElement(UmlElement, PropCollection.GetAt(Index), aToolname); end; @@ -240,8 +242,7 @@ procedure TBoldUMLRose98Properties.GetTaggedValues(RoseItem: IRoseItem; PropCollection: IRosePropertyCollection; DefaultProp: IRoseProperty;} begin - // the import spends quite a lot of time here... - + GetTaggedValuesForTool(RoseItem, UMLElement, ToolName); GetTaggedValuesForTool(RoseItem, UMLElement, BOLDSTDUMLTOOLNAME); for i := 0 to AdditionalTools.Count-1 do @@ -337,4 +338,6 @@ function TBoldUMLRose98Properties.StripToolName( end; end; +initialization + end. diff --git a/Source/UMLModel/ModelLinks/XMI/BoldDTDParser.pas b/Source/UMLModel/ModelLinks/XMI/BoldDTDParser.pas index 6b82fa6a..51a6d096 100644 --- a/Source/UMLModel/ModelLinks/XMI/BoldDTDParser.pas +++ b/Source/UMLModel/ModelLinks/XMI/BoldDTDParser.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDTDParser; interface @@ -73,9 +76,11 @@ TBoldDTDParser = class implementation uses - classes, + Classes, + SysUtils, BoldDefs, - BoldStringList; + BoldStringList, + BoldUtils; const SpaceChars = [#$20, #$9, #$D, #$A]; @@ -127,19 +132,15 @@ procedure TBoldDTDParser.Parse(DTD: string); function TBoldDTDParser.ParseAttListDecl: Boolean; begin -// AttlistDecl ::= '' if ParseToken(dtAttlistDecl) then begin -// Cheat! I don't really care, so just skip everything... while fScanner.LastToken <> dtEndDecl do fScanner.NextToken; fScanner.NextToken; -// AssertToken(dtSpace); -// AssertToken(dtName); -// while ParseAttDef do; -// OptionalToken(dtSpace); -// AssertToken(dtEndDecl); + + + result := true; end else result := false; @@ -152,25 +153,21 @@ function TBoldDTDParser.ParseChildren: Boolean; function TBoldDTDParser.ParseChildren2: Boolean; begin -// children ::= (choice | seq) ('?' | '*' | '+')? -// cp ::= (Name | choice | seq) ('?' | '*' | '+')? -// choice ::= '(' S? cp S? ( '|' S? cp S? )+ ')' /* */ -// seq ::= '(' S? cp S? ( ',' S? cp S? )* ')' -// note! '(' S? already parsed + + + result := ParseChoiceOrSeq; if result then if ParseToken(dtOptional) or ParseToken(dtZeroOrMore) or ParseToken(dtOneOrMore) then - ;//nothing + ; end; function TBoldDTDParser.ParseChoiceOrSeq: Boolean; begin -// choice ::= '(' S? cp S? ( '|' S? cp S? )+ ')' /* */ -// seq ::= '(' S? cp S? ( ',' S? cp S? )* ')' -// note! '(' S? already parsed + AssertNonterminal(ParseCp); OptionalToken(dtSpace); @@ -196,7 +193,7 @@ function TBoldDTDParser.ParseChoiceOrSeq: Boolean; end; AssertToken(dtCloseParen); end - else // seq without comma + else begin AssertToken(dtCloseParen); end; @@ -205,7 +202,6 @@ function TBoldDTDParser.ParseChoiceOrSeq: Boolean; function TBoldDTDParser.ParseContentSpec: Boolean; begin -// contentspec ::= 'EMPTY' | 'ANY' | Mixed | children result := ParseToken(dtEmptyContent) or ParseToken(dtAnyContent) or ParseMixedOrChildren; @@ -213,7 +209,6 @@ function TBoldDTDParser.ParseContentSpec: Boolean; function TBoldDTDParser.ParseCp: Boolean; begin -// cp ::= (Name | choice | seq) ('?' | '*' | '+')? if fScanner.LastToken = dtName then begin FoundCpName(fScanner.LastTokenText); @@ -231,12 +226,11 @@ function TBoldDTDParser.ParseCp: Boolean; if result then if ParseToken(dtOptional) or ParseToken(dtZeroOrMore) or ParseToken(dtOneOrMore) then - ;//nothing... + ; end; function TBoldDTDParser.ParseElementDecl: Boolean; begin -// elementDecl ::= '' if ParseToken(dtElementDecl) then begin AssertToken(dtSpace); @@ -257,13 +251,11 @@ function TBoldDTDParser.ParseElementDecl: Boolean; function TBoldDTDParser.ParseEntityDecl: Boolean; begin -// EntityDecl ::= GEDecl | PEDecl -// GEDecl ::= '' -// PEDecl ::= '' + + if ParseToken(dtEntityDecl) then begin -// Cheat! I don't really care, so just skip everything... while fScanner.LastToken <> dtEndDecl do fScanner.NextToken; fScanner.NextToken; @@ -276,13 +268,11 @@ function TBoldDTDParser.ParseEntityDecl: Boolean; procedure TBoldDTDParser.ParseExtSubsetDecl; begin -// extSubsetDecl ::= ( markupdecl | conditionalSect | DeclSep)* while (ParseMarkupDecl or ParseToken(dtSpace)) do; end; function TBoldDTDParser.ParseMarkupDecl: Boolean; begin -// markupdecl ::= elementdecl | AttlistDecl | EntityDecl | NotationDecl | PI | Comment result := ParseElementDecl or ParseAttListDecl or ParseEntityDecl or @@ -291,15 +281,13 @@ function TBoldDTDParser.ParseMarkupDecl: Boolean; function TBoldDTDParser.ParseMixed: Boolean; begin -//Mixed ::= '(' S? '#PCDATA' (S? '|' S? Name)* S? ')*' -// | '(' S? '#PCDATA' S? ')' + raise EBold.Create('Not implemented'); end; function TBoldDTDParser.ParseMixed2: Boolean; begin -//Mixed ::= '#PCDATA' S? ( '|' S? Name S? )* ')*' -// | '#PCDATA' S? ')' + result := ParseToken(dtPCDataDecl); if result then @@ -384,13 +372,12 @@ function TBoldDTDParser.Preprocess(DTD: string): string; PETable.Sort; DTDStrings := TStringList.Create; DTDStrings.Text := DTD; -// BoldAppendToStrings(DTDStrings, DTD, True); for i := 0 to DTDStrings.Count-1 do begin j := 1; while j <= length(DTDStrings[i]) do begin - if (DTDStrings[i][j] = '%') and not (DTDStrings[i][j+1] in SpaceChars) then + if (DTDStrings[i][j] = '%') and not CharInSet(DTDStrings[i][j+1], SpaceChars) then begin k := j+1; while DTDStrings[i][k] <> ';' do @@ -423,9 +410,9 @@ constructor TBoldDTDScanner.Create(DTD: string); procedure TBoldDTDScanner.DeclarationToken; begin - if not (TryToken(' 0) then begin dotpos := pos('.', fAttr.AsString); - result := 'RationalRose$' + Copy(fAttr.AsString, 1, dotpos-1) + ':' + // do not localize + result := 'RationalRose$' + Copy(fAttr.AsString, 1, dotpos-1) + ':' + Copy(fAttr.AsString, dotpos+1, MAXINT); end else @@ -528,6 +531,7 @@ constructor TBoldUMLMOFReferenceListAdapter.Create(Obj: TBoldObject; OwningLink: GetReferences(fRefs, Obj); end; + destructor TBoldUMLMOFReferenceListAdapter.Destroy; begin FreeAndNil(fRefs); @@ -547,13 +551,11 @@ procedure TBoldUMLMOFReferenceListAdapter.GetMIReferences(List: TList; GetReferences(List2, Obj2); for i := 0 to List2.Count-1 do begin - // The two halves should have the common part (diamond inheritence) first. if TBoldMember(List[i]).BoldMemberRTInfo.ModelName = - TBoldMember(List2[i]).BoldMemberRTInfo.ModelName then // FIXME: use qualified names + TBoldMember(List2[i]).BoldMemberRTInfo.ModelName then begin - // Just keep the first one. - // FIXME: Merge? - // Note: Tagged Values will be handled by ObjectListAdapter-factory + + end else List.Add(List2[i]); end; @@ -582,10 +584,10 @@ function TBoldUMLMOFReferenceListAdapter.IsBoldAddedRole( begin assert(Role.BoldMemberRTInfo.IsRole); RoleRt := TBoldRoleRTInfo(Role.BoldMemberRTInfo); - Result := (RoleRt.Stereotype = 'Bold') or // do not localize - (RoleRt.AssociationStereotype = 'Bold') or // do not localize - (RoleRt.ClassTypeInfoOfOtherEnd.Stereotype = 'Bold') or // do not localize - ((RoleRt.ModelName = 'associationEnd') and (RoleRt.ClassTypeInfo.ModelName = 'Classifier')) or // do not localize + Result := (RoleRt.Stereotype = 'Bold') or + (RoleRt.AssociationStereotype = 'Bold') or + (RoleRt.ClassTypeInfoOfOtherEnd.Stereotype = 'Bold') or + ((RoleRt.ModelName = 'associationEnd') and (RoleRt.ClassTypeInfo.ModelName = 'Classifier')) or IsInheritedButShouldNotBe(Role); end; @@ -763,7 +765,7 @@ function TBoldUMLMOFMultiplicityAdapter.IsComposite: Boolean; function TBoldUMLMOFMultiplicityAdapter.IsDerived: Boolean; begin - result := false; + result := false; end; function TBoldUMLMOFMultiplicityAdapter.IsMulti: Boolean; @@ -788,12 +790,12 @@ function TBoldUMLMOFMultiplicityAdapter.Objects: IBoldMOFObjectList; function TBoldUMLMOFMultiplicityAdapter.QualifiedClassName: string; begin - result := 'Foundation.Data_Types.Multiplicity'; // do not localize + result := 'Foundation.Data_Types.Multiplicity'; end; function TBoldUMLMOFMultiplicityAdapter.QualifiedName: string; begin - result := 'Foundation.Data_Types.Multiplicity.range'; // do not localize + result := 'Foundation.Data_Types.Multiplicity.range'; end; function TBoldUMLMOFMultiplicityAdapter.Reference( @@ -819,9 +821,9 @@ function TBoldUMLMOFMultiplicityRangeAdapter.Attribute( index: Integer): IBoldMOFAttribute; begin if index = 0 then - result := TBoldUMLMOFMultiplicityRangeBoundAdapter.Create('lower', fLower) // do not localize + result := TBoldUMLMOFMultiplicityRangeBoundAdapter.Create('lower', fLower) else if index = 1 then - result := TBoldUMLMOFMultiplicityRangeBoundAdapter.Create('upper', fUpper) // do not localize + result := TBoldUMLMOFMultiplicityRangeBoundAdapter.Create('upper', fUpper) else raise EBoldInternal.CreateFmt('%s.Attribute: index out of bounds %d', [classname, index]); end; @@ -845,24 +847,24 @@ constructor TBoldUMLMOFMultiplicityRangeAdapter.Create(Range: string; OwningLink splitpos := pos('..', Range); if splitpos = 0 then begin - if (trim(Range) = '*') or (trim(Range) = 'n') then + if Range = '*' then begin fLower := 0; fUpper := -1; end else begin - fLower := StrToInt(trim(Range)); + fLower := StrToInt(Range); fUpper := fLower; - end; + end; end else begin - fLower := StrToInt(trim(Copy(Range, 1, splitpos-1))); + fLower := StrToInt(Copy(Range, 1, splitpos-1)); Upper := Copy(Range, splitpos+2, maxint); - if (trim(Upper) = '*') or (trim(Upper) = 'n') then + if Upper = '*' then fUpper := -1 else - fUpper := StrToInt(trim(Upper)); + fUpper := StrToInt(Upper); end; end; @@ -873,7 +875,7 @@ function TBoldUMLMOFMultiplicityRangeAdapter.LocalId: string; function TBoldUMLMOFMultiplicityRangeAdapter.QualifiedClassName: string; begin - result := 'Foundation.Data_Types.MultiplicityRange'; // do not localize + result := 'Foundation.Data_Types.MultiplicityRange'; end; function TBoldUMLMOFMultiplicityRangeAdapter.RefCount: Integer; @@ -938,7 +940,7 @@ function TBoldUMLMOFMultiplicityRangeBoundAdapter.IsObject: Boolean; function TBoldUMLMOFMultiplicityRangeBoundAdapter.QualifiedName: string; begin - result := 'Foundation.Data_Types.MultiplicityRange.' + fAttrName; // do not localize + result := 'Foundation.Data_Types.MultiplicityRange.' + fAttrName; end; { TBoldUMLMOFExpressionAdapter } @@ -962,7 +964,7 @@ function TBoldUMLMOFExpressionAdapter.Attribute( index: Integer): IBoldMOFAttribute; begin if index = 0 then - result := TBoldUMLMOFDummyAttrAdapter.Create('Foundation.Data_Types.Expression.language') // do not localize + result := TBoldUMLMOFDummyAttrAdapter.Create('Foundation.Data_Types.Expression.language') else if index = 1 then result := self else @@ -1017,12 +1019,12 @@ function TBoldUMLMOFExpressionAdapter.LocalId: string; function TBoldUMLMOFExpressionAdapter.QualifiedClassName: string; begin - result := 'Foundation.Data_Types.' + fExprAttr.BoldType.ModelName; // do not localize + result := 'Foundation.Data_Types.' + fExprAttr.BoldType.ModelName; end; function TBoldUMLMOFExpressionAdapter.QualifiedName: string; begin - result := 'Foundation.Data_Types.Expression.body'; // do not localize + result := 'Foundation.Data_Types.Expression.body'; end; function TBoldUMLMOFExpressionAdapter.Reference( @@ -1083,4 +1085,6 @@ function TBoldUMLMOFDummyAttrAdapter.QualifiedName: string; result := fQualifiedName; end; +initialization + end. diff --git a/Source/UMLModel/ModelLinks/XMI/BoldUMLXMICommon.pas b/Source/UMLModel/ModelLinks/XMI/BoldUMLXMICommon.pas index 9ced9ee6..73a4d283 100644 --- a/Source/UMLModel/ModelLinks/XMI/BoldUMLXMICommon.pas +++ b/Source/UMLModel/ModelLinks/XMI/BoldUMLXMICommon.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLXMICommon; interface @@ -23,7 +26,7 @@ function UnqualifiedName(const aText: String): String; function RemoveBoldPackageNames(Name: string): string; const - BoldPackagePrefix = 'BoldUMLModel.UMLMeta.'; // do not localize + BoldPackagePrefix = 'BoldUMLModel.UMLMeta.'; begin assert(Copy(Name, 1, Length(BoldPackagePrefix)) = BoldPackagePrefix); result := Copy(Name, Length(BoldPackagePrefix)+1, maxint); @@ -55,16 +58,16 @@ function QualifiedMemberName(MemberRT: TBoldMemberRTInfo): string; function IsNameOfExpressionClass(Name: string): Boolean; begin - result :=(Name = 'Expression') or // do not localize - (Name = 'ActionExpression') or // do not localize - (Name = 'ArgListsExpression') or // do not localize - (Name = 'BooleanExpression') or // do not localize - (Name = 'IterationExpression') or // do not localize - (Name = 'MappingExpression') or // do not localize - (Name = 'ObjectSetExpression') or // do not localize - (Name = 'ProcedureExpression') or // do not localize - (Name = 'TimeExpression') or // do not localize - (Name = 'TypeExpression'); // do not localize + result :=(Name = 'Expression') or + (Name = 'ActionExpression') or + (Name = 'ArgListsExpression') or + (Name = 'BooleanExpression') or + (Name = 'IterationExpression') or + (Name = 'MappingExpression') or + (Name = 'ObjectSetExpression') or + (Name = 'ProcedureExpression') or + (Name = 'TimeExpression') or + (Name = 'TypeExpression'); end; end. diff --git a/Source/UMLModel/ModelLinks/XMI/BoldUMLXMIImporter.pas b/Source/UMLModel/ModelLinks/XMI/BoldUMLXMIImporter.pas index 35dd7a55..21863119 100644 --- a/Source/UMLModel/ModelLinks/XMI/BoldUMLXMIImporter.pas +++ b/Source/UMLModel/ModelLinks/XMI/BoldUMLXMIImporter.pas @@ -1,7 +1,10 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLXMIImporter; interface - + uses Variants, BoldContainers, @@ -11,8 +14,8 @@ interface BoldUMLXMILink, BoldSystemRT, BoldUMLXMILinkSupport, - MSXML_TLB, - Sysutils, // for TFileName + Bold_MSXML_TLB, + Sysutils, Classes; type @@ -28,7 +31,7 @@ TBoldUMLXMIImporter = class fTheUMLModel: TUMLModel; fTheUMLModelFound: Boolean; fDOMDocument: TDOMDocument; -// fDebugLog: TBoldLogForm; + fDebugLog: TBoldLogForm; fBoldSystem: TBoldSystem; fSkipMetaClassList: TStringList; fTraverseOnlyMetaClassList: TStringList; @@ -46,7 +49,6 @@ TBoldUMLXMIImporter = class procedure ImportMetaAssociationEndFromElement(BoldMember: TBoldMember; XMLElement: IXMLDOMElement; Multi: Boolean); property DOMDocument: TDOMDocument read GetDOMDocument; class function GetUMLName(const aText: String): String; -// class function UnqualifiedName(const aText: String): String; procedure ImportMetaAttributeFromElement(BoldAttribute: TBoldAttribute; XMLElement: IXMLDOMElement); function CreateUMLObjectsForMetaObject(XMLElement: IXMLDOMElement): TBoldUMLElementArray; function MetaClassAction(XMLElement: IXMLDOMElement): TClassAction; @@ -93,7 +95,7 @@ constructor TBoldUMLXMIImporter.Create(OwningLink: TBoldUMLXMILink; UMLModel: TU fOwningLink := OwningLink; fTheUMLModel := UMLModel; fBoldSystem := UMLModel.BoldSystem; -// fDebugLog := TBoldLogForm.Create(nil); + fDebugLog := TBoldLogForm.Create(nil); fImportedElementList := TBoldXMIIObjectList.Create; InitializeLists; end; @@ -101,7 +103,7 @@ constructor TBoldUMLXMIImporter.Create(OwningLink: TBoldUMLXMILink; UMLModel: TU destructor TBoldUMLXMIImporter.Destroy; begin FreeAndNil(fDOMDocument); -// FreeAndNil(fDebugLog); + FreeAndNil(fDebugLog); FreeAndNil(fSkipMetaClassList); FreeAndNil(fTraverseOnlyMetaClassList); FreeAndNil(fImportedElementList); @@ -160,7 +162,6 @@ procedure TBoldUMLXMIImporter.ImportMetaAssociationEndFromElement(BoldMember: TB TBoldObjectReference(BoldMember).BoldObject := nil else TBoldObjectReference(BoldMember).BoldObject := ObjectsToAdd[0]; - // raise EBold.Create('Multiple elements to single reference'); end else raise Exception.Create('Wrong association type, expected single.'); @@ -182,7 +183,7 @@ procedure TBoldUMLXMIImporter.ImportXMIObjectList(list: TUMLELementList; XMLElem childElement := FirstElementFromNodeList(nodeList); while Assigned(ChildElement) do begin - if (IsNonBlank(GetXMIIdref(ChildElement))) then // Object Reference + if (IsNonBlank(GetXMIIdref(ChildElement))) then ObjectsToAdd := (fImportedElementList.UMLElementsById[GetXMIIdref(ChildElement)]) else ObjectsToAdd := ImportMetaObject(childElement); @@ -201,7 +202,7 @@ class function TBoldUMLXMIImporter.UnqualifiedName(const aText: String): String; } class function TBoldUMLXMIImporter.GetUMLName(const aText: String): String; begin - Result := 'UML' + UnqualifiedName(aText); //do not localize + Result := 'UML' + UnqualifiedName(aText); end; function TBoldUMLXMIImporter.ImportMetaObject(XMLElement: IXMLDOMElement): TBoldUMLElementArray; @@ -232,7 +233,7 @@ function TBoldUMLXMIImporter.ImportMetaObject(XMLElement: IXMLDOMElement): TBold else Result := nil end - else // PASS2, objects refered in previous pass must exist, the rest created now + else begin if IsNonBlank(Id) then begin @@ -255,26 +256,25 @@ function TBoldUMLXMIImporter.ImportMetaObject(XMLElement: IXMLDOMElement): TBold ; caSkip: begin -// fDebugLog.AddLog(Format('Skipping metaobject: %s', [XMLElement.NodeName])); + fDebugLog.AddLog(Format('Skipping metaobject: %s', [XMLElement.NodeName])); Exit; end; caUNKNOWN: begin -// fDebugLog.AddLog(Format('Skipping Unknown metaobject: (%s),(%s)', [XMLElement.ParentNode.Nodename, XMLElement.NodeName])); + fDebugLog.AddLog(Format('Skipping Unknown metaobject: (%s),(%s)', [XMLElement.ParentNode.Nodename, XMLElement.NodeName])); Exit; end; end; - // Very hardcoded for max two types, and only AssociationClass having two if Assigned(Result) then begin for i := 0 to Result.Count-1 do ClassTypeInfo[i] := Result[i].BoldClassTypeInfo; ClassTypeInfoCount := Result.Count; end - else if GetUMLName(XMLElement.tagName) = 'AssociationClass' then //do not localize + else if GetUMLName(XMLElement.tagName) = 'AssociationClass' then begin - ClassTypeInfo[0] := BoldSystem.BoldSystemTypeInfo.ClassTypeInfoByExpressionName[GetUMLName('Class')]; //do not localize - ClassTypeInfo[1] := BoldSystem.BoldSystemTypeInfo.ClassTypeInfoByExpressionName[GetUMLName('Association')]; //do not localize + ClassTypeInfo[0] := BoldSystem.BoldSystemTypeInfo.ClassTypeInfoByExpressionName[GetUMLName('Class')]; + ClassTypeInfo[1] := BoldSystem.BoldSystemTypeInfo.ClassTypeInfoByExpressionName[GetUMLName('Association')]; ClassTypeInfoCount := 2; end else @@ -336,7 +336,6 @@ function TBoldUMLXMIImporter.ImportMetaObject(XMLElement: IXMLDOMElement): TBold if rtInfo.IsAttribute then ImportMetaAttributeFromElement(Boldmember as TBoldAttribute, Element) else - // don't import associations twice if (i = 0) or not assigned(ClassTypeInfo[0].MemberRTInfoByExpressionName[UnqualifiedName(Element.nodeName)]) then ImportMetaAssociationEndFromElement(Boldmember, Element, rtinfo.IsMultiRole) end @@ -350,13 +349,12 @@ function TBoldUMLXMIImporter.ImportMetaObject(XMLElement: IXMLDOMElement): TBold procedure TBoldUMLXMIImporter.ImportMetaAttributeFromElement(BoldAttribute: TBoldAttribute; XMLElement: IXMLDOMElement); function ValueIsMultiplicity(DOMElement: IXMLDOMElement): Boolean; begin - Result := UnqualifiedName(DOMElement.nodeName) = 'multiplicity'; //do not localize + Result := UnqualifiedName(DOMElement.nodeName) = 'multiplicity'; end; function ValueIsXmiValue(DOMElement: IXMLDOMElement): Boolean; begin - Result := assigned(DOMElement.getAttributeNode('xmi.value')); //do not localize -//not (ValueIsMultiplicity(DOMElement) or ValueISCData(DOMElement)); + Result := assigned(DOMElement.getAttributeNode('xmi.value')); end; function ValueIsExpression(DOMElement: IXMLDOMElement): Boolean; @@ -369,17 +367,16 @@ procedure TBoldUMLXMIImporter.ImportMetaAttributeFromElement(BoldAttribute: TBol begin Result := not (ValueIsXmiValue(DOMElement) or ValueIsMultiplicity(DOMElement) or ValueIsExpression(DOMElement)); -// DOMElement.nodeName = XMI_CORE_MODELELEMENT_NAME; end; var anAttribValue: String; begin if (pass = PASS1) then - Exit; // only set attributes on pass 2 + Exit; if ValueIsXmiValue(XMLElement) then begin - anAttribValue := BoldSharedStringManager.GetSharedString(VarToStr(XMLElement.getAttribute('xmi.value'))); //do not localize + anAttribValue := BoldSharedStringManager.GetSharedString(VarToStr(XMLElement.getAttribute('xmi.value'))); if anAttribValue <> '' then ImportAttributeFromString(BoldAttribute, anAttribValue); end @@ -393,8 +390,7 @@ procedure TBoldUMLXMIImporter.ImportMetaAttributeFromElement(BoldAttribute: TBol else if ValueIsExpression(XMLElement) then BoldAttribute.AsString := BoldSharedStringManager.GetSharedString(ImportExpressionAsString(XMLElement.firstChild as IXMLDOMElement)) else - begin - { TODO : Further types } + begin end; end; @@ -402,7 +398,7 @@ function TBoldUMLXMIImporter.MetaClassAction(XMLElement: IXMLDOMElement): TClass begin if Assigned(BoldSystem.BoldSystemTypeInfo.ClassTypeInfoByExpressionName[GetUMLName(XMLElement.nodeName)]) then Result := caIMPORT - else if GetUMLName(XMLElement.nodeName) = 'UMLAssociationClass' then //do not localize + else if GetUMLName(XMLElement.nodeName) = 'UMLAssociationClass' then Result := caIMPORT else if SkipMetaClassList.IndexOf(XMLElement.nodeName) <> -1 then Result := caSkip @@ -424,8 +420,6 @@ function TBoldUMLXMIImporter.GetAttributeMember(OwningObject: TUMLElement; const Result := TBoldAttribute(OwningObject.BoldMembers[aMemberRTInfo.Index]); end; end; - -// Due to implementation of multiple inheritance more than one UMLObject may be created function TBoldUMLXMIImporter.CreateUMLObjectsForMetaObject(XMLElement: IXMLDOMElement): TBoldUMLElementArray; var UMLClassName: String; @@ -434,43 +428,41 @@ function TBoldUMLXMIImporter.CreateUMLObjectsForMetaObject(XMLElement: IXMLDOMEl Element1, Element2: TUMLModelElement; begin XMIId := GetXMIId(XMLElement); -// fDebugLog.AddLog(Format('Creating model part: %s(%s)', [XMLElement.nodeName, FormatId(XMIId)])); + fDebugLog.AddLog(Format('Creating model part: %s(%s)', [XMLElement.nodeName, FormatId(XMIId)])); if Assigned(fImportedElementList.ItemsById[XMIId]) then begin raise EBoldInternal.Create('Modelpart already exists'); end else begin - // Handle Model and AssociationClass separately UMLClassName := GetUMLName(XMLElement.nodeName); - if UMLClassName = 'UMLModel' then //do not localize + if UMLClassName = 'UMLModel' then begin if not fTheUMLModelFound then begin - // We already have a model, just associate it with ID. Result := fImportedElementList.Add(XMIId, fTheUMLModel); fTheUMLModelFound := True; end else begin Element1 := BoldSystem.CreateNewObjectByExpressionName(UMLClassName, False) as TUMLModelElement; -// TBoldUMLSupport.EnsureBoldTaggedValues(Element1); + TBoldUMLSupport.EnsureBoldTaggedValues(Element1); Result := fImportedElementList.Add(XMIId, Element1); end; end - else if UMLClassName = 'UMLAssociationClass' then //do not localize + else if UMLClassName = 'UMLAssociationClass' then begin - Element1 := BoldSystem.CreateNewObjectByExpressionName('UMLClass', False) as TUMLModelElement; //do not localize -// TBoldUMLSupport.EnsureBoldTaggedValues(Element1); - Element2 := BoldSystem.CreateNewObjectByExpressionName('UMLAssociation', False) as TUMLModelElement; //do not localize -// TBoldUMLSupport.EnsureBoldTaggedValues(Element2); + Element1 := BoldSystem.CreateNewObjectByExpressionName('UMLClass', False) as TUMLModelElement; + TBoldUMLSupport.EnsureBoldTaggedValues(Element1); + Element2 := BoldSystem.CreateNewObjectByExpressionName('UMLAssociation', False) as TUMLModelElement; + TBoldUMLSupport.EnsureBoldTaggedValues(Element2); Result := fImportedElementList.Add(XMIId, Element1, Element2); (Result[1] as TUMLAssociation).Class_ := (Result[0] as TUMLClass); end else begin Element1 := BoldSystem.CreateNewObjectByExpressionName(UMLClassName, False) as TUMLModelElement; -// TBoldUMLSupport.EnsureBoldTaggedValues(Element1); + TBoldUMLSupport.EnsureBoldTaggedValues(Element1); Result := fImportedElementList.Add(XMIId, Element1); end; end; @@ -483,12 +475,10 @@ function TBoldUMLXMIImporter.CreateUMLObjectsForMetaObject(XMLElement: IXMLDOMEl procedure TBoldUMLXMIImporter.InitializeLists; begin - // Initialize skip list fSkipMetaClassList := TStringList.Create; fTraverseOnlyMetaClassList := TStringList.Create; -// if XMIExporter = UNISYS_TCR_2 then -// SkipMetaClassList.Add('Diagramming.Diagram'); - // Initialize travsrse list + + SkipMetaClassList.Sorted := True; TraverseOnlyMetaClassList.Sorted := True; end; @@ -499,18 +489,18 @@ function TBoldUMLXMIImporter.ImportMultiplicityAsString(XMLElement: IXMLDOMELeme nodeList: IXMLDOMNodeList; Ranges: TStringList; begin - if UnqualifiedName(XMLElement.nodeName) <> 'Multiplicity' then //do not localize + if UnqualifiedName(XMLElement.nodeName) <> 'Multiplicity' then raise EBold.CreateFmt('Wrong nodename: %s', [XMLElement.nodeName]); if (XMLElement.childNodes.length = 0) or (XMLElement.firstChild.childNodes.length = 0) then begin Result := ImportCdataValue(XMLElement); if result = '' then - result := '0..*'; //do not localize + result := '0..*'; end else begin - if UnqualifiedName(XMLElement.firstChild.nodeName) <> 'range' then //do not localize + if UnqualifiedName(XMLElement.firstChild.nodeName) <> 'range' then raise EBold.CreateFmt('Wrong nodename: %s', [XMLElement.nodeName]); nodeList := XMLElement.firstChild.childNodes; @@ -536,14 +526,14 @@ function TBoldUMLXMIImporter.ImportMultiplicityRangeAsString(XMLElement: IXMLDOM nodeList: IXMLDOMNodeList; attr: IXMLDOMAttribute; begin - if UnqualifiedName(XMLElement.nodeName) <> 'MultiplicityRange' then //do not localize + if UnqualifiedName(XMLElement.nodeName) <> 'MultiplicityRange' then raise EBold.CreateFmt('Wrong nodename: %s', [XMLElement.nodeName]); - attr := XMLElement.getAttributeNode('lower'); //do not localize + attr := XMLElement.getAttributeNode('lower'); if assigned(attr) then Lower := attr.value; - attr := XMLElement.getAttributeNode('upper'); //do not localize + attr := XMLElement.getAttributeNode('upper'); if assigned(attr) then Upper := attr.value; @@ -551,9 +541,9 @@ function TBoldUMLXMIImporter.ImportMultiplicityRangeAsString(XMLElement: IXMLDOM childElement := FirstElementFromNodeList(nodeList); while Assigned(ChildElement) do begin - if UnqualifiedName(childElement.nodeName) = 'lower' then //do not localize + if UnqualifiedName(childElement.nodeName) = 'lower' then Lower := ImportCdataValue(childElement) - else if UnqualifiedName(childElement.nodeName) = 'upper' then //do not localize + else if UnqualifiedName(childElement.nodeName) = 'upper' then Upper := ImportCdataValue(childElement) else raise EBoldInternal.Create('Import error'); @@ -589,8 +579,6 @@ function TBoldUMLXMIImporter.ImportCdataValue(XMLElement: IXMLDOMELement): strin procedure TBoldUMLXMIImporter.RawImport; var RootElement, ContentElement: IXMLDOMElement; - AllElements: TUMLModelElementList; - i: integer; function FindContent(XMLElement: IXMLDOMElement): IXMLDOMElement; var @@ -615,7 +603,7 @@ procedure TBoldUMLXMIImporter.RawImport; begin LoadAndCheck(OwningLink.Filename); -// fDebugLog.Show; + fDebugLog.Show; fImportedElementList.Clear; DOMDocument.preserveWhiteSpace := True; @@ -627,18 +615,13 @@ procedure TBoldUMLXMIImporter.RawImport; if not Assigned(ContentElement) then raise EBold.Create('Content missing'); -// fDebugLog.AddLog('PASS 1'); + fDebugLog.AddLog('PASS 1'); fPass := PASS1; ImportXMIObjectList(nil, ContentElement, nil); -// fDebugLog.AddLog('PASS 2'); + fDebugLog.AddLog('PASS 2'); fPass := PASS2; ImportXMIObjectList(nil, ContentElement, nil); - - AllElements := fBoldSystem.ClassByExpressionName['UMLModelElement'] as TUMLModelElementList; //do not localize - for i := AllElements.Count-1 downto 0 do - TBoldUMLSupport.EnsureBoldTaggedValues(AllElements[i]); - -// fDebugLog.AddLog('DONE'); + fDebugLog.AddLog('DONE'); end; function TBoldUMLXMIImporter.FindMemberRt( @@ -667,7 +650,7 @@ function TBoldUMLXMIImporter.ImportExpressionAsString( nodeList: IXMLDOMNodeList; childElement: IXMLDOMElement; begin - attr := XMLElement.getAttributeNode('body'); //do not localize + attr := XMLElement.getAttributeNode('body'); if assigned(attr) then result := attr.value else @@ -677,7 +660,7 @@ function TBoldUMLXMIImporter.ImportExpressionAsString( childElement := FirstElementFromNodeList(nodeList); while assigned(childElement) do begin - if UnqualifiedName(childElement.nodeName) = 'body' then //do not localize + if UnqualifiedName(childElement.nodeName) = 'body' then result := ImportCdataValue(childElement); childElement := NextElementFromNodeList(nodeList); end; @@ -690,11 +673,11 @@ procedure TBoldUMLXMIImporter.ImportAttributeFromString( colonpos: integer; begin if OwningLink.TranslateRoseTaggedValues and - (BoldAttribute.DisplayName = 'UMLTaggedValue.tag') and //do not localize - (pos('RationalRose$', AttributeValue) = 1) and //do not localize + (BoldAttribute.DisplayName = 'UMLTaggedValue.tag') and + (pos('RationalRose$', AttributeValue) = 1) and (pos(':', AttributeValue) <> 0) then begin - AttributeValue := Copy(AttributeValue, length('RationalRose$')+1, MAXINT); //do not localize + AttributeValue := Copy(AttributeValue, length('RationalRose$')+1, MAXINT); colonpos := pos(':', AttributeValue); BoldAttribute.AsString := Copy(AttributeValue, 1, colonpos-1) + '.' + Copy(AttributeValue, colonpos+1, MAXINT); @@ -702,12 +685,9 @@ procedure TBoldUMLXMIImporter.ImportAttributeFromString( else if BoldAttribute is TBABoolean then BoldAttribute.StringRepresentation[3] := AttributeValue else - begin - if (BoldAttribute is TBAVisibilityKind) and - (AttributeValue = 'package') then //do not localize - AttributeValue := 'public'; //do not localize BoldAttribute.AsString := AttributeValue; - end end; +initialization + end. diff --git a/Source/UMLModel/ModelLinks/XMI/BoldUMLXMILink.pas b/Source/UMLModel/ModelLinks/XMI/BoldUMLXMILink.pas index 91b0b4fa..146ab604 100644 --- a/Source/UMLModel/ModelLinks/XMI/BoldUMLXMILink.pas +++ b/Source/UMLModel/ModelLinks/XMI/BoldUMLXMILink.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLXMILink; interface @@ -12,6 +15,7 @@ interface TBoldUMLXMILink = class; { TBoldUMLXMILink } + [ComponentPlatformsAttribute (pidWin32 or pidWin64)] TBoldUMLXMILink = class(TBoldUMLModelLink) private fFilename: String; @@ -61,7 +65,7 @@ function TBoldUMLXMILink.ExportModel(UMLModel: TUMLModel): Boolean; BoldLog.EndLog; finally exporter.Free; - end; + end; result := true; end; diff --git a/Source/UMLModel/ModelLinks/XMI/BoldUMLXMILinkSupport.pas b/Source/UMLModel/ModelLinks/XMI/BoldUMLXMILinkSupport.pas index 0067121b..138a44fc 100644 --- a/Source/UMLModel/ModelLinks/XMI/BoldUMLXMILinkSupport.pas +++ b/Source/UMLModel/ModelLinks/XMI/BoldUMLXMILinkSupport.pas @@ -1,10 +1,13 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLXMILinkSupport; interface uses Variants, - MSXML_TLB, + Bold_MSXML_TLB, BoldContainers, BoldIndexableList, BoldUMLModel; @@ -89,17 +92,17 @@ TUUIdIndex = class(TBoldStringHashIndex) function FormatId(const id: TXMIId): string; begin if id.id <> '' then - Result := Format('id:%s ', [id.id]); // do not localize + Result := Format('id:%s ', [id.id]); if id.UUid <> '' then - Result := Format('UUid:%s ', [id.id]); // do not localize + Result := Format('UUid:%s ', [id.id]); end; function GetXMIId(UMLElementNode: IXMLDOMElement): TXMIId; begin - if not VarIsNull(UMLElementNode.getAttribute('xmi.id')) then // do not localize - Result.Id := UMLElementNode.getAttribute('xmi.id'); // do not localize - if not VarIsNull(UMLElementNode.getAttribute('xmi.uuid')) then // do not localize - Result.UUId := UMLElementNode.getAttribute('xmi.uuid'); // do not localize + if not VarIsNull(UMLElementNode.getAttribute('xmi.id')) then + Result.Id := UMLElementNode.getAttribute('xmi.id'); + if not VarIsNull(UMLElementNode.getAttribute('xmi.uuid')) then + Result.UUId := UMLElementNode.getAttribute('xmi.uuid'); end; function IsNonBlank(const XMIId: TXMIId): boolean; @@ -109,18 +112,16 @@ function IsNonBlank(const XMIId: TXMIId): boolean; function GetXMIIdRef(UMLElementNode: IXMLDOMElement): TXMIId; begin - if not VarIsNull(UMLElementNode.getAttribute('xmi.idref')) then // do not localize - Result.Id := UMLElementNode.getAttribute('xmi.idref'); // do not localize - if not VarIsNull(UMLElementNode.getAttribute('xmi.uuidref')) then // do not localize - Result.UUId := UMLElementNode.getAttribute('xmi.uuidref'); // do not localize + if not VarIsNull(UMLElementNode.getAttribute('xmi.idref')) then + Result.Id := UMLElementNode.getAttribute('xmi.idref'); + if not VarIsNull(UMLElementNode.getAttribute('xmi.uuidref')) then + Result.UUId := UMLElementNode.getAttribute('xmi.uuidref'); end; function XMIIdforId(const id: string): TXMIId; begin Result.Id := id; -end; - -{ TODO : move to common IXMLDOMSupport unit} +end; function NextElementFromNodeList(List: IXMLDOMNodeList): IXMLDOMElement; var Node: IXMLDOMNode; @@ -132,8 +133,7 @@ function NextElementFromNodeList(List: IXMLDOMNodeList): IXMLDOMElement; Result := Node as IXMLDOMElement else Node := List.NextNode; -end; -{ TODO : move to common IXMLDOMSupport unit} +end; function FirstElementFromNodeList(List: IXMLDOMNodeList): IXMLDOMElement; begin List.Reset; @@ -222,4 +222,6 @@ function TUUIdIndex.ItemAsKeyString(Item: TObject): string; Result := (Item as TBoldXMIObjectItem).xmiid.uuid; end; +initialization + end. diff --git a/Source/UMLModel/ModelLinks/XMI/BoldUMXMILinkReg.res b/Source/UMLModel/ModelLinks/XMI/BoldUMXMILinkReg.res new file mode 100644 index 00000000..16eb42b6 Binary files /dev/null and b/Source/UMLModel/ModelLinks/XMI/BoldUMXMILinkReg.res differ diff --git a/Source/UMLModel/ModelLinks/XMI/BoldUMXMILinkreg.pas b/Source/UMLModel/ModelLinks/XMI/BoldUMXMILinkreg.pas index 385d3ded..85d7fc68 100644 --- a/Source/UMLModel/ModelLinks/XMI/BoldUMXMILinkreg.pas +++ b/Source/UMLModel/ModelLinks/XMI/BoldUMXMILinkreg.pas @@ -1,11 +1,16 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMXMILinkreg; -interface +interface procedure Register; implementation +{$R BoldUMXMILinkreg.res} + uses SysUtils, BoldUtils, @@ -20,8 +25,6 @@ implementation BoldAbstractModel, BoldUMLXMILink; -{$R *.res} - type {---TBoldRose98FileNameProperty---} @@ -34,7 +37,7 @@ TBoldUMLXMIFileNameProperty = class(TBoldFileNameProperty) {---TBoldRose98FileNameProperty---} function TBoldUMLXMIFileNameProperty.FileFilter: string; begin - Result := Format('%s (*%s)|*%1:s', [XMI_LINKDESC, XMI_LINKEXTENSION]); // do not localize + Result := Format('%s (*%s)|*%1:s', [XMI_LINKDESC, XMI_LINKEXTENSION]); end; function TBoldUMLXMIFileNameProperty.IsValid: boolean; @@ -59,8 +62,8 @@ procedure RegisterComponentsOnPalette; procedure RegisterEditors; begin - RegisterPropertyEditor(TypeInfo(String), TBoldUMLXMILink, 'Filename', TBoldUMLXMIFileNameProperty); // do not localize - RegisterPropertyEditor(TypeInfo(TBoldAbstractModel), TBoldUMLXMILink, 'BoldModel', TBoldComponentPropertyIndicateMissing); // do not localize + RegisterPropertyEditor(TypeInfo(String), TBoldUMLXMILink, 'Filename', TBoldUMLXMIFileNameProperty); + RegisterPropertyEditor(TypeInfo(TBoldAbstractModel), TBoldUMLXMILink, 'BoldModel', TBoldComponentPropertyIndicateMissing); end; procedure Register; diff --git a/Source/UMLModel/ModelLinks/XMI/BoldXMI10Exporter.pas b/Source/UMLModel/ModelLinks/XMI/BoldXMI10Exporter.pas index 3c254686..edba15bc 100644 --- a/Source/UMLModel/ModelLinks/XMI/BoldXMI10Exporter.pas +++ b/Source/UMLModel/ModelLinks/XMI/BoldXMI10Exporter.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldXMI10Exporter; interface @@ -5,16 +8,12 @@ interface uses Variants, BoldContainers, -// BoldUMLModel, BoldLogForm, -// BoldSystem, -// BoldAttributes, + BoldUMLXMILink, -// BoldSystemRT, BoldMOFInterfaces, -// BoldUMLXMILinkSupport, - MSXML_TLB, - Sysutils, // for TFileName + Bold_MSXML_TLB, + Sysutils, BoldStringList, BoldUMLDTDData, Classes; @@ -90,9 +89,9 @@ function TBoldXMI10Exporter.BooleanAsString(Value: IBoldMOFAttribute): string; begin assert(Value.IsBoolean); if Value.AsBoolean then - result := 'true' // do not localize + result := 'true' else - result := 'false'; // do not localize + result := 'false'; end; procedure TBoldXMI10Exporter.CompositeAsElement(Composite: IBoldMOFReference; @@ -290,7 +289,7 @@ function TBoldXMI10Exporter.QualifiedClassName(Obj: IBoldMOFObject): string; function TBoldXMI10Exporter.QualifiedAttributeName( Attribute: IBoldMOFAttribute): string; begin - result := Attribute.QualifiedName; + result := Attribute.QualifiedName; end; procedure TBoldXMI10Exporter.RawExport(RootObj: IBoldMOFObject); @@ -300,14 +299,14 @@ procedure TBoldXMI10Exporter.RawExport(RootObj: IBoldMOFObject); begin aDom := TDOMDocument.Create(nil); aDom.documentElement := aDom.createElement(XMI_NODENAME_ROOT); - aDom.documentElement.setAttribute(XMI_ATTRIBUTENAME_VERSION, '1.0'); // do not localize + aDom.documentElement.setAttribute(XMI_ATTRIBUTENAME_VERSION, '1.0'); ProduceHeader(aDom.documentElement); ContentsFromRoot(RootObj, aDom.documentElement); aStringList := TStringList.Create; - aStringList.Add(''); // do not localize - aStringList.Add(''); // do not localize + aStringList.Add(''); + aStringList.Add(''); aStringList.Add(aDom.DefaultInterface.xml); aStringList.SaveToFile(OwningLink.FileName); @@ -380,7 +379,7 @@ procedure TBoldXMI10Exporter.SvAttributeContents( function TBoldXMI10Exporter.QualifiedReferenceName( Reference: IBoldMOFReference): string; begin - result := Reference.QualifiedName; + result := Reference.QualifiedName; end; procedure TBoldXMI10Exporter.EmbeddedObject(Attribute: IBoldMOFAttribute; @@ -402,4 +401,6 @@ destructor TBoldXMI10Exporter.Destroy; inherited; end; +initialization + end. diff --git a/Source/UMLModel/Plugins/BoldCodePlugins.pas b/Source/UMLModel/Plugins/BoldCodePlugins.pas index dff78d0b..930f46ef 100644 --- a/Source/UMLModel/Plugins/BoldCodePlugins.pas +++ b/Source/UMLModel/Plugins/BoldCodePlugins.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldCodePlugins; interface @@ -112,7 +115,7 @@ function TUMLCodeGenerator.GetMenuItemName: String; function TUMLCodeGenerator.GetImageResourceName: String; begin - result := 'UMLPluginGenCodeImage'; // do not localize + result := 'UMLPluginGenCodeImage'; end; procedure TUMLCodeGenerator.GenerateCode(Generator: TBoldGenerator); @@ -131,7 +134,7 @@ procedure TUMLIDLGenerator.GenerateCode(Generator: TBoldGenerator); function TUMLIDLGenerator.GetImageResourceName: String; begin - result := 'UMLPluginGenIDLImage'; // do not localize + result := 'UMLPluginGenIDLImage'; end; function TUMLIDLGenerator.GetMenuItemName: String; @@ -144,13 +147,13 @@ function TUMLIDLGenerator.GetMenuItemName: String; procedure TUMLMIDLGenerator.GenerateCode(Generator: TBoldGenerator); begin Generator.GenerateMIDLCode := true; - Generator.UseTypedLists := true; + Generator.UseTypedLists := false; Generator.GenerateComInterfaces; end; function TUMLMIDLGenerator.GetImageResourceName: String; begin - result := 'UMLPluginGenMIDLImage'; // do not localize + result := 'UMLPluginGenMIDLImage'; end; function TUMLMIDLGenerator.GetMenuItemName: String; @@ -169,7 +172,7 @@ procedure TUMLAbstractCodeGenerator.Execute(context: IUMLModelPlugInContext); BoldGuard := TBoldGuard.Create(Validator); BoldModel := Context.GetCurrentModelHandle; - Validator := TBoldUMLModelValidator.Create(Context.GetCurrentModelHandle.EnsuredUMLModel, nil, BoldDefaultValidatorSourceLanguage); + Validator := TBoldUMLModelValidator.Create(Context.GetCurrentModelHandle, nil, BoldDefaultValidatorSourceLanguage); Validator.validate(BoldModel.TypeNameDictionary); if context.GetCurrentModelHandle.EnsuredUMLModel.Validator.HighestSeverity = sError then @@ -191,7 +194,7 @@ procedure TUMLAbstractCodeGenerator.Generate(MoldModel: TMoldModel; BoldGuard: IBoldGuard; begin BoldGuard := TBoldGuard.Create(Generator); - Generator := BoldGeneratorClass.Create(TypenameDictionary); + Generator := TBoldGenerator.Create(TypenameDictionary); Generator.BaseFilePath := Path; Generator.UseTypedLists := true; Generator.MoldModel := MoldModel; @@ -247,7 +250,7 @@ function TUMLGUIDGenerator.GetImageMaskColor: TColor; function TUMLGUIDGenerator.GetImageResourceName: String; begin - result := 'UMLPluginGenGUIDs'; // do not localize + result := 'UMLPluginGenGUIDs'; end; function TUMLGUIDGenerator.GetMenuItemName: String; @@ -274,7 +277,7 @@ procedure TUMLPersistenceInterfaceGenerator.GenerateCode(Generator: TBoldGenerat function TUMLPersistenceInterfaceGenerator.GetImageResourceName: String; begin - result := 'UMLPluginGenPersistenceInterfaceImage'; // do not localize + result := 'UMLPluginGenPersistenceInterfaceImage'; end; function TUMLPersistenceInterfaceGenerator.GetMenuItemName: String; @@ -296,5 +299,3 @@ finalization FreeAndNil(_IDLGenerator); FreeAndNil(_MIDLGenerator); end. - - diff --git a/Source/UMLModel/Plugins/BoldDbPlugins.pas b/Source/UMLModel/Plugins/BoldDbPlugins.pas index bfde0bd7..2a44dc35 100644 --- a/Source/UMLModel/Plugins/BoldDbPlugins.pas +++ b/Source/UMLModel/Plugins/BoldDbPlugins.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDbPlugins; interface @@ -24,7 +27,7 @@ TUMLGenericDBPlugin = class(TUMLPlugInFunction) private function GetPersistenceHandle(BoldModel: TBoldModel): TBoldAbstractPersistenceHandleDB; protected - function GetImageMaskColor: TColor; override; + function GetImageMaskColor: TColor; override; function GetPlugInType: TPlugInType; override; function GetOptions: TBoldUMLPluginOptions; override; function GetValidPersistenceHandle(Context: IUMLModelPlugInContext): TBoldAbstractPersistenceHandleDB; @@ -104,7 +107,7 @@ function TUMLDBGenerator.GetMenuItemName: String; function TUMLDBGenerator.GetImageResourceName: String; begin - result := 'UMLPluginGenDBImage'; // do not localize + result := 'UMLPluginGenDBImage'; end; procedure TUMLDBGenerator.Execute(context: IUMLModelPlugInContext); @@ -146,7 +149,7 @@ procedure TBoldDbDataValidatorPlugin.Execute(context: IUMLModelPlugInContext); function TBoldDbDataValidatorPlugin.GetImageResourceName: String; begin - result := 'UMLPluginDataValidator'; // do not localize + result := 'UMLPluginDataValidator'; end; function TBoldDbDataValidatorPlugin.GetMenuItemName: String; @@ -185,7 +188,7 @@ procedure TBoldUMLDBEvolutorPlugin.Execute(context: IUMLModelPlugInContext); function TBoldUMLDBEvolutorPlugin.GetImageResourceName: String; begin - result := 'UMLPluginDbEvolutor'; // do not localize + result := 'UMLPluginDbEvolutor'; end; function TBoldUMLDBEvolutorPlugin.GetMenuItemName: String; @@ -210,21 +213,35 @@ function TUMLGenericDBPlugin.GetPersistenceHandle(BoldModel: TBoldModel): TBoldA var i: integer; temp: TBoldAbstractPersistenceHandleDB; + List: TList; begin result := nil; - for i := 0 to BoldHandle.BoldHandleList.Count - 1 do - if (BoldHandleList[i] is TBoldAbstractPersistenceHandleDB) then + List := TList.Create; + try + for i := 0 to BoldHandle.BoldHandleList.Count - 1 do + if (BoldHandleList[i] is TBoldAbstractPersistenceHandleDB) then + begin + temp := BoldHandleList[i] as TBoldAbstractPersistenceHandleDB; + if (temp.BoldModel = BoldModel) then + List.Add(Temp); + end; + if List.Count = 0 then + raise Exception.Create('No persistencehandle found. If your persistencehandle is on a datamodule/form that has not been opened, please open the datamodule/form and try again'); + if List.Count = 1 then + Result := TBoldAbstractPersistenceHandleDB(List[0]) + else + for I := 0 to List.Count - 1 do begin - temp := BoldHandleList[i] as TBoldAbstractPersistenceHandleDB; - if (temp.BoldModel = BoldModel) and - (MessageDlg(format('Use Database settings from %s?', [Temp.Name]), mtConfirmation, [mbYes, mbNo], 0) = mrYes) then + Temp := TBoldAbstractPersistenceHandleDB(List[0]); + if (MessageDlg(format('Use Database settings from %s?', [Temp.Name]), mtConfirmation, [mbYes, mbNo], 0) = mrYes) then begin result := temp; break; end; end; - if not assigned(Result) then - raise Exception.Create('No persistencehandle found. If your persistencehandle is on a datamodule/form that has not been opened, please open the datamodule/form and try again'); + finally + List.free; + end; end; function TUMLGenericDBPlugin.GetPlugInType: TPlugInType; @@ -246,7 +263,9 @@ function TUMLGenericDBPlugin.GetValidPersistenceHandle( Result := GetPersistenceHandle(BoldModel); if not assigned(Result) then raise EBold.CreateFmt('%s: No persistence handle to act on', [MenuItemName]); - Validator := TBoldUMLModelValidator.Create(Context.GetCurrentModelHandle.EnsuredUMLModel, Result.SQLDataBaseConfig); + if not assigned(Result.SQLDataBaseConfig) then + raise EBold.CreateFmt('%s: No SQLDataBaseConfig found.', [MenuItemName]); + Validator := TBoldUMLModelValidator.Create(Context.GetCurrentModelHandle, Result.SQLDataBaseConfig); Validator.validate(BoldModel.TypeNameDictionary); if Context.GetCurrentModelHandle.EnsuredUMLModel.Validator.HighestSeverity = sError then @@ -254,6 +273,7 @@ function TUMLGenericDBPlugin.GetValidPersistenceHandle( end; initialization + _DBGenerator := TUMLDBGenerator.Create(true); _dbStructureValidator := TBolddbStructureValidatorPlugin.Create(true); _dbDataValidator := TBolddbDataValidatorPlugin.Create(true); @@ -265,4 +285,3 @@ finalization FreeAndNil(_dbDataValidator); FreeAndNil(_DbEvolutor); end. - diff --git a/Source/UMLModel/Plugins/BoldModelOCLValidatorPlugIn.pas b/Source/UMLModel/Plugins/BoldModelOCLValidatorPlugIn.pas index 03bfff16..97c55a4b 100644 --- a/Source/UMLModel/Plugins/BoldModelOCLValidatorPlugIn.pas +++ b/Source/UMLModel/Plugins/BoldModelOCLValidatorPlugIn.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldModelOCLValidatorPlugIn; interface @@ -43,7 +46,6 @@ procedure TUMLOCLValidator.Execute(Context: IUMLModelPlugInContext); var frmValidation: TfrmValidation; begin - // We delegate to the validation form to invoke the validation via the callback method. frmValidation := EnsureValidationForm(context.GetCurrentModelHandle, G_ValidationFormDefaultOwner, nil); frmValidation.ValidationProc := TUMLOCLValidatorCallBack.Validate; frmValidation.Validate; @@ -76,6 +78,7 @@ function TUMLOCLValidator.GetPlugInType: TPlugInType; end; initialization + _UMLOCLValidator := TUMLOCLValidator.Create(true); finalization diff --git a/Source/UMLModel/Plugins/BoldUMLModelEditPlugIn.pas b/Source/UMLModel/Plugins/BoldUMLModelEditPlugIn.pas index 49ad39bb..28d572fa 100644 --- a/Source/UMLModel/Plugins/BoldUMLModelEditPlugIn.pas +++ b/Source/UMLModel/Plugins/BoldUMLModelEditPlugIn.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLModelEditPlugIn; interface @@ -58,8 +61,6 @@ TUMLPlugIn = class property PluginClassName: string read fPlugInClassName; procedure GuardedExecute(Context: IUMLModelPlugInContext); procedure UnGuardedExecute(Context: IUMLModelPlugInContext); - - //property Action: TAction read FAction write FAction; end; TUMLPlugInMenuItem = class(TMenuItem) @@ -122,4 +123,6 @@ procedure TUMLPlugIn.UnGuardedExecute(Context: IUMLModelPlugInContext); OnExecute(Context); end; +initialization + end. diff --git a/Source/UMLModel/Plugins/BoldUMLModelToEcoIIIGenerator.pas b/Source/UMLModel/Plugins/BoldUMLModelToEcoIIIGenerator.pas index 46dac180..7003c772 100644 --- a/Source/UMLModel/Plugins/BoldUMLModelToEcoIIIGenerator.pas +++ b/Source/UMLModel/Plugins/BoldUMLModelToEcoIIIGenerator.pas @@ -8,7 +8,7 @@ interface Dialogs, BoldSystem, BoldGuidUtils, - MSXML_TLB, + Bold_MSXML_TLB, BoldUMLModel, BoldUMLTypes, BoldUMLPlugins, @@ -334,7 +334,7 @@ function TUMLModelToEcoIIIGenerator.GetImageMaskColor: TColor; // Resource for menu and button icon function TUMLModelToEcoIIIGenerator.GetImageResourceName: String; begin - result := 'EcoIII package file generator'; + result := 'UMLPluginExportImage'; end; // Caption for menu and hint for button diff --git a/Source/UMLModel/Plugins/BoldUMLPluginCallBacks.pas b/Source/UMLModel/Plugins/BoldUMLPluginCallBacks.pas index 5860d49f..6506e921 100644 --- a/Source/UMLModel/Plugins/BoldUMLPluginCallBacks.pas +++ b/Source/UMLModel/Plugins/BoldUMLPluginCallBacks.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLPluginCallBacks; interface @@ -21,7 +24,7 @@ TUMLOCLValidatorCallBack = class TBoldUMLModelValidatorCallBack = class public class procedure Validate(Modelhandle: TBoldModel); - end; + end; implementation @@ -40,7 +43,7 @@ class procedure TUMLOCLValidatorCallBack.Validate(Modelhandle: TBoldModel); begin OCLValidityChecker := TOCLValidityChecker.Create(Modelhandle.TypeNameDictionary); try - OCLValidityChecker.ValidateModel(Modelhandle.EnsuredUMLModel); + OCLValidityChecker.ValidateModel(Modelhandle); finally OCLValidityChecker.Free; end; @@ -52,7 +55,7 @@ class procedure TBoldUMLModelValidatorCallBack.Validate(Modelhandle: TBoldModel) var ModelValidator: TBoldUMLModelValidator; begin - ModelValidator := TBoldUMLModelValidator.Create(Modelhandle.EnsuredUMLModel, SQLDataBaseConfigforModel(Modelhandle)); + ModelValidator := TBoldUMLModelValidator.Create(Modelhandle, SQLDataBaseConfigforModel(Modelhandle)); try ModelValidator.Validate(Modelhandle.TypeNameDictionary); finally @@ -60,4 +63,6 @@ class procedure TBoldUMLModelValidatorCallBack.Validate(Modelhandle: TBoldModel) end; end; +initialization + end. diff --git a/Source/UMLModel/Plugins/BoldUMLPlugins.pas b/Source/UMLModel/Plugins/BoldUMLPlugins.pas index a6d6b534..af6ecaf0 100644 --- a/Source/UMLModel/Plugins/BoldUMLPlugins.pas +++ b/Source/UMLModel/Plugins/BoldUMLPlugins.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldUMLPlugins; interface @@ -68,7 +71,7 @@ TUMLLinkExporter = class(TUMLLinkImporterExporter) function GetPlugInType: TPlugInType; override; function GetImageResourceName: String; override; function GetImageMaskColor: TColor; override; - function GetOptions: TBoldUMLPluginOptions; override; + function GetOptions: TBoldUMLPluginOptions; override; public procedure Execute(context: IUMLModelPlugInContext); override; end; @@ -85,6 +88,7 @@ TUMLModelUpdaterPlugIn = class(TUMLPlugInFunction) end; implementation + {$R BoldUMLPlugins.res} uses @@ -106,7 +110,6 @@ implementation var _LinkExporter: TUMLLinkExporter; _LinkImporter: TUMLLinkImporter; -// _ModelUpdater: TUMLModelUpdaterPlugIn; { TUMLPlugInFunction } @@ -169,7 +172,7 @@ function TUMLLinkImporter.GetPlugInType: TPlugInType; function TUMLLinkImporter.GetImageResourceName: String; begin - result := 'UMLPluginImportImage'; // do not localize + result := 'UMLPluginImportImage'; end; function TUMLLinkImporter.GetImageMaskColor: TColor; @@ -214,7 +217,7 @@ function TUMLLinkExporter.GetPlugInType: TPlugInType; function TUMLLinkExporter.GetImageResourceName: String; begin - result := 'UMLPluginExportImage'; // do not localize + result := 'UMLPluginExportImage'; end; function TUMLLinkExporter.GetImageMaskColor: TColor; @@ -279,7 +282,7 @@ function TUMLModelUpdaterPlugIn.GetImageMaskColor: TColor; function TUMLModelUpdaterPlugIn.GetImageResourceName: String; begin - result := 'UMLPluginModelUpdater'; // do not localize + result := 'UMLPluginModelUpdater'; end; function TUMLModelUpdaterPlugIn.GetMenuItemName: String; @@ -293,13 +296,12 @@ function TUMLModelUpdaterPlugIn.GetPlugInType: TPlugInType; end; initialization + _LinkExporter := TUMLLinkExporter.Create(true); _LinkImporter := TUMLLinkImporter.Create(true); -// _ModelUpdater := TUMLModelUpdaterPlugIn.Create(true); finalization FreeAndNil(_LinkExporter); FreeAndNil(_LinkImporter); -// FreeAndNil(_ModelUpdater); end. diff --git a/Source/UMLModel/Plugins/BoldUMLPlugins.res b/Source/UMLModel/Plugins/BoldUMLPlugins.res new file mode 100644 index 00000000..1f5cda28 Binary files /dev/null and b/Source/UMLModel/Plugins/BoldUMLPlugins.res differ diff --git a/Source/Unassigned/Asta/AstaforBfD.dproj b/Source/Unassigned/Asta/AstaforBfD.dproj new file mode 100644 index 00000000..9a61c9e5 --- /dev/null +++ b/Source/Unassigned/Asta/AstaforBfD.dproj @@ -0,0 +1,176 @@ + + + {80E62428-6352-4CB3-B8F0-613CE169AA20} + AstaforBfD.dpk + True + Debug + 38017 + Package + None + 19.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + true + Cfg_2 + true + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + AstaforBfD + 1 + false + 0 + true + Asta support for Bold for Delphi + true + true + 1046 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + + + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=auto;largeHeap=False;theme=TitleBar;hardwareAccelerated=true;apiKey= + Debug + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_192x192.png + android-support-v4.dex.jar;cloud-messaging.dex.jar;com-google-android-gms.play-services-ads-base.17.2.0.dex.jar;com-google-android-gms.play-services-ads-identifier.16.0.0.dex.jar;com-google-android-gms.play-services-ads-lite.17.2.0.dex.jar;com-google-android-gms.play-services-ads.17.2.0.dex.jar;com-google-android-gms.play-services-analytics-impl.16.0.8.dex.jar;com-google-android-gms.play-services-analytics.16.0.8.dex.jar;com-google-android-gms.play-services-base.16.0.1.dex.jar;com-google-android-gms.play-services-basement.16.2.0.dex.jar;com-google-android-gms.play-services-gass.17.2.0.dex.jar;com-google-android-gms.play-services-identity.16.0.0.dex.jar;com-google-android-gms.play-services-maps.16.1.0.dex.jar;com-google-android-gms.play-services-measurement-base.16.4.0.dex.jar;com-google-android-gms.play-services-measurement-sdk-api.16.4.0.dex.jar;com-google-android-gms.play-services-stats.16.0.1.dex.jar;com-google-android-gms.play-services-tagmanager-v4-impl.16.0.8.dex.jar;com-google-android-gms.play-services-tasks.16.0.1.dex.jar;com-google-android-gms.play-services-wallet.16.0.1.dex.jar;com-google-firebase.firebase-analytics.16.4.0.dex.jar;com-google-firebase.firebase-common.16.1.0.dex.jar;com-google-firebase.firebase-iid-interop.16.0.1.dex.jar;com-google-firebase.firebase-iid.17.1.1.dex.jar;com-google-firebase.firebase-measurement-connector.17.0.1.dex.jar;com-google-firebase.firebase-messaging.17.5.0.dex.jar;fmx.dex.jar;google-play-billing.dex.jar;google-play-licensing.dex.jar + + + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_192x192.png + android-support-v4.dex.jar;cloud-messaging.dex.jar;com-google-android-gms.play-services-ads-base.17.2.0.dex.jar;com-google-android-gms.play-services-ads-identifier.16.0.0.dex.jar;com-google-android-gms.play-services-ads-lite.17.2.0.dex.jar;com-google-android-gms.play-services-ads.17.2.0.dex.jar;com-google-android-gms.play-services-analytics-impl.16.0.8.dex.jar;com-google-android-gms.play-services-analytics.16.0.8.dex.jar;com-google-android-gms.play-services-base.16.0.1.dex.jar;com-google-android-gms.play-services-basement.16.2.0.dex.jar;com-google-android-gms.play-services-gass.17.2.0.dex.jar;com-google-android-gms.play-services-identity.16.0.0.dex.jar;com-google-android-gms.play-services-maps.16.1.0.dex.jar;com-google-android-gms.play-services-measurement-base.16.4.0.dex.jar;com-google-android-gms.play-services-measurement-sdk-api.16.4.0.dex.jar;com-google-android-gms.play-services-stats.16.0.1.dex.jar;com-google-android-gms.play-services-tagmanager-v4-impl.16.0.8.dex.jar;com-google-android-gms.play-services-tasks.16.0.1.dex.jar;com-google-android-gms.play-services-wallet.16.0.1.dex.jar;com-google-firebase.firebase-analytics.16.4.0.dex.jar;com-google-firebase.firebase-common.16.1.0.dex.jar;com-google-firebase.firebase-iid-interop.16.0.1.dex.jar;com-google-firebase.firebase-iid.17.1.1.dex.jar;com-google-firebase.firebase-measurement-connector.17.0.1.dex.jar;com-google-firebase.firebase-messaging.17.5.0.dex.jar;fmx.dex.jar;google-play-billing.dex.jar;google-play-licensing.dex.jar + + + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_1024x1024.png + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + DEBUG;$(DCC_Define) + false + true + + + Debug + + + Debug + + + Debug + + + + MainSource + + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + AstaforBfD.dpk + + + + False + True + False + True + False + True + False + True + True + False + + + 12 + + + + diff --git a/Source/Unassigned/Asta/AstaforBfD.res b/Source/Unassigned/Asta/AstaforBfD.res new file mode 100644 index 00000000..89beac0b Binary files /dev/null and b/Source/Unassigned/Asta/AstaforBfD.res differ diff --git a/Source/Unassigned/BoldDataSetIPD4.dproj b/Source/Unassigned/BoldDataSetIPD4.dproj new file mode 100644 index 00000000..f547a218 --- /dev/null +++ b/Source/Unassigned/BoldDataSetIPD4.dproj @@ -0,0 +1,168 @@ + + + {AA2B7764-D39D-459A-A19F-D2ED3E34A62B} + BoldDataSetIPD4.dpk + True + Debug + 38017 + Package + None + 19.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + true + Cfg_2 + true + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + BoldDataSetIPD4 + 1 + true + true + 1046 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + + + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=auto;largeHeap=False;theme=TitleBar;hardwareAccelerated=true;apiKey= + Debug + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_192x192.png + android-support-v4.dex.jar;cloud-messaging.dex.jar;com-google-android-gms.play-services-ads-base.17.2.0.dex.jar;com-google-android-gms.play-services-ads-identifier.16.0.0.dex.jar;com-google-android-gms.play-services-ads-lite.17.2.0.dex.jar;com-google-android-gms.play-services-ads.17.2.0.dex.jar;com-google-android-gms.play-services-analytics-impl.16.0.8.dex.jar;com-google-android-gms.play-services-analytics.16.0.8.dex.jar;com-google-android-gms.play-services-base.16.0.1.dex.jar;com-google-android-gms.play-services-basement.16.2.0.dex.jar;com-google-android-gms.play-services-gass.17.2.0.dex.jar;com-google-android-gms.play-services-identity.16.0.0.dex.jar;com-google-android-gms.play-services-maps.16.1.0.dex.jar;com-google-android-gms.play-services-measurement-base.16.4.0.dex.jar;com-google-android-gms.play-services-measurement-sdk-api.16.4.0.dex.jar;com-google-android-gms.play-services-stats.16.0.1.dex.jar;com-google-android-gms.play-services-tagmanager-v4-impl.16.0.8.dex.jar;com-google-android-gms.play-services-tasks.16.0.1.dex.jar;com-google-android-gms.play-services-wallet.16.0.1.dex.jar;com-google-firebase.firebase-analytics.16.4.0.dex.jar;com-google-firebase.firebase-common.16.1.0.dex.jar;com-google-firebase.firebase-iid-interop.16.0.1.dex.jar;com-google-firebase.firebase-iid.17.1.1.dex.jar;com-google-firebase.firebase-measurement-connector.17.0.1.dex.jar;com-google-firebase.firebase-messaging.17.5.0.dex.jar;fmx.dex.jar;google-play-billing.dex.jar;google-play-licensing.dex.jar + + + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_192x192.png + android-support-v4.dex.jar;cloud-messaging.dex.jar;com-google-android-gms.play-services-ads-base.17.2.0.dex.jar;com-google-android-gms.play-services-ads-identifier.16.0.0.dex.jar;com-google-android-gms.play-services-ads-lite.17.2.0.dex.jar;com-google-android-gms.play-services-ads.17.2.0.dex.jar;com-google-android-gms.play-services-analytics-impl.16.0.8.dex.jar;com-google-android-gms.play-services-analytics.16.0.8.dex.jar;com-google-android-gms.play-services-base.16.0.1.dex.jar;com-google-android-gms.play-services-basement.16.2.0.dex.jar;com-google-android-gms.play-services-gass.17.2.0.dex.jar;com-google-android-gms.play-services-identity.16.0.0.dex.jar;com-google-android-gms.play-services-maps.16.1.0.dex.jar;com-google-android-gms.play-services-measurement-base.16.4.0.dex.jar;com-google-android-gms.play-services-measurement-sdk-api.16.4.0.dex.jar;com-google-android-gms.play-services-stats.16.0.1.dex.jar;com-google-android-gms.play-services-tagmanager-v4-impl.16.0.8.dex.jar;com-google-android-gms.play-services-tasks.16.0.1.dex.jar;com-google-android-gms.play-services-wallet.16.0.1.dex.jar;com-google-firebase.firebase-analytics.16.4.0.dex.jar;com-google-firebase.firebase-common.16.1.0.dex.jar;com-google-firebase.firebase-iid-interop.16.0.1.dex.jar;com-google-firebase.firebase-iid.17.1.1.dex.jar;com-google-firebase.firebase-measurement-connector.17.0.1.dex.jar;com-google-firebase.firebase-messaging.17.5.0.dex.jar;fmx.dex.jar;google-play-billing.dex.jar;google-play-licensing.dex.jar + + + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_1024x1024.png + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + DEBUG;$(DCC_Define) + false + true + + + Debug + + + Debug + + + Debug + + + + MainSource + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + BoldDataSetIPD4.dpk + + + + False + True + False + True + False + True + False + True + True + False + + + 12 + + + + diff --git a/Source/Unassigned/BoldDataSetIPD4.res b/Source/Unassigned/BoldDataSetIPD4.res new file mode 100644 index 00000000..c29ccf6f Binary files /dev/null and b/Source/Unassigned/BoldDataSetIPD4.res differ diff --git a/Source/Unassigned/BoldUMLModelEditorDebugger.dpk b/Source/Unassigned/BoldUMLModelEditorDebugger.dpk index e9137456..1e24c0f9 100644 --- a/Source/Unassigned/BoldUMLModelEditorDebugger.dpk +++ b/Source/Unassigned/BoldUMLModelEditorDebugger.dpk @@ -25,11 +25,11 @@ package BoldUMLModelEditorDebugger; {$IMPLICITBUILD OFF} requires - vcl50, - Vcldb50, - Bold30D5, - Bold30D5Uml, - Bold30D5Utils; + vcl, + Vcldb, + Bold90, + BoldUml90, + BoldUtility; contains BoldUMLModelEditorDebuggerPlugin in 'BoldUMLModelEditorDebuggerPlugin.pas'; diff --git a/Source/Unassigned/BoldUMLModelEditorDebugger.dproj b/Source/Unassigned/BoldUMLModelEditorDebugger.dproj new file mode 100644 index 00000000..ecd84c78 --- /dev/null +++ b/Source/Unassigned/BoldUMLModelEditorDebugger.dproj @@ -0,0 +1,170 @@ + + + {B1033BC2-F58D-4BB6-A117-26186C23A3EF} + BoldUMLModelEditorDebugger.dpk + True + Debug + 38017 + Package + None + 19.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + true + Cfg_2 + true + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + BoldUMLModelEditorDebugger + 1 + false + true + true + 1046 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + + + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=auto;largeHeap=False;theme=TitleBar;hardwareAccelerated=true;apiKey= + Debug + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_192x192.png + android-support-v4.dex.jar;cloud-messaging.dex.jar;com-google-android-gms.play-services-ads-base.17.2.0.dex.jar;com-google-android-gms.play-services-ads-identifier.16.0.0.dex.jar;com-google-android-gms.play-services-ads-lite.17.2.0.dex.jar;com-google-android-gms.play-services-ads.17.2.0.dex.jar;com-google-android-gms.play-services-analytics-impl.16.0.8.dex.jar;com-google-android-gms.play-services-analytics.16.0.8.dex.jar;com-google-android-gms.play-services-base.16.0.1.dex.jar;com-google-android-gms.play-services-basement.16.2.0.dex.jar;com-google-android-gms.play-services-gass.17.2.0.dex.jar;com-google-android-gms.play-services-identity.16.0.0.dex.jar;com-google-android-gms.play-services-maps.16.1.0.dex.jar;com-google-android-gms.play-services-measurement-base.16.4.0.dex.jar;com-google-android-gms.play-services-measurement-sdk-api.16.4.0.dex.jar;com-google-android-gms.play-services-stats.16.0.1.dex.jar;com-google-android-gms.play-services-tagmanager-v4-impl.16.0.8.dex.jar;com-google-android-gms.play-services-tasks.16.0.1.dex.jar;com-google-android-gms.play-services-wallet.16.0.1.dex.jar;com-google-firebase.firebase-analytics.16.4.0.dex.jar;com-google-firebase.firebase-common.16.1.0.dex.jar;com-google-firebase.firebase-iid-interop.16.0.1.dex.jar;com-google-firebase.firebase-iid.17.1.1.dex.jar;com-google-firebase.firebase-measurement-connector.17.0.1.dex.jar;com-google-firebase.firebase-messaging.17.5.0.dex.jar;fmx.dex.jar;google-play-billing.dex.jar;google-play-licensing.dex.jar + + + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_192x192.png + android-support-v4.dex.jar;cloud-messaging.dex.jar;com-google-android-gms.play-services-ads-base.17.2.0.dex.jar;com-google-android-gms.play-services-ads-identifier.16.0.0.dex.jar;com-google-android-gms.play-services-ads-lite.17.2.0.dex.jar;com-google-android-gms.play-services-ads.17.2.0.dex.jar;com-google-android-gms.play-services-analytics-impl.16.0.8.dex.jar;com-google-android-gms.play-services-analytics.16.0.8.dex.jar;com-google-android-gms.play-services-base.16.0.1.dex.jar;com-google-android-gms.play-services-basement.16.2.0.dex.jar;com-google-android-gms.play-services-gass.17.2.0.dex.jar;com-google-android-gms.play-services-identity.16.0.0.dex.jar;com-google-android-gms.play-services-maps.16.1.0.dex.jar;com-google-android-gms.play-services-measurement-base.16.4.0.dex.jar;com-google-android-gms.play-services-measurement-sdk-api.16.4.0.dex.jar;com-google-android-gms.play-services-stats.16.0.1.dex.jar;com-google-android-gms.play-services-tagmanager-v4-impl.16.0.8.dex.jar;com-google-android-gms.play-services-tasks.16.0.1.dex.jar;com-google-android-gms.play-services-wallet.16.0.1.dex.jar;com-google-firebase.firebase-analytics.16.4.0.dex.jar;com-google-firebase.firebase-common.16.1.0.dex.jar;com-google-firebase.firebase-iid-interop.16.0.1.dex.jar;com-google-firebase.firebase-iid.17.1.1.dex.jar;com-google-firebase.firebase-measurement-connector.17.0.1.dex.jar;com-google-firebase.firebase-messaging.17.5.0.dex.jar;fmx.dex.jar;google-play-billing.dex.jar;google-play-licensing.dex.jar + + + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_1024x1024.png + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + DEBUG;$(DCC_Define) + false + true + + + Debug + + + Debug + + + Debug + + + + MainSource + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + BoldUMLModelEditorDebugger.dpk + + + + False + True + False + True + False + True + False + True + True + False + + + 12 + + + + diff --git a/Source/Unassigned/BoldUMLModelEditorDebugger.res b/Source/Unassigned/BoldUMLModelEditorDebugger.res new file mode 100644 index 00000000..3ac2f838 Binary files /dev/null and b/Source/Unassigned/BoldUMLModelEditorDebugger.res differ diff --git a/Source/ValueSpace/Condition/BoldCondition.pas b/Source/ValueSpace/Condition/BoldCondition.pas index f81ad769..e30f0c5c 100644 --- a/Source/ValueSpace/Condition/BoldCondition.pas +++ b/Source/ValueSpace/Condition/BoldCondition.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldCondition; interface @@ -60,6 +63,17 @@ TBoldSQLCondition = class(TBoldConditionWithClass) property JoinInheritedTables: Boolean read fJoinInheritedTables write fJoinInheritedTables; end; + {---TBoldRawSQLCondition---} + TBoldRawSQLCondition = class(TBoldConditionWithClass) + private + fSQL: string; + fParams: TParams; + public + function GetStreamName: string; override; + property Params: TParams read fParams write fParams; + property SQL: string read fSQL write fSQL; + end; + {---TBoldTimestampCondition---} TBoldTimestampCondition = class(TBoldConditionWithClass) private @@ -105,8 +119,8 @@ implementation uses classes, - MSXML_TLB, - BoldDefaultStreamNames; + {$IFDEF OXML}OXmlPDOM{$ELSE}Bold_MSXML_TLB{$ENDIF}, + BoldDefaultStreamNames; const BoldNodeName_MaxAnswers = 'MaxAnswers'; @@ -130,6 +144,10 @@ implementation BoldNodeName_MemberIds = 'MemberIds'; type + {$IFNDEF BOLD_DELPHI17_OR_LATER} + TValueBuffer = Pointer; + {$ENDIF} + { TBoldXMLSQLConditionStreamer} TBoldXMLSQLConditionStreamer = class(TBoldXMLConditionWithClassStreamer) protected @@ -162,6 +180,7 @@ TBoldXMLChangePointConditionStreamer = class(TBoldXMLConditionStreamer) const SQLConditionName = 'SQLCondition'; + RawSQLConditionName = 'RawSQLCondition'; ClassConditionName = 'ClassCondition'; TimestampConditionName = 'TimestampCondition'; OclConditionName = 'OclCondition'; @@ -193,6 +212,13 @@ function TBoldSQLCondition.GetStreamName: string; result := SQLConditionName; end; +{ TBoldRawSQLCondition } + +function TBoldRawSQLCondition.GetStreamName: string; +begin + Result := RawSQLConditionName; +end; + { TBoldTimestampCondition } function TBoldTimestampCondition.GetStreamName: string; @@ -278,13 +304,19 @@ function TBoldXMLSQLConditionStreamer.GetStreamName: string; procedure TBoldXMLSQLConditionStreamer.ReadObject(Obj: TObject; Node: TBoldXMLNode); var anSQLCond: TBoldSQLCondition; + {$IFDEF OXML} + aNodeEnumerator: TXMLResNodeListEnumerator; + aNodeList: IXMLNodeList; + aNode: PXMLNode; + {$ELSE} aNodeList: IXMLDOMNodeList; aNode: IXMLDOMNode; + {$ENDIF} aSubNode: TBoldXMLNode; ParamsNode: TBoldXMLNode; DataNode: TBoldXMLNode; aParam: TParam; - Buf: string; + Buf: TBoldAnsiString; begin inherited; anSQLCond := Obj as TBoldSQLCondition; @@ -296,6 +328,32 @@ procedure TBoldXMLSQLConditionStreamer.ReadObject(Obj: TObject; Node: TBoldXMLNo if not ParamsNode.IsNull then begin anSQLCond.Params := TParams.Create; + {$IFDEF OXML} + if Node.XMLDomElement.GetElementsByTagName(BoldNodeName_Param, aNodeList) then + begin + aNodeEnumerator := aNodeList.GetEnumerator; + try + while aNodeEnumerator.MoveNext do begin + aNode := aNodeEnumerator.Current; + aSubNode := Node.MakeNodeForElement(aNode); + aParam := anSQLCond.Params.Add as TParam; + aParam.Name := aSubNode.ReadSubNodeString(BoldNodeName_Name); + aParam.DataType := TFieldType(aSubNode.ReadSubNodeInteger(BoldNodeName_DataType)); + aParam.ParamType := TParamType(aSubNode.ReadSubNodeInteger(BoldNodeName_ParamType)); + DataNode := aSubNode.GetSubNode(BoldNodeName_Data); + if Assigned(DataNode) then + begin + Buf := DataNode.ReadData; + aParam.SetData(TValueBuffer(PAnsiChar(Buf))); + end; + DataNode.Free; + aSubNode.Free; + end; + finally + aNodeEnumerator.Free; + end; + end; + {$ELSE} aNodeList := Node.XMLDomElement.getElementsByTagName(BoldNodeName_Param); aNode := aNodeList.nextNode; @@ -311,12 +369,13 @@ procedure TBoldXMLSQLConditionStreamer.ReadObject(Obj: TObject; Node: TBoldXMLNo if assigned(DataNode) then begin Buf := DataNode.ReadData; - aParam.SetData(PChar(Buf)); + aParam.SetData(PAnsiChar(Buf)); end; DataNode.Free; aSubNode.Free; aNode := aNodeList.nextNode; end; + {$ENDIF} end else anSQLCond.Params := nil; @@ -326,7 +385,7 @@ procedure TBoldXMLSQLConditionStreamer.ReadObject(Obj: TObject; Node: TBoldXMLNo procedure TBoldXMLSQLConditionStreamer.WriteObject(Obj: TBoldInterfacedObject; Node: TBoldXMLNode); var anSQLCond: TBoldSQLCondition; - Buf: string; + Buf: TBoldAnsiString; i: Integer; SubNode: TBoldXMLNode; ParamsNode: TBoldXMLNode; @@ -344,7 +403,7 @@ procedure TBoldXMLSQLConditionStreamer.WriteObject(Obj: TBoldInterfacedObject; N begin SubNode := ParamsNode.NewSubNode(BoldNodeName_Param); SetLength(Buf, anSQLCond.Params[i].GetDataSize); - anSQLCond.Params[i].GetData(PChar(Buf)); + anSQLCond.Params[i].GetData(TValueBuffer(PAnsiChar(Buf))); SubNode.WriteSubNodeString(BoldNodeName_Name, anSQLCond.Params[i].Name); SubNode.WriteSubNodeInteger(BoldNodeName_DataType, Integer(anSQLCond.Params[i].DataType)); SubNode.WriteSubNodeInteger(BoldNodeName_ParamType, Integer(anSQLCond.Params[i].ParamType)); @@ -417,6 +476,7 @@ procedure TBoldXMLChangePointConditionStreamer.WriteObject(Obj: TBoldInterfacedO Node.WriteSubNodeObject(BoldNodeName_MemberIds, BOLDMEMBERIDLISTNAME, aCond.MemberIdList); end; + { TBoldCondition } constructor TBoldCondition.create; diff --git a/Source/ValueSpace/ExternalEvents/BoldObjectSpaceExternalEvents.pas b/Source/ValueSpace/ExternalEvents/BoldObjectSpaceExternalEvents.pas index 75099aa4..0e1d2c0e 100644 --- a/Source/ValueSpace/ExternalEvents/BoldObjectSpaceExternalEvents.pas +++ b/Source/ValueSpace/ExternalEvents/BoldObjectSpaceExternalEvents.pas @@ -1,50 +1,81 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldObjectSpaceExternalEvents; interface uses BoldID, - BoldDefaultID; + BoldDefaultID, + BoldLogHandler; type TBoldEventType = Char; TBoldExternalEvent = String; TBoldObjectSpaceExternalEvent = class; - TBoldObjectSpaceSubscriptionType = (bsClassChanged, bsEmbeddedStateOfObjectChanged, - bsNonEmbeddedStateOfObjectChanged, bsGotLocks, bsLockLost{, bsDBLock}, bsObjectDeleted); + TBoldObjectSpaceSubscriptionType = + (bsClassChanged, + bsEmbeddedStateOfObjectChanged, + bsNonEmbeddedStateOfObjectChanged, + bsGotLocks, + bsLockLost{, bsDBLock}, + bsObjectCreated, + bsObjectDeleted, + bsMemberChanged); TBoldObjectSpaceExternalEvent = class private - class procedure GetID(Event: TBoldExternalEvent; ObjectID: TBoldDefaultID); - class function GetParameter(Event: tBoldExternalEvent): String; - class function GetEventType(Event: TBoldExternalEvent): TBoldObjectSpaceSubscriptionType; + class procedure GetID(const Event: TBoldExternalEvent; ObjectID: TBoldDefaultID; AClassName: string = ''); + class function GetParameter(const Event: TBoldExternalEvent): String; + class function GetEventType(const Event: TBoldExternalEvent): TBoldObjectSpaceSubscriptionType; public - class function EncodeExternalEvent(SubscriptionType: TBoldObjectSpaceSubscriptionType; ClassName,MemberName, LockName: string; + class function EncodeExternalEvent(SubscriptionType: TBoldObjectSpaceSubscriptionType; const AClassName, AMemberName, ALockName: string; ObjectID: TBoldObjectID): String; - class function DecodeExternalEvent(Event: TBoldExternalEvent; - var Classname, MemberName, LockName: String; + class function DecodeExternalEvent(const Event: TBoldExternalEvent; + var AClassname, MemberName, LockName: String; ObjectID: TBoldDefaultID): TBoldObjectSpaceSubscriptionType; end; +procedure BoldOSSLog(const s: string); +procedure BoldOSSLogFmt(const s: string; const Args: array of const); + +var + BoldOSSLogHandler: TBoldLogHandler; + implementation uses SysUtils, BoldDefs, - ValueSpaceConst; + BoldIsoDateTime; const SUBSCRIPTION_DELIMITER_CHAR = ':'; + CLASS_MEMBER_SEPARATOR = '.'; EXTERNAL_EVENT_CLASSCHANGED = 'C'; + EXTERNAL_EVENT_MEMBERCHANGED = 'M'; EXTERNAL_EVENT_EMBEDDEDSTATEOFOBJECTCHANGED = 'E'; EXTERNAL_EVENT_NONEMBEDDEDSTATEOFOBJECTCHANGED = 'I'; + EXTERNAL_EVENT_OBJECTCREATED = 'N'; EXTERNAL_EVENT_EMBEDDEDSTATE_OBJECTDELETED = 'D'; EXTERNAL_EVENT_LOCKLOST = 'L'; EXTERNAL_EVENT_GOTLOCK = 'GotLocks'; -// EXTERNAL_EVENT_DBLOCK = 'DBLock'; -class function TBoldObjectSpaceExternalEvent.GetEventType(Event: TBoldExternalEvent): TBoldObjectSpaceSubscriptionType; +procedure BoldOSSLog(const s: string); +begin + if assigned(BoldOSSLogHandler) then + BoldOSSLogHandler.Log(AsISODateTimeMS(now)+':'+trim(s)); +end; + +procedure BoldOSSLogFmt(const s: string; const Args: array of const); +begin + if assigned(BoldOSSLogHandler) then + BoldOSSLogHandler.LogFmt(AsIsoDateTimeMs(now)+':'+ trim(s), Args); +end; + +class function TBoldObjectSpaceExternalEvent.GetEventType(const Event: TBoldExternalEvent): TBoldObjectSpaceSubscriptionType; var ExternalEvent: char; begin @@ -53,6 +84,7 @@ class function TBoldObjectSpaceExternalEvent.GetEventType(Event: TBoldExternalEv ExternalEvent := Event[1]; case ExternalEvent of EXTERNAL_EVENT_CLASSCHANGED: Result := bsClassChanged; + EXTERNAL_EVENT_MEMBERCHANGED: Result := bsMemberChanged; EXTERNAL_EVENT_EMBEDDEDSTATEOFOBJECTCHANGED: begin if GetParameter(Event) = EXTERNAL_EVENT_EMBEDDEDSTATE_OBJECTDELETED then @@ -61,18 +93,19 @@ class function TBoldObjectSpaceExternalEvent.GetEventType(Event: TBoldExternalEv Result := bsEmbeddedStateOfObjectChanged; end; EXTERNAL_EVENT_NONEMBEDDEDSTATEOFOBJECTCHANGED: Result := bsNonEmbeddedStateOfObjectChanged; + EXTERNAL_EVENT_OBJECTCREATED: Result := bsObjectCreated; EXTERNAL_EVENT_LOCKLOST: Result := bsLockLost; else if Pos(EXTERNAL_EVENT_GOTLOCK, Event) = 1 then Result := bsGotLocks -// else if Pos(EXTERNAL_EVENT_DBLock, Event) = 1 then -// Result := bsDBLock + else - raise EBold.CreateFmt(sInvalidEvent, [Event]); + raise EBold.CreateFmt('Invalid event: %s', [Event]); end end; -class procedure TBoldObjectSpaceExternalEvent.GetID(Event: TBoldExternalEvent; ObjectID: TBoldDefaultID); +class procedure TBoldObjectSpaceExternalEvent.GetID(const Event: TBoldExternalEvent; + ObjectID: TBoldDefaultID; AClassName: string); var p, IDAsInt: Integer; IDAsString: String; @@ -80,83 +113,133 @@ class procedure TBoldObjectSpaceExternalEvent.GetID(Event: TBoldExternalEvent; O if assigned(ObjectId) then begin case GetEventType(Event) of - bsObjectdeleted, bsEmbeddedStateOfObjectChanged: + bsObjectDeleted, bsEmbeddedStateOfObjectChanged, bsObjectCreated, bsNonEmbeddedStateOfObjectChanged, bsMemberChanged: begin - p := pos(PROPAGATOR_PARAMETER_DELIMITER_CHAR, Event); - if p <> 0 then - Delete(Event, p, maxint); - IDAsString := Copy(Event, 3, MaxInt); + IDAsString := Event; + Delete(IDAsString, 1, Pos(SUBSCRIPTION_DELIMITER_CHAR, IDAsString)); + Delete(IDAsString, 1, Pos(SUBSCRIPTION_DELIMITER_CHAR, IDAsString)); + Delete(IDAsString, Pos(PROPAGATOR_PARAMETER_DELIMITER_CHAR,IDAsString), MaxInt); end; - bsNonEmbeddedStateOfObjectChanged: - begin - Delete(Event, 1, Pos(SUBSCRIPTION_DELIMITER_CHAR, Event)); - Delete(Event, 1, Pos(SUBSCRIPTION_DELIMITER_CHAR, Event)); - IDAsString := Event; - end; end; try IDAsInt := StrToInt(IDAsString); ObjectID.AsInteger := IDAsInt; except - raise EBold.CreateFmt(sInvalidID, [IDAsString]); + raise EBold.CreateFmt('Invalid ID, %s is not an valid integer.', [IDAsString]); end; end; end; class function TBoldObjectSpaceExternalEvent.EncodeExternalEvent(SubscriptionType: TBoldObjectSpaceSubscriptionType; - ClassName,MemberName, LockName: string; ObjectID: TBoldObjectID): String; + const AClassName, AMemberName, ALockName: string; ObjectID: TBoldObjectID): String; begin case SubscriptionType of bsClassChanged: Result := EXTERNAL_EVENT_CLASSCHANGED + SUBSCRIPTION_DELIMITER_CHAR + - ClassName; + AClassName; + bsMemberChanged: Result := EXTERNAL_EVENT_MEMBERCHANGED + + SUBSCRIPTION_DELIMITER_CHAR + + AClassName + + CLASS_MEMBER_SEPARATOR + + AMemberName + + SUBSCRIPTION_DELIMITER_CHAR + + ObjectID.AsString; bsEmbeddedStateOfObjectChanged: Result := EXTERNAL_EVENT_EMBEDDEDSTATEOFOBJECTCHANGED + + SUBSCRIPTION_DELIMITER_CHAR + + AClassName + SUBSCRIPTION_DELIMITER_CHAR + ObjectID.AsString; bsNonEmbeddedStateOfObjectChanged: Result := EXTERNAL_EVENT_NONEMBEDDEDSTATEOFOBJECTCHANGED + SUBSCRIPTION_DELIMITER_CHAR + - MemberName + + AClassName + + CLASS_MEMBER_SEPARATOR + + AMemberName + SUBSCRIPTION_DELIMITER_CHAR + ObjectID.AsString; bsLockLost: Result := EXTERNAL_EVENT_LOCKLOST + SUBSCRIPTION_DELIMITER_CHAR + - LockName; + ALockName; bsGotLocks: Result := EXTERNAL_EVENT_GOTLOCK; + bsObjectCreated: Result := EXTERNAL_EVENT_OBJECTCREATED + + SUBSCRIPTION_DELIMITER_CHAR + + AClassName + + SUBSCRIPTION_DELIMITER_CHAR + + ObjectID.AsString; + bsObjectDeleted: Result := EXTERNAL_EVENT_EMBEDDEDSTATEOFOBJECTCHANGED + + SUBSCRIPTION_DELIMITER_CHAR + + AClassName + SUBSCRIPTION_DELIMITER_CHAR + ObjectID.AsString + PROPAGATOR_PARAMETER_DELIMITER_CHAR + EXTERNAL_EVENT_EMBEDDEDSTATE_OBJECTDELETED -// bsDBLock: Result := EXTERNAL_EVENT_DBLOCK; else Result := ''; end; end; -class function TBoldObjectSpaceExternalEvent.DecodeExternalEvent(Event: TBoldExternalEvent; - var Classname, MemberName, LockName: String; +class function TBoldObjectSpaceExternalEvent.DecodeExternalEvent(const Event: TBoldExternalEvent; + var AClassname, MemberName, LockName: String; ObjectID: TBoldDefaultID): TBoldObjectSpaceSubscriptionType; +var + s: string; + i: integer; begin Result := GetEventType(Event); - case Result of - bsClassChanged: ClassName := Copy(Event, Length(EXTERNAL_EVENT_CLASSCHANGED + SUBSCRIPTION_DELIMITER_CHAR) + 1, MaxInt); - bsObjectdeleted, bsEmbeddedStateOfObjectChanged: - begin - GetID(Event, ObjectID); - end; + bsClassChanged: AClassName := Copy(Event, Length(EXTERNAL_EVENT_CLASSCHANGED + SUBSCRIPTION_DELIMITER_CHAR) + 1, MaxInt); + bsObjectCreated: + begin + AClassName := Copy(Event, Length(EXTERNAL_EVENT_OBJECTCREATED + SUBSCRIPTION_DELIMITER_CHAR) + 1, MaxInt); + AClassName := Copy(AClassName, 1, Pos(SUBSCRIPTION_DELIMITER_CHAR,AClassName) - 1); + GetID(Event, ObjectID, AClassName); + BoldOSSLogFmt('Object %s.%s created', [AClassName, ObjectID.AsString]); + end; + bsMemberChanged: + begin + s := Copy(Event, pos(SUBSCRIPTION_DELIMITER_CHAR, Event) + 1, maxint); + i := Pos(CLASS_MEMBER_SEPARATOR, s); + AClassName := Copy(s, 1, i-1); + MemberName := Copy(s, i+1, Pos(SUBSCRIPTION_DELIMITER_CHAR, s)-i-1); + s := Copy(s, Pos(SUBSCRIPTION_DELIMITER_CHAR, s) + 1, MaxInt); + ObjectID.AsInteger := StrToInt(s); + BoldOSSLogFmt('Member modified %s.%s.%s', [AClassName, MemberName, ObjectID.AsString]); + end; + bsObjectDeleted, bsEmbeddedStateOfObjectChanged: + begin + i := pos(SUBSCRIPTION_DELIMITER_CHAR, Event) + 1; + AClassName := Copy(Event, i, Pos(SUBSCRIPTION_DELIMITER_CHAR, Copy(Event, i, maxint)) - 1); + GetID(Event, ObjectID, AClassName); + case bsObjectDeleted of + bsObjectDeleted: BoldOSSLogFmt('Object Deleted %s.%s', [AClassName, ObjectID.AsString]); + bsEmbeddedStateOfObjectChanged: BoldOSSLogFmt('EmbeddedStateOfObjectChanged %s.%s', [AClassName, ObjectID.AsString]); + end; + BoldOSSLogFmt('Object Deleted %s.%s', [AClassName, ObjectID.AsString]); + end; bsNonEmbeddedStateOfObjectChanged: begin - MemberName := Copy(Event, pos(SUBSCRIPTION_DELIMITER_CHAR, Event) + 1, Pos(SUBSCRIPTION_DELIMITER_CHAR, Copy(Event, pos(SUBSCRIPTION_DELIMITER_CHAR, Event) + 1, maxint)) - 1); - GetID(Event, ObjectID); + i := pos(SUBSCRIPTION_DELIMITER_CHAR, Event) + 1; + s := Copy(Event, i, Pos(SUBSCRIPTION_DELIMITER_CHAR, Copy(Event, i, maxint)) - 1); + AClassName := Copy(s, 1, Pos(CLASS_MEMBER_SEPARATOR, s) - 1); + MemberName := Copy(s, Pos(CLASS_MEMBER_SEPARATOR, s) +1, maxint); + GetID(Event, ObjectID, AClassName); + BoldOSSLogFmt('Non Embedded state of object changed: Deleted %s.%s.%s', [AClassName, ObjectID.AsString, MemberName]); + end; + bsLockLost: + begin + LockName := Copy(Event, Length(EXTERNAL_EVENT_LOCKLOST + SUBSCRIPTION_DELIMITER_CHAR) + 1, MaxInt); + BoldOSSLogFmt('Lock Lost %s', [LockName]); + end; + bsGotLocks: + begin + LockName := Copy(Event, Length(EXTERNAL_EVENT_LOCKLOST + SUBSCRIPTION_DELIMITER_CHAR) + 1, MaxInt); + BoldOSSLogFmt('Locks placed %s', [LockName]); end; - bsLockLost: LockName := Copy(Event, Length(EXTERNAL_EVENT_LOCKLOST + SUBSCRIPTION_DELIMITER_CHAR) + 1, MaxInt); - bsGotLocks{, bsDBLock}: ; end; end; -class function TBoldObjectSpaceExternalEvent.GetParameter(Event: tBoldExternalEvent): String; +class function TBoldObjectSpaceExternalEvent.GetParameter(const Event: TBoldExternalEvent): String; var p: integer; begin @@ -168,3 +251,4 @@ class function TBoldObjectSpaceExternalEvent.GetParameter(Event: tBoldExternalEv end; end. + diff --git a/Source/ValueSpace/Id/BoldDefaultId.pas b/Source/ValueSpace/Id/BoldDefaultId.pas index 37999581..dac96f83 100644 --- a/Source/ValueSpace/Id/BoldDefaultId.pas +++ b/Source/ValueSpace/Id/BoldDefaultId.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDefaultId; interface @@ -15,8 +18,8 @@ TBoldTimestampedDefaultId = class; TBoldDefaultID = class(TBoldExternalObjectID) protected fDBValue: integer; - procedure SetAsInteger(NewValue: integer); - function GetAsInteger: Integer; + procedure SetAsInteger(NewValue: integer); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetAsInteger: Integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetAsString: string; override; function GetHash: cardinal; override; function GetStreamName: string; override; @@ -35,8 +38,10 @@ TBoldTimestampedDefaultId = class(TBoldDefaultId) protected function GetStreamName: string; override; function GetTimeStamp: TBoldTimeStampType; override; + function GetHash: cardinal; override; + function GetIsEqual(MatchID: TBoldObjectID): Boolean; override; public - constructor createWithTimeAndClassId(TimeStamp: TBoldTimeStampType; TopSortedIndex: integer; Exact: Boolean); + constructor CreateWithTimeAndClassId(TimeStamp: TBoldTimeStampType; TopSortedIndex: integer; Exact: Boolean); function CloneWithClassId(TopSortedIndex: integer; Exact: Boolean): TBoldObjectId; override; property TimeStamp: TBoldTimeStampType read GetTimeStamp write fTimeStamp; end; @@ -88,16 +93,22 @@ function TBoldDefaultID.GetAsInteger: Integer; Result := FDbValue; end; -Function TBolddefaultID.GetIsEqual(MatchID: TBoldObjectID): Boolean; +Function TBoldDefaultID.GetIsEqual(MatchID: TBoldObjectID): Boolean; begin - result := assigned(MatchId) and ((MatchID.ClassType = TBoldDefaultId ) or (MatchID.ClassType = TBoldTimestampedDefaultId )) and - (fdbValue = TBoldDefaultId(MatchId).fDbValue) and - (MatchId.TimeStamp = TimeStamp); + if not assigned(MatchId) then + Result := false + else if MatchID.ClassType = TBoldDefaultId then + Result := fdbValue = TBoldDefaultId(MatchId).fDbValue + else if MatchID.ClassType = TBoldTimestampedDefaultId then + Result := (fdbValue = TBoldTimestampedDefaultId(MatchId).fDbValue) and + (MatchId.TimeStamp = BOLDMAXTIMESTAMP) + else + Result := false; end; function TBoldDefaultID.GetHash: cardinal; begin - result := cardinal(fDBValue) + cardinal(Timestamp); + result := cardinal(fDBValue) + cardinal(BOLDMAXTIMESTAMP); end; procedure TBoldDefaultId.SetAsInteger(NewValue: integer); @@ -124,12 +135,35 @@ function TBoldTimestampedDefaultId.CloneWithClassId(TopSortedIndex: integer; Exa (result as TBoldTimestampedDefaultId).fTimeStamp := fTimeStamp; end; -constructor TBoldTimestampedDefaultId.createWithTimeAndClassId(TimeStamp: TBoldTimeStampType; TopSortedIndex: integer; Exact: Boolean); +constructor TBoldTimestampedDefaultId.CreateWithTimeAndClassId(TimeStamp: TBoldTimeStampType; TopSortedIndex: integer; Exact: Boolean); begin inherited CreateWithClassId(TopSortedIndex, Exact); fTimeStamp := TimeStamp; end; +function TBoldTimestampedDefaultId.GetHash: cardinal; +begin + result := cardinal(fDBValue) + cardinal(fTimestamp); +end; + +function TBoldTimestampedDefaultId.GetIsEqual(MatchID: TBoldObjectID): Boolean; +var + TimestampedMatchId: TBoldTimestampedDefaultId; +begin + if not assigned(MatchId) then + Result := false + else if MatchID.ClassType = TBoldDefaultId then + Result := (fdbValue = TBoldDefaultId(MatchId).fDbValue) and (fTimeStamp = BOLDMAXTIMESTAMP) + else if MatchID.ClassType = TBoldTimestampedDefaultId then + begin + TimestampedMatchId := TBoldTimestampedDefaultId(MatchId); + Result := (fdbValue = TimestampedMatchId.fDbValue) and + (TimestampedMatchId.fTimeStamp = fTimeStamp) + end + else + Result := false; +end; + function TBoldTimestampedDefaultId.GetStreamName: string; begin result := BOLDTIMESTAMPEDDEFAULTIDNAME; @@ -207,6 +241,7 @@ procedure TBoldXMLTimestampedDefaultIdStreamer.WriteObject(Obj: TBoldInterfacedO Node.WriteSubNodeInteger(BoldNodeName_Timestamp, (Obj as TBoldTimestampedDefaultId).TimeStamp); end; + function TBoldDefaultID.CloneWithTimeStamp(Time: TBoldTimeStampType): TBoldDefaultId; begin result := CloneWithClassIdAndTimeStamp(TopSortedIndex, TopSortedIndexExact, time); diff --git a/Source/ValueSpace/Id/BoldGlobalId.pas b/Source/ValueSpace/Id/BoldGlobalId.pas index 75661c20..f9531837 100644 --- a/Source/ValueSpace/Id/BoldGlobalId.pas +++ b/Source/ValueSpace/Id/BoldGlobalId.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldGlobalId; interface @@ -5,7 +8,7 @@ interface uses BoldId, BoldStreams; - + const BOLDGLOBALIDNAME = 'BoldGlobalId'; @@ -29,6 +32,7 @@ TBoldGlobalId = class(TBoldObjectId) property AsString: String read GetAsString; end; + implementation uses diff --git a/Source/ValueSpace/Id/BoldId.pas b/Source/ValueSpace/Id/BoldId.pas index e42b35c9..fc5a8205 100644 --- a/Source/ValueSpace/Id/BoldId.pas +++ b/Source/ValueSpace/Id/BoldId.pas @@ -1,14 +1,15 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldId; interface uses - Classes, BoldDefs, BoldBase, BoldStreams, BoldIndex, - BoldHashIndexes, BoldXMLStreaming, BoldIndexableList; @@ -29,6 +30,10 @@ TBoldIDTranslationList = class; TBoldID = class (TBoldNonRefCountedObject, IBoldStreamable) protected function GetStreamName: string; virtual; abstract; + function GetAsString: string; virtual; abstract; + function GetDebugInfo: string; override; + public + property AsString: string read GetAsString; end; {---TBoldMemberID---} @@ -37,8 +42,10 @@ TBoldMemberID = class(TBoldID) fMemberIndex: Integer; protected function GetStreamName: string; override; + function GetAsString: string; override; public - constructor create(MemberIndex: Integer); + constructor Create(MemberIndex: Integer); + function Clone: TBoldMemberID; property MemberIndex: integer read fMemberIndex; end; @@ -48,32 +55,32 @@ TBoldSubMemberID = class(TBoldmemberID) fOwnsPartof: Boolean; fPartOf: TBoldMemberID; public - constructor Create(partOf: TBoldMemberID; OwnspartOf: Boolean; IndexInMemberList: integer); - destructor Destroy; override; + constructor create(partOf: TBoldMemberID; OwnspartOf: Boolean; IndexInMemberList: integer); + destructor destroy; override; end; {---TBoldObjectId---} TBoldObjectId = class(TBoldID) private FClassId: integer; - function getTopSortedIndex: integer; - function GetTopSortedIndexExact: Boolean; - procedure SetClassIdData(TopSortedIndex: integer; Exact: boolean); + function GetTopSortedIndex: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetTopSortedIndexExact: Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetClassIdData(TopSortedIndex: integer; Exact: boolean); {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected - function GetAsString: string; virtual; abstract; function GetIsStorable: Boolean; virtual; abstract; function GetHash: Cardinal; virtual; abstract; Function GetIsEqual(MatchID: TBoldObjectID): Boolean; virtual; abstract; function GetTimeStamp: TBoldTimeStampType; virtual; + function GetNonExisting: Boolean; virtual; public constructor CreateWithClassID(TopSortedIndex: integer; Exact: Boolean); virtual; function CloneWithClassId(TopSortedIndex: integer; Exact: Boolean): TBoldObjectid; virtual; abstract; - function Clone: TBoldObjectId; + function Clone: TBoldObjectId; {$IFDEF BOLD_INLINE} inline; {$ENDIF} property TopSortedIndex: integer read getTopSortedIndex; property TopSortedIndexExact: Boolean read GetTopSortedIndexExact; - property AsString: string read GetAsString; property IsStorable: Boolean read GetIsStorable; property IsEqual[MatchId: TBoldObjectId]: Boolean read GetIsEqual; + property NonExisting: Boolean read GetNonExisting; property Hash: Cardinal read GetHash; property TimeStamp: TBoldTimeStampType read GetTimeStamp; end; @@ -88,7 +95,6 @@ TBoldInternalObjectId = class(TBoldObjectId) function GetIsStorable: Boolean; override; function GetIsEqual(MatchID: TBoldObjectID): Boolean; override; function GetStreamName: string; override; - public constructor CreateWithClassID(TopSortedIndex: integer; Exact: Boolean); override; constructor CreateWithClassIDandInternalId(InternalIdentifier: integer; TopSortedIndex: integer; Exact: Boolean); @@ -101,8 +107,24 @@ TBoldExternalObjectID = class(TBoldObjectId) function GetIsStorable: Boolean; override; end; + TBoldNonExistingObjectId = class(TBoldObjectId) + protected + function GetStreamName: string; override; + function GetAsString: string; override; + function GetNonExisting: Boolean; override; + function GetIsStorable: Boolean; override; + function GetHash: Cardinal; override; + function GetIsEqual(MatchID: TBoldObjectID): Boolean; override; + public + function CloneWithClassId(TopSortedIndex: integer; Exact: Boolean): TBoldObjectid; override; + end; + {---TBoldIdList---} - TBoldIdList = class(TBoldIndexableList); + TBoldIdList = class(TBoldIndexableList) + public + function CommaSeparatedIdList: String; + property AsString: string read CommaSeparatedIdList; + end; {---TBoldObjectIdHashIndex---} TBoldObjectIdHashIndex = class(TBoldHashIndex) @@ -111,75 +133,88 @@ TBoldObjectIdHashIndex = class(TBoldHashIndex) function HashItem(Item: TObject): Cardinal; override; function Match(const Key; Item:TObject):Boolean; override; function Hash(const Key): Cardinal; override; - function FindById(boldObjectId:TboldObjectId): TObject; + function FindById(BoldObjectId: TBoldObjectId): TObject; {$IFDEF BOLD_INLINE} inline; {$ENDIF} end; {---TBoldObjectIdList---} TBoldObjectIdList = class(TBoldIdList, IBoldStreamable) private + class var IX_ObjectID: integer; function GetObjectIDIndex: TBoldObjectIDHashIndex; + function GetHasInexactIds: boolean; + function GetHasNonExistingIds: boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected - function GetCount: integer; + function GetCount: integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetIDByID(ObjectID: TBoldObjectId): TBoldObjectId; function GetIndexByID(ObjectID: TBoldObjectId): Integer; - function GetObjectId(index: Integer): TBoldObjectId; - function GetIdInList(ObjectID: TBoldObjectId): Boolean; - function GetStreamName: string; + function GetObjectId(index: Integer): TBoldObjectId; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetIdInList(ObjectID: TBoldObjectId): Boolean; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetStreamName: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} property ObjectIDIndex: TBoldObjectIDHashIndex read GetObjectIDIndex; public constructor Create; - procedure Add(ObjectID: TBoldObjectId); - procedure AddIfNotInList(ObjectID: TBoldObjectId); - procedure AddList(ObjectIdList: TBoldObjectIdList); - procedure Insert(Index: integer; ObjectID: TBoldObjectId); + procedure Add(ObjectID: TBoldObjectId); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure AddAndAdopt(ObjectID: TBoldObjectId); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure AddIfNotInList(ObjectID: TBoldObjectId); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure AddList(ObjectIdList: TBoldObjectIdList); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function AddAndGetID(aBoldObjectId: TBoldObjectId): TBoldObjectId; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure Insert(Index: integer; ObjectID: TBoldObjectId); {$IFDEF BOLD_INLINE} inline; {$ENDIF} function ContainsSameIDs(List: TBoldObjectIdList): Boolean; function Clone: TBoldObjectIdList; - function CommaSeparatedIdList: String; - procedure remove(Id: TBoldObjectId); - procedure ReplaceID(OldId, NewId: TBoldObjectId); + procedure Remove(Id: TBoldObjectId); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure ReplaceID(OldId, NewId: TBoldObjectId); {$IFDEF BOLD_INLINE} inline; {$ENDIF} procedure ExactifyIds(TranslationList: TBoldIDTranslationList); procedure ApplyTranslationList(TranslationList: TBoldIdTranslationList); + procedure RemoveNonExistingIds; property IDByID[ObjectID: TBoldObjectId]: TBoldObjectId read GetIdById; property IndexByID[ObjectID: TBoldObjectId]: Integer read GetIndexByID; property ObjectIds[index: Integer]: TBoldObjectId read GetObjectId; default; property IdInList[Objectid: TBoldObjectId]: Boolean read GetIdInList; + property HasInexactIds: boolean read GetHasInexactIds; + property HasNonExistingIds: boolean read GetHasNonExistingIds; end; {---TBoldMemberIdList---} TBoldMemberIdList = class(TBoldIdList, IBoldStreamable) - function GetStreamName: string; + function GetStreamName: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected - function GetMemberIds(Index: Integer): TBoldMemberId; + function GetMemberIds(Index: Integer): TBoldMemberId; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public - Property MemberIds[Index: integer]: TBoldmemberId read GetMemberIds; default; + function IsEqual(AList: TBoldMemberIdList): boolean; + function HasId(AId: TBoldMemberId): boolean; + function Clone: TBoldMemberIdList; + property MemberIds[Index: integer]: TBoldMemberId read GetMemberIds; default; end; {---TBoldIDTranslationList---} TBoldIDTranslationList = class(TBoldNonRefCountedObject, IBoldStreamable) - // Possible Translations: - // In Create-phase: ObjectID changed (Internal -> external), ClassID unchanged - // In Update-Phase: ObjectID Changed (internal -> external) - // In Delete-Phase: Nothing changed - // In Fetch-phase: ObjectID unchanged, ClassID changed private fOldIds: TBoldObjectIdList; fNewIds: TBoldObjectIdList; - function GetOldId(index: Integer): TBoldObjectId; - function GetNewId(index: Integer): TBoldObjectId; - function GetCount: Integer; - function GetTranslateToOldId(NewID: TBoldObjectId): TBoldObjectId; - function GetTranslateToNewId(OldID: TBoldObjectId): TBoldObjectId; + function GetOldId(index: Integer): TBoldObjectId; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetNewId(index: Integer): TBoldObjectId; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetCount: Integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetTranslateToOldId(NewID: TBoldObjectId): TBoldObjectId; overload; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetTranslateToNewId(OldID: TBoldObjectId): TBoldObjectId; overload; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + + function GetTranslateToOldId(Index: integer): TBoldObjectId; overload; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetTranslateToNewId(Index: integer): TBoldObjectId; overload;{$IFDEF BOLD_INLINE} inline; {$ENDIF} + function GetCapacity: Integer; {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure SetCapacity(const Value: Integer); {$IFDEF BOLD_INLINE} inline; {$ENDIF} protected - function GetStreamName: string; + function GetStreamName: string; {$IFDEF BOLD_INLINE} inline; {$ENDIF} public constructor Create; destructor Destroy; override; - procedure AddTranslation(OldId, NewId: TBoldObjectId); + procedure AddTranslation(OldId, NewId: TBoldObjectId); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure AddTranslationAdoptNew(OldId, NewId: TBoldObjectId); {$IFDEF BOLD_INLINE} inline; {$ENDIF} + procedure AddTranslationAdoptBoth(OldId, NewId: TBoldObjectId); {$IFDEF BOLD_INLINE} inline; {$ENDIF} property Count: Integer read GetCount; property TranslateToOldId[NewID: TBoldObjectId]: TBoldObjectId read GetTranslateToOldId; property TranslateToNewId[OldID: TBoldObjectId]: TBoldObjectId read GetTranslateToNewId; property OldIds[Index: integer] :TBoldObjectId read GetOldId; property NewIds[Index: integer] :TBoldObjectId read GetNewId; + property Capacity: Integer read GetCapacity write SetCapacity; end; { EBoldOperationFailedForIdList } @@ -187,8 +222,8 @@ EBoldOperationFailedForIdList = class(EBold) private fIdList: TBoldObjectIdList; public - constructor Create(msg: string; args: array of const; IdList: TBoldObjectIdList); - destructor Destroy; override; + constructor create(msg: string; args: array of const; IdList: TBoldObjectIdList); + destructor destroy; override; property IdList: TBoldObjectIdList read fIdList; end; @@ -202,16 +237,17 @@ TBoldXMLObjectIdStreamer = class(TBoldXMLObjectStreamer) implementation uses + {$IFDEF OXML}OXmlPDOM{$ELSE}Bold_MSXML_TLB{$ENDIF}, SysUtils, - BoldUtils, - MSXML_TLB, + {$IFNDEF BOLD_UNICODE} + StringBuilder, + {$ENDIF} BoldDefaultXMLStreaming, BoldDefaultStreamNames, BoldMeta; var InternalIdCounter: Integer = 0; - IX_ObjectID: integer = -1; const TOPSORTEDINDEXTMASK = $0FFFFFFF; @@ -269,6 +305,31 @@ TBoldXMLMemberIdListStreamer = class(TBoldXMLObjectStreamer) function CreateObject: TObject; override; end; +{---TBoldObjectId---} + +function TBoldObjectId.getTopSortedIndex: integer; +const + TOPSORTEDINDEXTMASK = TOPSORTEDINDEXTMASK; // copied here for inlining +begin + result := fClassId and TOPSORTEDINDEXTMASK; +end; + +function TBoldObjectId.GetTopSortedIndexExact: Boolean; +const + CLASSIDEXACTMASK = CLASSIDEXACTMASK; // copied here for inlining +begin + result := (fClassId and CLASSIDEXACTMASK) = CLASSIDEXACTMASK; +end; + +procedure TBoldObjectId.SetClassIdData(TopSortedIndex: integer; Exact: boolean); +const + CLASSIDEXACTMASK = CLASSIDEXACTMASK; // copied here for inlining +begin + if exact then + fClassId := TopSortedIndex or CLASSIDEXACTMASK + else + fClassId := TopSortedIndex; +end; {---TBoldObjectIdHashIndex---} @@ -288,23 +349,35 @@ function TBoldObjectIdHashIndex.Match(const Key; Item:TObject):Boolean; Result := TBoldObjectId(Key).IsEqual[ItemAsBoldObjectId(Item)]; end; -function TBoldObjectIdHashIndex.FindById(boldObjectId:TboldObjectId): TObject; +function TBoldObjectIdHashIndex.FindById(BoldObjectId: TBoldObjectId): TObject; begin - Result := Find(boldObjectId); + Result := Find(BoldObjectId); end; {---TBoldMemberID---} -constructor TBoldMemberId.create(MemberIndex: Integer); + +function TBoldMemberID.Clone: TBoldMemberID; +begin + result := TBoldMemberID.Create(MemberIndex); +end; + +constructor TBoldMemberId.Create(MemberIndex: Integer); begin fMemberIndex := MemberIndex; end; +function TBoldMemberID.GetAsString: string; +begin + result := IntToStr(fMemberIndex); +end; + function TBoldMemberId.GetStreamName: string; begin result := BOLDMEMBERIDNAME; end; {---TBoldSubMemberID---} + constructor TBoldSubMemberId.create(partOf: TBoldMemberID; OwnsPartOf: Boolean; IndexInMemberList: integer); begin Inherited Create(IndexInMemberList); @@ -323,6 +396,7 @@ destructor TBoldSubMemberId.destroy; end; {---TBoldObjectId---} + function TBoldObjectId.Clone: TBoldObjectId; begin result := CloneWithClassId(TopSortedIndex, TopSortedIndexExact); @@ -344,8 +418,7 @@ constructor TBoldInternalObjectID.CreateWithClassIDandInternalId(InternalIdentif function TBoldInternalObjectID.CloneWithClassId(TopSortedIndex: integer; Exact: Boolean):TBoldObjectid; begin - result := TBoldInternalObjectId.CreateWithClassId(TopSortedIndex, Exact); - (result as TBoldInternalObjectId).fInternalIdentifier := fInternalIdentifier; + result := TBoldInternalObjectId.CreateWithClassIDandInternalId(fInternalIdentifier, TopSortedIndex, Exact); end; constructor TBoldInternalObjectId.CreateWithClassID(TopSortedIndex: integer; Exact: Boolean); @@ -397,6 +470,11 @@ constructor TBoldObjectIdList.Create; OwnsEntries := true; end; +function TBoldObjectIdList.GetIdInList(ObjectID: TBoldObjectId): Boolean; +begin + Result := Assigned(ObjectId) and Assigned(GetIdByID(ObjectID)); +end; + function TBoldObjectIdList.ContainsSameIDs(List: TBoldObjectIdList): Boolean; var i: integer; @@ -409,6 +487,42 @@ function TBoldObjectIdList.ContainsSameIDs(List: TBoldObjectIdList): Boolean; end; end; +function TBoldObjectIdList.GetObjectIDIndex: TBoldObjectIDHashIndex; +begin + if UnorderedIndexCount = 0 then + begin + IX_ObjectID := -1; + SetIndexVariable(IX_ObjectID, AddIndex(TBoldObjectIDHashIndex.Create)); + end; + result := TBoldObjectIDHashIndex(Indexes[IX_ObjectID]); +end; + +function TBoldObjectIdList.GetHasInexactIds: boolean; +var + i: integer; +begin + result := false; + for i := 0 to Count - 1 do + if not TBoldObjectId(Items[i]).TopSortedIndexExact then + begin + result := true; + exit; + end; +end; + +function TBoldObjectIdList.GetHasNonExistingIds: boolean; +var + i: integer; +begin + result := false; + for i := 0 to Count - 1 do + if TBoldObjectId(Items[i]).NonExisting then + begin + result := true; + exit; + end; +end; + function TBoldObjectIdList.GetIDByID(ObjectID: TBoldObjectId): TBoldObjectId; var i: integer; @@ -438,34 +552,35 @@ function TBoldObjectIdList.GetIndexByID(ObjectID: TBoldObjectId): Integer; result := -1; end; -function TBoldObjectIdList.GetIdInList(ObjectID: TBoldObjectId): Boolean; +function TBoldObjectIdList.GetObjectId(index: Integer): TBoldObjectId; begin - Result := Assigned(ObjectId) and Assigned(GetIdByID(ObjectID)); + Result := TBoldObjectId(Items[index]); end; -function TBoldObjectIdList.Clone: TBoldObjectIdList; -var - i: Integer; +procedure TBoldObjectIdList.Add(ObjectID: TBoldObjectId); begin - Result := TBoldObjectIdList.Create; - for i := 0 to Count - 1 do - Result.Add(ObjectIDs[i]); + if assigned(ObjectID) then + inherited Add(ObjectId.Clone) + else + inherited Add(nil); end; -function TBoldObjectIdList.GetObjectId(index: Integer): TBoldObjectId; +procedure TBoldObjectIdList.AddAndAdopt(ObjectID: TBoldObjectId); begin - Result := TBoldObjectId(Items[index]); + inherited Add(ObjectId); end; -procedure TBoldObjectIdList.Add(ObjectID: TBoldObjectId); -var - newObjectID: TBoldObjectID; +function TBoldObjectIdList.AddAndGetID( + aBoldObjectId: TBoldObjectId): TBoldObjectId; begin - if assigned(ObjectID) then - NewObjectId := ObjectId.Clone - else - NewObjectId := nil; - inherited Add(NewObjectID); + if assigned(aBoldObjectId) then + begin + result := aBoldObjectId.Clone + end else + begin + result := nil; + end; + inherited Add(result); end; procedure TBoldObjectIdList.AddIfNotInList(ObjectID: TBoldObjectId); @@ -476,14 +591,11 @@ procedure TBoldObjectIdList.AddIfNotInList(ObjectID: TBoldObjectId); procedure TBoldObjectIdList.Insert(Index: integer; ObjectID: TBoldObjectId); -var - newObjectID: TBoldObjectID; begin if assigned(ObjectID) then - NewObjectId := ObjectId.Clone + inherited insert(index, ObjectId.Clone) else - NewObjectId := nil; - inherited insert(index, NewObjectID); + inherited insert(index, nil); end; procedure TBoldObjectIdList.ReplaceID(OldId, NewId: TBoldObjectId); @@ -495,8 +607,7 @@ procedure TBoldObjectIdList.ReplaceID(OldId, NewId: TBoldObjectId); exit; TempID := IDByID[OldId]; OldIndex := IndexOf(tempId); - RemoveByIndex(OldIndex); - Insert(OldIndex, NewId); + Items[OldIndex] := NewId.Clone; end; function TBoldObjectIdList.GetCount: integer; @@ -504,11 +615,23 @@ function TBoldObjectIdList.GetCount: integer; result := count; end; +function TBoldObjectIdList.Clone: TBoldObjectIdList; +var + i: Integer; +begin + Result := TBoldObjectIdList.Create; + Result.Capacity := Count; + for i := 0 to Count - 1 do + Result.Add(ObjectIDs[i]); +end; + function TBoldObjectIdList.GetStreamName: string; begin result := BOLDOBJECTIDLISTNAME; end; + {---TBoldMemberIdList---} + function TBoldMemberIdList.GetStreamName: string; begin result := BOLDMEMBERIDLISTNAME; @@ -516,12 +639,74 @@ function TBoldMemberIdList.GetStreamName: string; function TBoldMemberIdList.GetMemberIds(Index: Integer): TBoldMemberId; begin - Assert(Items[Index] is TBoldmemberId); - result := Items[Index] as TBoldmemberId; - assert(Assigned(Result)); + result := TBoldmemberId(Items[Index]); + Assert(result is TBoldmemberId); +end; + +function TBoldMemberIdList.HasId(AId: TBoldMemberId): boolean; +var + i: integer; +begin + for I := 0 to Count - 1 do + if MemberIds[i].MemberIndex = AId.MemberIndex then + begin + result := true; + exit; + end; + result := false; +end; + +function TBoldMemberIdList.IsEqual(AList: TBoldMemberIdList): boolean; +var + i: integer; +begin + result := Assigned(AList) and (AList.Count = Count); + if result then + for I := 0 to Count - 1 do + begin + if not AList.HasId(MemberIds[i]) then + begin + result := false; + exit; + end; + end; +end; + +function TBoldMemberIdList.Clone: TBoldMemberIdList; +var + i: integer; +begin + result := TBoldMemberIdList.Create; + for I := 0 to Count - 1 do + Result.Add(MemberIds[i].clone); end; {---TBoldIDTranslationList---} + +function TBoldIDTranslationList.GetCapacity: Integer; +begin + result := fOldIds.Capacity; +end; + +function TBoldIDTranslationList.GetCount: Integer; +begin + Result := fOldIds.Count; +end; + +procedure TBoldIDTranslationList.AddTranslationAdoptNew(OldId, + NewId: TBoldObjectId); +begin + fOldIDs.Add(OldId); + fNewIds.AddAndAdopt(NewId) +end; + +procedure TBoldIDTranslationList.AddTranslationAdoptBoth(OldId, + NewId: TBoldObjectId); +begin + fOldIDs.AddAndAdopt(OldId); + fNewIds.AddAndAdopt(NewId) +end; + constructor TBoldIDTranslationList.Create; begin fOldIds := TBoldObjectIdList.Create; @@ -545,15 +730,54 @@ function TBoldIDTranslationList.GetNewId(index: Integer): TBoldObjectId; Result := fNewIds[index]; end; -function TBoldIDTranslationList.GetCount: Integer; -begin - Result := fOldIds.Count; -end; - procedure TBoldIDTranslationList.AddTranslation(OldId, NewId: TBoldObjectId); +var + iIndex: Integer; begin + // This routine no longer handles multiple translations! +{ + if Assigned(OldId) then begin + iIndex := fOldIds.IndexByID[OldId]; + if (iIndex > -1) then begin + if ((NewID = nil) and (fNewIds[iIndex] = nil)) or + ((fNewIds[iIndex] <> nil) and fNewIds[iIndex].IsEqual[NewId]) then + begin + Exit; + end; + end; + end; + if Assigned(NewId) then begin + iIndex := fNewIds.IndexByID[NewId]; + if (iIndex > -1) then begin + if ((OldID = nil) and (fOldIds[iIndex] = nil)) or + ((fOldIds[iIndex] <> nil) and fOldIds[iIndex].IsEqual[OldId]) then + begin + Exit; + end; + end; + end; + fOldIDs.Add(OldId); - fNewIds.Add(NewId) + fNewIds.Add(NewId); +} + // Translation only makes sense, if both IDs are set + if Assigned(OldId) and Assigned(NewId) then begin + iIndex := fOldIds.IndexByID[OldId]; + if (iIndex > -1) then begin + if fNewIds[iIndex].IsEqual[NewId] then begin + Exit; + end; + end; + iIndex := fNewIds.IndexByID[NewId]; + if (iIndex > -1) then begin + if fOldIds[iIndex].IsEqual[OldId] then begin + Exit; + end; + end; + + fOldIDs.Add(OldId); + fNewIds.Add(NewId); + end; end; function TBoldIDTranslationList.GetTranslateToOldId(NewID: TBoldObjectId): TBoldObjectId; @@ -564,7 +788,6 @@ function TBoldIDTranslationList.GetTranslateToOldId(NewID: TBoldObjectId): TBold Pos := fNewIds.IndexByID[Result]; if pos <> -1 then result := GetOldId(Pos); - // This routine no longer handles multiple translations! { while Pos <> -1 do begin result := OriginalId[Pos]; @@ -572,6 +795,12 @@ function TBoldIDTranslationList.GetTranslateToOldId(NewID: TBoldObjectId): TBold end;} end; +procedure TBoldIDTranslationList.SetCapacity(const Value: Integer); +begin + fOldIds.Capacity := Value; + fNewIds.Capacity := Value; +end; + function TBoldIDTranslationList.GetTranslateToNewId(OldID: TBoldObjectId): TBoldObjectId; var Pos: Integer; @@ -580,7 +809,7 @@ function TBoldIDTranslationList.GetTranslateToNewId(OldID: TBoldObjectId): TBold Pos := fOldIds.IndexById[Result]; if pos <> -1 then Result := GetNewId(Pos); - // This routine no longer handles multiple translations! + { while Pos <> -1 do begin Result := FinalId[Pos]; @@ -588,6 +817,16 @@ function TBoldIDTranslationList.GetTranslateToNewId(OldID: TBoldObjectId): TBold end;} end; +function TBoldIDTranslationList.GetTranslateToOldId(Index: integer): TBoldObjectId; +begin + result := fOldIds[Index]; +end; + +function TBoldIDTranslationList.GetTranslateToNewId(Index: integer): TBoldObjectId; +begin + Result := GetNewId(Index); +end; + function TBoldIDTranslationList.GetStreamName: string; begin result := BOLDIDTRANSLATIONLISTNAME; @@ -600,7 +839,7 @@ procedure TBoldObjectIdList.ExactifyIds( begin for i := 0 to count - 1 do if not ObjectIds[i].TopSortedIndexExact then - ReplaceID(ObjectIds[i], TranslationList.TranslateToNewId[ObjectIds[i]]); + Items[i] := TranslationList.TranslateToNewId[ObjectIds[i]].Clone; end; procedure TBoldObjectIdList.ApplyTranslationList( @@ -608,16 +847,32 @@ procedure TBoldObjectIdList.ApplyTranslationList( var i: Integer; anId: TBoldObjectId; + SameCount: boolean; begin + SameCount := TranslationList.Count = count; for i := Count - 1 downto 0 do - begin - anId := TranslationList.TranslateToNewId[ObjectIds[i]]; - if assigned(anId) then - ReplaceId(ObjectIds[i], anId); - end; + begin + Assert(Assigned(ObjectIds[i])); + if SameCount and Assigned(TranslationList.OldIds[i]) then + begin + if TranslationList.OldIds[i].IsEqual[self.ObjectIds[i]] then + begin // faster handling for special but most common case, where both lists contain same elements at same places + self.Items[i] := TranslationList.NewIds[i].Clone; + continue; + end; + end; + anId := TranslationList.TranslateToNewId[ObjectIds[i]]; + if assigned(anId) then + ReplaceId(ObjectIds[i], anId); + end; end; { TBoldClassIdWithExpressionName } +function TBoldObjectId.GetNonExisting: Boolean; +begin + Result := false; +end; + function TBoldObjectId.GetTimeStamp: TBoldTimeStampType; begin result := BOLDMAXTIMESTAMP; @@ -637,7 +892,6 @@ destructor EBoldOperationFailedForIdList.destroy; inherited; end; - { TBoldXMLObjectIdStreamer } procedure TBoldXMLObjectIdStreamer.ReadObject(Obj: TObject; Node: TBoldXMLNode); @@ -652,13 +906,13 @@ procedure TBoldXMLObjectIdStreamer.ReadObject(Obj: TObject; Node: TBoldXMLNode); inherited; aModel := (Node.Manager as TBoldDefaultXMLStreamManager).Model; - aSubNode := Node.GetSubNode('ClassName'); // do not localize + aSubNode := Node.GetSubNode('ClassName'); if assigned(aSubNode) then begin TopSortedIndex := aModel.Classes.ItemsByName[aSubNode.ReadString].TopSortedIndex;; aSubNode.Free; - aSubNode := Node.GetSubNode('Exact'); // do not localize + aSubNode := Node.GetSubNode('Exact'); if assigned(aSubNode) then Exact := aSubNode.ReadBoolean else @@ -667,12 +921,11 @@ procedure TBoldXMLObjectIdStreamer.ReadObject(Obj: TObject; Node: TBoldXMLNode); end else begin - // BackwardCompatibility - ClassIdNode := Node.GetSubNode('classid'); // do not localize - aSubNode := ClassIdNode.GetSubNode('name'); // do not localize + ClassIdNode := Node.GetSubNode('classid'); + aSubNode := ClassIdNode.GetSubNode('name'); TopSortedIndex := aModel.Classes.ItemsByName[aSubNode.ReadString].TopSortedIndex; aSubNode.Free; - aSubNode := ClassIdNode.GetSubNode('exact'); // do not localize + aSubNode := ClassIdNode.GetSubNode('exact'); Exact := aSubNode.ReadBoolean; aSubNode.Free; end; @@ -685,19 +938,19 @@ procedure TBoldXMLObjectIdStreamer.WriteObject(Obj: TBoldInterfacedObject; Node: var aSubNode: TBoldXMLNode; aModel: TMoldModel; - ObjectId: TBoldObjectId; + ObjectId: TBoldObjectId; begin inherited; aModel := (Node.Manager as TBoldDefaultXMLStreamManager).Model; ObjectId := Obj as TBoldObjectId; - aSubNode := Node.NewSubNode('ClassName'); // do not localize + aSubNode := Node.NewSubNode('ClassName'); aSubNode.WriteString(aModel.Classes[ObjectId.TopSortedIndex].Name); aSubNode.Free; if not ObjectId.TopSortedIndexExact then begin - aSubNode := Node.NewSubNode('Exact'); // do not localize + aSubNode := Node.NewSubNode('Exact'); aSubNode.WriteBoolean(ObjectId.TopSortedIndexExact); aSubNode.Free; end; @@ -721,7 +974,7 @@ procedure TBoldXMLInternalObjectIdStreamer.ReadObject(Obj: TObject; aSubNode: TBoldXMLNode; begin inherited; - aSubNode := Node.GetSubNode('identifier'); // do not localize + aSubNode := Node.GetSubNode('identifier'); (Obj as TBoldInternalObjectId).fInternalIdentifier := aSubNode.ReadInteger; aSubNode.Free; end; @@ -732,7 +985,7 @@ procedure TBoldXMLInternalObjectIdStreamer.WriteObject( aSubNode: TBoldXMLNode; begin inherited; - aSubNode := Node.NewSubNode('identifier'); // do not localize + aSubNode := Node.NewSubNode('identifier'); aSubNode.WriteInteger((Obj as TBoldInternalObjectId).fInternalIdentifier); aSubNode.Free; end; @@ -753,13 +1006,36 @@ procedure TBoldXMLObjectIdListStreamer.ReadObject(Obj: TObject; Node: TBoldXMLNode); var anIdList: TBoldObjectIdList; + {$IFDEF OXML} + aNodeEnumerator: TXMLResNodeListEnumerator; + aNodeList: IXMLNodeList; + aNode: PXMLNode; + {$ELSE} aNodeList: IXMLDOMNodeList; aNode: IXMLDOMNode; + {$ENDIF} aSubNode: TBoldXMLNode; ObjectId: TBoldObjectId; begin inherited; anIdList := Obj as TBoldObjectIdList; + {$IFDEF OXML} + if Node.XMLDomElement.GetElementsByTagName('id', aNodeList) then begin + aNodeEnumerator := aNodeList.GetEnumerator; + try + while aNodeEnumerator.MoveNext do begin + aNode := aNodeEnumerator.Current; + aSubNode := Node.MakeNodeForElement(aNode); + ObjectId := aSubNode.ReadObject('') as TBoldObjectId; + anIdList.Add(ObjectId); + ObjectId.Free; + aSubNode.Free; + end; + finally + aNodeEnumerator.Free; + end; + end; + {$ELSE} aNodeList := Node.XMLDomElement.getElementsByTagName('id'); // do not localize aNode := aNodeList.nextNode; while assigned(aNode) do @@ -771,6 +1047,7 @@ procedure TBoldXMLObjectIdListStreamer.ReadObject(Obj: TObject; aSubNode.Free; aNode := aNodeList.nextNode; end; + {$ENDIF} end; procedure TBoldXMLObjectIdListStreamer.WriteObject(Obj: TBoldInterfacedObject; @@ -784,7 +1061,7 @@ procedure TBoldXMLObjectIdListStreamer.WriteObject(Obj: TBoldInterfacedObject; anIdList := Obj as TBoldObjectIdList; for i := 0 to anIdList.Count - 1 do begin - aSubNode := Node.NewSubNode('id'); // do not localize + aSubNode := Node.NewSubNode('id'); aSubNode.WriteObject('', anIdList[i]); aSubNode.Free; end; @@ -811,8 +1088,8 @@ procedure TBoldXMLTranslationListStreamer.ReadObject(Obj: TObject; aTranslationList := Obj as TBoldIDTranslationList; aTranslationList.fOldIds.Free; aTranslationList.fNewIds.Free; - aTranslationList.fOldIds := Node.ReadSubNodeObject('OldIds', BOLDOBJECTIDLISTNAME) as TBoldObjectIdList; // do not localize - aTranslationList.fNewIds := Node.ReadSubNodeObject('NewIds', BOLDOBJECTIDLISTNAME) as TBoldObjectIdList; // do not localize + aTranslationList.fOldIds := Node.ReadSubNodeObject('OldIds', BOLDOBJECTIDLISTNAME) as TBoldObjectIdList; + aTranslationList.fNewIds := Node.ReadSubNodeObject('NewIds', BOLDOBJECTIDLISTNAME) as TBoldObjectIdList; end; procedure TBoldXMLTranslationListStreamer.WriteObject( @@ -822,15 +1099,15 @@ procedure TBoldXMLTranslationListStreamer.WriteObject( begin inherited; aTranslationList := Obj as TBoldIDTranslationList; - Node.WriteSubNodeObject('OldIds', BOLDOBJECTIDLISTNAME, aTranslationList.fOldIds); // do not localize - Node.WriteSubNodeObject('NewIds', BOLDOBJECTIDLISTNAME, aTranslationList.fNewIds); // do not localize + Node.WriteSubNodeObject('OldIds', BOLDOBJECTIDLISTNAME, aTranslationList.fOldIds); + Node.WriteSubNodeObject('NewIds', BOLDOBJECTIDLISTNAME, aTranslationList.fNewIds); end; { TBoldXMLMemberIdStreamer } function TBoldXMLMemberIdStreamer.CreateObject: TObject; begin - result := TBoldMemberID.create(0); // index param to constructor chosen arbitrarily, will be overwritten anyway + result := TBoldMemberID.create(0); end; function TBoldXMLMemberIdStreamer.GetStreamName: string; @@ -842,14 +1119,14 @@ procedure TBoldXMLMemberIdStreamer.ReadObject(Obj: TObject; Node: TBoldXMLNode); begin inherited; - (Obj as TBoldMemberId).fMemberIndex := Node.ReadSubNodeInteger('MemberIndex'); // do not localize + (Obj as TBoldMemberId).fMemberIndex := Node.ReadSubNodeInteger('MemberIndex'); end; procedure TBoldXMLMemberIdStreamer.WriteObject(Obj: TBoldInterfacedObject; Node: TBoldXMLNode); begin inherited; - Node.WriteSubNodeInteger('MemberIndex', (Obj as TBoldMemberId).MemberIndex); // do not localize + Node.WriteSubNodeInteger('MemberIndex', (Obj as TBoldMemberId).MemberIndex); end; { TBoldXMLMemberIdListStreamer } @@ -868,12 +1145,33 @@ procedure TBoldXMLMemberIdListStreamer.ReadObject(Obj: TObject; Node: TBoldXMLNode); var aMemberIdList: TBoldMemberIdList; + {$IFDEF OXML} + aNodeEnumerator: TXMLResNodeListEnumerator; + aNodeList: IXMLNodeList; + aNode: PXMLNode; + {$ELSE} aNodeList: IXMLDOMNodeList; aNode: IXMLDOMNode; + {$ENDIF} aSubNode: TBoldXMLNode; begin inherited; aMemberIdList := Obj as TBoldMemberIdList; + {$IFDEF OXML} + if Node.XMLDomElement.GetElementsByTagName('id', aNodeList) then begin + aNodeEnumerator := aNodeList.GetEnumerator; + try + while aNodeEnumerator.MoveNext do begin + aNode := aNodeEnumerator.Current; + aSubNode := Node.MakeNodeForElement(aNode); + aMemberIdList.Add(aSubNode.ReadObject('') as TBoldMemberId); + aSubNode.Free; + end; + finally + aNodeEnumerator.Free; + end; + end; + {$ELSE} aNodeList := Node.XMLDomElement.getElementsByTagName('id'); // do not localize aNode := aNodeList.nextNode; while assigned(aNode) do @@ -883,6 +1181,7 @@ procedure TBoldXMLMemberIdListStreamer.ReadObject(Obj: TObject; aSubNode.Free; aNode := aNodeList.nextNode; end; + {$ENDIF} end; procedure TBoldXMLMemberIdListStreamer.WriteObject( @@ -896,73 +1195,116 @@ procedure TBoldXMLMemberIdListStreamer.WriteObject( aMemberIdList := Obj as TBoldMemberIdList; for i := 0 to aMemberIdList.Count - 1 do begin - aSubNode := Node.NewSubNode('id'); // do not localize + aSubNode := Node.NewSubNode('id'); aSubNode.WriteObject('', aMemberIdList[i]); aSubNode.Free; end; end; - { TBoldID } -function TBoldObjectIdList.GetObjectIDIndex: TBoldObjectIDHashIndex; -begin - if UnorderedIndexCount = 0 then - SetIndexVariable(IX_ObjectID, AddIndex(TBoldObjectIDHashIndex.Create)); - result := TBoldObjectIDHashIndex(Indexes[IX_ObjectID]); -end; - procedure TBoldObjectIdList.AddList(ObjectIdList: TBoldObjectIdList); var i: integer; begin + Capacity := Count + ObjectidList.Count; for i := 0 to ObjectidList.Count - 1 do Add(ObjectidList[i]); end; -function TBoldObjectId.getTopSortedIndex: integer; +function TBoldObjectIdHashIndex.Hash(const Key): Cardinal; begin - result := fClassId and TOPSORTEDINDEXTMASK; + Result := TBoldObjectId(Key).Hash; end; -function TBoldObjectId.GetTopSortedIndexExact: Boolean; +procedure TBoldObjectIdList.remove(Id: TBoldObjectId); +var + p: integer; begin - result := (fClassId and CLASSIDEXACTMASK) = CLASSIDEXACTMASK; + p := IndexOf(Id); + if p <> -1 then + removebyIndex(p); end; -procedure TBoldObjectId.SetClassIdData(TopSortedIndex: integer; Exact: boolean); +procedure TBoldObjectIdList.RemoveNonExistingIds; +var + i: integer; begin - if exact then - fClassId := TopSortedIndex or CLASSIDEXACTMASK - else - fClassId := TopSortedIndex; + for i := 0 to Count - 1 do + if TBoldObjectId(Items[i]).NonExisting then + RemoveByIndex(i); end; -function TBoldObjectIdHashIndex.Hash(const Key): Cardinal; +{ TBoldID } + +function TBoldID.GetDebugInfo: string; begin - Result := TBoldObjectId(Key).Hash; + result := AsString; end; -function TBoldObjectIdList.CommaSeparatedIdList: String; -var - i: integer; +{ TBoldNonExistingObjectId } + +function TBoldNonExistingObjectId.CloneWithClassId(TopSortedIndex: integer; Exact: Boolean): TBoldObjectid; +begin +// raise EBold.CreateFmt('CloneWithClassId not available in %s',[ClassName]); + result := TBoldNonExistingObjectId.CreateWithClassID(TopSortedIndex, Exact); +end; + +function TBoldNonExistingObjectId.GetAsString: string; +begin + result := '-1'; +end; + +function TBoldNonExistingObjectId.GetHash: Cardinal; +begin + result := 0; +end; + +function TBoldNonExistingObjectId.GetIsEqual(MatchID: TBoldObjectID): Boolean; +begin + result := MatchId is TBoldNonExistingObjectId; +end; + +function TBoldNonExistingObjectId.GetIsStorable: Boolean; +begin + result := false; +end; + +function TBoldNonExistingObjectId.GetNonExisting: Boolean; +begin + Result := true; +end; + +function TBoldNonExistingObjectId.GetStreamName: string; begin result := ''; - for i := 0 to Count - 1 do - begin - if i <> 0 then - result := result + ', '; - result := result + ObjectIds[i].AsString; - end; end; -procedure TBoldObjectIdList.remove(Id: TBoldObjectId); +{ TBoldIdList } + +function TBoldIdList.CommaSeparatedIdList: String; var - p: integer; + i: integer; + sb: TStringBuilder; begin - p := IndexOf(Id); - if p <> -1 then - removebyIndex(p); + case count of + 0 : result := ''; + 1 : result := TBoldId(Items[0]).AsString; + 2..MaxInt: + begin + sb := TStringBuilder.Create(TBoldId(Items[0]).AsString); + try + for i := 1 to Count - 1 do + begin + sb.Append(','); + sb.Append(TBoldId(Items[i]).AsString); + end; + result := sb.ToString; + finally + sb.free; + end; + end; + end; end; initialization @@ -973,4 +1315,3 @@ initialization TBoldXMLStreamerRegistry.MainStreamerRegistry.RegisterStreamer(TBoldXMLTranslationListStreamer.Create); end. - diff --git a/Source/ValueSpace/Id/BoldStringId.pas b/Source/ValueSpace/Id/BoldStringId.pas index 49552a52..8528f550 100644 --- a/Source/ValueSpace/Id/BoldStringId.pas +++ b/Source/ValueSpace/Id/BoldStringId.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldStringId; interface @@ -5,11 +8,12 @@ interface uses BoldId; + type TBoldStringID = class(TBoldExternalObjectID) protected fIdValue: String; - procedure SetAsString(NewValue: String); + procedure SetAsString(NewValue: String); {$IFDEF BOLD_INLINE} inline; {$ENDIF} function GetAsString: string; override; function GetHash: cardinal; override; function GetStreamName: string; override; @@ -19,6 +23,7 @@ TBoldStringID = class(TBoldExternalObjectID) property AsString: String read GetAsString write SetAsString; end; + implementation uses @@ -42,7 +47,7 @@ TBoldXMLStringIdStreamer = class(TBoldXMLObjectIdStreamer) { TBoldStringID } -function HashString(const S: string): CARDINAL; +function HashString(const S: string): CARDINAL; {$IFDEF BOLD_INLINE} inline; {$ENDIF} var i: integer; begin @@ -111,7 +116,6 @@ procedure TBoldXMLStringIdStreamer.WriteObject(Obj: TBoldInterfacedObject; inherited; Node.WriteSubNodeString(BoldNodeName_IdValue, (Obj as TBoldStringID).fIdValue); end; - initialization TBoldXMLStreamerRegistry.MainStreamerRegistry.RegisterStreamer(TBoldXMLStringIdStreamer.Create); end. diff --git a/Source/ValueSpace/Id/ValueSpaceConst.pas b/Source/ValueSpace/Id/ValueSpaceConst.pas index ec37c971..a3d1c30b 100644 --- a/Source/ValueSpace/Id/ValueSpaceConst.pas +++ b/Source/ValueSpace/Id/ValueSpaceConst.pas @@ -12,4 +12,4 @@ interface implementation -end. \ No newline at end of file +end. diff --git a/Source/ValueSpace/Interfaces/BoldValueInterfaces.pas b/Source/ValueSpace/Interfaces/BoldValueInterfaces.pas index 50d1c71c..0ec55a26 100644 --- a/Source/ValueSpace/Interfaces/BoldValueInterfaces.pas +++ b/Source/ValueSpace/Interfaces/BoldValueInterfaces.pas @@ -1,8 +1,13 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldValueInterfaces; interface uses + Classes, // for TStream + BoldId, BoldDefs; @@ -25,15 +30,35 @@ interface IBoldObjectIdListRef = interface; IBoldObjectIdListRefPair = interface; + TBoldValueContentType = ( + bctValueSpace, + bctObject, + bctString, + bctCurrency, + bctFloat, + bctInteger, + bctBoolean, + bctDate, + bctTime, + bctDateTime, + bctBlob, + bctTypedBlob, + + bctObjectIdRef, + bctObjectIdRefPair, + bctObjectIdListRef, + bctObjectIdListRefPair); IBoldValue = interface ['{67C57AD9-621B-11D2-AFF7-006008F62CFF}'] function GetContentName: String; - procedure AssignContent(Source: IBoldValue); + procedure AssignContent(const Source: IBoldValue); function GetBoldPersistenceState: TBoldValuePersistenceState; procedure SetBoldPersistenceState(Value: TBoldValuePersistenceState); + function GetContentType: TBoldValueContentType; property BoldPersistenceState: TBoldValuePersistenceState read GetBoldPersistenceState write SetBoldPersistenceState; property ContentName: String read GetContentName; + property ContentType: TBoldValueContentType read GetContentType; end; IBoldNullableValue = interface(IBoldValue) @@ -43,78 +68,106 @@ interface property IsNull: Boolean read GetContentIsNull; end; + IBoldStringRepresentable = interface(IBoldNullableValue) + ['{67C57AC7-621B-11D2-AFF7-006008F62CFF}'] + function GetStringRepresentation(representation:integer): String; +// procedure SetStringRepresentation(Representation: integer; const NewValue: String); + property StringRepresentation[representation: integer]: String read GetStringRepresentation {write SetStringRepresentation}; + function GetContentAsString: String; + property asString: String read GetContentAsString; + end; - IBoldStringContent = interface(IBoldNullableValue) + IBoldStringContent = interface(IBoldStringRepresentable) ['{67C57AC6-621B-11D2-AFF7-006008F62CFF}'] procedure SetContentAsString(const NewValue: String); - function GetContentAsString: String; property asString: String read GetContentAsString write SetContentAsString; end; - IBoldStringRepresentable = interface(IBoldNullableValue) - ['{67C57AC7-621B-11D2-AFF7-006008F62CFF}'] - function GetStringRepresentation(representation:integer): String; - procedure SetStringRepresentation(Representation: integer; const NewValue: String); - property StringRepresentation[representation: integer]: String read GetStringRepresentation write SetStringRepresentation; + IBoldAnsiStringContent = interface(IBoldStringContent) + ['{67C57ADA-621B-11D2-AFF7-006008F62CFF}'] + procedure SetContentAsAnsiString(const NewValue: TBoldAnsiString); + function GetContentAsAnsiString: TBoldAnsiString; + property asAnsiString: TBoldAnsiString read GetContentAsAnsiString write SetContentAsAnsiString; + end; + + IBoldUnicodeStringContent = interface(IBoldStringContent) + ['{67C57ADB-621B-11D2-AFF7-006008F62CFF}'] + procedure SetContentAsUnicodeString(const NewValue: TBoldUnicodeString); + function GetContentAsUnicodeString: TBoldUnicodeString; + property asUnicodeString: TBoldUnicodeString read GetContentAsUnicodeString write SetContentAsUnicodeString; + end; + + IBoldVariantReadable = interface(IBoldStringRepresentable) + ['{4284362D-6830-4FB1-87CD-AEED41E57192}'] + function GetAsVariant: Variant; + property AsVariant: Variant read GetAsVariant; end; - IBoldIntegerContent = interface(IBoldNullableValue) + IBoldIntegerContent = interface(IBoldStringRepresentable) ['{67C57AC8-621B-11D2-AFF7-006008F62CFF}'] function GetContentAsInteger: Integer; procedure SetContentAsInteger(NewValue: Integer); property asInteger: Integer read GetContentAsInteger write SetContentAsInteger; end; - IBoldFloatContent = interface(IBoldNullableValue) + IBoldFloatContent = interface(IBoldStringRepresentable) ['{67C57AC9-621B-11D2-AFF7-006008F62CFF}'] function GetContentAsFloat: Double; procedure SetContentAsFloat(NewValue: Double); property asFloat: Double read GetContentAsFloat write SetContentAsFloat; end; - IBoldCurrencyContent = interface(IBoldNullableValue) + IBoldCurrencyContent = interface(IBoldStringRepresentable) ['{67C57ACA-621B-11D2-AFF7-006008F62CFF}'] function GetContentAsCurrency: Currency; procedure SetContentAsCurrency(NewValue: Currency); property asCurrency: Currency read GetContentAsCurrency write SetContentAsCurrency; end; - IBoldBooleanContent = interface(IBoldNullableValue) + IBoldBooleanContent = interface(IBoldStringRepresentable) ['{67C57ACB-621B-11D2-AFF7-006008F62CFF}'] function GetContentAsBoolean: Boolean; procedure SetContentAsBoolean(NewValue: Boolean); property asBoolean: Boolean read GetContentAsBoolean write SetContentAsBoolean; end; - IBoldDateContent = interface(IBoldNullableValue) + IBoldDateContent = interface(IBoldStringRepresentable) ['{67C57ACC-621B-11D2-AFF7-006008F62CFF}'] function GetContentAsDate: TDateTime; procedure SetContentAsDate(NewValue: TDateTime); property asDate: TDateTime read GetContentAsDate write SetContentAsDate; end; - IBoldTimeContent = interface(IBoldNullableValue) + IBoldTimeContent = interface(IBoldStringRepresentable) ['{67C57ACD-621B-11D2-AFF7-006008F62CFF}'] function GetContentAsTime: TDateTime; procedure SetContentAsTime(NewValue: TDateTime); property asTime: TDateTime read GetContentAsTime write SetContentAsTime; end; - IBoldDateTimeContent = interface(IBoldNullableValue) + IBoldDateTimeContent = interface(IBoldStringRepresentable) ['{67C57ACE-621B-11D2-AFF7-006008F62CFF}'] function GetContentAsDateTime: TDateTime; procedure SetContentAsDateTime(NewValue: TDateTime); property asDateTime: TDateTime read GetContentAsDateTime write SetContentAsDateTime; end; - IBoldBlobContent = interface(IBoldNullableValue) + IBoldBlobContent = interface(IBoldStringRepresentable) ['{F6CE03A0-6283-11D2-AFF7-006008F62CFF}'] - function GetContentAsBlob: String; - procedure SetContentAsBlob(const NewValue: String); - property asBlob: String read GetContentAsBlob write SetContentAsBlob; + function GetContentAsBlob: TBoldAnsiString; + procedure SetContentAsBlob(const NewValue: TBoldAnsiString); + property asBlob: TBoldAnsiString read GetContentAsBlob write SetContentAsBlob; end; - IBoldTypedBlob = interface(IBoldNullableValue) + IBoldBlobStreamContent = interface(IBoldBlobContent) + ['{193BF532-CEC6-4749-919E-12FB5A9E98E7}'] + procedure BeginSupressEvents; + procedure EndSupressEvents; + function GetBlobAsStream: TStream; + property AsStream: TStream read GetBlobAsStream; + end; + + IBoldTypedBlob = interface(IBoldBlobContent) ['{6EFB7D60-65BF-11D2-AFF7-006008F62CFF}'] function GetContentTypeContent: String; procedure SetContentTypeContent(const NewValue: String); @@ -123,7 +176,7 @@ interface IBoldObjectIdRef = Interface(IBoldValue) ['{E5AD30CD-544F-4941-998B-947DDDC4E698}'] - procedure SetFromId(Id: TBoldObjectId); + procedure SetFromId(Id: TBoldObjectId; Adopt: Boolean); function GetId: TBoldObjectID; function GetOrderNo: integer; procedure SetOrderNo(NewOrder: Integer); @@ -133,7 +186,8 @@ interface IBoldObjectIdListRef = Interface(IBoldValue) ['{2EFDD2F7-F998-4ADB-842B-9AEA65C9E602}'] - procedure SetFromIdList(IdLIst: TBoldObjectIdList); + procedure SetFromIdList(IdList: TBoldObjectIdList); + procedure SetList(IdList: TBoldObjectIdList); function GetIdList(Index: Integer): TBoldObjectID; property IdList[Index: integer]: TBoldObjectID read GetIdList; function GetCount: integer; @@ -165,4 +219,7 @@ interface implementation + +initialization + end. diff --git a/Source/ValueSpace/Interfaces/BoldValueSpaceInterfaces.pas b/Source/ValueSpace/Interfaces/BoldValueSpaceInterfaces.pas index 38b4e674..0d975ba3 100644 --- a/Source/ValueSpace/Interfaces/BoldValueSpaceInterfaces.pas +++ b/Source/ValueSpace/Interfaces/BoldValueSpaceInterfaces.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldValueSpaceInterfaces; interface @@ -20,21 +23,25 @@ interface ['{A90FA286-018A-4032-8392-72EA9213F3F5}'] procedure AllObjectIds(resultList: TBoldObjectIdList; OnlyLoaded: Boolean); procedure ApplytranslationList(IdTranslationList: TBoldIdTranslationList); - procedure ApplyValueSpace(ValueSpace: IBoldValueSpace; IgnorePersistenceState: Boolean); + procedure ApplyValueSpace(const ValueSpace: IBoldValueSpace; IgnorePersistenceState: Boolean); procedure EnsureObjectContents(ObjectId: TBoldObjectId); procedure EnsureObjectId(ObjectId: TBoldObjectId); procedure ExactifyIDs(TranslationList: TBoldIdTranslationList); function GetHasContentsForId(ObjectId: TBoldObjectId): boolean; function GetObjectContentsByObjectId(ObjectId: TBoldObjectId): IBoldObjectContents; function GetEnsuredObjectContentsByObjectId(ObjectId: TBoldObjectId): IBoldObjectContents; + function GetEnsuredObjectContentsByObjectIdAndCheckIfCreated(ObjectId: TBoldObjectId; out aBoldObjectContents: IBoldObjectContents): boolean; property HasContentsForId[ObjectId: TBoldObjectId]: boolean read GetHasContentsForId; property ObjectContentsByObjectId[ObjectId: TBoldObjectId]: IBoldObjectContents read GetObjectContentsByObjectId; property EnsuredObjectContentsByObjectId[ObjectId: TBoldObjectId]: IBoldObjectContents read GetEnsuredObjectContentsByObjectId; + function IdCount: integer; + function IsEmpty: boolean; end; IBoldObjectContents = interface ['{67C57AC5-621B-11D2-AFF7-006008F62CFF}'] procedure EnsureMember(MemberId: TBoldMemberId; const ContentName: string); + function EnsureMemberAndGetValueByIndex(MemberIndex: Integer; const ContentName: string): IBoldValue; function GetBoldExistenceState: TBoldExistenceState; function GetBoldMemberCount: Integer; function GetBoldPersistenceState: TBoldValuePersistenceState; @@ -63,22 +70,23 @@ interface end; -procedure BoldApplyPartialValueSpace(DestVS, SourceVS: IBoldValueSpace; ObjectidList: TBoldObjectIdList; MemberIdList: TBoldMemberIdList; +procedure BoldApplyPartialValueSpace(const DestVS, SourceVS: IBoldValueSpace; ObjectidList: TBoldObjectIdList; MemberIdList: TBoldMemberIdList; ForceCurrent: Boolean; PersistenceStatesToIgnore: TBoldValuePersistenceStateSet = [bvpsInvalid]); + implementation uses SysUtils, BoldGuard, - BoldUtils; + BoldRev; -procedure BoldApplyPartialValueSpace(DestVS, SourceVS: IBoldValueSpace; ObjectidList: TBoldObjectIdList; MemberIdList: TBoldMemberIdList; ForceCurrent: Boolean; PersistenceStatesToIgnore: TBoldValuePersistenceStateSet = [bvpsInvalid]); +procedure BoldApplyPartialValueSpace(const DestVS, SourceVS: IBoldValueSpace; ObjectidList: TBoldObjectIdList; MemberIdList: TBoldMemberIdList; ForceCurrent: Boolean; PersistenceStatesToIgnore: TBoldValuePersistenceStateSet = [bvpsInvalid]); var O, M: integer; SourceObjectContents, DestObjectContents: IBoldObjectContents; - MemberId, OwnMemberId: TBoldMemberId; + MemberId: TBoldMemberId; ObjectId: TBoldObjectId; SourceValue, DestValue: IBoldValue; @@ -86,7 +94,7 @@ procedure BoldApplyPartialValueSpace(DestVS, SourceVS: IBoldValueSpace; Objectid ListToCopy: TBoldObjectIdList; G: IBoldGuard; begin - G := TBoldGuard.Create(OwnIdList, OwnmemberId); + G := TBoldGuard.Create(OwnIdList); if Assigned(ObjectIdList) then ListToCopy := ObjectIdList else @@ -116,8 +124,7 @@ procedure BoldApplyPartialValueSpace(DestVS, SourceVS: IBoldValueSpace; Objectid SourceValue := SourceObjectContents.ValueByMemberId[MemberId]; if assigned(SourceValue) and not (SourceValue.BoldPersistenceState in PersistenceStatesToIgnore) then begin - DestObjectContents.EnsureMember(MemberId, SourceValue.ContentName);; - DestValue := DestObjectContents.ValueByMemberId[MemberId]; + DestValue := DestObjectContents.EnsureMemberAndGetValueByIndex(MemberId.MemberIndex, SourceValue.ContentName);; DestValue.AssignContent(SourceValue); if ForceCurrent then DestValue.BoldPersistenceState := bvpsCurrent; @@ -131,13 +138,10 @@ procedure BoldApplyPartialValueSpace(DestVS, SourceVS: IBoldValueSpace; Objectid SourceValue := SourceObjectContents.ValueByIndex[M]; if assigned(SourceValue) and not (SourceValue.BoldPersistenceState in PersistenceStatesToIgnore) then begin - OwnMemberId := TBoldmemberId.Create(M); - DestObjectContents.EnsureMember(OwnMemberId, SourceValue.ContentName); - DestValue := DestObjectContents.ValueByMemberId[OwnMemberId]; + DestValue := DestObjectContents.EnsureMemberAndGetValueByIndex(M, SourceValue.ContentName); DestValue.AssignContent(SourceValue); if ForceCurrent then DestValue.BoldPersistenceState := bvpsCurrent; - FreeAndNil(OwnmemberId); end; end; end; @@ -145,4 +149,6 @@ procedure BoldApplyPartialValueSpace(DestVS, SourceVS: IBoldValueSpace; Objectid end; end; +initialization + end. diff --git a/Source/ValueSpace/XMLStreaming/BoldDefaultStreamNames.pas b/Source/ValueSpace/XMLStreaming/BoldDefaultStreamNames.pas index b1b11c3b..efcf11d0 100644 --- a/Source/ValueSpace/XMLStreaming/BoldDefaultStreamNames.pas +++ b/Source/ValueSpace/XMLStreaming/BoldDefaultStreamNames.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDefaultStreamNames; interface @@ -15,22 +18,42 @@ interface BOLDMEMBERIDLISTNAME = 'BoldMemberIdList'; BOLDIDTRANSLATIONLISTNAME = 'BoldIDTranslationList'; - BoldContentName_String = 'String'; - BoldContentName_Integer = 'Integer'; - BoldContentName_Float = 'Float'; - BoldContentName_Currency = 'Currency'; - BoldContentName_Blob = 'Blob'; - BoldContentName_TypedBlob = 'TypedBlob'; - BoldContentName_DateTime = 'DateTime'; - BoldContentName_Date = 'Date'; - BoldContentName_Time = 'Time'; - BoldContentName_Boolean = 'Boolean'; - - BoldContentName_ObjectIdRef = 'ObjectIdRef'; - BoldContentName_ObjectIdRefPair = 'ObjectIdRefPair'; - BoldContentName_ObjectIdListRef = 'ObjectIdListRef'; - BoldContentName_ObjectIdListRefPair = 'ObjectIdListRefPair'; +var + BoldContentName_String: string; + BoldContentName_Integer: string; + BoldContentName_Float: string; + BoldContentName_Currency: string; + BoldContentName_Blob: string; + BoldContentName_TypedBlob: string; + BoldContentName_DateTime: string; + BoldContentName_Date: string; + BoldContentName_Time: string; + BoldContentName_Boolean: string; + + BoldContentName_ObjectIdRef: string; + BoldContentName_ObjectIdRefPair: string; + BoldContentName_ObjectIdListRef: string; + BoldContentName_ObjectIdListRefPair: string; implementation +uses + BoldSharedStrings; + +initialization + BoldContentName_ObjectIdRef := BoldSharedStringManager.GetSharedString('ObjectIdRef'); + BoldContentName_ObjectIdRefPair := BoldSharedStringManager.GetSharedString('ObjectIdRefPair'); + BoldContentName_ObjectIdListRef := BoldSharedStringManager.GetSharedString('ObjectIdListRef'); + BoldContentName_ObjectIdListRefPair := BoldSharedStringManager.GetSharedString('ObjectIdListRefPair'); + BoldContentName_String := BoldSharedStringManager.GetSharedString('String'); + BoldContentName_Integer := BoldSharedStringManager.GetSharedString('Integer'); + BoldContentName_Float := BoldSharedStringManager.GetSharedString('Float'); + BoldContentName_Currency := BoldSharedStringManager.GetSharedString('Currency'); + BoldContentName_Blob := BoldSharedStringManager.GetSharedString('Blob'); + BoldContentName_TypedBlob := BoldSharedStringManager.GetSharedString('TypedBlob'); + BoldContentName_DateTime := BoldSharedStringManager.GetSharedString('DateTime'); + BoldContentName_Date := BoldSharedStringManager.GetSharedString('Date'); + BoldContentName_Time := BoldSharedStringManager.GetSharedString('Time'); + BoldContentName_Boolean := BoldSharedStringManager.GetSharedString('Boolean'); + end. diff --git a/Source/ValueSpace/XMLStreaming/BoldDefaultXMLStreaming.pas b/Source/ValueSpace/XMLStreaming/BoldDefaultXMLStreaming.pas index f4e288db..e81b8970 100644 --- a/Source/ValueSpace/XMLStreaming/BoldDefaultXMLStreaming.pas +++ b/Source/ValueSpace/XMLStreaming/BoldDefaultXMLStreaming.pas @@ -1,3 +1,6 @@ + +{ Global compiler directives } +{$include bold.inc} unit BoldDefaultXMLStreaming; interface @@ -72,8 +75,8 @@ TBoldXMLMemberStreamer = class(TBoldXMLModelElementStreamer) public constructor Create(MoldMember: TMoldMember; Owner: TBoldXMLClassStreamer); destructor Destroy; override; - procedure WriteValue(Node: TBoldXMLNode; Value: IBoldValue); - procedure ReadValue(Node: TBoldXMLNode; Value: IBoldValue); + procedure WriteValue(Node: TBoldXMLNode; const Value: IBoldValue); + procedure ReadValue(Node: TBoldXMLNode; const Value: IBoldValue); property TypeStreamName: string read fTypeStreamName; property Persistent: Boolean read fPersistent; property MemberId: TBoldMemberId read fMemberId; @@ -86,14 +89,14 @@ TBoldXMLClassStreamer = class(TBoldXMLModelElementStreamer) fMemberStreamers: TBoldXMLModelElementStreamerList; fOwner: TBoldDefaultXMLStreamManager; function GetMemberStreamer(Index: Integer): TBoldXMLMemberStreamer; - function GetMemberStreamerByName(Name: string): TBoldXMLMemberStreamer; + function GetMemberStreamerByName(const Name: string): TBoldXMLMemberStreamer; public constructor Create(MoldClass: TMoldClass; Owner: TBoldDefaultXMLStreamManager); destructor Destroy; override; - procedure WriteObject(Node: TBoldXMLNode; ObjectContents: IBoldObjectContents; ObjectId: TBoldObjectId; MemberIdList: TBoldMemberIdList); - procedure ReadObject(Node: TBoldXMLNode; ValueSpace: IBoldValueSpace); + procedure WriteObject(Node: TBoldXMLNode; const ObjectContents: IBoldObjectContents; ObjectId: TBoldObjectId; MemberIdList: TBoldMemberIdList); + procedure ReadObject(Node: TBoldXMLNode; const ValueSpace: IBoldValueSpace); property MemberStreamers[Index: integer]: TBoldXMLMemberStreamer read GetMemberStreamer; - property MemberStreamerByName[Name: String]: TBoldXMLMemberStreamer read GetMemberStreamerByName; + property MemberStreamerByName[const Name: String]: TBoldXMLMemberStreamer read GetMemberStreamerByName; end; { TBoldDefaultXMLStreamManager } @@ -105,15 +108,15 @@ TBoldDefaultXMLStreamManager = class(TBoldXMLStreamManager) fPersistenceStatesToBeStreamed: TBoldValuePersistenceStateSet; fPersistenceStatesToOverwrite: TBoldValuePersistenceStateSet; function GetClassStreamer(TopSortedIndex: Integer): TBoldXMLClassStreamer; - function GetClassStreamerByName(Name: string): TBoldXMLClassStreamer; + function GetClassStreamerByName(const Name: string): TBoldXMLClassStreamer; public constructor Create(Registry: TBoldXMLStreamerRegistry; Model: TMoldModel); destructor Destroy; override; - procedure WriteValueSpace(ValueSpace: IBoldValueSpace; IdList: TBoldObjectIdList; MemberIdList: TBoldMemberIdList; Node: TBoldXMLNode); - procedure ReadValueSpace(ValueSpace: IBoldValueSpace; Node: TBoldXMLNode); + procedure WriteValueSpace(const ValueSpace: IBoldValueSpace; IdList: TBoldObjectIdList; MemberIdList: TBoldMemberIdList; Node: TBoldXMLNode); + procedure ReadValueSpace(const ValueSpace: IBoldValueSpace; Node: TBoldXMLNode); property Model: TMoldModel read fModel; property ClassStreamers[TopSortedIndex: Integer]: TBoldXMLClassStreamer read GetClassStreamer; - property ClassStreamerByName[Name: string]: TBoldXMLClassStreamer read GetClassStreamerByName; + property ClassStreamerByName[const Name: string]: TBoldXMLClassStreamer read GetClassStreamerByName; property IgnorePersistenceState: Boolean read fIgnorePersistenceState write fIgnorePersistenceState; property PersistenceStatesToOverwrite: TBoldValuePersistenceStateSet read fPersistenceStatesToOverwrite write fPersistenceStatesToOverwrite; property PersistenceStatesToBeStreamed: TBoldValuePersistenceStateSet read fPersistenceStatesToBeStreamed write fPersistenceStatesToBeStreamed; @@ -122,151 +125,149 @@ TBoldDefaultXMLStreamManager = class(TBoldXMLStreamManager) { TBoldXMLValueStreamer } TBoldXMLValueStreamer = class(TBoldXMLInterfaceStreamer) public - procedure WriteInterface(Item: IBoldStreamable; Node: TBoldXMLNode); override; - procedure ReadInterface(Item: IBoldStreamable; Node: TBoldXMLNode); override; + procedure WriteInterface(const Item: IBoldStreamable; Node: TBoldXMLNode); override; + procedure ReadInterface(const Item: IBoldStreamable; Node: TBoldXMLNode); override; end; { TBoldXMLNullableValueStreamer } TBoldXMLNullableValueStreamer = class(TBoldXMLValueStreamer) protected - procedure WriteContent(Item: IBoldValue; Node: TBoldXMLNode); virtual; - procedure ReadContent(Item: IBoldValue; Node: TBoldXMLNode); virtual; + procedure WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); virtual; + procedure ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); virtual; public - procedure WriteInterface(Item: IBoldStreamable; Node: TBoldXMLNode); override; - procedure ReadInterface(Item: IBoldStreamable; Node: TboldXMLNode); override; + procedure WriteInterface(const Item: IBoldStreamable; Node: TBoldXMLNode); override; + procedure ReadInterface(const Item: IBoldStreamable; Node: TboldXMLNode); override; end; { TBoldXMLStringContentStreamer } TBoldXMLStringContentStreamer = class(TBoldXMLNullableValueStreamer) protected function GetStreamName: string; override; - procedure WriteContent(Item: IBoldValue; Node: TBoldXMLNode); override; - procedure ReadContent(Item: IBoldValue; Node: TBoldXMLNode); override; + procedure WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); override; + procedure ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); override; end; { TBoldXMLIntegerContentStreamer } TBoldXMLIntegerContentStreamer = class(TBoldXMLNullableValueStreamer) protected function GetStreamName: string; override; - procedure WriteContent(Item: IBoldValue; Node: TBoldXMLNode); override; - procedure ReadContent(Item: IBoldValue; Node: TBoldXMLNode); override; + procedure WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); override; + procedure ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); override; end; { TBoldXMLFloatContentStreamer } TBoldXMLFloatContentStreamer = class(TBoldXMLNullableValueStreamer) protected function GetStreamName: string; override; - procedure WriteContent(Item: IBoldValue; Node: TBoldXMLNode); override; - procedure ReadContent(Item: IBoldValue; Node: TBoldXMLNode); override; + procedure WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); override; + procedure ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); override; end; { TBoldXMLCurrencyContentStreamer } TBoldXMLCurrencyContentStreamer = class(TBoldXMLNullableValueStreamer) protected function GetStreamName: string; override; - procedure WriteContent(Item: IBoldValue; Node: TBoldXMLNode); override; - procedure ReadContent(Item: IBoldValue; Node: TBoldXMLNode); override; + procedure WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); override; + procedure ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); override; end; { TBoldXMLBooleanContentStreamer } TBoldXMLBooleanContentStreamer = class(TBoldXMLNullableValueStreamer) protected function GetStreamName: string; override; - procedure WriteContent(Item: IBoldValue; Node: TBoldXMLNode); override; - procedure ReadContent(Item: IBoldValue; Node: TBoldXMLNode); override; + procedure WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); override; + procedure ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); override; end; { TBoldXMLDateContentStreamer } TBoldXMLDateContentStreamer = class(TBoldXMLNullableValueStreamer) protected function GetStreamName: string; override; - procedure WriteContent(Item: IBoldValue; Node: TBoldXMLNode); override; - procedure ReadContent(Item: IBoldValue; Node: TBoldXMLNode); override; + procedure WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); override; + procedure ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); override; end; { TBoldXMLTimeContentStreamer } TBoldXMLTimeContentStreamer = class(TBoldXMLNullableValueStreamer) protected function GetStreamName: string; override; - procedure WriteContent(Item: IBoldValue; Node: TBoldXMLNode); override; - procedure ReadContent(Item: IBoldValue; Node: TBoldXMLNode); override; + procedure WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); override; + procedure ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); override; end; { TBoldXMLDateTimeContentStreamer } TBoldXMLDateTimeContentStreamer = class(TBoldXMLNullableValueStreamer) protected function GetStreamName: string; override; - procedure WriteContent(Item: IBoldValue; Node: TBoldXMLNode); override; - procedure ReadContent(Item: IBoldValue; Node: TBoldXMLNode); override; + procedure WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); override; + procedure ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); override; end; { TBoldXMLBlobContentStreamer } TBoldXMLBlobContentStreamer = class(TBoldXMLNullableValueStreamer) protected function GetStreamName: string; override; - procedure WriteContent(Item: IBoldValue; Node: TBoldXMLNode); override; - procedure ReadContent(Item: IBoldValue; Node: TBoldXMLNode); override; + procedure WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); override; + procedure ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); override; end; { TBoldXMLTypedBlobStreamer } TBoldXMLTypedBlobStreamer = class(TBoldXMLBlobContentStreamer) protected function GetStreamName: string; override; - procedure WriteContent(Item: IBoldValue; Node: TBoldXMLNode); override; - procedure ReadContent(Item: IBoldValue; Node: TBoldXMLNode); override; + procedure WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); override; + procedure ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); override; end; { TBoldXMLRoleStreamer } TBoldXMLRoleStreamer = class(TBoldXMLValueStreamer) protected - procedure WriteContent(Item: IBoldValue; Node: TBoldXMLNode); virtual; - procedure ReadContent(Item: IBoldValue; Node: TBoldXMLNode); virtual; + procedure WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); virtual; + procedure ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); virtual; public - procedure WriteInterface(Item: IBoldStreamable; Node: TBoldXMLNode); override; - procedure ReadInterface(Item: IBoldStreamable; Node: TBoldXMLNode); override; + procedure WriteInterface(const Item: IBoldStreamable; Node: TBoldXMLNode); override; + procedure ReadInterface(const Item: IBoldStreamable; Node: TBoldXMLNode); override; end; { TBoldXMLIdRefStreamer } TBoldXMLIdRefStreamer = class(TBoldXMLRoleStreamer) protected function GetStreamName: string; override; - procedure WriteContent(Item: IBoldValue; Node: TBoldXMLNode); override; - procedure ReadContent(Item: IBoldValue; Node: TBoldXMLNode); override; + procedure WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); override; + procedure ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); override; end; { TBoldXMLIdRefPairStreamer } TBoldXMLIdRefPairStreamer = class(TBoldXMLRoleStreamer) protected function GetStreamName: string; override; - procedure WriteContent(Item: IBoldValue; Node: TBoldXMLNode); override; - procedure ReadContent(Item: IBoldValue; Node: TBoldXMLNode); override; + procedure WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); override; + procedure ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); override; end; { TBoldXMLIdListRefStreamer } TBoldXMLIdListRefStreamer = class(TBoldXMLRoleStreamer) protected function GetStreamName: string; override; - procedure WriteContent(Item: IBoldValue; Node: TBoldXMLNode); override; - procedure ReadContent(Item: IBoldValue; Node: TBoldXMLNode); override; + procedure WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); override; + procedure ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); override; end; { TBoldXMLIdListRefPairStreamer } TBoldXMLIdListRefPairStreamer = class(TBoldXMLRoleStreamer) protected function GetStreamName: string; override; - procedure WriteContent(Item: IBoldValue; Node: TBoldXMLNode); override; - procedure ReadContent(Item: IBoldValue; Node: TBoldXMLNode); override; + procedure WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); override; + procedure ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); override; end; implementation uses BoldHashIndexes, - MSXML_TLB, + {$IFDEF OXML}OXmlPDOM{$ELSE}Bold_MSXML_TLB{$ENDIF}, SysUtils, - ValueSpaceConst, BoldDefaultStreamNames; -// BoldUtils; const BoldNodeName_persistencestate = 'persistencestate'; @@ -320,40 +321,60 @@ destructor TBoldDefaultXMLStreamManager.Destroy; function TBoldDefaultXMLStreamManager.GetClassStreamer(TopSortedIndex: Integer): TBoldXMLClassStreamer; begin if TopSortedIndex >= fClassStreamers.Count then - raise EBold.CreateFmt(sInvalidIndex, [classname]); + raise EBold.CreateFmt('%s.GetClassStreamer: Not a valid index', [classname]); result := TBoldXMLClassStreamer(fClassStreamers.Items[TopSortedIndex]); end; -function TBoldDefaultXMLStreamManager.GetClassStreamerByName(Name: string): TBoldXMLClassStreamer; +function TBoldDefaultXMLStreamManager.GetClassStreamerByName(const Name: string): TBoldXMLClassStreamer; begin result := fClassStreamers.StreamerByName[Name] as TBoldXMLClassStreamer; if not assigned(result) then - raise EBold.CreateFmt(sUnrecognizedClassName, [classname, 'GetClassStreamerByName', name]); // Do not localize + raise EBold.CreateFmt('%s.GetClassStreamerByName: Unrecognized class name %s', [classname, name]); end; -procedure TBoldDefaultXMLStreamManager.ReadValueSpace(ValueSpace: IBoldValueSpace; Node: TBoldXMLNode); +procedure TBoldDefaultXMLStreamManager.ReadValueSpace(const ValueSpace: IBoldValueSpace; Node: TBoldXMLNode); var aSubNode: TBoldXMLNode; + {$IFDEF OXML} + aNodeListEnumerator: TXMLChildNodeListEnumerator; + aNode: PXMLNode; + {$ELSE} aNodeList: IXMLDomNodeList; aNode: IXMLDomNode; + {$ENDIF} begin - if not assigned(ValueSpace) then + if not assigned(ValueSpace) then begin exit; + end; + {$IFDEF OXML} + aNodeListEnumerator := Node.XMLDomElement.ChildNodes.GetEnumerator; + try + while aNodeListEnumerator.MoveNext do + begin + aNode := aNodeListEnumerator.Current; + aSubNode := TBoldXMLNode.Create(Node.Manager, aNode, nil); + ClassStreamerByName[aSubNode.Accessor].ReadObject(aSubNode, ValueSpace); + aSubNode.Free; + end; + finally + aNodeListEnumerator.Free; + end; + {$ELSE} aNodeList := Node.XMLDomElement.childNodes; aNode := aNodeList.nextNode; - while assigned(aNode) do - begin + while assigned(aNode) do begin aSubNode := TBoldXMLNode.Create(Node.Manager, aNode as IXMLDOMElement, nil); ClassStreamerByName[aSubNode.Accessor].ReadObject(aSubNode, ValueSpace); aSubNode.Free; aNode := aNodeList.nextNode; end; + {$ENDIF} end; -procedure TBoldDefaultXMLStreamManager.WriteValueSpace(ValueSpace: IBoldValueSpace; IdList: TBoldObjectIdList; +procedure TBoldDefaultXMLStreamManager.WriteValueSpace(const ValueSpace: IBoldValueSpace; IdList: TBoldObjectIdList; MemberIdList: TBoldMemberIdList; Node: TBoldXMLNode); var i: integer; @@ -373,7 +394,7 @@ procedure TBoldDefaultXMLStreamManager.WriteValueSpace(ValueSpace: IBoldValueSpa { TBoldXMLValueStreamer } -procedure TBoldXMLValueStreamer.ReadInterface(Item: IBoldStreamable; Node: TBoldXMLNode); +procedure TBoldXMLValueStreamer.ReadInterface(const Item: IBoldStreamable; Node: TBoldXMLNode); var SubNode: TBoldXMLNode; begin @@ -381,28 +402,39 @@ procedure TBoldXMLValueStreamer.ReadInterface(Item: IBoldStreamable; Node: TBold if not (Node.Manager as TBoldDefaultXMLStreamManager).IgnorePersistenceState then begin SubNode := Node.GetSubNode(BoldNodeName_persistencestate); - (Item as IBoldValue).BoldPersistenceState := TBoldValuePersistenceState(SubNode.ReadInteger); - SubNode.Free; + if Assigned(SubNode) then begin + (Item as IBoldValue).BoldPersistenceState := + TBoldValuePersistenceState(SubNode.ReadInteger); + SubNode.Free; + end else begin + // No node found -> set default BoldPersistenceState (bvpsCurrent) + (Item as IBoldValue).BoldPersistenceState := bvpsCurrent; + end; end; end; -procedure TBoldXMLValueStreamer.WriteInterface(Item: IBoldStreamable; Node: TBoldXMLNode); +procedure TBoldXMLValueStreamer.WriteInterface(const Item: IBoldStreamable; Node: TBoldXMLNode); var SubNode: TBoldXMLNode; + iPersistenceState: Integer; begin inherited; - SubNode := Node.NewSubNode(BoldNodeName_persistencestate); - SubNode.WriteInteger(Integer((Item as IBoldValue).BoldPersistenceState)); - SubNode.Free; + iPersistenceState := Integer((Item as IBoldValue).BoldPersistenceState); + // Only write BoldPersistenceState other than bvpsCurrent, to minimize XML size + if iPersistenceState <> 0 then begin + SubNode := Node.NewSubNode(BoldNodeName_persistencestate); + SubNode.WriteInteger(iPersistenceState); + SubNode.Free; + end; end; { TBoldXMLNullableValueStreamer } -procedure TBoldXMLNullableValueStreamer.ReadContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLNullableValueStreamer.ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); begin end; -procedure TBoldXMLNullableValueStreamer.ReadInterface(Item: IBoldStreamable; Node: TboldXMLNode); +procedure TBoldXMLNullableValueStreamer.ReadInterface(const Item: IBoldStreamable; Node: TboldXMLNode); var ContentNode: TBoldXMLNode; begin @@ -415,11 +447,11 @@ procedure TBoldXMLNullableValueStreamer.ReadInterface(Item: IBoldStreamable; Nod ContentNode.Free; end; -procedure TBoldXMLNullableValueStreamer.WriteContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLNullableValueStreamer.WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); begin end; -procedure TBoldXMLNullableValueStreamer.WriteInterface(Item: IBoldStreamable; Node: TBoldXMLNode); +procedure TBoldXMLNullableValueStreamer.WriteInterface(const Item: IBoldStreamable; Node: TBoldXMLNode); var ContentNode: TBoldXMLNode; begin @@ -439,13 +471,13 @@ function TBoldXMLStringContentStreamer.GetStreamName: string; result := BoldContentName_String; end; -procedure TBoldXMLStringContentStreamer.ReadContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLStringContentStreamer.ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); begin inherited; (Item as IBoldStringContent).asString := Node.ReadString; end; -procedure TBoldXMLStringContentStreamer.WriteContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLStringContentStreamer.WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); begin inherited; Node.WriteString((Item as IBoldStringContent).asString); @@ -458,13 +490,13 @@ function TBoldXMLIntegerContentStreamer.GetStreamName: string; result := BoldContentName_Integer; end; -procedure TBoldXMLIntegerContentStreamer.ReadContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLIntegerContentStreamer.ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); begin inherited; (Item as IBoldIntegerContent).asInteger := Node.ReadInteger; end; -procedure TBoldXMLIntegerContentStreamer.WriteContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLIntegerContentStreamer.WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); begin inherited; Node.WriteInteger((Item as IBoldIntegerContent).asInteger); @@ -472,11 +504,11 @@ procedure TBoldXMLIntegerContentStreamer.WriteContent(Item: IBoldValue; Node: TB { TBoldXMLRefStreamer } -procedure TBoldXMLRoleStreamer.ReadContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLRoleStreamer.ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); begin end; -procedure TBoldXMLRoleStreamer.ReadInterface(Item: IBoldStreamable; Node: TBoldXMLNode); +procedure TBoldXMLRoleStreamer.ReadInterface(const Item: IBoldStreamable; Node: TBoldXMLNode); var ContentNode: TBoldXMLNode; begin @@ -486,11 +518,11 @@ procedure TBoldXMLRoleStreamer.ReadInterface(Item: IBoldStreamable; Node: TBoldX ContentNode.Free; end; -procedure TBoldXMLRoleStreamer.WriteContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLRoleStreamer.WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); begin end; -procedure TBoldXMLRoleStreamer.WriteInterface(Item: IBoldStreamable; Node: TBoldXMLNode); +procedure TBoldXMLRoleStreamer.WriteInterface(const Item: IBoldStreamable; Node: TBoldXMLNode); var ContentNode: TBoldXMLNode; begin @@ -507,7 +539,7 @@ function TBoldXMLIdRefStreamer.GetStreamName: string; result := BoldContentName_ObjectIdRef; end; -procedure TBoldXMLIdRefStreamer.ReadContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLIdRefStreamer.ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); var SubNode: TBoldXMLNode; anId: TBoldObjectId; @@ -516,17 +548,15 @@ procedure TBoldXMLIdRefStreamer.ReadContent(Item: IBoldValue; Node: TBoldXMLNode inherited; anIdRef := Item as IBoldObjectIdRef; anId := Node.ReadSubNodeObject(BoldNodeName_id , '') as TBoldObjectId; - anIdRef.SetFromId(anId); - anId.Free; + anIdRef.SetFromId(anId, true); SubNode := Node.GetSubNode(BoldNodeName_OrderNo); if assigned(SubNode) then anIdRef.OrderNo := SubNode.ReadInteger; SubNode.Free; end; -procedure TBoldXMLIdRefStreamer.WriteContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLIdRefStreamer.WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); var -// SubNode: TBoldXMLNode; anIdRef: IBoldObjectIdRef; begin inherited; @@ -545,7 +575,7 @@ function TBoldXMLIdRefPairStreamer.GetStreamName: string; result := BoldContentName_ObjectIdRefPair; end; -procedure TBoldXMLIdRefPairStreamer.ReadContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLIdRefPairStreamer.ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); var SubNode: TBoldXMLNode; Id1, Id2: TBoldObjectId; @@ -562,7 +592,7 @@ procedure TBoldXMLIdRefPairStreamer.ReadContent(Item: IBoldValue; Node: TBoldXML Id2.Free; end; -procedure TBoldXMLIdRefPairStreamer.WriteContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLIdRefPairStreamer.WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); var SubNode: TBoldXMLNode; begin @@ -582,7 +612,7 @@ function TBoldXMLIdListRefStreamer.GetStreamName: string; result := BoldContentName_ObjectIdListRef; end; -procedure TBoldXMLIdListRefStreamer.ReadContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLIdListRefStreamer.ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); var SubNode: TBoldXMLNode; anIdList: TBoldObjectIdList; @@ -595,7 +625,7 @@ procedure TBoldXMLIdListRefStreamer.ReadContent(Item: IBoldValue; Node: TBoldXML anIdList.Free; end; -procedure TBoldXMLIdListRefStreamer.WriteContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLIdListRefStreamer.WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); var SubNode: TBoldXMLNode; anIdList: TBoldobjectIdList; @@ -620,7 +650,7 @@ function TBoldXMLIdListRefPairStreamer.GetStreamName: string; result := BoldContentName_ObjectIdListRefPair; end; -procedure TBoldXMLIdListRefPairStreamer.ReadContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLIdListRefPairStreamer.ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); var SubNode: TBoldXMLNode; IdList1, IdList2: TBoldObjectIdList; @@ -637,7 +667,7 @@ procedure TBoldXMLIdListRefPairStreamer.ReadContent(Item: IBoldValue; Node: TBol IdList2.Free; end; -procedure TBoldXMLIdListRefPairStreamer.WriteContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLIdListRefPairStreamer.WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); var SubNode: TBoldXMLNode; anIdList: TBoldobjectIdList; @@ -683,7 +713,7 @@ constructor TBoldXMLClassStreamer.Create(MoldClass: TMoldClass; Owner: TBoldDefa fExpressionName := MoldClass.ExpandedExpressionName; fMemberStreamers := TBoldXMLModelElementStreamerList.Create; for i := 0 to MoldClass.AllBoldMembers.Count - 1 do - fMemberStreamers.Add(TBoldXMLMemberStreamer.Create(MoldClass.AllBoldMembers[i], self)); + fMemberStreamers.Add(TBoldXMLMemberStreamer.Create(MoldClass.AllBoldMembers[i], self)); end; destructor TBoldXMLClassStreamer.Destroy; @@ -700,23 +730,28 @@ function TBoldXMLClassStreamer.GetMemberStreamer(Index: Integer): TBoldXMLMember result := nil; end; -function TBoldXMLClassStreamer.GetMemberStreamerByName(Name: string): TBoldXMLMemberStreamer; +function TBoldXMLClassStreamer.GetMemberStreamerByName(const Name: string): TBoldXMLMemberStreamer; begin result := fMemberStreamers.StreamerByName[Name] as TBoldXMLMemberStreamer; if not assigned(result) then - raise EBold.CreateFmt(sUnrecognizedClassName, [classname, 'GetMemberStreamerByName', name]); // do not localize + raise EBold.CreateFmt('%s.GetMemberStreamerByName: Unrecognized class name %s', [classname, name]); end; -procedure TBoldXMLClassStreamer.ReadObject(Node: TBoldXMLNode; ValueSpace: IBoldValueSpace); +procedure TBoldXMLClassStreamer.ReadObject(Node: TBoldXMLNode; const ValueSpace: IBoldValueSpace); var aSubNode: TBoldXMLNode; MembersNode: TBoldXMLNode; anId: TboldObjectId; ObjectContents: IBoldObjectContents; + aMemberStreamer: TBoldXMLMemberStreamer; + {$IFDEF OXML} + aNodeEnumerator: TXMLChildNodeListEnumerator; + aNode: PXMLNode; + {$ELSE} aNodeList: IXMLDomNodeList; aNode: IXMLDomNode; - aMemberStreamer: TBoldXMLMemberStreamer; + {$ENDIF} begin aSubNode := Node.GetSubNode(BoldNodeName_id); anId := aSubNode.ReadObject('') as TBoldObjectId; @@ -726,12 +761,23 @@ procedure TBoldXMLClassStreamer.ReadObject(Node: TBoldXMLNode; ValueSpace: IBold if not fOwner.IgnorePersistenceState then begin aSubNode := Node.GetSubNode(BoldNodeName_persistencestate); - ObjectContents.BoldPersistenceState := TBoldValuePersistenceState(aSubNode.ReadInteger); - aSubNode.Free; + if Assigned(aSubNode) then begin + ObjectContents.BoldPersistenceState := TBoldValuePersistenceState(aSubNode.ReadInteger); + aSubNode.Free; + end else begin + // No node found -> set default BoldPersistenceState (bvpsCurrent) + ObjectContents.BoldPersistenceState := bvpsCurrent; + end; end; aSubNode := Node.GetSubNode(BoldNodeName_existencestate); - ObjectContents.BoldExistenceState := TBoldExistenceState(aSubNode.ReadInteger); - aSubNode.Free; + if Assigned(aSubNode) then begin + ObjectContents.BoldExistenceState := TBoldExistenceState(aSubNode.ReadInteger); + aSubNode.Free; + end else begin + // No node found -> set default BoldExistenceState (besExisting) + ObjectContents.BoldExistenceState := besExisting; + end; + aSubNode := Node.GetSubNode(BoldNodeName_timestamp); if assigned(aSubNode) then @@ -748,6 +794,22 @@ procedure TBoldXMLClassStreamer.ReadObject(Node: TBoldXMLNode; ValueSpace: IBold end; MembersNode := Node.GetSubNode(BoldNodeName_members); + {$IFDEF OXML} + aNodeEnumerator := MembersNode.XMLDomElement.ChildNodes.GetEnumerator; + try + while aNodeEnumerator.MoveNext do begin + aNode := aNodeEnumerator.Current; + aSubNode := TBoldXMLNode.Create(Node.Manager, aNode, nil); + aMemberStreamer := MemberStreamerByName[aSubNode.Accessor]; + ObjectContents.EnsureMember(aMemberStreamer.MemberId, aMemberStreamer.TypeStreamName); + aMemberStreamer.ReadValue(aSubNode, ObjectContents.ValueByIndex[aMemberStreamer.Index]); + aSubNode.Free; + end; + finally + aNodeEnumerator.Free; + MembersNode.Free; + end; + {$ELSE} aNodeList := MembersNode.XMLDomElement.childNodes; aNode := aNodeList.nextNode; while assigned(aNode) do @@ -756,20 +818,22 @@ procedure TBoldXMLClassStreamer.ReadObject(Node: TBoldXMLNode; ValueSpace: IBold aMemberStreamer := MemberStreamerByName[aSubNode.Accessor]; ObjectContents.EnsureMember(aMemberStreamer.MemberId, aMemberStreamer.TypeStreamName); aMemberStreamer.ReadValue(aSubNode, ObjectContents.ValueByIndex[aMemberStreamer.Index]); - aSubNode.Free; aNode := aNodeList.nextNode; end; MembersNode.Free; + {$ENDIF} end; procedure TBoldXMLClassStreamer.WriteObject(Node: TBoldXMLNode; - ObjectContents: IBoldObjectContents; ObjectId: TBoldObjectId; MemberIdList: TBoldMemberIdList); + const ObjectContents: IBoldObjectContents; ObjectId: TBoldObjectId; MemberIdList: TBoldMemberIdList); var i: Integer; ObjNode: TBoldXMLNode; MembersNode: TBoldXMLNode; aSubNode: TBoldXMLNode; + iBoldPersistenceState, + iBoldExistenceState: Integer; begin if not assigned(ObjectContents) then exit; @@ -779,15 +843,26 @@ procedure TBoldXMLClassStreamer.WriteObject(Node: TBoldXMLNode; aSubNode := ObjNode.NewSubNode(BoldNodeName_id); aSubNode.WriteObject('', ObjectId); aSubNode.Free; - aSubNode := ObjNode.NewSubNode(BoldNodeName_persistencestate); - aSubNode.WriteInteger(Integer(ObjectContents.BoldPersistenceState)); - aSubNode.Free; - aSubNode := ObjNode.NewSubNode(BoldNodeName_existencestate); - aSubNode.WriteInteger(Integer(ObjectContents.BoldExistenceState)); - aSubNode.Free; - aSubNode := ObjNode.NewSubNode(BoldNodeName_timestamp); - aSubNode.WriteInteger(ObjectContents.TimeStamp); - aSubNode.Free; + iBoldPersistenceState := Integer(ObjectContents.BoldPersistenceState); + // Only write BoldPersistenceState other than bvpsCurrent, to minimize XML size + if iBoldPersistenceState <> 0 then begin + aSubNode := ObjNode.NewSubNode(BoldNodeName_persistencestate); + aSubNode.WriteInteger(iBoldPersistenceState); + aSubNode.Free; + end; + iBoldExistenceState := Integer(ObjectContents.BoldExistenceState); + // Only write BoldExistenceState other than besExisting, to minimize XML size + if iBoldExistenceState <> 1 then begin + aSubNode := ObjNode.NewSubNode(BoldNodeName_existencestate); + aSubNode.WriteInteger(iBoldExistenceState); + aSubNode.Free; + end; + // Onyl write TimeStamp if it is set, to minimize XML size + if ObjectContents.TimeStamp <> -1 then begin + aSubNode := ObjNode.NewSubNode(BoldNodeName_timestamp); + aSubNode.WriteInteger(ObjectContents.TimeStamp); + aSubNode.Free; + end; if ObjectContents.GlobalId <> '' then ObjNode.WriteSubNodeString(BoldNodeName_globalid, ObjectContents.GlobalId); @@ -826,14 +901,14 @@ destructor TBoldXMLMemberStreamer.Destroy; end; procedure TBoldXMLMemberStreamer.ReadValue(Node: TBoldXMLNode; - Value: IBoldValue); + const Value: IBoldValue); begin if assigned(self) and assigned(Value) then if (Value.BoldPersistenceState in fOwner.fOwner.PersistenceStatesToOverwrite) then Node.ReadInterface(TypeStreamName, Value as IBoldStreamable); end; -procedure TBoldXMLMemberStreamer.WriteValue(Node: TBoldXMLNode; Value: IBoldValue); +procedure TBoldXMLMemberStreamer.WriteValue(Node: TBoldXMLNode; const Value: IBoldValue); var aSubNode: TBoldXMLNode; begin @@ -853,12 +928,12 @@ function TBoldXMLFloatContentStreamer.GetStreamName: string; result := BoldContentName_Float; end; -procedure TBoldXMLFloatContentStreamer.ReadContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLFloatContentStreamer.ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); begin (Item as IBoldFloatContent).asFloat := Node.ReadFloat; end; -procedure TBoldXMLFloatContentStreamer.WriteContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLFloatContentStreamer.WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); begin Node.WriteFloat((Item as IBoldFloatContent).asFloat); end; @@ -870,12 +945,12 @@ function TBoldXMLCurrencyContentStreamer.GetStreamName: string; result := BoldContentName_Currency; end; -procedure TBoldXMLCurrencyContentStreamer.ReadContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLCurrencyContentStreamer.ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); begin (Item as IBoldCurrencyContent).asCurrency := Node.ReadCurrency; end; -procedure TBoldXMLCurrencyContentStreamer.WriteContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLCurrencyContentStreamer.WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); begin Node.WriteCurrency((Item as IBoldCurrencyContent).asCurrency); end; @@ -887,13 +962,13 @@ function TBoldXMLBooleanContentStreamer.GetStreamName: string; result := BoldContentName_Boolean; end; -procedure TBoldXMLBooleanContentStreamer.ReadContent(Item: IBoldValue; +procedure TBoldXMLBooleanContentStreamer.ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); begin (Item as IBoldBooleanContent).asBoolean := Node.ReadBoolean; end; -procedure TBoldXMLBooleanContentStreamer.WriteContent(Item: IBoldValue; +procedure TBoldXMLBooleanContentStreamer.WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); begin Node.WriteBoolean((Item as IBoldBooleanContent).asBoolean); @@ -906,12 +981,12 @@ function TBoldXMLDateContentStreamer.GetStreamName: string; result := BoldContentName_Date; end; -procedure TBoldXMLDateContentStreamer.ReadContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLDateContentStreamer.ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); begin (Item as IBoldDateContent).asDate := Node.ReadDate; end; -procedure TBoldXMLDateContentStreamer.WriteContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLDateContentStreamer.WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); begin Node.WriteDate((Item as IBoldDateContent).asDate); end; @@ -923,14 +998,14 @@ function TBoldXMLTimeContentStreamer.GetStreamName: string; result := BoldContentName_Time; end; -procedure TBoldXMLTimeContentStreamer.ReadContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLTimeContentStreamer.ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); begin (Item as IBoldTimeContent).asTime := Node.ReadTime; end; -procedure TBoldXMLTimeContentStreamer.WriteContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLTimeContentStreamer.WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); begin - Node.WriteTime((Item as IBoldTimeContent).asTime); + Node.WriteTime((Item as IBoldTimeContent).asTime); end; { TBoldXMLDateTimeContentStreamer } @@ -940,12 +1015,12 @@ function TBoldXMLDateTimeContentStreamer.GetStreamName: string; result := BoldContentName_DateTime; end; -procedure TBoldXMLDateTimeContentStreamer.ReadContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLDateTimeContentStreamer.ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); begin (Item as IBoldDateTimeContent).asDateTime := Node.ReadDateTime; end; -procedure TBoldXMLDateTimeContentStreamer.WriteContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLDateTimeContentStreamer.WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); begin Node.WriteDateTime((Item as IBoldDateTimeContent).asDateTime); end; @@ -957,12 +1032,12 @@ function TBoldXMLBlobContentStreamer.GetStreamName: string; result := BoldContentName_Blob; end; -procedure TBoldXMLBlobContentStreamer.ReadContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLBlobContentStreamer.ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); begin (Item as IBoldBlobContent).asBlob := Node.ReadData; end; -procedure TBoldXMLBlobContentStreamer.WriteContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLBlobContentStreamer.WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); begin inherited; Node.WriteData((Item as IBoldBlobContent).asBlob); @@ -975,13 +1050,13 @@ function TBoldXMLTypedBlobStreamer.GetStreamName: string; result := BoldContentName_TypedBlob; end; -procedure TBoldXMLTypedBlobStreamer.ReadContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLTypedBlobStreamer.ReadContent(const Item: IBoldValue; Node: TBoldXMLNode); begin inherited; (Item as IBoldTypedBlob).ContentTypeContent := Node.ReadSubNodeString(BoldNodeName_ContentType); end; -procedure TBoldXMLTypedBlobStreamer.WriteContent(Item: IBoldValue; Node: TBoldXMLNode); +procedure TBoldXMLTypedBlobStreamer.WriteContent(const Item: IBoldValue; Node: TBoldXMLNode); begin inherited; Node.WriteSubNodeString(BoldNodeName_ContentType, (Item as IBoldTypedBlob).ContentTypeContent); @@ -1025,6 +1100,6 @@ initialization TBoldXMLStreamerRegistry.MainStreamerRegistry.RegisterStreamer(TBoldXMLIdListRefPairStreamer.Create); finalization - FreeAndNil(G_MainRegistry); + FreeAndNil(G_MainRegistry); end. diff --git a/dclBold.dpk b/dclBold.dpk new file mode 100644 index 00000000..8b17e774 --- /dev/null +++ b/dclBold.dpk @@ -0,0 +1,149 @@ +package dclBold; + +{$R *.res} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS ON} +{$RANGECHECKS ON} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$DESCRIPTION 'Bold for Delphi'} +{$LIBVERSION '27'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + vcl, + vcldb, + DesignIDE, + Bold, + FireDac, + FireDACCommonDriver, + FireDACCommon, + FireDACPgDriver, + IndySystem, + IndyCore; + +contains + BoldAbstractPropertyEditors in 'Source\Common\IDE\BoldAbstractPropertyEditors.pas', + BoldAFPPluggableReg in 'Source\BoldAwareGUI\FormGen\BoldAFPPluggableReg.pas', + BoldAttributeWizard in 'Source\ObjectSpace\IDE\AttributeWizard\BoldAttributeWizard.pas', + BoldAwareGuiReg in 'Source\BoldAwareGUI\IDE\BoldAwareGuiReg.pas', + BoldCheckListBoxReg in 'Source\Samples\BoldCheckListBox\BoldCheckListBoxReg.pas', + BoldCodePlugins in 'Source\UMLModel\Plugins\BoldCodePlugins.pas', + BoldComboBoxPropertyEditors in 'Source\BoldAwareGUI\IDE\BoldComboBoxPropertyEditors.pas', + BoldComEditors in 'Source\Common\IDECOM\BoldComEditors.pas', + BoldComElementHandleReg in 'Source\Handles\IDECOM\BoldComElementHandleReg.pas', + BoldComPersistenceHandleReg in 'Source\Persistence\IDECOM\BoldComPersistenceHandleReg.pas', + BoldComponentValidatorIDE in 'Source\ObjectSpace\IDE\BoldComponentValidatorIDE.pas', + BoldComReg in 'Source\Common\IDECOM\BoldComReg.pas', + BoldConcurrencyControlReg in 'Source\ConcurrencyControl\IDECOM\BoldConcurrencyControlReg.pas', + BoldConstraintValidatorReg in 'Source\Samples\ConstraintValidator\BoldConstraintValidatorReg.pas', + BoldControlPackPropertyEditors in 'Source\BoldAwareGUI\IDE\BoldControlPackPropertyEditors.pas', + BoldDefsDT in 'Source\Common\IDE\BoldDefsDT.pas', + BoldEditOCLActionPropEditor in 'Source\Samples\IDE\BoldEditOCLActionPropEditor.pas', + BoldExpert in 'Source\Common\IDE\BoldExpert.pas', + BoldExpertMenus in 'Source\Common\IDE\BoldExpertMenus.pas', + BoldExternalObjectSpaceEventHandlerReg in 'Source\ObjectSpace\IDE\BoldExternalObjectSpaceEventHandlerReg.pas', + BoldGridPropertyEditors in 'Source\BoldAwareGUI\IDE\BoldGridPropertyEditors.pas', + BoldHandlePropEditor in 'Source\Handles\IDE\BoldHandlePropEditor.pas', + BoldHandleReg in 'Source\Handles\IDE\BoldHandleReg.pas', + BoldHandlesPropagationReg in 'Source\Persistence\IDE\BoldHandlesPropagationReg.pas', + BoldHTTPClientPersistenceHandleReg in 'Source\Persistence\IDECOM\BoldHTTPClientPersistenceHandleReg.pas', + BoldHTTPServerPersistenceHandlePassthroughReg in 'Source\Persistence\IDECOM\BoldHTTPServerPersistenceHandlePassthroughReg.pas', + BoldIDEConsts in 'Source\Common\IDE\BoldIDEConsts.pas', + BoldIDEMenus in 'Source\Common\IDE\BoldIDEMenus.pas', + BoldIDESupport in 'Source\Common\IDE\BoldIDESupport.pas', + BoldLockingReg in 'Source\Handles\IDE\BoldLockingReg.pas', + BoldManipulatorReg in 'Source\Handles\IDE\BoldManipulatorReg.pas', + BoldModelAwareComponentEditor in 'Source\Common\IDE\BoldModelAwareComponentEditor.pas', + BoldModelReg in 'Source\MoldModel\IDE\BoldModelReg.pas', + BoldNodeDescriptionEditor in 'Source\BoldAwareGUI\IDE\BoldNodeDescriptionEditor.pas', + BoldObjectNamePropertyEditor in 'Source\Common\IDECOM\BoldObjectNamePropertyEditor.pas', + BoldObjectUpgraderHandleReg in 'Source\Persistence\IDE\BoldObjectUpgraderHandleReg.pas', + BoldOTACodeGen in 'Source\ObjectSpace\IDE\AttributeWizard\BoldOTACodeGen.pas', + BoldOTAFileHandler in 'Source\Common\IDE\BoldOTAFileHandler.pas', + BoldOTASupport in 'Source\Common\IDE\BoldOTASupport.pas', + BoldPersistenceHandleDBreg in 'Source\Persistence\DB\BoldPersistenceHandleDBreg.pas', + BoldPersistenceHandleFileReg in 'Source\Persistence\IDE\BoldPersistenceHandleFileReg.pas', + BoldPersistenceHandleFireDACReg in 'Source\Persistence\FireDAC\BoldPersistenceHandleFireDACReg.pas', + BoldPersistenceHandleReg in 'Source\Persistence\IDE\BoldPersistenceHandleReg.pas', + BoldPersistenceHandleSystemReg in 'Source\Persistence\IDE\BoldPersistenceHandleSystemReg.pas', + BoldPersistenceNotifierReg in 'Source\Persistence\IDE\BoldPersistenceNotifierReg.pas', + BoldPropagatorHandleCOMReg in 'Source\Propagator\IDECOM\BoldPropagatorHandleCOMReg.pas', + BoldPropertiesControllerPropertyEditors in 'Source\BoldAwareGUI\IDE\BoldPropertiesControllerPropertyEditors.pas', + BoldPropertyEditors in 'Source\Common\IDE\BoldPropertyEditors.pas', + BoldReg in 'Source\Common\IDE\BoldReg.pas', + BoldSamplesReg in 'Source\Samples\IDE\BoldSamplesReg.pas', + BoldSelectionListBoxReg in 'Source\Samples\BoldCheckListBox\BoldSelectionListBoxReg.pas', + BoldTextStream in 'Source\Common\IDE\BoldTextStream.pas', + BoldTypeNameHandleReg in 'Source\MoldModel\IDE\BoldTypeNameHandleReg.pas', + BoldUMLModelEditReg in 'Source\UMLModel\Ide\BoldUMLModelEditReg.pas', + BoldUMLModelHandleReg in 'Source\UMLModel\Ide\BoldUMLModelHandleReg.pas', + BoldUMLRose98Linkreg in 'Source\UMLModel\ModelLinks\Rose98\BoldUMLRose98Linkreg.pas', + BoldVclUtils in 'Source\ObjectSpace\IDE\AttributeWizard\BoldVclUtils.pas', + BoldWAClassInfo in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWAClassInfo.pas', + BoldWACustomAttr in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWACustomAttr.pas', + BoldWACustomAttrForm1 in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWACustomAttrForm1.pas', + BoldWAdatamodule in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWAdatamodule.pas', + BoldWAdmTemplates in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWAdmTemplates.pas', + BoldWAInputFormUnit in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWAInputFormUnit.pas', + BoldWAInterfaces in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWAInterfaces.pas', + BoldWAMainForm in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWAMainForm.pas', + BoldWAMethodInfo in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWAMethodInfo.pas', + BoldWAStringGridManager in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWAStringGridManager.pas', + BoldWASubClassForm1 in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWASubClassForm1.pas', + BoldWAValueSetDlg in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWAValueSetDlg.pas', + BoldWAValueSetForm1 in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWAValueSetForm1.pas', + BoldWCodeInformer in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWCodeInformer.pas', + BoldWebConnectionReg in 'Source\Common\IDE\BoldWebConnectionReg.pas', + BoldWProjectWizard in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWProjectWizard.pas', + BoldWScanner in 'Source\ObjectSpace\IDE\AttributeWizard\BoldWScanner.pas', + BoldWSimpleMenuWizard in 'Source\ObjectSpace\IDE\BoldWSimpleMenuWizard.pas', + BoldXMLDispatcherEditor in 'Source\Common\IDECOM\BoldXMLDispatcherEditor.pas', + BoldXMLDispatcherReg in 'Source\Common\IDECOM\BoldXMLDispatcherReg.pas', + BoldXMLDispatcherVBReg in 'Source\Common\IDECOM\BoldXMLDispatcherVBReg.pas', + BoldXMLReg in 'Source\Handles\IDE\BoldXMLReg.pas', + BoldExternalPersistenceHandlesReg in 'Source\Persistence\ExternalPersistence\BoldExternalPersistenceHandlesReg.pas', + BoldDTDParser in 'Source\UMLModel\ModelLinks\XMI\BoldDTDParser.pas', + BoldMOFInterfaces in 'Source\UMLModel\ModelLinks\XMI\BoldMOFInterfaces.pas', + BoldUMLDTDData in 'Source\UMLModel\ModelLinks\XMI\BoldUMLDTDData.pas', + BoldUMLModelMOFAdapters in 'Source\UMLModel\ModelLinks\XMI\BoldUMLModelMOFAdapters.pas', + BoldUMLXMICommon in 'Source\UMLModel\ModelLinks\XMI\BoldUMLXMICommon.pas', + BoldUMLXMIImporter in 'Source\UMLModel\ModelLinks\XMI\BoldUMLXMIImporter.pas', + BoldUMLXMILink in 'Source\UMLModel\ModelLinks\XMI\BoldUMLXMILink.pas', + BoldUMLXMILinkSupport in 'Source\UMLModel\ModelLinks\XMI\BoldUMLXMILinkSupport.pas', + BoldUMXMILinkreg in 'Source\UMLModel\ModelLinks\XMI\BoldUMXMILinkreg.pas', + BoldXMI10Exporter in 'Source\UMLModel\ModelLinks\XMI\BoldXMI10Exporter.pas', + BoldOLLEController in 'Source\Extensions\OLLE\Core\BoldOLLEController.pas', + BoldOLLEDistributableObjectHandlers in 'Source\Extensions\OLLE\Core\BoldOLLEDistributableObjectHandlers.pas', + BoldOLLEdmmain in 'Source\Extensions\OLLE\Core\BoldOLLEdmmain.pas', + BoldOLLEHandles in 'Source\Extensions\OLLE\Core\BoldOLLEHandles.pas', + DistributableInfo in 'Source\Extensions\OLLE\Core\DistributableInfo.pas', + OlleConsts in 'Source\Extensions\OLLE\Core\OlleConsts.pas', + BoldOLLEHandlesComponentEditor in 'Source\Extensions\OLLE\IDE\BoldOLLEHandlesComponentEditor.pas', + BoldOLLEHandlesReg in 'Source\Extensions\OLLE\IDE\BoldOLLEHandlesReg.pas', + BoldAbstractModificationPropagator in 'Source\Persistence\UDPPropagator\BoldAbstractModificationPropagator.pas', + BoldUDPModificationBroadcaster in 'Source\Persistence\UDPPropagator\BoldUDPModificationBroadcaster.pas', + BoldEnvironmentIDE in 'Source\Common\Environment\BoldEnvironmentIDE.pas', + BoldUDPBroadcasterReg in 'Source\Persistence\IDEUDP\BoldUDPBroadcasterReg.pas'; + +end. diff --git a/dclBold.dproj b/dclBold.dproj new file mode 100644 index 00000000..ee213f79 --- /dev/null +++ b/dclBold.dproj @@ -0,0 +1,972 @@ + + + {BA681BD2-4AA5-4AB0-8850-FFE2B8AAC9E0} + dclBold.dpk + 19.2 + None + True + Debug + Win32 + 1 + Package + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + true + true + System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace) + All + dclBold + $(BoldDelphi)\Source\BoldAwareGUI;$(BoldDelphi)\Source\BoldQAwareGUI;$(BoldDelphi)\Source\ClientGuiCom;$(BoldDelphi)\Source\ClientHandlesCom;$(BoldDelphi)\Source\Common;$(BoldDelphi)\Source\ConcurrencyControl;$(BoldDelphi)\Source\Extensions;$(BoldDelphi)\Source\FreestandingValueSpace;$(BoldDelphi)\Source\Handles;$(BoldDelphi)\Source\MoldModel;$(BoldDelphi)\Source\ObjectSpace;$(BoldDelphi)\Source\Persistence;$(BoldDelphi)\Source\PMapper;$(BoldDelphi)\Source\Propagator;$(BoldDelphi)\Source\Samples;$(BoldDelphi)\Source\UMLModel;$(BoldDelphi)\Source\Unassigned;$(BoldDelphi)\Source\ValueSpace;$(BoldDelphi)\Source\BoldAwareGUI\Actions;$(BoldDelphi)\Source\BoldAwareGUI\BoldControls;$(BoldDelphi)\Source\BoldAwareGUI\ControlPacks;$(BoldDelphi)\Source\BoldAwareGUI\Core;$(BoldDelphi)\Source\BoldAwareGUI\FormGen;$(BoldDelphi)\Source\BoldAwareGUI\IDE;$(BoldDelphi)\Source\BoldQAwareGUI\BoldControls;$(BoldDelphi)\Source\BoldQAwareGUI\ControlPacks;$(BoldDelphi)\Source\BoldQAwareGUI\Core;$(BoldDelphi)\Source\ClientGuiCom\BoldControls;$(BoldDelphi)\Source\ClientGuiCom\ControlPacks;$(BoldDelphi)\Source\ClientGuiCom\Core;$(BoldDelphi)\Source\ClientGuiCom\IDE;$(BoldDelphi)\Source\ClientHandlesCom\Core;$(BoldDelphi)\Source\ClientHandlesCom\IDE;$(BoldDelphi)\Source\Common\COM;$(BoldDelphi)\Source\Common\Connection;$(BoldDelphi)\Source\Common\ConnectionCOM;$(BoldDelphi)\Source\Common\ConnectionHandles;$(BoldDelphi)\Source\Common\ConnectionHandlesCOM;$(BoldDelphi)\Source\Common\Core;$(BoldDelphi)\Source\Common\Environment;$(BoldDelphi)\Source\Common\Handles;$(BoldDelphi)\Source\Common\HTTP;$(BoldDelphi)\Source\Common\IDE;$(BoldDelphi)\Source\Common\IDECOM;$(BoldDelphi)\Source\Common\Include;$(BoldDelphi)\Source\Common\Logging;$(BoldDelphi)\Source\Common\MsXml;$(BoldDelphi)\Source\Common\Queue;$(BoldDelphi)\Source\Common\Rose2000;$(BoldDelphi)\Source\Common\Rose98;$(BoldDelphi)\Source\Common\SOAP;$(BoldDelphi)\Source\Common\Subscription;$(BoldDelphi)\Source\Common\Support;$(BoldDelphi)\Source\Common\SupportWin;$(BoldDelphi)\Source\Common\TaggedValues;$(BoldDelphi)\Source\Common\Template;$(BoldDelphi)\Source\Common\UML;$(BoldDelphi)\Source\Common\UtilsGUI;$(BoldDelphi)\Source\ConcurrencyControl\COM;$(BoldDelphi)\Source\ConcurrencyControl\Common;$(BoldDelphi)\Source\ConcurrencyControl\IDECOM;$(BoldDelphi)\Source\Extensions\OLLE;$(BoldDelphi)\Source\Extensions\OLLE\Core;$(BoldDelphi)\Source\Extensions\OLLE\IDE;$(BoldDelphi)\Source\FreestandingValueSpace\Core;$(BoldDelphi)\Source\Handles\Actions;$(BoldDelphi)\Source\Handles\COM;$(BoldDelphi)\Source\Handles\Core;$(BoldDelphi)\Source\Handles\IDE;$(BoldDelphi)\Source\Handles\IDECOM;$(BoldDelphi)\Source\Handles\Manipulators;$(BoldDelphi)\Source\Handles\PessimisticLocking;$(BoldDelphi)\Source\Handles\UnLoader;$(BoldDelphi)\Source\Handles\XML;$(BoldDelphi)\Source\MoldModel\Bld;$(BoldDelphi)\Source\MoldModel\CodeGenerator;$(BoldDelphi)\Source\MoldModel\Core;$(BoldDelphi)\Source\MoldModel\Handles;$(BoldDelphi)\Source\MoldModel\IDE;$(BoldDelphi)\Source\MoldModel\TypeNameDictionary;$(BoldDelphi)\Source\MoldModel\UtilsGUI;$(BoldDelphi)\Source\ObjectSpace\BORepresentation;$(BoldDelphi)\Source\ObjectSpace\COM;$(BoldDelphi)\Source\ObjectSpace\Core;$(BoldDelphi)\Source\ObjectSpace\IDE;$(BoldDelphi)\Source\ObjectSpace\Interfaces;$(BoldDelphi)\Source\ObjectSpace\Ocl;$(BoldDelphi)\Source\ObjectSpace\PessimisticLocking;$(BoldDelphi)\Source\ObjectSpace\RTModel;$(BoldDelphi)\Source\ObjectSpace\Undo;$(BoldDelphi)\Source\ObjectSpace\Unloader;$(BoldDelphi)\Source\ObjectSpace\UtilsGUI;$(BoldDelphi)\Source\ObjectSpace\IDE\AttributeWizard;$(BoldDelphi)\Source\Persistence\ADO;$(BoldDelphi)\Source\Persistence\Advantage;$(BoldDelphi)\Source\Persistence\BDE;$(BoldDelphi)\Source\Persistence\COM;$(BoldDelphi)\Source\Persistence\Core;$(BoldDelphi)\Source\Persistence\DB;$(BoldDelphi)\Source\Persistence\DBExpress;$(BoldDelphi)\Source\Persistence\DBISAM;$(BoldDelphi)\Source\Persistence\DOA;$(BoldDelphi)\Source\Persistence\ExternalPersistence;$(BoldDelphi)\Source\Persistence\File;$(BoldDelphi)\Source\Persistence\FireDAC;$(BoldDelphi)\Source\Persistence\HTTP;$(BoldDelphi)\Source\Persistence\IBX;$(BoldDelphi)\Source\Persistence\IDE;$(BoldDelphi)\Source\Persistence\IDECOM;$(BoldDelphi)\Source\Persistence\IDEUDP;$(BoldDelphi)\Source\Persistence\ObjectUpgrading;$(BoldDelphi)\Source\Persistence\Propagation;$(BoldDelphi)\Source\Persistence\SOAP;$(BoldDelphi)\Source\Persistence\SQLDirect;$(BoldDelphi)\Source\Persistence\System;$(BoldDelphi)\Source\Persistence\UDPPropagator;$(BoldDelphi)\Source\Persistence\UniDAC;$(BoldDelphi)\Source\PMapper\Core;$(BoldDelphi)\Source\PMapper\DbEvolutor;$(BoldDelphi)\Source\PMapper\Default;$(BoldDelphi)\Source\PMapper\SQL;$(BoldDelphi)\Source\PMapper\Validator;$(BoldDelphi)\Source\Propagator\COM;$(BoldDelphi)\Source\Propagator\Common;$(BoldDelphi)\Source\Propagator\Enterprise;$(BoldDelphi)\Source\Propagator\IDECOM;$(BoldDelphi)\Source\Propagator\LowEnd;$(BoldDelphi)\Source\Samples\Actions;$(BoldDelphi)\Source\Samples\BoldCheckListBox;$(BoldDelphi)\Source\Samples\ConstraintValidator;$(BoldDelphi)\Source\Samples\FormSaver;$(BoldDelphi)\Source\Samples\IDE;$(BoldDelphi)\Source\Samples\Misc;$(BoldDelphi)\Source\Samples\ModelLoader;$(BoldDelphi)\Source\Samples\NewObjectInterceptor;$(BoldDelphi)\Source\Samples\SortingGrid;$(BoldDelphi)\Source\Samples\SystemComparer;$(BoldDelphi)\Source\Samples\SystemDebugger;$(BoldDelphi)\Source\Samples\UMLPlugins;$(BoldDelphi)\Source\Samples\Unicode;$(BoldDelphi)\Source\UMLModel\Core;$(BoldDelphi)\Source\UMLModel\Editor;$(BoldDelphi)\Source\UMLModel\Handles;$(BoldDelphi)\Source\UMLModel\Ide;$(BoldDelphi)\Source\UMLModel\ModelLinks;$(BoldDelphi)\Source\UMLModel\Plugins;$(BoldDelphi)\Source\UMLModel\ModelLinks\Bld;$(BoldDelphi)\Source\UMLModel\ModelLinks\Core;$(BoldDelphi)\Source\UMLModel\ModelLinks\ModelMaker;$(BoldDelphi)\Source\UMLModel\ModelLinks\Rose98;$(BoldDelphi)\Source\UMLModel\ModelLinks\XMI;$(BoldDelphi)\Source\UMLModel\ModelLinks\ModelMaker\Link;$(BoldDelphi)\Source\UMLModel\ModelLinks\ModelMaker\MMPlugin;$(BoldDelphi)\Source\UMLModel\ModelLinks\ModelMaker\Support;$(BoldDelphi)\Source\ValueSpace\Condition;$(BoldDelphi)\Source\ValueSpace\ExternalEvents;$(BoldDelphi)\Source\ValueSpace\Id;$(BoldDelphi)\Source\ValueSpace\Interfaces;$(BoldDelphi)\Source\ValueSpace\XMLStreaming;$(DCC_UnitSearchPath) + 2077 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + true + true + true + true + true + Bold for Delphi Design Package + true + true + + + Debug + true + 1033 + vcl;IndySystem;IndyCore;vcldb;FireDAC;FireDACCommonDriver;FireDACCommon;FireDACPgDriver;BoldCore;BoldAdditional;Bold;$(DCC_UsePackage) + + + vcl;IndySystem;IndyCore;vcldb;FireDAC;FireDACCommonDriver;FireDACCommon;FireDACPgDriver;BoldCore;BoldAdditional;Bold;$(DCC_UsePackage) + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + true + 1033 + Bold for Delphi + 27 + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + true + 1033 + + + + MainSource + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + dclBold.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + + + true + + + + + true + + + + + true + + + + + dclBold.bpl + true + + + + + 1 + + + 0 + + + + + classes + 1 + + + classes + 1 + + + + + res\xml + 1 + + + res\xml + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + library\lib\armeabi + 1 + + + library\lib\armeabi + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + library\lib\mips + 1 + + + library\lib\mips + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\values-v21 + 1 + + + res\values-v21 + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-ldpi + 1 + + + res\drawable-ldpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-small + 1 + + + res\drawable-small + 1 + + + + + res\drawable-normal + 1 + + + res\drawable-normal + 1 + + + + + res\drawable-large + 1 + + + res\drawable-large + 1 + + + + + res\drawable-xlarge + 1 + + + res\drawable-xlarge + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + 1 + + + 1 + + + 0 + + + + + 1 + .framework + + + 1 + .framework + + + 0 + + + + + 1 + .dylib + + + 1 + .dylib + + + 0 + .dll;.bpl + + + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 0 + .bpl + + + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + 1 + + + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + + + + 1 + + + 1 + + + 1 + + + + + + + + Contents\Resources + 1 + + + Contents\Resources + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 0 + + + + + library\lib\armeabi-v7a + 1 + + + + + 1 + + + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + + + + + + + + + + + True + False + + + 12 + + + + + diff --git a/dclBoldDevEx.dpk b/dclBoldDevEx.dpk new file mode 100644 index 00000000..02f052b1 --- /dev/null +++ b/dclBoldDevEx.dpk @@ -0,0 +1,57 @@ +package dclBoldDevEx; + +{$R *.res} +{$R 'Source\BoldAwareGUI\BoldDevex\cxBoldRegUnit.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$DESCRIPTION 'Bold For Delphi (DevEx controls)'} +{$LIBVERSION '27'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + rtl, + dclBold, + cxGridRS27, + dclcxGridRS27, + dxBarRS27; + +contains + BoldAFPCxGridProviderUnit in 'Source\BoldAwareGUI\BoldDevex\BoldAFPCxGridProviderUnit.pas', + BoldToCxConverterForm in 'Source\BoldAwareGUI\BoldDevex\BoldToCxConverterForm.pas' {frmBoldToCxConverter}, + BoldToCxConverterUnit in 'Source\BoldAwareGUI\BoldDevex\BoldToCxConverterUnit.pas', + BoldToCxGridConverterUnit in 'Source\BoldAwareGUI\BoldDevex\BoldToCxGridConverterUnit.pas', + cxBoldEditConsts in 'Source\BoldAwareGUI\BoldDevex\cxBoldEditConsts.pas', + cxBoldEditors in 'Source\BoldAwareGUI\BoldDevex\cxBoldEditors.pas', + cxBoldEditRepositoryItems in 'Source\BoldAwareGUI\BoldDevex\cxBoldEditRepositoryItems.pas', + cxBoldExtLookupComboBox in 'Source\BoldAwareGUI\BoldDevex\cxBoldExtLookupComboBox.pas', + cxBoldLookupComboBox in 'Source\BoldAwareGUI\BoldDevex\cxBoldLookupComboBox.pas', + cxBoldLookupEdit in 'Source\BoldAwareGUI\BoldDevex\cxBoldLookupEdit.pas', + cxBoldRegUnit in 'Source\BoldAwareGUI\BoldDevex\cxBoldRegUnit.pas', + cxGridBoldSupportUnit in 'Source\BoldAwareGUI\BoldDevex\cxGridBoldSupportUnit.pas', + cxLookupBoldGrid in 'Source\BoldAwareGUI\BoldDevex\cxLookupBoldGrid.pas', + dxBarBoldNav in 'Source\BoldAwareGUI\BoldDevex\dxBarBoldNav.pas'; + +end. diff --git a/dclBoldDevEx.dproj b/dclBoldDevEx.dproj new file mode 100644 index 00000000..ebff433b --- /dev/null +++ b/dclBoldDevEx.dproj @@ -0,0 +1,878 @@ + + + {58D5CA38-AC66-4CE0-9BB3-80CAB1DE12EE} + dclBoldDevEx.dpk + 19.2 + VCL + True + Debug + Win32 + 1 + Package + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + true + true + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) + All + dclBoldDevEx + Source\Common\Include\;$(DCC_UnitSearchPath) + 2077 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + Bold DevEx Controls + true + true + + + Debug + true + 1033 + rtl;dxBarRS27;cxGridRS27;$(DCC_UsePackage) + + + rtl;dxBarRS27;cxGridRS27;$(DCC_UsePackage) + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + true + 1033 + Bold For Delphi (DevEx controls) + 27 + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + true + 1033 + + + + MainSource + + + + + + + + + +
frmBoldToCxConverter
+ + + + + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + dclBoldDevEx.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + + + true + + + + + true + + + + + true + + + + + dclBoldDevEx.bpl + true + + + + + 1 + + + 0 + + + + + classes + 1 + + + classes + 1 + + + + + res\xml + 1 + + + res\xml + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + library\lib\armeabi + 1 + + + library\lib\armeabi + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + library\lib\mips + 1 + + + library\lib\mips + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\values-v21 + 1 + + + res\values-v21 + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-ldpi + 1 + + + res\drawable-ldpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-small + 1 + + + res\drawable-small + 1 + + + + + res\drawable-normal + 1 + + + res\drawable-normal + 1 + + + + + res\drawable-large + 1 + + + res\drawable-large + 1 + + + + + res\drawable-xlarge + 1 + + + res\drawable-xlarge + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + 1 + + + 1 + + + 0 + + + + + 1 + .framework + + + 1 + .framework + + + 0 + + + + + 1 + .dylib + + + 1 + .dylib + + + 0 + .dll;.bpl + + + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 0 + .bpl + + + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + 1 + + + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + + + + 1 + + + 1 + + + 1 + + + + + + + + Contents\Resources + 1 + + + Contents\Resources + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 0 + + + + + library\lib\armeabi-v7a + 1 + + + + + 1 + + + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + + + + + + + + + + + True + False + + + 12 + + + + + diff --git a/dclBoldUniDAC.dpk b/dclBoldUniDAC.dpk new file mode 100644 index 00000000..9a080e4d --- /dev/null +++ b/dclBoldUniDAC.dpk @@ -0,0 +1,47 @@ +package dclBoldUniDAC; + +{$R *.res} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$DESCRIPTION 'Bold for Delphi (UniDAC Support)'} +{$LIBVERSION '27'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + rtl, + vcldb, + DesignIDE, + dclBold, + dac270, + unidac270; + +contains + BoldPersistenceHandleUniDACReg in 'Source\Persistence\UniDAC\BoldPersistenceHandleUniDACReg.pas', + BoldUniDACInterfaces in 'Source\Persistence\UniDAC\BoldUniDACInterfaces.pas', + UniDACConsts in 'Source\Persistence\UniDAC\UniDACConsts.pas', + BoldDatabaseAdapterUniDAC in 'Source\Persistence\UniDAC\BoldDatabaseAdapterUniDAC.pas'; + +end. diff --git a/dclBoldUniDAC.dproj b/dclBoldUniDAC.dproj new file mode 100644 index 00000000..716d3eaa --- /dev/null +++ b/dclBoldUniDAC.dproj @@ -0,0 +1,863 @@ + + + {62DD6777-B230-4653-9B18-180B21451307} + dclBoldUniDAC.dpk + 19.2 + None + True + Debug + Win32 + 1 + Package + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + true + true + System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace) + All + dclBoldUniDAC + true + $(BoldDelphi)\Source\Common\Include;C:\Attracs\Attracs-Common\components\UniDAC\Source;C:\Attracs\Attracs-Common\components\UniDAC\Source\UniProviders\SQLServer;C:\Attracs\Attracs-Common\components\UniDAC\Source\UniProviders\TDS;$(DCC_UnitSearchPath) + 2077 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + true + + + Debug + true + 1033 + rtl;vcldb;ibxpress;$(DCC_UsePackage) + + + rtl;vcldb;ibxpress;$(DCC_UsePackage) + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + true + 1033 + Bold for Delphi (UniDAC Support) + 27 + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + true + 1033 + + + + MainSource + + + + + + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + dclBoldUniDAC.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + + + true + + + + + true + + + + + true + + + + + dclBoldUniDAC.bpl + true + + + + + 1 + + + 0 + + + + + classes + 1 + + + classes + 1 + + + + + res\xml + 1 + + + res\xml + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + library\lib\armeabi + 1 + + + library\lib\armeabi + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + library\lib\mips + 1 + + + library\lib\mips + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\values-v21 + 1 + + + res\values-v21 + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-ldpi + 1 + + + res\drawable-ldpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-small + 1 + + + res\drawable-small + 1 + + + + + res\drawable-normal + 1 + + + res\drawable-normal + 1 + + + + + res\drawable-large + 1 + + + res\drawable-large + 1 + + + + + res\drawable-xlarge + 1 + + + res\drawable-xlarge + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + 1 + + + 1 + + + 0 + + + + + 1 + .framework + + + 1 + .framework + + + 0 + + + + + 1 + .dylib + + + 1 + .dylib + + + 0 + .dll;.bpl + + + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 0 + .bpl + + + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + 1 + + + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + + + + 1 + + + 1 + + + 1 + + + + + + + + Contents\Resources + 1 + + + Contents\Resources + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 0 + + + + + library\lib\armeabi-v7a + 1 + + + + + 1 + + + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + + + + + + + + + + + True + False + + + 12 + + + + + diff --git a/examples/Delphi/Compound/Building/BldOwn.dpr b/examples/Delphi/Compound/Building/BldOwn.dpr index a1ee31fc..7be267b1 100644 --- a/examples/Delphi/Compound/Building/BldOwn.dpr +++ b/examples/Delphi/Compound/Building/BldOwn.dpr @@ -7,8 +7,8 @@ program Bldown; uses Forms, - datamod in 'Datamod.pas' {DataModule1: TDataModule}, - mainform in 'Mainform.pas' {allform}, + Datamod in 'Datamod.pas' {DataModule1: TDataModule}, + Mainform in 'Mainform.pas' {allform}, PersonAutoFormUnit in 'PersonAutoFormUnit.pas' {PersonAutoForm}; {$R *.RES} diff --git a/examples/Delphi/Compound/Building/BldOwn.res b/examples/Delphi/Compound/Building/BldOwn.res index 6d50bf51..5f4831f3 100644 Binary files a/examples/Delphi/Compound/Building/BldOwn.res and b/examples/Delphi/Compound/Building/BldOwn.res differ diff --git a/examples/Delphi/Compound/Building/BuildingClasses.pas b/examples/Delphi/Compound/Building/BuildingClasses.pas index 9873b863..e0a1cdce 100644 --- a/examples/Delphi/Compound/Building/BuildingClasses.pas +++ b/examples/Delphi/Compound/Building/BuildingClasses.pas @@ -2,7 +2,7 @@ (* This file is autogenerated *) (* Any manual changes will be LOST! *) (*****************************************) -(* Generated 2002-05-24 16:22:04 *) +(* Generated 17.05.2021 21:03:18 *) (*****************************************) (* This file should be stored in the *) (* same directory as the form/datamodule *) @@ -78,7 +78,7 @@ function TBuilding._GetZipCode: Integer; Result := M_ZipCode.AsInteger; end; -procedure TBuilding._SetZipCode(NewValue: Integer); +procedure TBuilding._SetZipCode(const NewValue: Integer); begin M_ZipCode.AsInteger := NewValue; end; @@ -94,7 +94,7 @@ function TBuilding._GetAddress: String; Result := M_Address.AsString; end; -procedure TBuilding._SetAddress(NewValue: String); +procedure TBuilding._SetAddress(const NewValue: String); begin M_Address.AsString := NewValue; end; @@ -224,7 +224,7 @@ function TPerson._GetFirstName: String; Result := M_FirstName.AsString; end; -procedure TPerson._SetFirstName(NewValue: String); +procedure TPerson._SetFirstName(const NewValue: String); begin M_FirstName.AsString := NewValue; end; @@ -240,7 +240,7 @@ function TPerson._GetLastName: String; Result := M_LastName.AsString; end; -procedure TPerson._SetLastName(NewValue: String); +procedure TPerson._SetLastName(const NewValue: String); begin M_LastName.AsString := NewValue; end; @@ -256,7 +256,7 @@ function TPerson._GetAssets: Currency; Result := M_Assets.AsCurrency; end; -procedure TPerson._SetAssets(NewValue: Currency); +procedure TPerson._SetAssets(const NewValue: Currency); begin M_Assets.AsCurrency := NewValue; end; @@ -272,15 +272,26 @@ function TPerson._GetIsMarried: Boolean; Result := M_IsMarried.AsBoolean; end; -procedure TPerson._SetIsMarried(NewValue: Boolean); +procedure TPerson._SetIsMarried(const NewValue: Boolean); begin M_IsMarried.AsBoolean := NewValue; end; +function TPerson._Get_M_name: TBAString; +begin + assert(ValidateMember('TPerson', 'name', 4, TBAString)); + Result := TBAString(BoldMembers[4]); +end; + +function TPerson._Getname: String; +begin + Result := M_name.AsString; +end; + function TPerson._Get_M_Home: TBoldObjectReference; begin - assert(ValidateMember('TPerson', 'Home', 4, TBoldObjectReference)); - Result := TBoldObjectReference(BoldMembers[4]); + assert(ValidateMember('TPerson', 'Home', 5, TBoldObjectReference)); + Result := TBoldObjectReference(BoldMembers[5]); end; function TPerson._GetHome: TResidential_Building; @@ -289,21 +300,21 @@ function TPerson._GetHome: TResidential_Building; Result := TResidential_Building(M_Home.BoldObject); end; -procedure TPerson._SetHome(value: TResidential_Building); +procedure TPerson._SetHome(const value: TResidential_Building); begin M_Home.BoldObject := value; end; function TPerson._GetOwnedBuildings: TBuildingList; begin - assert(ValidateMember('TPerson', 'OwnedBuildings', 5, TBuildingList)); - Result := TBuildingList(BoldMembers[5]); + assert(ValidateMember('TPerson', 'OwnedBuildings', 6, TBuildingList)); + Result := TBuildingList(BoldMembers[6]); end; function TPerson._GetOwnership: TOwnershipList; begin - assert(ValidateMember('TPerson', 'Ownership', 6, TOwnershipList)); - Result := TOwnershipList(BoldMembers[6]); + assert(ValidateMember('TPerson', 'Ownership', 7, TOwnershipList)); + Result := TOwnershipList(BoldMembers[7]); end; procedure TPersonList.Add(NewObject: TPerson); @@ -356,15 +367,31 @@ function TResidential_Building._GetTotalRent: Currency; Result := M_TotalRent.AsCurrency; end; -procedure TResidential_Building._SetTotalRent(NewValue: Currency); +procedure TResidential_Building._SetTotalRent(const NewValue: Currency); begin M_TotalRent.AsCurrency := NewValue; end; +function TResidential_Building._Get_M_Capacity: TBAInteger; +begin + assert(ValidateMember('TResidential_Building', 'Capacity', 5, TBAInteger)); + Result := TBAInteger(BoldMembers[5]); +end; + +function TResidential_Building._GetCapacity: Integer; +begin + Result := M_Capacity.AsInteger; +end; + +procedure TResidential_Building._SetCapacity(const NewValue: Integer); +begin + M_Capacity.AsInteger := NewValue; +end; + function TResidential_Building._GetResidents: TPersonList; begin - assert(ValidateMember('TResidential_Building', 'Residents', 5, TPersonList)); - Result := TPersonList(BoldMembers[5]); + assert(ValidateMember('TResidential_Building', 'Residents', 6, TPersonList)); + Result := TPersonList(BoldMembers[6]); end; procedure TResidential_BuildingList.Add(NewObject: TResidential_Building); @@ -406,7 +433,7 @@ procedure TResidential_BuildingList.SetBoldObject(index: Integer; NewObject: TRe function GeneratedCodeCRC: String; begin - result := '1091338414'; + result := '63867191'; end; procedure InstallObjectListClasses(BoldObjectListClasses: TBoldGeneratedClassList); diff --git a/examples/Delphi/Compound/Building/BuildingClasses_Interface.inc b/examples/Delphi/Compound/Building/BuildingClasses_Interface.inc index 7c5bee6a..d4083ded 100644 --- a/examples/Delphi/Compound/Building/BuildingClasses_Interface.inc +++ b/examples/Delphi/Compound/Building/BuildingClasses_Interface.inc @@ -2,7 +2,7 @@ (* This file is autogenerated *) (* Any manual changes will be LOST! *) (*****************************************) -(* Generated 2002-05-24 16:22:04 *) +(* Generated 17.05.2021 21:03:19 *) (*****************************************) (* This file should be stored in the *) (* same directory as the form/datamodule *) @@ -62,15 +62,15 @@ type private function _Get_M_ZipCode: TBAInteger; function _GetZipCode: Integer; - procedure _SetZipCode(NewValue: Integer); + procedure _SetZipCode(const NewValue: Integer); function _Get_M_Address: TBAString; function _GetAddress: String; - procedure _SetAddress(NewValue: String); + procedure _SetAddress(const NewValue: String); function _GetOwners: TPersonList; function _GetOwnership: TOwnershipList; protected - procedure CompleteCreate; override; public + procedure CompleteCreate; override; property M_ZipCode: TBAInteger read _Get_M_ZipCode; property M_Address: TBAString read _Get_M_Address; property M_Owners: TPersonList read _GetOwners; @@ -99,29 +99,32 @@ type private function _Get_M_FirstName: TBAString; function _GetFirstName: String; - procedure _SetFirstName(NewValue: String); + procedure _SetFirstName(const NewValue: String); function _Get_M_LastName: TBAString; function _GetLastName: String; - procedure _SetLastName(NewValue: String); + procedure _SetLastName(const NewValue: String); function _Get_M_Assets: TBACurrency; function _GetAssets: Currency; - procedure _SetAssets(NewValue: Currency); + procedure _SetAssets(const NewValue: Currency); function _Get_M_IsMarried: TBABoolean; function _GetIsMarried: Boolean; - procedure _SetIsMarried(NewValue: Boolean); + procedure _SetIsMarried(const NewValue: Boolean); + function _Get_M_name: TBAString; + function _Getname: String; function _GetHome: TResidential_Building; function _Get_M_Home: TBoldObjectReference; - procedure _SetHome(value: TResidential_Building); + procedure _SetHome(const value: TResidential_Building); function _GetOwnedBuildings: TBuildingList; function _GetOwnership: TOwnershipList; protected - procedure CompleteCreate; override; public - procedure BorrowFrom(Lender: TPerson; Amount: Integer); + procedure CompleteCreate; override; + procedure BorrowFrom(Lender: TPerson; Amount: Integer); property M_FirstName: TBAString read _Get_M_FirstName; property M_LastName: TBAString read _Get_M_LastName; property M_Assets: TBACurrency read _Get_M_Assets; property M_IsMarried: TBABoolean read _Get_M_IsMarried; + property M_name: TBAString read _Get_M_name; property M_Home: TBoldObjectReference read _Get_M_Home; property M_OwnedBuildings: TBuildingList read _GetOwnedBuildings; property M_Ownership: TOwnershipList read _GetOwnership; @@ -129,6 +132,7 @@ type property LastName: String read _GetLastName write _SetLastName; property Assets: Currency read _GetAssets write _SetAssets; property IsMarried: Boolean read _GetIsMarried write _SetIsMarried; + property name: String read _Getname; property Home: TResidential_Building read _GetHome write _SetHome; property OwnedBuildings: TBuildingList read _GetOwnedBuildings; property Ownership: TOwnershipList read _GetOwnership; @@ -138,15 +142,20 @@ type private function _Get_M_TotalRent: TBACurrency; function _GetTotalRent: Currency; - procedure _SetTotalRent(NewValue: Currency); + procedure _SetTotalRent(const NewValue: Currency); + function _Get_M_Capacity: TBAInteger; + function _GetCapacity: Integer; + procedure _SetCapacity(const NewValue: Integer); function _GetResidents: TPersonList; protected - procedure CompleteCreate; override; public - procedure ChargeRent; + procedure ChargeRent; + procedure CompleteCreate; override; property M_TotalRent: TBACurrency read _Get_M_TotalRent; + property M_Capacity: TBAInteger read _Get_M_Capacity; property M_Residents: TPersonList read _GetResidents; property TotalRent: Currency read _GetTotalRent write _SetTotalRent; + property Capacity: Integer read _GetCapacity write _SetCapacity; property Residents: TPersonList read _GetResidents; end; diff --git a/examples/Delphi/Compound/Building/Datamod.dfm b/examples/Delphi/Compound/Building/Datamod.dfm index 08c6322e..34d78618 100644 Binary files a/examples/Delphi/Compound/Building/Datamod.dfm and b/examples/Delphi/Compound/Building/Datamod.dfm differ diff --git a/examples/Delphi/Compound/Building/Datamod.pas b/examples/Delphi/Compound/Building/Datamod.pas index 21197ae7..ed7f055c 100644 --- a/examples/Delphi/Compound/Building/Datamod.pas +++ b/examples/Delphi/Compound/Building/Datamod.pas @@ -3,7 +3,6 @@ interface uses -// dbLogDlg, SysUtils, Classes, Controls, @@ -33,8 +32,18 @@ interface BoldreferenceHandle, ActnList, BoldHandleAction, BoldAFPPluggable, BoldAbstractPersistenceHandleDB, - DB, IBDatabase, - BoldAbstractDatabaseAdapter, BoldDatabaseAdapterIB; + DB, + BoldAbstractDatabaseAdapter, + FireDAC.Stan.Intf, + FireDAC.Stan.Option, FireDAC.Stan.Error, FireDAC.UI.Intf, FireDAC.Phys.Intf, + FireDAC.Stan.Def, FireDAC.Stan.Pool, FireDAC.Stan.Async, FireDAC.Phys, + FireDAC.Phys.FB, FireDAC.Phys.FBDef, FireDAC.VCLUI.Wait, FireDAC.Comp.Client, + BoldDatabaseAdapterFireDAC, FireDAC.Phys.MSSQL, FireDAC.Phys.MSSQLDef, + FireDAC.DApt, BoldAbstractPropagatorHandle, + BoldPropagatorHandleCOM, BoldPersistenceHandlePassthrough, + BoldPersistenceHandlePTWithModel, BoldSnooperHandle, BoldAbstractDequeuer, + BoldExternalObjectSpaceEventHandler, BoldConstraintValidator, FireDAC.Phys.PG, + FireDAC.Phys.PGDef; type TDataModule1 = class(TDataModule) @@ -48,19 +57,26 @@ TDataModule1 = class(TDataModule) BoldSystemTypeInfoHandle1: TBoldSystemTypeInfoHandle; BoldPlaceableAFP1: TBoldPlaceableAFP; BoldPersistenceHandleDB1: TBoldPersistenceHandleDB; - IBDatabase1: TIBDatabase; - BoldDatabaseAdapterIB1: TBoldDatabaseAdapterIB; - procedure IsRichRendererSubscribe(Element: TBoldElement; Representation: Integer; Expression: String; Subscriber: TBoldSubscriber); - function IsRichRendererGetAsCheckBoxState(element: TBoldElement; representation: Integer; Expression: String): TCheckBoxState; + BoldDatabaseAdapterPostgres: TBoldDatabaseAdapterFireDAC; + FDConnectionSQLServer: TFDConnection; + BoldConstraintValidatorOnModify: TBoldConstraintValidator; + BoldConstraintValidatorOnUpdate: TBoldConstraintValidator; + FDConnectionPostgres: TFDConnection; + BoldDatabaseAdapterSQLServer: TBoldDatabaseAdapterFireDAC; function NameComparerCompare(item1, item2: TBoldElement): Integer; procedure NameComparerSubscribe(boldElement: TBoldElement; subscriber: TBoldSubscriber); - procedure NegativeRedRendererHoldsChangedValue(element: TBoldElement; representation: Integer; Expression: String; Subscriber: TBoldSubscriber); - procedure NegativeRedRendererSetFont(element: TBoldElement; aFont: TFont; representation: Integer; Expression: String); function IsRichFilterFilter(element: TBoldElement): Boolean; procedure IsRichFilterSubscribe(element: TBoldElement; subscriber: TBoldSubscriber); procedure BoldPlaceableAFP1GetFormClass(Element: TBoldElement; var Result: TFormClass); procedure BoldPlaceableAFP1RetrieveHandle(Form: TForm; var Result: TBoldReferenceHandle); + function IsRichRendererGetAsCheckBoxState( + aFollower: TBoldFollower): TCheckBoxState; + procedure IsRichRendererSubscribe(aFollower: TBoldFollower; + Subscriber: TBoldSubscriber); + procedure NegativeRedRendererSetFont(aFollower: TBoldFollower; + AFont: TFont); + function IsRichRendererMayModify(aFollower: TBoldFollower): Boolean; private { Private declarations } public @@ -77,19 +93,6 @@ implementation {$R *.DFM} -function TDataModule1.IsRichRendererGetAsCheckBoxState( - element: TBoldElement; representation: Integer; - Expression: String): TCheckBoxState; -begin - result := cbGrayed; - if element is TPerson then - begin - if TPerson(element).Assets > 10000 then - Result := cbChecked - else - Result := cbUnChecked - end; -end; function TDataModule1.NameComparerCompare(item1, item2: TBoldElement): Integer; begin @@ -111,22 +114,12 @@ function TDataModule1.IsRichFilterFilter(element: TBoldElement): Boolean; Result := TPerson(element).Assets > 10000; end; -procedure TDataModule1.NegativeRedRendererHoldsChangedValue( - element: TBoldElement; representation: Integer; - Expression: String; Subscriber: TBoldSubscriber); +procedure TDataModule1.NegativeRedRendererSetFont(aFollower: TBoldFollower; + AFont: TFont); begin - if assigned(element) then - with NegativeRedRenderer do - DefaultHoldsChangedValue(element, representation, Expression, nil, subscriber); -end; - -procedure TDataModule1.NegativeRedRendererSetFont( - element: TBoldElement; aFont: TFont; representation: Integer; - Expression: String); -begin - if Element is TPerson then + if aFollower.Element is TPerson then begin - if TPerson(Element).Assets < 0 then + if TPerson(aFollower.Element).Assets < 0 then aFont.Color := clRed else aFont.Color := clBlue; @@ -138,11 +131,29 @@ procedure TDataModule1.IsRichFilterSubscribe(element: TBoldElement; subscriber: Element.SubscribeToExpression('assets', Subscriber, False); end; -procedure TDataModule1.IsRichRendererSubscribe(Element: TBoldElement; - Representation: Integer; Expression: String; +function TDataModule1.IsRichRendererGetAsCheckBoxState( + aFollower: TBoldFollower): TCheckBoxState; +begin + result := cbGrayed; + if aFollower.element is TPerson then + begin + if TPerson(aFollower.element).Assets > 10000 then + Result := cbChecked + else + Result := cbUnChecked + end; +end; + +function TDataModule1.IsRichRendererMayModify( + aFollower: TBoldFollower): Boolean; +begin + result := false; +end; + +procedure TDataModule1.IsRichRendererSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); begin - Element.SubscribeToExpression('assets', Subscriber, False); + aFollower.Element.SubscribeToExpression('assets', Subscriber, False); end; procedure TDataModule1.BoldPlaceableAFP1GetFormClass(Element: TBoldElement; var Result: TFormClass); @@ -156,7 +167,10 @@ procedure TDataModule1.BoldPlaceableAFP1GetFormClass(Element: TBoldElement; var procedure TDataModule1.BoldPlaceableAFP1RetrieveHandle(Form: TForm; var Result: TBoldReferenceHandle); begin if form is TPersonAutoForm then - result := TPersonAutoForm(form).brhPerson + begin + result := TPersonAutoForm(form).brhPerson; + TPersonAutoForm(form).BoldFormSaver1.SystemHandle := BoldSystemHandle1; + end else result := nil; end; diff --git a/examples/Delphi/Compound/Building/Mainform.dfm b/examples/Delphi/Compound/Building/Mainform.dfm index 6f049835..d9716d5b 100644 Binary files a/examples/Delphi/Compound/Building/Mainform.dfm and b/examples/Delphi/Compound/Building/Mainform.dfm differ diff --git a/examples/Delphi/Compound/Building/Mainform.pas b/examples/Delphi/Compound/Building/Mainform.pas index a2b8bdf0..fd553d6b 100644 --- a/examples/Delphi/Compound/Building/Mainform.pas +++ b/examples/Delphi/Compound/Building/Mainform.pas @@ -14,7 +14,10 @@ interface ExtCtrls, ComCtrls, Grids, + Actions, ActnList, + Types, + BoldSubscription, BoldElements, BoldSystem, @@ -37,7 +40,15 @@ interface BoldActions, BoldDBActions, BoldAFP, - BoldReferenceHandle, BoldIBDatabaseAction; + BoldFormSaver, + BoldPlaceableSubscriber, + BoldReferenceHandle, + BoldNavigatorDefs, + BoldDebugActions, + BoldUndoActions, + BoldCaptionController, + BoldAction, + BoldFormSaverActions; type Tallform = class(TForm) @@ -54,7 +65,6 @@ Tallform = class(TForm) Label3: TLabel; Label1: TLabel; FirstName: TLabel; - btnUpdateDB: TButton; bedFirstName: TBoldEdit; PersonCount: TBoldEdit; bedPersonHome: TBoldEdit; @@ -80,7 +90,6 @@ Tallform = class(TForm) bsrResidentsTotalAssets: TBoldAsStringRenderer; bsrAddress: TBoldAsStringRenderer; bgrPerson: TBoldGrid; - pbdbNotification: TProgressBar; PageControl1: TPageControl; tabBuilding: TTabSheet; tabResidentialBuilding: TTabSheet; @@ -111,9 +120,63 @@ Tallform = class(TForm) BoldUpdateDBAction1: TBoldUpdateDBAction; HighRentRenderer: TBoldAsStringRenderer; btnCheckpoint: TButton; + BoldCreateDatabaseAction1: TBoldCreateDatabaseAction; + GroupBox2: TGroupBox; btnUnDo: TButton; btnRedo: TButton; - BoldIBDatabaseAction1: TBoldIBDatabaseAction; + GroupBox3: TGroupBox; + BoldFailureDetectionAction1: TBoldFailureDetectionAction; + BoldUndoAction1: TBoldUndoAction; + BoldRedoAction1: TBoldRedoAction; + BoldSystemDebuggerAction1: TBoldSystemDebuggerAction; + BoldNavigator1: TBoldNavigator; + BoldNavigator2: TBoldNavigator; + BoldNavigator3: TBoldNavigator; + StatusBar1: TStatusBar; + MainMenu1: TMainMenu; + Opensystem1: TMenuItem; + CreateDB1: TMenuItem; + Opensystem2: TMenuItem; + UpdateDB1: TMenuItem; + ogglelog1: TMenuItem; + Systemdebugger1: TMenuItem; + Edit1: TMenuItem; + Undo1: TMenuItem; + Redo1: TMenuItem; + BoldModelEditorAction: TAction; + BoldModelEditorAction1: TMenuItem; + Log1: TMenuItem; + BoldLogOCLAction1: TBoldLogOCLAction; + BoldLogSQLAction1: TBoldLogSQLAction; + BoldLogPMAction1: TBoldLogPMAction; + oggleOCLlogs1: TMenuItem; + ogglePMCallslogs1: TMenuItem; + oggleSQLlogs1: TMenuItem; + BoldSetCheckPointAction1: TBoldSetCheckPointAction; + BoldCaptionController1: TBoldCaptionController; + actChargeRent: TBoldAction; + BoldLogFormAction1: TBoldLogFormAction; + BoldDiscardChangesAction1: TBoldDiscardChangesAction; + GroupBox4: TGroupBox; + Button3: TButton; + Button5: TButton; + Discardchanges1: TMenuItem; + pbdbNotification: TProgressBar; + Label8: TLabel; + GroupBox5: TGroupBox; + lbRedo: TListBox; + GroupBox6: TGroupBox; + lbUndo: TListBox; + UndoSubscriber: TBoldPlaceableSubscriber; + BoldLogOSSAction1: TBoldLogOSSAction; + oggleOSStrafficlogs1: TMenuItem; + BoldGenerateSchemaAction1: TBoldGenerateSchemaAction; + BoldValidateDBStructureAction1: TBoldValidateDBStructureAction; + BoldValidateDBDataAction1: TBoldValidateDBDataAction; + BoldEvolveDBAction1: TBoldEvolveDBAction; + EvolveDB1: TMenuItem; + ValidateDBData1: TMenuItem; + ValidateDBStructure1: TMenuItem; procedure newBuildingClick(Sender: TObject); procedure DeleteCurrentObject(Sender: TObject); procedure NewPersonClick(Sender: TObject); @@ -121,32 +184,47 @@ Tallform = class(TForm) procedure SingleItemRemove(Sender: TObject); procedure PopupPopup(Sender: TObject); procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); - procedure ShowInOwnWindow(Sender: TObject); - function bsrRentPerResidentGetAsString(Element: TBoldElement; representation: Integer; Expression: String): string; - function bsrRentPerResidentMayModify(element: TBoldElement; representation: Integer; Expression: String; Subscriber: TBoldSubscriber): Boolean; - function bsrRentPerResidentValidateCharacter(element: TBoldElement; value: String; representation: Integer; Expression: String): Boolean; - function bsrRentPerResidentValidateString(element: TBoldElement; value: String; representation: Integer; Expression: String): Boolean; - procedure bsrRentPerResidentHoldsChangedValue(Element: TBoldElement; representation: Integer; Expression: String; Subscriber: TBoldSubscriber); - procedure bsrRentPerResidentReleaseChangedValue(Element: TBoldElement; representation: Integer; Expression: String; Subscriber: TBoldSubscriber); - procedure bsrRentPerResidentSubscribe(Element: TBoldElement; representation: Integer; Expression: String; Subscriber: TBoldSubscriber); - procedure bsrRentPerResidentSetAsString(Element: TBoldElement; value: string; representation: Integer; Expression: String); procedure rgNameRepresentationClick(Sender: TObject); - procedure btnChargeRentClick(Sender: TObject); procedure CheckBox1Click(Sender: TObject); + procedure ShowInOwnWindow(Sender: TObject); procedure CheckBox1Click(Sender: TObject); procedure CheckBox2Click(Sender: TObject); - - function bsrResidentsTotalAssetsGetAsString(element: TBoldElement; representation: Integer; Expression: String): String; - procedure bsrResidentsTotalAssetsSubscribe(element: TBoldElement; representation: Integer; Expression: String; Subscriber: TBoldSubscriber); - procedure bsrAddressSetColor(element: TBoldElement; var aColor: TColor; representation: Integer; Expression: String); - procedure bsrAddressSetFont(element: TBoldElement; aFont: TFont; representation: Integer; Expression: String); procedure NewBuilding1Click(Sender: TObject); + function bsrRentPerResidentGetAsString(aFollower: TBoldFollower): string; + procedure bsrRentPerResidentHoldsChangedValue(aFollower: TBoldFollower); + function bsrRentPerResidentMayModify(aFollower: TBoldFollower): Boolean; + procedure bsrRentPerResidentReleaseChangedValue(aFollower: TBoldFollower); + procedure bsrRentPerResidentSetAsString(aFollower: TBoldFollower; + const NewValue: string); + procedure rgNameRepresentationClick(Sender: TObject); + procedure bsrRentPerResidentSubscribe(aFollower: TBoldFollower; + Subscriber: TBoldSubscriber); + function bsrRentPerResidentValidateCharacter(aFollower: TBoldFollower; + const Value: string): Boolean; + function bsrRentPerResidentValidateString(aFollower: TBoldFollower; + const Value: string): Boolean; + function bsrResidentsTotalAssetsGetAsString( + aFollower: TBoldFollower): string; + procedure bsrResidentsTotalAssetsSubscribe(aFollower: TBoldFollower; + Subscriber: TBoldSubscriber); + procedure bsrAddressSetColor(aFollower: TBoldFollower; var AColor: TColor); + procedure bsrAddressSetFont(aFollower: TBoldFollower; AFont: TFont); + procedure HighRentRendererSetColor(aFollower: TBoldFollower; + var AColor: TColor); + procedure HighRentRendererSetFont(aFollower: TBoldFollower; AFont: TFont); + procedure CheckBox3Click(Sender: TObject); + procedure BoldModelEditorActionExecute(Sender: TObject); + procedure actChargeRentExecute(Sender: TObject); + procedure FormCreate(Sender: TObject); procedure BoldActivateSystemAction1SystemOpened(Sender: TObject); - procedure HighRentRendererSetColor(Element: TBoldElement; var AColor: TColor; Representation: Integer; Expression: String); - procedure HighRentRendererSetFont(Element: TBoldElement; AFont: TFont; Representation: Integer; Expression: String); - procedure btnCheckpointClick(Sender: TObject); - procedure btnUnDoClick(Sender: TObject); - procedure btnRedoClick(Sender: TObject); + procedure lbUndoDblClick(Sender: TObject); + procedure lbUndoDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; + State: TOwnerDrawState); + procedure UndoSubscriberSubscribeToElement(element: TBoldElement; + Subscriber: TBoldSubscriber); + procedure UndoSubscriberReceive(sender: TBoldPlaceableSubscriber; + Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: Integer); private { Private declarations } function CurrentBuildingHandle: TBoldListHandle; + procedure UpdateUndo; public { Public declarations } end; @@ -160,7 +238,9 @@ implementation BuildingClasses, BoldGUI, PersonAutoFormUnit, - datamod; + datamod, + BoldUndoInterfaces, + BoldUMLModelEdit; {$R *.DFM} @@ -208,6 +288,21 @@ procedure Tallform.SingleItemRemove(Sender: TObject); TBoldObjectReference(BoldHandle.Value).BoldObject := nil; end; +procedure Tallform.UndoSubscriberReceive(sender: TBoldPlaceableSubscriber; + Originator: TObject; OriginalEvent: TBoldEvent; RequestedEvent: Integer); +begin + UpdateUndo; +end; + +procedure Tallform.UndoSubscriberSubscribeToElement(element: TBoldElement; + Subscriber: TBoldSubscriber); +begin + TBoldSystem(Element).UndoHandler.AddSubscription(Subscriber, beUndoChanged, beUndoChanged); + TBoldSystem(Element).UndoHandler.AddSubscription(Subscriber, beUndoBlock, beUndoChanged); + TBoldSystem(Element).UndoHandler.AddSubscription(Subscriber, beRedoBlock, beUndoChanged); + TBoldSystem(Element).UndoHandler.AddSubscription(Subscriber, beUndoSetCheckpoint, beUndoChanged); +end; + procedure Tallform.PopupPopup(Sender: TObject); begin if (sender is TMenuItem) then @@ -230,6 +325,12 @@ procedure Tallform.FormCloseQuery(Sender: TObject; var CanClose: Boolean); Canclose := False; end; +procedure Tallform.FormCreate(Sender: TObject); +begin + Randomize; + BoldCaptionController1.TrackControl := self; +end; + procedure Tallform.ShowInOwnWindow(Sender: TObject); var BoldObject: TBoldObject; @@ -248,12 +349,11 @@ procedure Tallform.ShowInOwnWindow(Sender: TObject); end; function Tallform.bsrRentPerResidentGetAsString( - Element: TBoldElement; representation: Integer; - Expression: String): string; + aFollower: TBoldFollower): string; begin result := ''; - if element is TResidential_Building then - with TResidential_Building(Element) do + if AFollower.element is TResidential_Building then + with TResidential_Building(AFollower.Element) do if M_TotalRent.IsNull then Result := '***' else if Residents.Count = 0 then @@ -263,45 +363,49 @@ function Tallform.bsrRentPerResidentGetAsString( end; procedure Tallform.bsrRentPerResidentHoldsChangedValue( - Element: TBoldElement; representation: Integer; Expression: String; - subscriber: TBoldsubscriber); + aFollower: TBoldFollower); begin - if element is TResidential_Building then - TResidential_Building(Element).M_TotalRent.RegisterModifiedValueHolder(subscriber); + if AFollower.element is TResidential_Building then + TResidential_Building(AFollower.Element).M_TotalRent.RegisterModifiedValueHolder(AFollower.subscriber); end; -procedure Tallform.bsrRentPerResidentReleaseChangedValue( - Element: TBoldElement; representation: Integer; Expression: String; - subscriber: TBoldSubscriber); +function Tallform.bsrRentPerResidentMayModify( + aFollower: TBoldFollower): Boolean; begin - if element is TResidential_Building then - TResidential_Building(Element).M_TotalRent.UnRegisterModifiedValueHolder(Subscriber); + Result := False; + if AFollower.element is TResidential_Building then + Result := TResidential_Building(AFollower.element).Residents.Count > 0; end; -procedure Tallform.bsrRentPerResidentSubscribe( - Element: TBoldElement; representation: Integer; Expression: String; - Subscriber: TBoldSubscriber); +procedure Tallform.bsrRentPerResidentReleaseChangedValue( + aFollower: TBoldFollower); begin - if element is TResidential_Building then - with Element do - begin - SubscribeToExpression('totalRent', Subscriber, False); - SubscribeToExpression('residents', Subscriber, False); - end; + if AFollower.element is TResidential_Building then + TResidential_Building(AFollower.Element).M_TotalRent.UnRegisterModifiedValueHolder(AFollower.Subscriber); end; -procedure Tallform.bsrRentPerResidentSetAsString( - Element: TBoldElement; value: string; representation: Integer; - Expression: String); +procedure Tallform.bsrRentPerResidentSetAsString(aFollower: TBoldFollower; + const NewValue: string); var v: string; begin - v := value; {avoid name clash} - if element is TResidential_Building then - with TResidential_Building(Element) do + v := NewValue; {avoid name clash} + if aFollower.element is TResidential_Building then + with TResidential_Building(aFollower.Element) do TotalRent := StrToCurr(v) * Residents.Count; end; +procedure Tallform.bsrRentPerResidentSubscribe(aFollower: TBoldFollower; + Subscriber: TBoldSubscriber); +begin + if AFollower.element is TResidential_Building then + with AFollower.Element do + begin + SubscribeToExpression('totalRent', Subscriber, False); + SubscribeToExpression('residents', Subscriber, False); + end; +end; + procedure Tallform.rgNameRepresentationClick(Sender: TObject); begin with blbBuildingOwners.BoldRowProperties do @@ -312,12 +416,6 @@ procedure Tallform.rgNameRepresentationClick(Sender: TObject); end; end; -procedure Tallform.btnChargeRentClick(Sender: TObject); -begin - if blhAllResidentialBuilding.CurrentBoldObject is TResidential_Building then - TResidential_Building(blhAllResidentialBuilding.CurrentBoldObject).ChargeRent; -end; - procedure Tallform.CheckBox1Click(Sender: TObject); begin if CheckBox1.Checked then @@ -334,25 +432,19 @@ procedure Tallform.CheckBox2Click(Sender: TObject); blhAllPerson.BoldComparer := nil; end; -function Tallform.bsrRentPerResidentMayModify( - element: TBoldElement; representation: Integer; - Expression: String; Subscriber: TBoldSubscriber): Boolean; +procedure Tallform.CheckBox3Click(Sender: TObject); begin - Result := False; - if element is TResidential_Building then - Result := TResidential_Building(element).Residents.Count > 0; + datamodule1.BoldSystemHandle1.System.UndoHandlerInterface.Enabled := (Sender as TCheckBox).Checked; end; -function Tallform.bsrRentPerResidentValidateCharacter( - element: TBoldElement; value: String; representation: Integer; - Expression: String): Boolean; +function Tallform.bsrRentPerResidentValidateCharacter(aFollower: TBoldFollower; + const Value: string): Boolean; begin - Result := value[1] in ['0'..'9', '-', '+', 'e', 'E', DecimalSeparator]; + Result := value[1] in ['0'..'9', '-', '+', 'e', 'E', FormatSettings.DecimalSeparator]; end; -function Tallform.bsrRentPerResidentValidateString( - element: TBoldElement; value: String; representation: Integer; - Expression: String): Boolean; +function Tallform.bsrRentPerResidentValidateString(aFollower: TBoldFollower; + const Value: string): Boolean; begin try StrToCurr(value); @@ -363,28 +455,26 @@ function Tallform.bsrRentPerResidentValidateString( end; function Tallform.bsrResidentsTotalAssetsGetAsString( - element: TBoldElement; representation: Integer; - Expression: String): String; + aFollower: TBoldFollower): string; var i: integer; sum: Currency; begin Sum := 0; - if element is TResidential_Building then - with TResidential_Building(Element) do + if AFollower.element is TResidential_Building then + with TResidential_Building(AFollower.Element) do for i := 0 to Residents.Count - 1 do Sum := Sum + Residents[i].Assets; Result := CurrToStr(Sum); end; -procedure Tallform.bsrResidentsTotalAssetsSubscribe(element: TBoldElement; - representation: Integer; Expression: String; +procedure Tallform.bsrResidentsTotalAssetsSubscribe(aFollower: TBoldFollower; Subscriber: TBoldSubscriber); var i: integer; begin - if element is TResidential_Building then - with TResidential_Building(Element) do + if AFollower.element is TResidential_Building then + with TResidential_Building(AFollower.Element) do begin SubscribeToExpression('residents', subscriber, true); for i := 0 to Residents.Count - 1 do @@ -392,23 +482,56 @@ procedure Tallform.bsrResidentsTotalAssetsSubscribe(element: TBoldElement; end; end; -procedure Tallform.bsrAddressSetColor( - element: TBoldElement; var aColor: TColor; representation: Integer; - Expression: String); +procedure Tallform.UpdateUndo; +var + i: integer; +begin + if not datamodule1.BoldSystemHandle1.Active then + exit; + if not datamodule1.BoldSystemHandle1.System.UndoHandlerInterface.Enabled then + exit; + lbUndo.Items.BeginUpdate; + lbUndo.Items.Clear; + lbRedo.Items.BeginUpdate; + lbRedo.Items.Clear; + with datamodule1.BoldSystemHandle1.System.UndoHandlerInterface do + try + for I := 0 to UndoList.Count-1 do + lbUndo.Items.Add(TimeToStr(UndoList[i].Created) + ':'+ UndoList[i].Name {+ ' ' + UndoList[i].Content}); + lbUndo.ItemIndex := i; + for I := 0 to RedoList.Count-1 do + lbRedo.Items.Add(TimeToStr(RedoList[i].Created) + ':'+ RedoList[i].Name {+ ' ' + RedoList[i].Content}); + finally + lbUndo.Items.EndUpdate; + lbRedo.Items.EndUpdate; + end; +end; + +procedure Tallform.BoldActivateSystemAction1SystemOpened(Sender: TObject); +begin + datamodule1.BoldSystemHandle1.System.UndoHandlerInterface.Enabled := true; +end; + +procedure Tallform.BoldModelEditorActionExecute(Sender: TObject); begin - if Assigned(element) then - with TBuilding(element) do + BoldUMLModelEdit.UMLModelEditor.ShowEditFormForBoldModel(DataModule1.BoldModel1); +end; + +procedure Tallform.bsrAddressSetColor(aFollower: TBoldFollower; + var AColor: TColor); +begin + if Assigned(AFollower.element) then + with TBuilding(AFollower.element) do begin if Pos('Bold', Address) > 0 then aColor := clAqua; end; end; -procedure Tallform.bsrAddressSetFont(element: TBoldElement; - aFont: TFont; representation: Integer; Expression: String); +procedure Tallform.bsrAddressSetFont(aFollower: TBoldFollower; AFont: TFont); begin - if Assigned(element) then - with TBuilding(element).M_Address do + if Assigned(AFollower.element) then + with TBuilding(AFollower.element).M_Address do begin if Pos( 'Bold', AsString ) > 0 then aFont.Style := aFont.Style + [fsBold]; @@ -432,48 +555,62 @@ function Tallform.CurrentBuildingHandle: TBoldListHandle; result := blhAllResidentialBuilding; end; -procedure Tallform.BoldActivateSystemAction1SystemOpened(Sender: TObject); +procedure Tallform.actChargeRentExecute(Sender: TObject); begin - Randomize; + if blhAllResidentialBuilding.CurrentBoldObject is TResidential_Building then + TResidential_Building(blhAllResidentialBuilding.CurrentBoldObject).ChargeRent; end; -procedure Tallform.HighRentRendererSetColor(Element: TBoldElement; - var AColor: TColor; Representation: Integer; Expression: String); +procedure Tallform.HighRentRendererSetColor(aFollower: TBoldFollower; + var AColor: TColor); begin - if element is TResidential_Building then + if AFollower.element is TResidential_Building then begin - if (TResidential_Building(element).totalRent) >= 1500 then + if (TResidential_Building(AFollower.element).totalRent) >= 1500 then aColor := clSilver else aColor := clWhite; end; end; -procedure Tallform.HighRentRendererSetFont(Element: TBoldElement; - AFont: TFont; Representation: Integer; Expression: String); +procedure Tallform.HighRentRendererSetFont(aFollower: TBoldFollower; + AFont: TFont); begin - if element is TResidential_Building then + if aFollower.element is TResidential_Building then begin - if (TResidential_Building(element).totalRent) >= 1500 then + if (TResidential_Building(aFollower.element).totalRent) >= 1500 then AFont.Color := clRed else AFont.Color := clWindowText; end; end; -procedure Tallform.btnCheckpointClick(Sender: TObject); -begin - datamodule1.BoldSystemHandle1.System.UndoHandlerInterface.SetCheckPoint; -end; - -procedure Tallform.btnUnDoClick(Sender: TObject); +procedure Tallform.lbUndoDblClick(Sender: TObject); +var + blockName: string; + i: integer; begin - datamodule1.BoldSystemHandle1.System.UndoHandlerInterface.UnDoLatest; + blockName := lbUndo.Items[lbUndo.ItemIndex]; + i := datamodule1.BoldSystemHandle1.System.UndoHandlerInterface.UndoList.IndexOf(blockName); + if i <> -1 then + datamodule1.BoldSystemHandle1.System.UndoHandlerInterface.UndoBlock(blockname) + else + begin + i := datamodule1.BoldSystemHandle1.System.UndoHandlerInterface.RedoList.IndexOf(blockName); + if i <> -1 then + datamodule1.BoldSystemHandle1.System.UndoHandlerInterface.RedoBlock(blockname); + end; end; -procedure Tallform.btnRedoClick(Sender: TObject); +procedure Tallform.lbUndoDrawItem(Control: TWinControl; Index: Integer; + Rect: TRect; State: TOwnerDrawState); begin - datamodule1.BoldSystemHandle1.System.UndoHandlerInterface.Redolatest; + with (Control as TListBox) do + begin + if index = ItemIndex then + Canvas.Font.Color := clRed; + Canvas.TextOut(Rect.Left, Rect.Top, (Control as TListBox).Items[Index]); + end; end; end. diff --git a/examples/Delphi/Compound/Building/PersonAutoFormUnit.dfm b/examples/Delphi/Compound/Building/PersonAutoFormUnit.dfm index 6092292b..935b89ab 100644 --- a/examples/Delphi/Compound/Building/PersonAutoFormUnit.dfm +++ b/examples/Delphi/Compound/Building/PersonAutoFormUnit.dfm @@ -1,9 +1,9 @@ object PersonAutoForm: TPersonAutoForm Left = 31 Top = 96 - Width = 323 - Height = 419 Caption = 'Person Detail' + ClientHeight = 559 + ClientWidth = 267 Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText @@ -12,6 +12,7 @@ object PersonAutoForm: TPersonAutoForm Font.Style = [] OldCreateOrder = False Position = poScreenCenter + OnCreate = FormCreate PixelsPerInch = 96 TextHeight = 13 object Label1: TLabel @@ -35,16 +36,9 @@ object PersonAutoForm: TPersonAutoForm Height = 13 Caption = 'Assets' end - object Label3: TLabel - Left = 9 - Top = 116 - Width = 82 - Height = 13 - Caption = 'Owned Buildings:' - end object Label5: TLabel Left = 8 - Top = 272 + Top = 346 Width = 214 Height = 26 Caption = @@ -52,6 +46,20 @@ object PersonAutoForm: TPersonAutoForm 'module' WordWrap = True end + object Label3: TLabel + Left = 9 + Top = 116 + Width = 82 + Height = 13 + Caption = 'Owned Buildings:' + end + object Label6: TLabel + Left = 8 + Top = 269 + Width = 31 + Height = 13 + Caption = 'Home:' + end object BoldEdit1: TBoldEdit Left = 8 Top = 67 @@ -126,15 +134,16 @@ object PersonAutoForm: TPersonAutoForm BoldAutoColumns = True BoldShowConstraints = False BoldHandle = blhOwnedBuildings - BoldProperties.NilElementMode = neNone Columns = < item + BoldProperties.Expression = '' Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] + LookUpProperties.Expression = '' end item BoldProperties.Expression = 'zipCode' @@ -144,6 +153,7 @@ object PersonAutoForm: TPersonAutoForm Font.Name = 'MS Sans Serif' Font.Style = [] Title.Caption = 'ZipCode' + LookUpProperties.Expression = '' end item BoldProperties.Expression = 'address' @@ -153,6 +163,7 @@ object PersonAutoForm: TPersonAutoForm Font.Name = 'MS Sans Serif' Font.Style = [] Title.Caption = 'Address' + LookUpProperties.Expression = '' end item BoldProperties.Expression = 'owners->size' @@ -162,9 +173,16 @@ object PersonAutoForm: TPersonAutoForm Font.Name = 'MS Sans Serif' Font.Style = [] Title.Caption = '# owners' + LookUpProperties.Expression = '' end> DefaultRowHeight = 17 EnableColAdjust = False + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False TabOrder = 4 TitleFont.Charset = DEFAULT_CHARSET TitleFont.Color = clWindowText @@ -177,6 +195,93 @@ object PersonAutoForm: TPersonAutoForm 64 64) end + object BoldComboBox1: TBoldComboBox + Left = 8 + Top = 288 + Width = 249 + Height = 21 + Alignment = taLeftJustify + BoldHandle = brhPerson + BoldListHandle = blhOwnedResidentialBuildings + BoldProperties.Expression = 'home' + BoldRowProperties.Expression = '' + BoldSetValueExpression = 'home' + BoldSelectChangeAction = bdcsSetValue + TabOrder = 5 + end + object BoldGrid1: TBoldGrid + Left = 8 + Top = 400 + Width = 249 + Height = 120 + AddNewAtEnd = False + BoldAutoColumns = False + BoldShowConstraints = False + BoldHandle = BoldCursorHandle1 + Columns = < + item + BoldProperties.Expression = '' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + LookUpProperties.Expression = '' + end + item + BoldProperties.Expression = '' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + LookUpProperties.Expression = '' + end> + DefaultRowHeight = 17 + EnableColAdjust = False + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 6 + TitleFont.Charset = DEFAULT_CHARSET + TitleFont.Color = clWindowText + TitleFont.Height = -11 + TitleFont.Name = 'Tahoma' + TitleFont.Style = [] + ColWidths = ( + 17 + 64) + end + object Button1: TButton + Left = 8 + Top = 526 + Width = 75 + Height = 25 + Action = BoldFormSaverApplyAction1 + TabOrder = 7 + end + object Button2: TButton + Left = 94 + Top = 526 + Width = 75 + Height = 25 + Action = BoldFormSaverOkAction1 + Default = True + TabOrder = 8 + end + object Button3: TButton + Left = 182 + Top = 526 + Width = 75 + Height = 25 + Action = BoldFormSaverCancelAction1 + Cancel = True + TabOrder = 9 + end object brhPerson: TBoldReferenceHandle StaticSystemHandle = DataModule1.BoldSystemHandle1 StaticValueTypeName = 'Person' @@ -191,4 +296,47 @@ object PersonAutoForm: TPersonAutoForm Left = 24 Top = 168 end + object BoldCaptionController1: TBoldCaptionController + BoldHandle = brhPerson + BoldProperties.Expression = 'name' + Left = 160 + Top = 184 + end + object blhOwnedResidentialBuildings: TBoldListHandle + RootHandle = brhPerson + Expression = 'ownedBuildings->filterOnType(Residential_Building)' + Left = 24 + Top = 240 + end + object BoldFormSaver1: TBoldFormSaver + OnlyFirstDirty = False + Left = 208 + Top = 96 + end + object BoldCursorHandle1: TBoldCursorHandle + RootHandle = BoldFormSaver1 + Left = 120 + Top = 456 + end + object ActionList1: TActionList + Left = 208 + Top = 432 + object BoldFormSaverApplyAction1: TBoldFormSaverApplyAction + Category = 'Bold Actions' + Caption = '&Apply' + ShortCut = 16474 + BoldFormSaver = BoldFormSaver1 + end + object BoldFormSaverCancelAction1: TBoldFormSaverCancelAction + Category = 'Bold Actions' + Caption = '&Cancel' + BoldFormSaver = BoldFormSaver1 + end + object BoldFormSaverOkAction1: TBoldFormSaverOkAction + Category = 'Bold Actions' + Caption = '&Ok' + ShortCut = 16474 + BoldFormSaver = BoldFormSaver1 + end + end end diff --git a/examples/Delphi/Compound/Building/PersonAutoFormUnit.pas b/examples/Delphi/Compound/Building/PersonAutoFormUnit.pas index d3552ba0..4149dfe0 100644 --- a/examples/Delphi/Compound/Building/PersonAutoFormUnit.pas +++ b/examples/Delphi/Compound/Building/PersonAutoFormUnit.pas @@ -18,14 +18,14 @@ interface BoldGrid, StdCtrls, BoldCheckBox, - BoldEdit; + BoldEdit, BoldCaptionController, BoldComboBox, BoldFormSaver, + BoldFormSaverActions, System.Actions, Vcl.ActnList, BoldHandleAction; type TPersonAutoForm = class(TForm) Label1: TLabel; Label2: TLabel; Label4: TLabel; - Label3: TLabel; BoldEdit1: TBoldEdit; beFirstName: TBoldEdit; BoldEdit7: TBoldEdit; @@ -34,7 +34,23 @@ TPersonAutoForm = class(TForm) brhPerson: TBoldReferenceHandle; blhOwnedBuildings: TBoldListHandle; Label5: TLabel; + BoldCaptionController1: TBoldCaptionController; + BoldComboBox1: TBoldComboBox; + Label3: TLabel; + Label6: TLabel; + blhOwnedResidentialBuildings: TBoldListHandle; + BoldFormSaver1: TBoldFormSaver; + BoldGrid1: TBoldGrid; + BoldCursorHandle1: TBoldCursorHandle; + Button1: TButton; + Button2: TButton; + Button3: TButton; + ActionList1: TActionList; + BoldFormSaverApplyAction1: TBoldFormSaverApplyAction; + BoldFormSaverCancelAction1: TBoldFormSaverCancelAction; + BoldFormSaverOkAction1: TBoldFormSaverOkAction; procedure brhPersonObjectDeleted(Sender: TObject); + procedure FormCreate(Sender: TObject); private { Private declarations } public @@ -51,4 +67,10 @@ procedure TPersonAutoForm.brhPersonObjectDeleted(Sender: TObject); TForm(TComponent(Sender).Owner).Release; end; +procedure TPersonAutoForm.FormCreate(Sender: TObject); +begin + // Links the form caption to person name + BoldCaptionController1.TrackControl := self; +end; + end. diff --git a/examples/Delphi/Compound/Building/ResidentialBuilding.inc b/examples/Delphi/Compound/Building/ResidentialBuilding.inc index 97f92971..532e74d1 100644 --- a/examples/Delphi/Compound/Building/ResidentialBuilding.inc +++ b/examples/Delphi/Compound/Building/ResidentialBuilding.inc @@ -15,12 +15,13 @@ procedure TResidential_Building.ChargeRent; var O, R: Integer; begin + if Residents.Count = 0 then raise Exception.Create('No residents to pay rent'); if Owners.Count = 0 then raise Exception.Create('No owners to receive payment'); - + for R := Residents.Count - 1 downto 0 do with Residents[R] do begin @@ -43,6 +44,7 @@ begin inherited; Address := IntToStr(Random(250)) + ' ' + streets[random(5)]; TotalRent := random(100) * 100; + Capacity := random(20); end; diff --git a/examples/Delphi/Simple/ObjectSpace/CustomAttributes/Readme.txt b/examples/Delphi/Simple/ObjectSpace/CustomAttributes/Readme.txt index 63b5b492..cd957454 100644 --- a/examples/Delphi/Simple/ObjectSpace/CustomAttributes/Readme.txt +++ b/examples/Delphi/Simple/ObjectSpace/CustomAttributes/Readme.txt @@ -1,4 +1,4 @@ -Contents of the Sample Attriubtes directory +Contents of the Sample Attributes directory ---------------------------------------- This directory contains a few sample attribute classes.