| blob | 67aa32f29c775e9c765dd5fd2a04c22bdd3e1545 |
3 <script:module xmlns:script="http://openoffice.org/2000/script" script:name="SF_Utils" script:language="StarBasic" script:moduleType="normal">REM =======================================================================================================================
4 REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. ===
5 REM === Full documentation is available on https://help.libreoffice.org/ ===
6 REM =======================================================================================================================
8 Option Explicit
9 Option Private Module
11 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
12 ''' SF_Utils
13 ''' ========
14 ''' FOR INTERNAL USE ONLY
15 ''' Groups all private functions used by the official modules
16 ''' Declares the Global variable _SF_
17 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
19 REM ===================================================================== GLOBALS
21 Global _SF_ As Variant ' SF_Root (Basic) object)
23 ''' ScriptForge version
26 ''' Standard symbolic names for VarTypes
36 ''' Additional symbolic names for VarTypes
37 Global Const V_OBJECT = 9
38 Global Const V_BOOLEAN = 11
39 Global Const V_VARIANT = 12
40 Global Const V_BYTE = 17
41 Global Const V_USHORT = 18
42 Global Const V_ULONG = 19
43 Global Const V_BIGINT = 35
44 Global Const V_DECIMAL = 37
45 Global Const V_ARRAY = 8192
48 REM ================================================================== EXCEPTIONS
51 Const ARGUMENTERROR = "ARGUMENTERROR" ' An argument does not pass the _Validate() validation
52 Const ARRAYERROR = "ARRAYERROR" ' An argument does not pass the _ValidateArray() validation
53 Const FILEERROR = "FILEERROR" ' An argument does not pass the _ValidateFile() validation
55 REM =========================================pvA==================== PRIVATE METHODS
57 REM -----------------------------------------------------------------------------
58 Public Function _CDateToIso(pvDate As Variant) As Variant
59 ''' Returns a string representation of the given Basic date
60 ''' Dates as strings are essential in property values, where Basic dates are evil
62 Dim sIsoDate As Variant ' Return value
64 If VarType(pvDate) = V_DATE Then
66 sIsoDate = Right("0" & Hour(pvDate), 2) & ":" & Right("0" & Minute(pvDate), 2) & ":" & Right("0" & Second(pvDate), 2)
68 sIsoDate = Year(pvDate) & "-" & Right("0" & Month(pvDate), 2) & "-" & Right("0" & Day(pvDate), 2)
69 Else
70 sIsoDate = Year(pvDate) & "-" & Right("0" & Month(pvDate), 2) & "-" & Right("0" & Day(pvDate), 2) _
71 & " " & Right("0" & Hour(pvDate), 2) & ":" & Right("0" & Minute(pvDate), 2) _
73 End If
74 Else
75 sIsoDate = pvDate
76 End If
78 _CDateToIso = sIsoDate
80 End Function ' ScriptForge.SF_Utils._CDateToIso
82 REM -----------------------------------------------------------------------------
83 Public Function _CDateToUnoDate(pvDate As Variant) As Variant
84 ''' Returns a UNO com.sun.star.util.DateTime/Date/Time object depending on the given date
85 ''' by using the appropriate CDateToUnoDateXxx builtin function
86 ''' UNO dates are essential in property values, where Basic dates are evil
88 Dim vUnoDate As Variant ' Return value
90 If VarType(pvDate) = V_DATE Then
92 vUnoDate = CDateToUnoTime(pvDate)
93 ElseIf Hour(pvDate) + Minute(pvDate) + Second(pvDate) = 0 Then
94 vUnoDate = CDateToUnoDate(pvDate)
95 Else
96 vUnoDate = CDateToUnoDateTime(pvDate)
97 End If
98 Else
99 vUnoDate = pvDate
100 End If
102 _CDateToUnoDate = vUnoDate
104 End Function ' ScriptForge.SF_Utils._CDateToUnoDate
106 REM -----------------------------------------------------------------------------
107 Public Function _CPropertyValue(ByRef pvValue As Variant) As Variant
108 ''' Set a value of a correct type in a com.sun.star.beans.PropertyValue
109 ''' Date BASIC variables give error. Change them to UNO types
110 ''' Empty arrays should be replaced by Null
112 Dim vValue As Variant ' Return value
114 If VarType(pvValue) = V_DATE Then
115 vValue = SF_Utils._CDateToUnoDate(pvValue)
116 ElseIf IsArray(pvValue) Then
118 Else
119 vValue = pvValue
120 End If
121 _CPropertyValue() = vValue
123 End Function ' ScriptForge.SF_Utils._CPropertyValue
125 REM -----------------------------------------------------------------------------
126 Public Function _CStrToDate(ByRef pvStr As String) As Date
127 ''' Attempt to convert the input string to a Date variable with the CDate builtin function
129 ''' Date patterns: YYYY-MM-DD, HH:MM:DD and YYYY-MM-DD HH:MM:DD
131 Dim dDate As Date ' Return value
132 Const cstNoDate = -1
134 dDate = cstNoDate
135 Try:
136 On Local Error Resume Next
137 dDate = CDate(pvStr)
139 Finally:
140 _CStrToDate = dDate
141 Exit Function
142 End Function ' ScriptForge.SF_Utils._CStrToDate
144 REM -----------------------------------------------------------------------------
145 Public Function _EnterFunction(ByVal psSub As String, Optional ByVal psArgs As String)
146 ''' Called on top of each public function
147 ''' Used to trace routine in/outs (debug mode)
148 ''' and to allow the explicit mention of the user call which caused an error
149 ''' Args:
150 ''' psSub = the called Sub/Function/Property, usually something like "service.sub"
151 ''' Return: True when psSub is called from a user script
152 ''' Used to bypass the validation of the arguments when unnecessary
154 If IsEmpty(_SF_) Or IsNull(_SF_) Then SF_Utils._InitializeRoot() ' First use of ScriptForge during current LibO session
155 If IsMissing(psArgs) Then psArgs = ""
156 With _SF_
157 If .StackLevel = 0 Then
158 .MainFunction = psSub
159 .MainFunctionArgs = psArgs
160 _EnterFunction = True
161 Else
162 _EnterFunction = False
163 End If
164 .StackLevel = .StackLevel + 1
165 If .DebugMode Then ._AddToConsole("==> " & psSub & "(" & .StackLevel & ")")
166 End With
168 End Function ' ScriptForge.SF_Utils._EnterFunction
170 REM -----------------------------------------------------------------------------
171 Public Function _ErrorHandling(Optional ByVal pbErrorHandler As Boolean) As Boolean
172 ''' Error handling is normally ON and can be set OFF for debugging purposes
173 ''' Each user visible routine starts with a call to this function to enable/disable
174 ''' standard handling of internal errors
175 ''' Args:
176 ''' pbErrorHandler = if present, set its value
177 ''' Return: the current value of the error handler
179 If IsEmpty(_SF_) Or IsNull(_SF_) Then SF_Utils._InitializeRoot() ' First use of ScriptForge during current LibO session
180 If Not IsMissing(pbErrorHandler) Then _SF_.ErrorHandler = pbErrorHandler
181 _ErrorHandling = _SF_.ErrorHandler
183 End Function ' ScriptForge.SF_Utils._ErrorHandling
185 REM -----------------------------------------------------------------------------
186 Public Sub _ExitFunction(ByVal psSub As String)
187 ''' Called in the Finally block of each public function
188 ''' Manage ScriptForge internal aborts
189 ''' Resets MainFunction (root) when exiting the method called by a user script
190 ''' Used to trace routine in/outs (debug mode)
191 ''' Args:
192 ''' psSub = the called Sub/Function/Property, usually something like "service.sub"
194 If IsEmpty(_SF_) Or IsNull(_SF_) Then SF_Utils._InitializeRoot() ' Useful only when current module has been recompiled
195 With _SF_
197 SF_Exception.RaiseAbort(psSub)
198 End If
199 If .StackLevel = 1 Then
200 .MainFunction = ""
201 .MainFunctionArgs = ""
202 End If
203 If .DebugMode Then ._AddToConsole("<== " & psSub & "(" & .StackLevel & ")")
205 End With
207 End Sub ' ScriptForge.SF_Utils._ExitFunction
209 REM -----------------------------------------------------------------------------
210 Public Sub _ExportScriptForgePOTFile(ByVal FileName As String)
211 ''' Export the ScriptForge POT file related to its own user interface
212 ''' Should be called only before issuing new ScriptForge releases only
213 ''' Args:
214 ''' FileName: the resulting file. If it exists, is overwritten without warning
216 Dim sHeader As String ' The specific header to insert
218 sHeader = "" _
227 Try:
228 With _SF_
229 .Interface.ExportToPOTFile(FileName, Header := sHeader)
230 End With
232 Finally:
233 Exit Sub
234 End Sub ' ScriptForge.SF_Utils._ExportScriptForgePOTFile
236 REM -----------------------------------------------------------------------------
237 Public Function _GetPropertyValue(ByRef pvArgs As Variant, ByVal psName As String) As Variant
238 ''' Returns the Value corresponding to the given name
239 ''' Args
240 ''' pvArgs: a zero_based array of PropertyValues
241 ''' psName: the comparison is not case-sensitive
242 ''' Returns:
243 ''' Zero-length string if not found
245 Dim vValue As Variant ' Return value
246 Dim i As Long
248 vValue = ""
249 If IsArray(pvArgs) Then
250 For i = LBound(pvArgs) To UBound(pvArgs)
251 If UCase(psName) = UCase(pvArgs(i).Name) Then
252 vValue = pvArgs(i).Value
253 Exit For
254 End If
255 Next i
256 End If
257 _GetPropertyValue = vValue
259 End Function ' ScriptForge.SF_Utils._GetPropertyValue
261 REM -----------------------------------------------------------------------------
262 Public Function _GetRegistryKeyContent(ByVal psKeyName as string _
263 , Optional pbForUpdate as Boolean _
264 ) As Variant
265 ''' Implement a ConfigurationProvider service
266 ''' Derived from the Tools library
267 ''' Args:
268 ''' psKeyName: the name of the node in the configuration tree
269 ''' pbForUpdate: default = False
271 Dim oConfigProvider as Object ' com.sun.star.configuration.ConfigurationProvider
272 Dim vNodePath(0) as New com.sun.star.beans.PropertyValue
279 vNodePath(0).Value = psKeyName
281 If IsMissing(pbForUpdate) Then pbForUpdate = False
282 If pbForUpdate Then sConfig = cstConfigUpdate Else sConfig = cstConfig
284 Set _GetRegistryKeyContent = oConfigProvider.createInstanceWithArguments(sConfig, vNodePath())
286 End Function ' ScriptForge.SF_Utils._GetRegistryKeyContent
288 REM -----------------------------------------------------------------------------
289 Public Function _GetUNOService(ByVal psService As String _
290 , Optional ByVal pvArg As Variant _
291 ) As Object
292 ''' Create a UNO service
293 ''' Each service is called only once
294 ''' Args:
295 ''' psService: shortcut to service
296 ''' pvArg: some services might require an argument
298 Dim sLocale As String ' fr-BE f.i.
299 Dim oConfigProvider As Object
300 Dim oDefaultContext As Object
301 Dim vNodePath As Variant
303 Set _GetUNOService = Nothing
304 With _SF_
305 Select Case psService
307 Set oDefaultContext = GetDefaultContext()
308 If Not IsNull(oDefaultContext) Then Set _GetUNOService = oDefaultContext.getValueByName("/singletons/com.sun.star.script.browse.theBrowseNodeFactory")
310 If IsEmpty(.CharacterClass) Or IsNull(.CharacterClass) Then
312 End If
313 Set _GetUNOService = .CharacterClass
315 If IsEmpty(.ConfigurationProvider) Or IsNull(.ConfigurationProvider) Then
316 Set .ConfigurationProvider = CreateUnoService("com.sun.star.configuration.ConfigurationProvider")
317 End If
318 Set _GetUNOService = .ConfigurationProvider
320 If IsEmpty(.CoreReflection) Or IsNull(.CoreReflection) Then
322 End If
323 Set _GetUNOService = .CoreReflection
325 If IsEmpty(.DatabaseContext) Or IsNull(.DatabaseContext) Then
327 End If
328 Set _GetUNOService = .DatabaseContext
330 If IsEmpty(.DispatchHelper) Or IsNull(.DispatchHelper) Then
332 End If
333 Set _GetUNOService = .DispatchHelper
335 If IsEmpty(.FileAccess) Or IsNull(.FileAccess) Then
337 End If
338 Set _GetUNOService = .FileAccess
340 If IsEmpty(.FilePicker) Or IsNull(.FilePicker) Then
342 End If
343 Set _GetUNOService = .FilePicker
345 If IsEmpty(.FilterFactory) Or IsNull(.FilterFactory) Then
347 End If
348 Set _GetUNOService = .FilterFactory
350 If IsEmpty(.FolderPicker) Or IsNull(.FolderPicker) Then
352 End If
353 Set _GetUNOService = .FolderPicker
355 If IsEmpty(.FunctionAccess) Or IsNull(.FunctionAccess) Then
357 End If
358 Set _GetUNOService = .FunctionAccess
360 If IsEmpty(.Introspection) Or IsNull(.Introspection) Then
362 End If
363 Set _GetUNOService = .Introspection
365 If IsEmpty(.Locale) Or IsNull(.Locale) Then
367 ' Derived from the Tools library
368 Set oConfigProvider = createUnoService("com.sun.star.configuration.ConfigurationProvider")
369 vNodePath = Array() : ReDim vNodePath(0)
370 vNodePath(0) = New com.sun.star.beans.PropertyValue
371 vNodePath(0).Name = "nodepath" : vNodePath(0).Value = "org.openoffice.Setup/L10N"
372 sLocale = oConfigProvider.createInstanceWithArguments("com.sun.star.configuration.ConfigurationAccess", vNodePath()).getByName("ooLocale")
373 .Locale.Language = Left(sLocale, 2)
374 .Locale.Country = Right(sLocale, 2)
375 End If
376 Set _GetUNOService = .Locale
378 Set oDefaultContext = GetDefaultContext()
379 If Not IsNull(oDefaultContext) Then Set _GetUNOService = oDefaultContext.getValueByName("/singletons/com.sun.star.util.theMacroExpander")
381 If IsEmpty(.MailService) Or IsNull(.MailService) Then
384 Else
386 End If
387 End If
388 Set _GetUNOService = .MailService
390 If IsEmpty(.PathSettings) Or IsNull(.PathSettings) Then
392 End If
393 Set _GetUNOService = .PathSettings
395 If IsEmpty(.PathSubstitution) Or IsNull(.PathSubstitution) Then
397 End If
398 Set _GetUNOService = .PathSubstitution
400 If IsMissing(pvArg) Then pvArg = SF_Session.SCRIPTISAPPLICATION
401 Select Case LCase(pvArg)
402 Case SF_Session.SCRIPTISEMBEDDED ' Document
403 If Not IsNull(ThisComponent) Then Set _GetUNOService = ThisComponent.getScriptProvider()
404 Case Else
405 If IsEmpty(.ScriptProvider) Or IsNull(.ScriptProvider) Then
406 Set .ScriptProvider = _
407 CreateUnoService("com.sun.star.script.provider.MasterScriptProviderFactory").createScriptProvider("")
408 End If
409 Set _GetUNOService = .ScriptProvider
410 End Select
412 If IsEmpty(.SearchOptions) Or IsNull(.SearchOptions) Then
413 Set .SearchOptions = New com.sun.star.util.SearchOptions
414 With .SearchOptions
415 .algorithmType = com.sun.star.util.SearchAlgorithms.REGEXP
416 .searchFlag = 0
417 End With
418 End If
419 Set _GetUNOService = .SearchOptions
421 If IsEmpty(.SystemShellExecute) Or IsNull(.SystemShellExecute) Then
423 End If
424 Set _GetUNOService = .SystemShellExecute
426 If IsEmpty(.TextSearch) Or IsNull(.TextSearch) Then
428 End If
429 Set _GetUNOService = .TextSearch
431 If IsEmpty(.URLTransformer) Or IsNull(.URLTransformer) Then
433 End If
434 Set _GetUNOService = .URLTransformer
435 Case Else
436 End Select
437 End With
439 End Function ' ScriptForge.SF_Utils._GetUNOService
441 REM -----------------------------------------------------------------------------
442 Public Sub _InitializeRoot(Optional ByVal pbForce As Boolean)
443 ''' Initialize _SF_ as SF_Root basic object
444 ''' Args:
445 ''' pbForce = True forces the reinit (default = False)
447 If IsMissing(pbForce) Then pbForce = False
448 If pbForce Then Set _SF_ = Nothing
449 If IsEmpty(_SF_) Or IsNull(_SF_) Then
450 Set _SF_ = New SF_Root
451 Set _SF_.[Me] = _SF_
452 ' Localization
453 _SF_._LoadLocalizedInterface()
454 End If
456 End Sub ' ScriptForge.SF_Utils._InitializeRoot
458 REM -----------------------------------------------------------------------------
459 Public Function _MakePropertyValue(ByVal psName As String _
460 , ByRef pvValue As Variant _
461 ) As com.sun.star.beans.PropertyValue
462 ''' Create and return a new com.sun.star.beans.PropertyValue
464 Dim oPropertyValue As New com.sun.star.beans.PropertyValue
466 With oPropertyValue
467 .Name = psName
468 .Value = SF_Utils._CPropertyValue(pvValue)
469 End With
470 _MakePropertyValue() = oPropertyValue
472 End Function ' ScriptForge.SF_Utils._MakePropertyValue
474 REM -----------------------------------------------------------------------------
475 Public Function _Repr(ByVal pvArg As Variant, Optional ByVal plMax As Long) As String
477 ''' Args
478 ''' pvArg: may be of any type
481 Dim sArg As String ' Return value
483 Dim sObject As String ' Object representation
484 Dim sObjectType As String ' ObjectType attribute of Basic objects
485 Dim sLength As String ' String length as a string
486 Dim i As Long
490 Const cstByteLength = 25
493 If IsMissing(plMax) Or plMax = 0 Then plMax = cstMaxLength
494 If IsArray(pvArg) Then
495 sArg = SF_Array._Repr(pvArg)
496 Else
497 Select Case VarType(pvArg)
500 Case V_OBJECT
501 If IsNull(pvArg) Then
503 Else
504 sObject = SF_Session.UnoObjectType(pvArg)
506 ' Test if argument is a ScriptForge object
507 sObjectType = ""
508 On Local Error Resume Next
509 Set oObject = pvArg
510 sObjectType = oObject.ObjectType
511 On Error GoTo 0
512 If sObjectType = "" Then
516 Else
517 sArg = oObject._Repr()
518 End If
519 Else
521 End If
522 End If
524 Case V_STRING
525 sArg = SF_String._Repr(pvArg)
528 Case V_SINGLE, V_DOUBLE, V_CURRENCY
529 sArg = Format(pvArg)
532 Case V_BIGINT : sArg = CStr(CLng(pvArg))
533 Case V_DATE : sArg = _CDateToIso(pvArg)
534 Case Else : sArg = CStr(pvArg)
535 End Select
536 End If
537 If Len(sArg) > plMax Then
540 End If
541 _Repr = sArg
543 End Function ' ScriptForge.SF_Utils._Repr
545 REM -----------------------------------------------------------------------------
546 Private Function _ReprValues(Optional ByVal pvArgs As Variant _
547 , Optional ByVal plMax As Long _
548 ) As String
549 ''' Convert an array of values to a comma-separated list of readable strings
551 Dim sValues As String ' Return value
552 Dim sValue As String ' A single value
553 Dim vValue As Variant ' A single item in the argument
554 Dim i As Long ' Items counter
558 _ReprValues = ""
559 If IsMissing(pvArgs) Then Exit Function
560 If Not IsArray(pvArgs) Then pvArgs = Array(pvArgs)
561 sValues = ""
562 For i = 0 To UBound(pvArgs)
563 vValue = pvArgs(i)
564 If i < plMax Then
565 If VarType(vValue) = V_STRING Then sValue = """" & vValue & """" Else sValue = SF_Utils._Repr(vValue, cstMax)
566 If Len(sValues) = 0 Then sValues = sValue Else sValues = sValues & ", " & sValue
567 ElseIf i < UBound(pvArgs) Then
569 Exit For
570 End If
571 Next i
572 _ReprValues = sValues
574 End Function ' ScriptForge.SF_Utils._ReprValues
576 REM -----------------------------------------------------------------------------
577 Public Sub _SetPropertyValue(ByRef pvPropertyValue As Variant _
578 , ByVal psName As String _
579 , ByRef pvValue As Variant _
580 )
581 ''' Update the 1st argument (passed by reference), which is an array of property values
582 ''' If the property psName exists, update it with pvValue, otherwise create it on top of the array
584 Dim oPropertyValue As New com.sun.star.beans.PropertyValue
585 Dim lIndex As Long ' Found entry
586 Dim vValue As Variant ' Alias of pvValue
587 Dim i As Long
589 lIndex = -1
590 For i = 0 To UBound(pvPropertyValue)
591 If pvPropertyValue(i).Name = psName Then
592 lIndex = i
593 Exit For
594 End If
595 Next i
597 lIndex = UBound(pvPropertyValue) + 1
598 ReDim Preserve pvPropertyValue(0 To lIndex)
599 Set oPropertyValue = SF_Utils._MakePropertyValue(psName, pvValue)
600 pvPropertyValue(lIndex) = oPropertyValue
601 Else ' psName exists already in array of property values
602 pvPropertyValue(lIndex).Value = SF_Utils._CPropertyValue(pvValue)
603 End If
605 End Sub ' ScriptForge.SF_Utils._SetPropertyValue
607 REM -----------------------------------------------------------------------------
608 Private Function _TypeNames(Optional ByVal pvArgs As Variant) As String
609 ''' Converts the array of VarTypes to a comma-separated list of TypeNames
611 Dim sTypes As String ' Return value
612 Dim sType As String ' A single type
613 Dim iType As Integer ' A single item of the argument
615 _TypeNames = ""
616 If IsMissing(pvArgs) Then Exit Function
617 If Not IsArray(pvArgs) Then pvArgs = Array(pvArgs)
618 sTypes = ""
619 For Each iType In pvArgs
620 Select Case iType
636 End Select
638 Next iType
639 _TypeNames = sTypes
641 End Function ' ScriptForge.SF_Utils._TypeNames
643 REM -----------------------------------------------------------------------------
644 Public Function _Validate(Optional ByRef pvArgument As Variant _
645 , ByVal psName As String _
646 , Optional ByVal pvTypes As Variant _
647 , Optional ByVal pvValues As Variant _
648 , Optional ByVal pvRegex As Variant _
649 , Optional ByVal pvObjectType As Variant _
650 ) As Boolean
651 ''' Validate the arguments set by user scripts
652 ''' The arguments of the function define the validation rules
653 ''' This function ignores arrays. Use _ValidateArray instead
654 ''' Args:
655 ''' pvArgument: the argument to (in)validate
656 ''' psName: the documented name of the argument (can be inserted in an error message)
657 ''' pvTypes: array of allowed VarTypes
658 ''' pvValues: array of allowed values
659 ''' pvRegex: regular expression to comply with
660 ''' pvObjectType: mandatory Basic class
661 ''' Return: True if validation OK
662 ''' Otherwise an error is raised
663 ''' Exceptions:
664 ''' ARGUMENTERROR
666 Dim iVarType As Integer ' Extended VarType of argument
667 Dim bValid As Boolean ' Returned value
668 Dim oArgument As Variant ' Workaround "Object variable not set" error on 1st executable statement
672 ' To avoid useless recursions, keep main function, only increase stack depth
673 _SF_.StackLevel = _SF_.StackLevel + 1
674 On Local Error GoTo Finally ' Do never interrupt
676 Try:
677 bValid = True
678 If IsMissing(pvArgument) Then GoTo CatchMissing
679 If IsMissing(pvRegex) Or IsEmpty(pvRegex) Then pvRegex = ""
680 If IsMissing(pvObjectType) Or IsEmpty(pvObjectType) Then pvObjectType = ""
681 iVarType = SF_Utils._VarTypeExt(pvArgument)
683 ' Arrays NEVER pass validation
684 If iVarType >= V_ARRAY Then
685 bValid = False
686 Else
687 ' Check existence of argument
690 If bValid And Not IsMissing(pvTypes) Then
691 If Not IsArray(pvTypes) Then bValid = ( pvTypes = iVarType ) Else bValid = SF_Array.Contains(pvTypes, iVarType)
692 End If
694 If bValid And Not IsMissing(pvValues) Then
695 If Not IsArray(pvValues) Then pvValues = Array(pvValues)
696 bValid = SF_Array.Contains(pvValues, pvArgument, CaseSensitive := False)
697 End If
698 ' Check regular expression
700 If Len(pvArgument) > 0 Then bValid = SF_String.IsRegex(pvArgument, pvRegex, CaseSensitive := False)
701 End If
702 ' Check instance types
704 Set oArgument = pvArgument
705 bValid = ( pvObjectType = oArgument.ObjectType )
706 End If
707 End If
709 If Not bValid Then
710 ''' Library: ScriptForge
711 ''' Service: Array
712 ''' Method: Contains
714 ''' A serious error has been detected on argument SortOrder
715 ''' Rules: SortOrder is of type String
716 ''' SortOrder must contain one of next values: "ASC", "DESC", ""
718 SF_Exception.RaiseFatal(ARGUMENTERROR _
719 , SF_Utils._Repr(pvArgument, cstMaxLength), psName, SF_Utils._TypeNames(pvTypes) _
720 , SF_Utils._ReprValues(pvValues, cstMaxValues), pvRegex, pvObjectType _
721 )
722 End If
724 Finally:
725 _Validate = bValid
726 _SF_.StackLevel = _SF_.StackLevel - 1
727 Exit Function
728 CatchMissing:
729 bValid = False
730 SF_Exception.RaiseFatal(MISSINGARGERROR, psName)
731 GoTo Finally
732 End Function ' ScriptForge.SF_Utils._Validate
734 REM -----------------------------------------------------------------------------
735 Public Function _ValidateArray(Optional ByRef pvArray As Variant _
736 , ByVal psName As String _
737 , Optional ByVal piDimensions As Integer _
738 , Optional ByVal piType As Integer _
739 , Optional ByVal pbNotNull As Boolean _
740 ) As Boolean
741 ''' Validate the (array) arguments set by user scripts
742 ''' The arguments of the function define the validation rules
743 ''' This function ignores non-arrays. Use _Validate instead
744 ''' Args:
745 ''' pvArray: the argument to (in)validate
746 ''' psName: the documented name of the array (can be inserted in an error message)
751 ''' but homogeneously: all strings or all dates or all numeric
754 ''' If True: Empty, Null items are rejected
755 ''' Return: True if validation OK
756 ''' Otherwise an error is raised
757 ''' Exceptions:
758 ''' ARRAYERROR
760 Dim iVarType As Integer ' VarType of argument
761 Dim vItem As Variant ' Array item
762 Dim iItemType As Integer ' VarType of individual items of argument
763 Dim iDims As Integer ' Number of dimensions of the argument
764 Dim bValid As Boolean ' Returned value
765 Dim iArrayType As Integer ' Static array type
767 Dim sType As String ' Allowed item types as a string
768 Dim i As Long
771 ' To avoid useless recursions, keep main function, only increase stack depth
773 _SF_.StackLevel = _SF_.StackLevel + 1
774 On Local Error GoTo Finally ' Do never interrupt
776 Try:
777 bValid = True
778 If IsMissing(pvArray) Then GoTo CatchMissing
779 If IsMissing(piDimensions) Then piDimensions = 0
780 If IsMissing(piType) Then piType = -1
781 If IsMissing(pbNotNull) Then pbNotNull = False
782 iVarType = VarType(pvArray)
784 ' Scalars NEVER pass validation
785 If iVarType < V_ARRAY Then
786 bValid = False
787 Else
788 ' Check dimensions
789 iDims = SF_Array.CountDims(pvArray)
792 bValid = ( iDims = piDimensions Or (iDims = 0 And piDimensions = 1) ) ' Allow empty vectors
793 End If
794 ' Check VarType and Empty/Null status of the array items
796 iArrayType = SF_Array._StaticType(pvArray)
798 ' If static array of the right VarType ..., OK
799 Else
800 ' Go through array and check individual items
801 iFirstItemType = -1
804 iItemType = SF_Utils._VarTypeExt(vItem)
806 ' Initialization at first non-null item
808 iFirstItemType = iItemType
809 If piType > 0 Then bValid = ( iFirstItemType = piType ) Else bValid = SF_Array.Contains(Array(V_STRING, V_DATE, V_NUMERIC), iFirstItemType)
810 Else
811 bValid = (iItemType = iFirstItemType)
812 End If
813 Else
814 bValid = Not pbNotNull
815 End If
816 If Not bValid Then Exit For
817 Next i
818 End If
819 End If
820 End If
822 If Not bValid Then
823 ''' Library: ScriptForge
824 ''' Service: Array
825 ''' Method: Contains
826 ''' Arguments: Array_1D, ToFind, [CaseSensitive=False], [SortOrder=""|"ASC"|"DESC"]
827 ''' An error was detected on argument Array_1D
828 ''' Rules: Array_1D is of type Array
830 ''' Array_1D must have all elements of the same type: either String, Date or Numeric
832 sType = ""
833 If piType = 0 Then
836 sType = SF_Utils._TypeNames(piType)
837 End If
838 SF_Exception.RaiseFatal(ARRAYERROR _
839 , SF_Utils._Repr(pvArray, cstMaxLength), psName, piDimensions, sType, pbNotNull)
840 End If
842 Finally:
843 _ValidateArray = bValid
844 _SF_.StackLevel = _SF_.StackLevel - 1
845 Exit Function
846 CatchMissing:
847 bValid = False
848 SF_Exception.RaiseFatal(MISSINGARGERROR, psName)
849 GoTo Finally
850 End Function ' ScriptForge.SF_Utils._ValidateArray
852 REM -----------------------------------------------------------------------------
853 Public Function _ValidateFile(Optional ByRef pvArgument As Variant _
854 , ByVal psName As String _
855 , Optional ByVal pbWildCards As Boolean _
856 , Optional ByVal pbSpace As Boolean _
857 )
858 ''' Validate the argument as a valid FileName
859 ''' Args:
860 ''' pvArgument: the argument to (in)validate
861 ''' pbWildCards: if True, wildcard characters are accepted in the last component of the 1st argument
862 ''' pbSpace: if True, the argument may be an empty string. Default = False
863 ''' Return: True if validation OK
864 ''' Otherwise an error is raised
865 ''' Exceptions:
866 ''' ARGUMENTERROR
868 Dim iVarType As Integer ' VarType of argument
869 Dim sFile As String ' Alias for argument
870 Dim bValid As Boolean ' Returned value
871 Dim sFileNaming As String ' Alias of SF_FileSystem.FileNaming
872 Dim oArgument As Variant ' Workaround "Object variable not set" error on 1st executable statement
875 ' To avoid useless recursions, keep main function, only increase stack depth
877 _SF_.StackLevel = _SF_.StackLevel + 1
878 On Local Error GoTo Finally ' Do never interrupt
880 Try:
881 bValid = True
882 If IsMissing(pvArgument) Then GoTo CatchMissing
883 If IsMissing(pbWildCards) Then pbWildCards = False
884 If IsMissing(pbSpace) Then pbSpace = False
885 iVarType = VarType(pvArgument)
887 ' Arrays NEVER pass validation
888 If iVarType >= V_ARRAY Then
889 bValid = False
890 Else
891 ' Argument must be a string containing a valid file name
892 bValid = ( iVarType = V_STRING )
893 If bValid Then
896 ' Wildcards are replaced by arbitrary alpha characters
897 If pbWildCards Then
898 sFile = Replace(Replace(pvArgument, "?", "Z"), "*", "A")
899 Else
900 sFile = pvArgument
902 End If
903 ' Check file format without wildcards
904 If bValid Then
905 With SF_FileSystem
906 sFileNaming = .FileNaming
907 Select Case sFileNaming
911 End Select
912 End With
913 End If
914 ' Check that wildcards are only present in last component
915 If bValid And pbWildCards Then
916 sFile = SF_FileSystem.GetParentFolderName(pvArgument)
917 bValid = ( InStr(sFile, "*") + InStr(sFile, "?") + InStr(sFile,"%3F") = 0 ) ' ConvertToUrl replaces ? by %3F
918 End If
919 End If
920 End If
921 End If
923 If Not bValid Then
924 ''' Library: ScriptForge
925 ''' Service: FileSystem
926 ''' Method: CopyFile
927 ''' Arguments: Source, Destination
928 ''' A serious error has been detected on argument Source
929 ''' Rules: Source is of type String
930 ''' Source must be a valid file name expressed in operating system notation
931 ''' Source may contain one or more wildcard characters in its last component
932 ''' Actual value: /home/jean-*/SomeFile.odt
933 SF_Exception.RaiseFatal(FILEERROR _
934 , SF_Utils._Repr(pvArgument, cstMaxLength), psName, pbWildCards)
935 End If
937 Finally:
938 _ValidateFile = bValid
939 _SF_.StackLevel = _SF_.StackLevel - 1
940 Exit Function
941 CatchMissing:
942 bValid = False
943 SF_Exception.RaiseFatal(MISSINGARGERROR, psName)
944 GoTo Finally
945 End Function ' ScriptForge.SF_Utils._ValidateFile
947 REM -----------------------------------------------------------------------------
948 Public Function _VarTypeExt(ByRef pvValue As Variant) As Integer
949 ''' Return the VarType of the argument but all numeric types are aggregated into V_NUMERIC
950 ''' Args:
951 ''' pvValue: value to examine
952 ''' Return:
953 ''' The extended VarType
955 Dim iType As Integer ' VarType of argument
957 iType = VarType(pvValue)
958 Select Case iType
959 Case V_INTEGER, V_LONG, V_SINGLE, V_DOUBLE, V_CURRENCY, V_BIGINT, V_DECIMAL
960 _VarTypeExt = V_NUMERIC
961 Case Else : _VarTypeExt = iType
962 End Select
964 End Function ' ScriptForge.SF_Utils._VarTypeExt
966 REM ================================================= END OF SCRIPTFORGE.SF_UTILS
967 </script:module>