Server : Apache/2.4.6 (CentOS) OpenSSL/1.0.2k-fips PHP/7.4.20 System : Linux st2.domain.com 3.10.0-1127.10.1.el7.x86_64 #1 SMP Wed Jun 3 14:28:03 UTC 2020 x86_64 User : apache ( 48) PHP Version : 7.4.20 Disable Function : NONE Directory : /opt/libreoffice6.4/share/basic/Access2Base/ |
<?xml version="1.0" encoding="UTF-8"?> <!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd"> <script:module xmlns:script="http://openoffice.org/2000/script" script:name="DataDef" script:language="StarBasic"> REM ======================================================================================================================= REM === The Access2Base library is a part of the LibreOffice project. === REM === Full documentation is available on http://www.access2base.com === REM ======================================================================================================================= Option Compatible Option ClassModule Option Explicit REM ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS ROOT FIELDS --- REM ----------------------------------------------------------------------------------------------------------------------- Private _Type As String ' Must be TABLEDEF or QUERYDEF Private _This As Object ' Workaround for absence of This builtin function Private _Parent As Object Private _Name As String ' For tables: [[Catalog.]Schema.]Table Private _ParentDatabase As Object Private _ReadOnly As Boolean Private Table As Object ' com.sun.star.sdb.dbaccess.ODBTable Private CatalogName As String Private SchemaName As String Private TableName As String Private Query As Object ' com.sun.star.sdb.dbaccess.OQuery Private TableDescriptor As Object ' com.sun.star.sdb.dbaccess.ODBTable Private TableFieldsCount As Integer Private TableKeysCount As Integer REM ----------------------------------------------------------------------------------------------------------------------- REM --- CONSTRUCTORS / DESTRUCTORS --- REM ----------------------------------------------------------------------------------------------------------------------- Private Sub Class_Initialize() _Type = "" Set _This = Nothing Set _Parent = Nothing _Name = "" Set _ParentDatabase = Nothing _ReadOnly = False Set Table = Nothing CatalogName = "" SchemaName = "" TableName = "" Set Query = Nothing Set TableDescriptor = Nothing TableFieldsCount = 0 TableKeysCount = 0 End Sub ' Constructor REM ----------------------------------------------------------------------------------------------------------------------- Private Sub Class_Terminate() On Local Error Resume Next Call Class_Initialize() End Sub ' Destructor REM ----------------------------------------------------------------------------------------------------------------------- Public Sub Dispose() Call Class_Terminate() End Sub ' Explicit destructor REM ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS GET/LET/SET PROPERTIES --- REM ----------------------------------------------------------------------------------------------------------------------- Property Get Name() As String Name = _PropertyGet("Name") End Property ' Name (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get ObjectType() As String ObjectType = _PropertyGet("ObjectType") End Property ' ObjectType (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get SQL() As Variant SQL = _PropertyGet("SQL") End Property ' SQL (get) Property Let SQL(ByVal pvValue As Variant) Call _PropertySet("SQL", pvValue) End Property ' SQL (set) REM ----------------------------------------------------------------------------------------------------------------------- Public Function pType() As Integer pType = _PropertyGet("Type") End Function ' Type (get) REM ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS METHODS --- REM ----------------------------------------------------------------------------------------------------------------------- Public Function CreateField(ByVal Optional pvFieldName As Variant _ , ByVal optional pvType As Variant _ , ByVal optional pvSize As Variant _ , ByVal optional pvAttributes As variant _ ) As Object 'Return a Field object Const cstThisSub = "TableDef.CreateField" Utils._SetCalledSub(cstThisSub) If _ErrorHandler() Then On Local Error Goto Error_Function Dim oTable As Object, oNewField As Object, oKeys As Object, oPrimaryKey As Object, oColumn As Object Const cstMaxKeyLength = 30 CreateField = Nothing If _ParentDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable If IsMissing(pvFieldName) Then Call _TraceArguments() If Not Utils._CheckArgument(pvFieldName, 1, vbString) Then Goto Exit_Function If pvFieldName = "" Then Call _TraceArguments() If IsMissing(pvType) Then Call _TraceArguments() If Not Utils._CheckArgument(pvType, 1, Utils._AddNumeric( _ dbInteger, dbLong, dbBigInt, dbFloat, vbSingle, dbDouble _ , dbNumeric, dbDecimal, dbText, dbChar, dbMemo _ , dbDate, dbTime, dbTimeStamp _ , dbBinary, dbVarBinary, dbLongBinary, dbBoolean _ )) Then Goto Exit_Function If IsMissing(pvSize) Then pvSize = 0 If pvSize < 0 Then pvSize = 0 If Not Utils._CheckArgument(pvSize, 1, Utils._AddNumeric()) Then Goto Exit_Function If IsMissing(pvAttributes) Then pvAttributes = 0 If Not Utils._CheckArgument(pvAttributes, 1, Utils._AddNumeric(), Array(0, dbAutoIncrField)) Then Goto Exit_Function If _Type <> OBJTABLEDEF Then Goto Error_NotApplicable If IsNull(Table) And IsNull(TableDescriptor) Then Goto Error_NotApplicable If _ReadOnly Then Goto Error_NoUpdate Set oNewField = New Field With oNewField ._This = oNewField ._Name = pvFieldName ._ParentName = _Name ._ParentType = OBJTABLEDEF If IsNull(Table) Then Set oTable = TableDescriptor Else Set oTable = Table Set .Column = oTable.Columns.createDataDescriptor() End With With oNewField.Column .Name = pvFieldName Select Case pvType Case dbInteger : .Type = com.sun.star.sdbc.DataType.TINYINT Case dbLong : .Type = com.sun.star.sdbc.DataType.INTEGER Case dbBigInt : .Type = com.sun.star.sdbc.DataType.BIGINT Case dbFloat : .Type = com.sun.star.sdbc.DataType.FLOAT Case dbSingle : .Type = com.sun.star.sdbc.DataType.REAL Case dbDouble : .Type = com.sun.star.sdbc.DataType.DOUBLE Case dbNumeric, dbCurrency : .Type = com.sun.star.sdbc.DataType.NUMERIC Case dbDecimal : .Type = com.sun.star.sdbc.DataType.DECIMAL Case dbText : .Type = com.sun.star.sdbc.DataType.CHAR Case dbChar : .Type = com.sun.star.sdbc.DataType.VARCHAR Case dbMemo : .Type = com.sun.star.sdbc.DataType.LONGVARCHAR Case dbDate : .Type = com.sun.star.sdbc.DataType.DATE Case dbTime : .Type = com.sun.star.sdbc.DataType.TIME Case dbTimeStamp : .Type = com.sun.star.sdbc.DataType.TIMESTAMP Case dbBinary : .Type = com.sun.star.sdbc.DataType.BINARY Case dbVarBinary : .Type = com.sun.star.sdbc.DataType.VARBINARY Case dbLongBinary : .Type = com.sun.star.sdbc.DataType.LONGVARBINARY Case dbBoolean : .Type = com.sun.star.sdbc.DataType.BOOLEAN End Select .Precision = Int(pvSize) If pvType = dbNumeric Or pvType = dbDecimal Or pvType = dbCurrency Then .Scale = Int(pvSize * 10) - Int(pvSize) * 10 .IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE If Utils._hasUNOProperty(oNewField.Column, "CatalogName") Then .CatalogName = CatalogName If Utils._hasUNOProperty(oNewField.Column, "SchemaName") Then .SchemaName = SchemaName If Utils._hasUNOProperty(oNewField.Column, "TableName") Then .TableName = TableName If Not IsNull(TableDescriptor) Then TableFieldsCount = TableFieldsCount + 1 If pvAttributes = dbAutoIncrField Then If Not IsNull(Table) Then Goto Error_Sequence ' Do not accept adding an AutoValue field when table exists Set oKeys = oTable.Keys Set oPrimaryKey = oKeys.createDataDescriptor() Set oColumn = oPrimaryKey.Columns.createDataDescriptor() oColumn.Name = pvFieldName oColumn.CatalogName = CatalogName oColumn.SchemaName = SchemaName oColumn.TableName = TableName oColumn.IsAutoIncrement = True oColumn.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS oPrimaryKey.Columns.appendByDescriptor(oColumn) oPrimaryKey.Name = Left("PK_" & Join(Split(TableName, " "), "_") & "_" & Join(Split(pvFieldName, " "), "_"), cstMaxKeyLength) oPrimaryKey.Type = com.sun.star.sdbcx.KeyType.PRIMARY oKeys.appendByDescriptor(oPrimaryKey) .IsAutoIncrement = True .IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS oColumn.dispose() Else .IsAutoIncrement = False End If End With oTable.Columns.appendByDescriptor(oNewfield.Column) Set CreateField = oNewField Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function Error_NotApplicable: TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) Goto Exit_Function Error_Sequence: TraceError(TRACEFATAL, ERRFIELDCREATION, Utils._CalledSub(), 0, 1, pvFieldName) Goto Exit_Function Error_NoUpdate: TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) Goto Exit_Function End Function ' CreateField V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function Execute(ByVal Optional pvOptions As Variant) As Boolean 'Execute a stored query. The query must be an ACTION query. Dim cstThisSub As String cstThisSub = Utils._PCase(_Type) & ".Execute" Utils._SetCalledSub(cstThisSub) On Local Error Goto Error_Function Const cstNull = -1 Execute = False If _Type <> OBJQUERYDEF Then Goto Trace_Method If IsMissing(pvOptions) Then pvOptions = cstNull Else If Not Utils._CheckArgument(pvOptions, 1, Utils._AddNumeric(), dbSQLPassThrough) Then Goto Exit_Function End If 'Check action query Dim oStatement As Object, vResult As Variant Dim iType As Integer, sSql As String iType = pType If ( (iType And DBQAction) = 0 ) And ( (iType And DBQDDL) = 0 ) Then Goto Trace_Action 'Execute action query Set oStatement = _ParentDatabase.Connection.createStatement() sSql = Query.Command If pvOptions = dbSQLPassThrough Then oStatement.EscapeProcessing = False _ Else oStatement.EscapeProcessing = Query.EscapeProcessing On Local Error Goto SQL_Error vResult = oStatement.executeUpdate(_ParentDatabase._ReplaceSquareBrackets(sSql)) On Local Error Goto Error_Function Execute = True Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Trace_Method: TraceError(TRACEFATAL, ERRMETHOD, cstThisSub, 0, , cstThisSub) Goto Exit_Function Trace_Action: TraceError(TRACEFATAL, ERRNOTACTIONQUERY, cstThisSub, 0, , _Name) Goto Exit_Function SQL_Error: TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , sSql) Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function End Function ' Execute V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function Fields(ByVal Optional pvIndex As variant) As Object If _ErrorHandler() Then On Local Error Goto Error_Function Dim cstThisSub As String cstThisSub = Utils._PCase(_Type) & ".Fields" Utils._SetCalledSub(cstThisSub) Set Fields = Nothing If Not IsMissing(pvIndex) Then If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function End If Dim sObjects() As String, sObjectName As String, oObject As Object Dim i As Integer, bFound As Boolean, oFields As Object If _Type = OBJTABLEDEF Then Set oFields = Table.getColumns() Else Set oFields = Query.getColumns() sObjects = oFields.ElementNames() Select Case True Case IsMissing(pvIndex) Set oObject = New Collect Set oObject._This = oObject oObject._CollType = COLLFIELDS Set oObject._Parent = _This oObject._Count = UBound(sObjects) + 1 Goto Exit_Function Case VarType(pvIndex) = vbString bFound = False ' Check existence of object and find its exact (case-sensitive) name For i = 0 To UBound(sObjects) If UCase(pvIndex) = UCase(sObjects(i)) Then sObjectName = sObjects(i) bFound = True Exit For End If Next i If Not bFound Then Goto Trace_NotFound Case Else ' pvIndex is numeric If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError sObjectName = sObjects(pvIndex) End Select Set oObject = New Field Set oObject._This = oObject oObject._Name = sObjectName Set oObject.Column = oFields.getByName(sObjectName) oObject._ParentName = _Name oObject._ParentType = _Type Set oObject._ParentDatabase = _ParentDatabase Exit_Function: Set Fields = oObject Set oObject = Nothing Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function Trace_NotFound: TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("FIELD"), pvIndex)) Goto Exit_Function Trace_IndexError: TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) Goto Exit_Function End Function ' Fields REM ----------------------------------------------------------------------------------------------------------------------- Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant ' Return property value of psProperty property name Dim cstThisSub As String cstThisSub = Utils._PCase(_Type) & ".getProperty" Utils._SetCalledSub(cstThisSub) If IsMissing(pvProperty) Then Call _TraceArguments() getProperty = _PropertyGet(pvProperty) Utils._ResetCalledSub(cstThisSub) End Function ' getProperty REM ----------------------------------------------------------------------------------------------------------------------- Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean ' Return True if object has a valid property called pvProperty (case-insensitive comparison !) Dim cstThisSub As String cstThisSub = Utils._PCase(_Type) & ".hasProperty" Utils._SetCalledSub(cstThisSub) If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) Utils._ResetCalledSub(cstThisSub) Exit Function End Function ' hasProperty REM ----------------------------------------------------------------------------------------------------------------------- Public Function OpenRecordset(ByVal Optional pvType As Variant, ByVal Optional pvOptions As Variant, ByVal Optional pvLockEdit As Variant) As Object 'Return a Recordset object based on current table- or querydef object Dim cstThisSub As String cstThisSub = Utils._PCase(_Type) & ".OpenRecordset" Utils._SetCalledSub(cstThisSub) Const cstNull = -1 Dim lCommandType As Long, sCommand As String, oObject As Object,bPassThrough As Boolean Set oObject = Nothing If IsMissing(pvType) Then pvType = cstNull Else If Not Utils._CheckArgument(pvType, 1, Utils._AddNumeric(), Array(cstNull, dbOpenForwardOnly)) Then Goto Exit_Function End If If IsMissing(pvOptions) Then pvOptions = cstNull Else If Not Utils._CheckArgument(pvOptions, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function End If If IsMissing(pvLockEdit) Then pvLockEdit = cstNull Else If Not Utils._CheckArgument(pvLockEdit, 3, Utils._AddNumeric(), Array(cstNull, dbReadOnly)) Then Goto Exit_Function End If Select Case _Type Case OBJTABLEDEF lCommandType = com.sun.star.sdb.CommandType.TABLE sCommand = _Name Case OBJQUERYDEF lCommandType = com.sun.star.sdb.CommandType.QUERY sCommand = _Name If pvOptions = dbSQLPassThrough Then bPassThrough = True Else bPassThrough = Not Query.EscapeProcessing End Select Set oObject = New Recordset With oObject ._CommandType = lCommandType ._Command = sCommand ._ParentName = _Name ._ParentType = _Type ._ForwardOnly = ( pvType = dbOpenForwardOnly ) ._PassThrough = bPassThrough ._ReadOnly = ( (pvLockEdit = dbReadOnly) Or _ReadOnly ) Set ._ParentDatabase = _ParentDatabase Set ._This = oObject Call ._Initialize() End With With _ParentDatabase .RecordsetMax = .RecordsetMax + 1 oObject._Name = Format(.RecordsetMax, "0000000") .RecordsetsColl.Add(oObject, UCase(oObject._Name)) End With If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() ' Do nothing if resultset empty Exit_Function: Set OpenRecordset = oObject Set oObject = Nothing Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) Set oObject = Nothing GoTo Exit_Function End Function ' OpenRecordset V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function Properties(ByVal Optional pvIndex As Variant) As Variant ' Return ' a Collection object if pvIndex absent ' a Property object otherwise Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String Dim cstThisSub As String cstThisSub = Utils._PCase(_Type) & ".Properties" Utils._SetCalledSub(cstThisSub) vPropertiesList = _PropertiesList() sObject = Utils._PCase(_Type) If IsMissing(pvIndex) Then vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) Else vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) End If Set vProperty._ParentDatabase = _ParentDatabase Exit_Function: Set Properties = vProperty Utils._ResetCalledSub(cstThisSub) Exit Function End Function ' Properties REM ----------------------------------------------------------------------------------------------------------------------- Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean ' Return True if property setting OK Dim cstThisSub As String cstThisSub = Utils._PCase(_Type) & ".setProperty" Utils._SetCalledSub(cstThisSub) setProperty = _PropertySet(psProperty, pvValue) Utils._ResetCalledSub(cstThisSub) End Function REM ----------------------------------------------------------------------------------------------------------------------- REM --- PRIVATE FUNCTIONS --- REM ----------------------------------------------------------------------------------------------------------------------- REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertiesList() As Variant Select Case _Type Case OBJTABLEDEF _PropertiesList = Array("Name", "ObjectType") Case OBJQUERYDEF _PropertiesList = Array("Name", "ObjectType", "SQL", "Type") Case Else End Select End Function ' _PropertiesList REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertyGet(ByVal psProperty As String) As Variant ' Return property value of the psProperty property name If _ErrorHandler() Then On Local Error Goto Error_Function Dim cstThisSub As String cstThisSub = Utils._PCase(_Type) Utils._SetCalledSub(cstThisSub & ".get" & psProperty) Dim sSql As String, sVerb As String, iType As Integer _PropertyGet = EMPTY If Not hasProperty(psProperty) Then Goto Trace_Error Select Case UCase(psProperty) Case UCase("Name") _PropertyGet = _Name Case UCase("ObjectType") _PropertyGet = _Type Case UCase("SQL") _PropertyGet = Query.Command Case UCase("Type") iType = 0 sSql = Utils._Trim(UCase(Query.Command)) sVerb = Split(sSql, " ")(0) If sVerb = "SELECT" Then iType = iType + dbQSelect If sVerb = "SELECT" And InStr(sSql, " INTO ") > 0 _ Or sVerb = "CREATE" And InStr(sSql, " TABLE ") > 0 _ Then iType = iType + dbQMakeTable If sVerb = "SELECT" And InStr(sSql, " UNION ") > 0 Then iType = iType + dbQSetOperation If Not Query.EscapeProcessing Then iType = iType + dbQSQLPassThrough If sVerb = "INSERT" Then iType = iType + dbQAppend If sVerb = "DELETE" Then iType = iType + dbQDelete If sVerb = "UPDATE" Then iType = iType + dbQUpdate If sVerb = "CREATE" _ Or sVerb = "ALTER" _ Or sVerb = "DROP" _ Or sVerb = "RENAME" _ Or sVerb = "TRUNCATE" _ Then iType = iType + dbQDDL ' dbQAction implied by dbQMakeTable, dbQAppend, dbQDelete and dbQUpdate ' To check Type use: If (iType And dbQxxx) <> 0 Then ... _PropertyGet = iType Case Else Goto Trace_Error End Select Exit_Function: Utils._ResetCalledSub(cstThisSub & ".get" & psProperty) Exit Function Trace_Error: TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) _PropertyGet = EMPTY Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub & "._PropertyGet", Erl) _PropertyGet = EMPTY GoTo Exit_Function End Function ' _PropertyGet REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean ' Return True if property setting OK If _ErrorHandler() Then On Local Error Goto Error_Function Dim cstThisSub As String cstThisSub = Utils._PCase(_Type) Utils._SetCalledSub(cstThisSub & ".set" & psProperty) 'Execute Dim iArgNr As Integer _PropertySet = True Select Case UCase(_A2B_.CalledSub) Case UCase("setProperty") : iArgNr = 3 Case UCase(cstThisSub & ".setProperty") : iArgNr = 2 Case UCase(cstThisSub & ".set" & psProperty) : iArgNr = 1 End Select If Not hasProperty(psProperty) Then Goto Trace_Error If _ReadOnly Then Goto Error_NoUpdate Select Case UCase(psProperty) Case UCase("SQL") If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value Query.Command = pvValue Case Else Goto Trace_Error End Select Exit_Function: Utils._ResetCalledSub(cstThisSub & ".set" & psProperty) Exit Function Trace_Error: TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) _PropertySet = False Goto Exit_Function Trace_Error_Value: TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) _PropertySet = False Goto Exit_Function Error_NoUpdate: TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub & "._PropertySet", Erl) _PropertySet = False GoTo Exit_Function End Function ' _PropertySet </script:module>