YS, 2011-02-19:
Excel VBA to LibreOffice/OpenOffice.org basic converter.
The purpose of the scripts below is to convert Excel VBA macroses to OpenOffice/LibreOffice ones. They were tested on OpenOffice.org 3.2, actually, so may be not up-to-date. Tcl 8.6 is required.
DISCLAIMER: Some conversions are hardcoded (for example, ADO databases access conversion presumes that connection object is called Module1.conn), so read the sources, esp. vba2oo.tcl!
How to use:
0. Save all scripts (convmodule.tcl, convmfix.tcl and vba2oo.tcl) into the same directory.
1. Export modules` sources from Excel (OpenOffice had a bug with exporting modules > 64K).
2. Process exported file with convmodule.tcl:
> tclkit.exe convmodule.tcl module1.bas module1_out.bas
3. Process module1_out.bas with convmfix.tcl (you can skip this step):
> tclkit.exe convmfix.tcl module1_out.bas module1_out2.bas
4. Import module1_out2.bas into LibreOffice.
5. Add 'Option Compatible' to the top of the module (adds Enum support), remove useless event processing Subs.
6. Add these to global definitions:
Public ActiveDialog as Object
Public conn as Object
7. Add this before calling dialogs:
DialogLibraries.LoadLibrary("Standard")
8. Add these functions into module (if needed):
Function CIndex2RGB(idx as Long) as Long
Select Case idx
Case 0
CIndex2RGB = -1
Case 1
CIndex2RGB = 0
Case 2
CIndex2RGB = 16777215
Case 3
CIndex2RGB = 16711680
Case 4
CIndex2RGB = 65280
Case 5
CIndex2RGB = 255
Case 6
CIndex2RGB = 16776960
Case 7
CIndex2RGB = 16711935
Case 8
CIndex2RGB = 65535
Case 9
CIndex2RGB = 8388608
Case 10
CIndex2RGB = 32768
Case 11
CIndex2RGB = 128
Case 12
CIndex2RGB = 8421376
Case 13
CIndex2RGB = 8388736
Case 14
CIndex2RGB = 32896
Case 15
CIndex2RGB = 12632256
Case 16
CIndex2RGB = 8421504
Case 17
CIndex2RGB = 10066431
Case 18
CIndex2RGB = 10040166
Case 19
CIndex2RGB = 16777164
Case 20
CIndex2RGB = 13434879
Case 21
CIndex2RGB = 6684774
Case 22
CIndex2RGB = 16744576
Case 23
CIndex2RGB = 26316
Case 24
CIndex2RGB = 13421823
Case 25
CIndex2RGB = 128
Case 26
CIndex2RGB = 16711935
Case 27
CIndex2RGB = 16776960
Case 28
CIndex2RGB = 65535
Case 29
CIndex2RGB = 8388736
Case 30
CIndex2RGB = 8388608
Case 31
CIndex2RGB = 32896
Case 32
CIndex2RGB = 255
Case 33
CIndex2RGB = 52479
Case 34
CIndex2RGB = 13434879
Case 35
CIndex2RGB = 13434828
Case 36
CIndex2RGB = 16777113
Case 37
CIndex2RGB = 10079487
Case 38
CIndex2RGB = 16751052
Case 39
CIndex2RGB = 13408767
Case 40
CIndex2RGB = 16764057
Case 41
CIndex2RGB = 3368703
Case 42
CIndex2RGB = 3394764
Case 43
CIndex2RGB = 10079232
Case 44
CIndex2RGB = 16763904
Case 45
CIndex2RGB = 16750848
Case 46
CIndex2RGB = 16737792
Case 47
CIndex2RGB = 6710937
Case 48
CIndex2RGB = 9868950
Case 49
CIndex2RGB = 13158
Case 50
CIndex2RGB = 3381606
Case 51
CIndex2RGB = 13056
Case 52
CIndex2RGB = 3355392
Case 53
CIndex2RGB = 10040064
Case 54
CIndex2RGB = 10040166
Case 55
CIndex2RGB = 3355545
Case 56
CIndex2RGB = 3355443
End Select
End Function
Function FixType(Value as string) as Variant
if IsNumeric(Value) then
FixType = CDbl(Value)
elseif IsDate(Value) then
FixType=CDate(Value)
else
FixType=Value
end if
End Function
Sub RecSetOpen (RS as Object, SQL as string, S1 as any, S2 as any, S3 as any, S4 as any)
Dim Statement As Object
Statement = conn.createStatement()
Statement.QueryTimeOut = 0
RS = Statement.executeQuery(SQL)
RS.first
End Sub
Function Round(dVal As Variant, Optional iPrecision As Integer) As Double
dim iPrec as integer
Dim roundStr As String
Dim WholeNumberPart As String
Dim DecimalPart As String
Dim i As Integer
Dim RoundUpValue As Double
roundStr = CStr(dVal)
if isMissing( iPrecision ) then
iPrec = 0
else
iPrec = iPrecision
endif
If InStr(1, roundStr, ",") = -1 Then
Round = dVal
Exit Function
End If
WholeNumberPart = Mid(roundStr, 1, InStr(1, roundStr, ",") - 1)
DecimalPart = Mid(roundStr, (InStr(2, roundStr, ",")))
If Len(DecimalPart) > iPrec + 1 Then
Select Case Mid(DecimalPart, iPrec + 2, 1)
Case "0", "1", "2", "3", "4"
DecimalPart = Mid(DecimalPart, 1, iPrec + 1)
Case "5", "6", "7", "8", "9"
RoundUpValue = 0.1
For i = 1 To iPrec - 1
RoundUpValue = RoundUpValue * 0.1
Next
DecimalPart = CStr(cdbl(Mid(DecimalPart, 1, iPrec + 1)) + RoundUpValue)
If Mid(DecimalPart, 1, 1) <> "1" Then
DecimalPart = Mid(DecimalPart, 1)
Else
WholeNumberPart = CStr(cDbl(WholeNumberPart) + 1)
DecimalPart = ""
End If
End Select
End If
Round = cDbl(WholeNumberPart & DecimalPart)
End Function
Function GetComboIndex (ComboName as string) as long
Dim f as Long
Dim Combobox as object
Combobox = ActiveDialog.getControl(ComboName)
GetComboIndex = -1
For f = 0 to ComboBox.ItemCount - 1
If ComboBox.Items(f) = ComboBox.Text Then
GetComboIndex = f
exit function
end if
next f
end function
9. Also, I suggest to:
a. Wrap long-running controls' events with:
ActiveDialog.model.enabled = false ... event source ... ActiveDialog.model.enabled = true
b. Replace FixType (produced by conversion if it can't recognize value type) with correct getXXX, if possible.
c. If you use Arrays to output information to sheet (as you should), then clear your arrays before using them, like this:
for f = 1 to 50000
for g = 1 to 4
DataArray(f, g) = ""
next g
next fAdd 'ReDim Preserve DataArray' for EXACT size of sheet area you want to fill before using SetDataArray (doesn't work otherwise in OO 3.2).
convmodule.tcl:
#convmodule.tcl
#Converts exported module. Can use its form.
#Helper proc for HIDING quoted strings:
proc S {} {
global G_CQStrs G_CQStrsIndex
set s [lindex $G_CQStrs $G_CQStrsIndex]
incr G_CQStrsIndex
return $s
}
proc CR {CC} {
if {[string is integer -strict $CC]} {
set CNum [scan $CC %d]
incr CNum
return $CNum
} else {
#If it's like "something + 2" OR "something - 3":
if {[regexp { [-+] \d+$} $CC]} {
set Idxs [regexp -inline -indices {( [-+]) (\d+)$} $CC]
set ss [lindex $Idxs 1 0]
set se [lindex $Idxs 1 1]
set ns [lindex $Idxs 2 0]
set ne [lindex $Idxs 2 1]
set CNum [scan [string index $CC $se][string range $CC $ns $ne] %d]
incr CNum
if {$CNum == 0} {return [string replace $CC $ss $ne ""]}
if {$CNum>0} {set sign "+"} else {set sign "-"}
return [string replace $CC $se $ne "$sign [expr {abs($CNum)}]"]
}
#If it's like "2 + something"
if {[regexp {^\d+ \+ } $CC]} {
regexp -indices {^\d+ \+ } $CC Idxs
set ei [lindex $Idxs 1]
set CNum [scan $CC %d]
incr CNum
if {$CNum == 0} {return [string replace $CC 0 $ei ""]}
return [string replace $CC 0 $ei "$CNum + "]
}
if {[regexp {^\w+$} $CC]} {
return "$CC + 1"
}
return "($CC) + 1"
}
}
#Must convert cell coordinate into OO's:
proc C {CC} {
if {[string is integer -strict $CC]} {
set CNum [scan $CC %d]
incr CNum -1
return $CNum
} else {
#If it's like "something + 2" OR "something - 3":
if {[regexp { [-+] \d+$} $CC]} {
set Idxs [regexp -inline -indices {( [-+]) (\d+)$} $CC]
set ss [lindex $Idxs 1 0]
set se [lindex $Idxs 1 1]
set ns [lindex $Idxs 2 0]
set ne [lindex $Idxs 2 1]
set CNum [scan [string index $CC $se][string range $CC $ns $ne] %d]
incr CNum -1
if {$CNum == 0} {return [string replace $CC $ss $ne ""]}
if {$CNum>0} {set sign "+"} else {set sign "-"}
return [string replace $CC $se $ne "$sign [expr {abs($CNum)}]"]
}
#If it's like "2 + something"
if {[regexp {^\d+ \+ } $CC]} {
regexp -indices {^\d+ \+ } $CC Idxs
set ei [lindex $Idxs 1]
set CNum [scan $CC %d]
incr CNum -1
if {$CNum == 0} {return [string replace $CC 0 $ei ""]}
return [string replace $CC 0 $ei "$CNum + "]
}
if {[regexp {^\w+$} $CC]} {
return "$CC - 1"
}
return "($CC) - 1"
}
}
#.Rows("7:60001").Delete Shift:=xlUp
#.Rows(CStr(psttot - 4) & ":60000").Delete Shift:=xlUp
proc RD {args} {
set RS [join $args]
foreach p [split $RS :] {
if {[regexp {CStr\((.+)\)} $p All InBrace]} {
#Try to get expression from there:
set res [C $InBrace]
} else {
#Try to scan number from there:
regexp {\d+} $p CNumStr
set res [scan $CNumStr %d]
incr res -1
}
lappend reslst $res
}
#First's correct, convert second (FROM end row number TO number of rows):
foreach {f s} $reslst break
if {[catch {set s [expr {$s-$f}]}]} {
set s "$s - ($f)"
}
return "$f, $s"
}
#Convert Row to range address:
proc RA {args} {
set RS "\"\$A\$\" & [join $args]"
set RS [string map {: {:$AMJ$}} $RS]
return $RS
}
#Uppercase string
proc U {args} {
set Str [join $args]
string toupper $Str
}
#Convert Format (Numbers):
#They aren't correct, but close for now.
proc CF {Str} {
switch -exact $Str {
{"#,##0.000"} {return 2}
{"#,##0.00$"} {return 4}
{"#,##0.00"} {return 4}
{"#,##0"} {return 3}
{"# ##0.000"} {return 4}
default {return $Str}
}
}
proc SW {spec} {
set ::G_FixNextWith $spec
return ""
}
proc EW {} {
set res ""
if {$::G_FixNextWith ne ""} {
set res $::G_FixNextWith
set ::G_FixNextWith ""
}
return $res
}
#Must process list of variables separately here:
proc AR {RS} {
foreach vp [split $RS ,] {
set RN [string trim $vp]
AddSubst "$RN\\.Open" "RecSetOpen $RN,"
}
return ""
}
#This must process ALL possible "DIM" forms:
proc CDim {Head Rest} {
#1. Hack: substitute [AR] in rest:
set Rest [subst -novariables $Rest]
set res ""
set s 0
while {1} {
if {![regexp -start $s -indices -nocase {As .+?(?:,|$)} $Rest All]} break
#So, we got one part:
set ns [lindex $All 0]
set ne [lindex $All 1]
set Type [string trim [string range $Rest $ns $ne] ,]
set Vars [string trim [string range $Rest $s $ns-1]]
#Process Vars now:
set vs 0
while {1} {
if {![regexp -start $vs -indices {\w+(?:\([^()]+\))?(?:,|$)} $Vars All]} break
set nvs [lindex $All 0]
set nve [lindex $All 1]
set VName [string trim [string range $Vars $nvs $nve] ,]
append res "$Head $VName $Type\n"
set vs [expr {$nve+1}]
}
set s [expr {$ne+1}]
}
string replace $res end end
}
proc AddSubst {RE REsub} {
global G_RE_Substs
lappend G_RE_Substs $RE $REsub
}
proc ConvNum {number} {
format %.0f [expr {$number/35.27778}]
}
proc ConvModuleFile {fname ofname} {
global G_RE_Substs G_CQStrs G_CQStrsIndex
set fd [open $fname]
fconfigure $fd -encoding cp1251
set ofd [open $ofname w]
fconfigure $ofd -encoding cp1251
while {[gets $fd nline] >= 0} {
set idnt ""
regexp {^[ \t]+} $nline idnt
set idnt "\n$idnt"
set trmline [string trim $nline]
if {[string index $trmline 0] eq "'"} {
puts $ofd $nline
continue
}
set G_CQStrsIndex 0
set G_CQStrs [regexp -inline -all {"[^\"]*"} $nline]
set nline [regsub -all {[\[\]\\]} $nline {\\\0}]
set nline [regsub -all {"[^\"]*"} $nline {[S]}]
#As strings are hidden now, take out comment:
set Comment ""
set CSt [string first ' $nline]
if {$CSt != -1} {
set Comment [string range $nline $CSt end]
set nline [string range $nline 0 $CSt-1]
}
foreach {RE RESub} $G_RE_Substs {
set nline [regsub -all -nocase $RE $nline $RESub]
}
set nline [subst -novariables $nline]
append nline [subst -novariables $Comment]
#Skip lines that became empty:
if {([string trim $nline] eq "") && ($trmline ne "")} continue
#Fix identation here:
set nline [regsub -all "\n" $nline $idnt]
puts $ofd $nline
}
close $fd
close $ofd
}
proc GetFormData {fname} {
set fd [open $fname]
fconfigure $fd -encoding utf-8
while {[gets $fd line] >= 0} {
if {[regexp {dlg:id=} $line]} {
regexp {dlg:id="(\w+)"} $line All Name
switch -glob $line {
"*dlg:checkbox*" {
AddSubst "(.+) = $Name.Value\$" "If ActiveDialog.getControl(\"$Name\").State = 1 Then \\1 = True Else \\1 = False"
AddSubst "If $Name.Value Then" "If ActiveDialog.getControl(\"$Name\").State = 1 Then"
AddSubst "$Name.Value = False" "ActiveDialog.getControl(\"$Name\").State = 0"
AddSubst "$Name.Value = True" "ActiveDialog.getControl(\"$Name\").State = 1"
}
"*dlg:menulist*" {
AddSubst "$Name.AddItem (.+)\$" "ActiveDialog.getControl(\"$Name\").addItem(\\1, ActiveDialog.getControl(\"$Name\").ItemCount)"
AddSubst "$Name.Clear" "ActiveDialog.getControl(\"$Name\").removeItems(0, ActiveDialog.getControl(\"$Name\").ItemCount)"
#Check: from zero in OO, in Excel ?
AddSubst "$Name.ListIndex" "ActiveDialog.getControl(\"$Name\").SelectedItemPos"
AddSubst "$Name.Text" "ActiveDialog.getControl(\"$Name\").SelectedItem"
}
"*dlg:text*" {
AddSubst "$Name.Caption = (.+)\$" "ActiveDialog.getControl(\"$Name\").Text = \\1"
}
"*dlg:radio*" {
AddSubst "$Name.Value" "ActiveDialog.getControl(\"$Name\").State"
}
"*dlg:combobox*" {
AddSubst "$Name.AddItem (.+)\$" "ActiveDialog.getControl(\"$Name\").addItem(\\1, ActiveDialog.getControl(\"$Name\").ItemCount)"
AddSubst "$Name.Clear" "ActiveDialog.getControl(\"$Name\").removeItems(0, ActiveDialog.getControl(\"$Name\").ItemCount)"
#Check: from zero in OO, in Excel ?
AddSubst "$Name.ListIndex = (.+)\$" "ActiveDialog.getControl(\"$Name\").text = ActiveDialog.getControl(\"$Name\").getItem(\\1)"
AddSubst "$Name.ListIndex" "GetComboIndex(\"$Name\")"
AddSubst "$Name.Text" "ActiveDialog.getControl(\"$Name\").Text"
}
"*dlg:datefield*" {
AddSubst "$Name.Value = (.+)\$" "ActiveDialog.getControl(\"$Name\").Date = CdateToIso(\\1)"
AddSubst "(.+) = $Name.Value\$" "\\1 = CDateFromIso(ActiveDialog.getControl(\"$Name\").Date)"
}
}
}
}
close $fd
}
set ::G_FixNextWith ""
set L [llength $argv]
if {$L==3} {
GetFormData [lindex $argv 1]
source VBA2OO.tcl
ConvModuleFile [lindex $argv 0] [lindex $argv 2]
} else {
source VBA2OO.tcl
ConvModuleFile [lindex $argv 0] [lindex $argv 1]
}
VBA2OO.tcl:
#What is NOT translatable:
#1. Multiple ranges (they are easy to convert by hand).
# like: "A1:B2, C4:C6, A16:B18"
#2. PageSetup --- deleted on translation, not so important.
#3. Creating toolbars --- can be done directly (without code) in OpenOffice.
#4. SQL command (INSERT/UPDATE) semantic's wrong --- it's executed
# on using ".CommandText" property.
#5. "Range(" with two string parametes is not translated:
# example: Range(v(G, 3), v(G, 4)).Select
#6. FormulaR1C1 is unsupported in OOBasic, so no conversion.
#7. "Range.Value = " is unsupported in OOBasic, so no conversion.
#8. Defining Enums is supported in OOBasic ONLY with 'Option Compatible'.
#============================================================================
#Destroy these lines:
AddSubst {^.+\.PageSetup\..+$} {}
AddSubst {^.+\.FitToPagesWide.+$} {}
AddSubst {^.+\.FitToPagesTall.+$} {}
AddSubst {^.+\.PrintArea.+$} {}
AddSubst {^.+\.ConnectionTimeout .+$} {}
AddSubst {^.+\.CommandTimeout .+$} {}
AddSubst {^.*\.Execute.*$} {}
AddSubst {Set .+ = New ADODB\.(\w+)$} {}
AddSubst {^.+\.ActiveConnection = .+$} {}
AddSubst {^.+\.BeginTrans$} {}
AddSubst {^.+\.CommitTrans$} {}
AddSubst {^.+\.Calculation = .+$} {}
AddSubst {^.+\.Calculate$} {}
AddSubst {^.+\.LineStyle = .+$} {}
#General substs:
AddSubst {Application\.UserName} {Environ("USERNAME")}
AddSubst {Application\.} {ThisComponent.}
AddSubst {CCur\(} {CDbl(}
#Formatting:
#Borders are next to impossible, who could think!?
AddSubst {With (.+)\.Borders\(xlEdgeLeft\)} "OOtmpobj1 = \\1\nOOtmpobj2 = OOtmpobj1.LeftBorder\nWith OOtmpobj2\[SW \"\nOOtmpobj1.LeftBorder = OOtmpobj2\"\]"
AddSubst {With (.+)\.Borders\(xlEdgeRight\)} "OOtmpobj1 = \\1\nOOtmpobj2 = OOtmpobj1.RightBorder\nWith OOtmpobj2\[SW \"\nOOtmpobj1.RightBorder = OOtmpobj2\"\]"
AddSubst {With (.+)\.Borders\(xlEdgeTop\)} "OOtmpobj1 = \\1\nOOtmpobj2 = OOtmpobj1.TopBorder\nWith OOtmpobj2\[SW \"\nOOtmpobj1.TopBorder = OOtmpobj2\"\]"
AddSubst {With (.+)\.Borders\(xlEdgeBottom\)} "OOtmpobj1 = \\1\nOOtmpobj2 = OOtmpobj1.BottomBorder\nWith OOtmpobj2\[SW \"\nOOtmpobj1.BottomBorder = OOtmpobj2\"\]"
AddSubst {With (.+)\.Borders\(xlInsideHorizontal\)} "OOtmpobj1 = \\1\nOOtmpobj2 = OOtmpobj1.TableBorder\nOOtmpobj3 = OOtmpobj2.HorizontalLine\nWith OOtmpobj3\[SW \"\nOOtmpobj2.HorizontalLine = OOtmpobj3\nOOtmpobj1.TableBorder = OOtmpobj2\"\]"
AddSubst {With (.+)\.Borders\(xlInsideVertical\)} "OOtmpobj1 = \\1\nOOtmpobj2 = OOtmpobj1.TableBorder\nOOtmpobj3 = OOtmpobj2.VerticalLine\nWith OOtmpobj3\[SW \"\nOOtmpobj2.VerticalLine = OOtmpobj3\nOOtmpobj1.TableBorder = OOtmpobj2\"\]"
#This works just by sequence:
AddSubst {(.+)\.Borders\.(.+)} "OOtmpobj1 = \\1\nOOtmpobj2l = OOtmpobj1.LeftBorder\nOOtmpobj2r = OOtmpobj1.RightBorder\nOOtmpobj2t = OOtmpobj1.TopBorder\nOOtmpobj2b = OOtmpobj1.BottomBorder\nOOtmpobj2l.\\2\nOOtmpobj2r.\\2\nOOtmpobj2t.\\2\nOOtmpobj2b.\\2\nOOtmpobj1.LeftBorder = OOtmpobj2l\nOOtmpobj1.RightBorder = OOtmpobj2r\nOOtmpobj1.TopBorder = OOtmpobj2t\nOOtmpobj1.BottomBorder = OOtmpobj2b"
AddSubst {(.+)\.Borders\(xlEdgeLeft\)(.+)} "OOtmpobj1 = \\1\nOOtmpobj2 = OOtmpobj1.LeftBorder\nOOtmpobj2\\2\nOOtmpobj1.LeftBorder = OOtmpobj2"
AddSubst {(.+)\.Borders\(xlEdgeRight\)(.+)} "OOtmpobj1 = \\1\nOOtmpobj2 = OOtmpobj1.LeftBorder\nOOtmpobj2\\2\nOOtmpobj1.RightBorder = OOtmpobj2"
AddSubst {(.+)\.Borders\(xlEdgeTop\)(.+)} "OOtmpobj1 = \\1\nOOtmpobj2 = OOtmpobj1.LeftBorder\nOOtmpobj2\\2\nOOtmpobj1.TopBorder = OOtmpobj2"
AddSubst {(.+)\.Borders\(xlEdgeBottom\)(.+)} "OOtmpobj1 = \\1\nOOtmpobj2 = OOtmpobj1.LeftBorder\nOOtmpobj2\\2\nOOtmpobj1.BottomBorder = OOtmpobj2"
AddSubst {(.+)\.Borders\(xlInsideVertical\)(.+)} "OOtmpobj1 = \\1\nOOtmpobj2 = OOtmpobj1.TableBorder\nOOtmpobj3 = OOtmpobj2.VerticalLine\nOOtmpobj3\\2\nOOtmpobj2.VerticalLine = OOtmpobj3\nOOtmpobj1.TableBorder = OOtmpobj2"
AddSubst {(.+)\.Borders\(xlInsideHorizontal\)(.+)} "OOtmpobj1 = \\1\nOOtmpobj2 = OOtmpobj1.TableBorder\nOOtmpobj3 = OOtmpobj2.HorizontalLine\nOOtmpobj3\\2\nOOtmpobj2.HorizontalLine = OOtmpobj3\nOOtmpobj1.TableBorder = OOtmpobj2"
AddSubst {End With} {End With[EW]}
#Other formatting:
AddSubst {\.Font\.Size} {.CharHeight}
AddSubst {\.Font\.Bold = True} {.CharWeight = 150}
AddSubst {\.Font\.Bold = False} {.CharWeight = 100}
AddSubst {\.Font\.Italic = True} {.CharPosture = 2}
AddSubst {\.Font\.Italic = False} {.CharPosture = 0}
AddSubst {\.RowHeight = (\d+)} {.Rows.Height = \1 * 35.27778}
AddSubst {\.MergeCells = (\w+)} {.Merge(\1)}
AddSubst {\.Merge$} {.Merge(True)}
AddSubst {\.Interior\.ColorIndex = (.+)$} {.CellBackColor = CIndex2RGB(\1)}
AddSubst {\.Font\.ColorIndex = (.+)$} {.CharColor = CIndex2RGB(\1)}
AddSubst {\.ColorIndex = xlAutomatic} {\.Color = 0}
AddSubst {\.Weight = xlThin} {.OuterLineWidth = 20}
AddSubst {\.HorizontalAlignment = xlRight} {.HoriJustify = 0}
AddSubst {\.HorizontalAlignment = xlLeft} {.HoriJustify = 1}
AddSubst {\.HorizontalAlignment = xlCenter} {.HoriJustify = 2}
AddSubst {\.HorizontalAlignment = xlJustify} {.HoriJustify = 4}
#NumberFormats. Must re-fix them, as result is almost the same:
AddSubst {\.NumberFormat = \[S\]} {.NumberFormat = [CF [S]]}
#Selection:
AddSubst {Selection\.Delete Shift:=xlUp$} {ThisComponent.CurrentController.ActiveSheet.RemoveRange(ThisComponent.getCurrentSelection.RangeAddress, com.sun.star.sheet.CellDeleteMode.UP)}
AddSubst {Selection\.Delete Shift:=xlToLeft$} {ThisComponent.CurrentController.ActiveSheet.RemoveRange(ThisComponent.getCurrentSelection.RangeAddress, com.sun.star.sheet.CellDeleteMode.LEFT)}
AddSubst {(\S+)\.Select$} {ThisComponent.CurrentController.Select(\1)}
#WorkSheets:
AddSubst {^Sheets\(\[S\]\)} {ThisComponent.Sheets.getByName([S])}
AddSubst {([ \(])Sheets\(\[S\]\)} {\1ThisComponent.Sheets.getByName([S])}
AddSubst {^Sheets\((\w+)\)} {ThisComponent.Sheets.getByIndex([C \1])}
AddSubst {([ \(])Sheets\((\w+)\)} {\1ThisComponent.Sheets.getByIndex([C \2])}
AddSubst {\.Worksheets\(\[S\]\)} {.Sheets.getByName([S])}
AddSubst {\.Worksheets\((\w+)\)} {.Sheets.getByIndex([C \1])}
#Rows access is tricky:
AddSubst {\.Rows\((.+)\)\.Delete Shift:=xl.+$} {.GetRows().RemoveByIndex([RD \1])}
#This is quite another thing:
AddSubst {\.Rows\((.+?)\)\.} {.getCellRangeByName([RA \1]).}
AddSubst {\.Columns\((.+?)\)\.} {.Columns([C \1]).}
#Ranges:
AddSubst {As Range} {As Object}
AddSubst {\.Range\((.+)\)\.Value = (\w+)$} {.Range(\1).setDataArray(\2)}
#Deletion first:
AddSubst {(.+)\.Range\((.+)\)\.Delete Shift:=xlToLeft} {\1.RemoveRange(\1.Range(\2).RangeAddress, com.sun.star.sheet.CellDeleteMode.LEFT)}
AddSubst {(.+)\.Range\((.+)\)\.Delete Shift:=xlUp} {\1.RemoveRange(\1.Range(\2).RangeAddress, com.sun.star.sheet.CellDeleteMode.UP)}
#Multiple ranges:
AddSubst {Set (.+) = Union\(\1, (.+)\)$} {\1.addRangeAddress(\2.RangeAddress, false)}
#ANY range assigment -> multiple range:
AddSubst {Set (.+) = (.+\.Range\(.+\))$} "\\1 = ThisComponent.createInstance(\"com.sun.star.sheet.SheetCellRanges\")\n\\1.addRangeAddress(\\2.RangeAddress, false)"
#Usual manipulation then:
AddSubst { Range\(} { ThisComponent.CurrentController.ActiveSheet.Range(}
AddSubst {^Range\(} {ThisComponent.CurrentController.ActiveSheet.Range(}
AddSubst {\.Range\(\.?Cells\((.+?), (.+?)\), \.?Cells\((.+?), (.+?)\)\)} {.getCellRangeByPosition([C {\2}], [C {\1}], [C {\4}], [C {\3}])}
AddSubst {\.Range\(} {.getCellRangeByName(}
#Cell values must be DECREASED by ONE to please OO:
AddSubst {([ \(])Cells\.} {\1ThisComponent.CurrentController.ActiveSheet.}
AddSubst {([ \(])Cells\)} {\1ThisComponent.CurrentController.ActiveSheet)}
AddSubst {([ \(])Cells\(} {\1ThisComponent.CurrentController.ActiveSheet.Cells(}
AddSubst {^Cells\(} {ThisComponent.CurrentController.ActiveSheet.Cells(}
AddSubst {\.Cells\((.+?), (.+?)\)\.Value} {.getCellByPosition([C {\2}], [C {\1}]).FormulaLocal}
AddSubst {\.Cells\((.+?), (.+?)\)\.} {.getCellByPosition([C {\2}], [C {\1}]).}
#Misc:
AddSubst {.Clear$} {.clearContents(com.sun.star.sheet.CellFlags.VALUE + com.sun.star.sheet.CellFlags.STRING + com.sun.star.sheet.CellFlags.DATETIME + com.sun.star.sheet.CellFlags.ANNOTATION + com.sun.star.sheet.CellFlags.FORMULA + com.sun.star.sheet.CellFlags.HARDATTR + com.sun.star.sheet.CellFlags.STYLES + com.sun.star.sheet.CellFlags.OBJECTS + com.sun.star.sheet.CellFlags.EDITATTR)}
AddSubst {.ClearContents$} {.clearContents(com.sun.star.sheet.CellFlags.VALUE + com.sun.star.sheet.CellFlags.STRING +com.sun.star.sheet.CellFlags.DATETIME)}
AddSubst {ThisComponent\.ScreenUpdating = False} "ThisComponent.LockControllers\nThisComponent.CurrentController.Frame.ContainerWindow.Enable = False"
AddSubst {ThisComponent\.ScreenUpdating = True} "ThisComponent.UnLockControllers\nThisComponent.CurrentController.Frame.ContainerWindow.Enable = True"
AddSubst {(\w+)\.Show} "ActiveDialog = CreateUnoDialog(DialogLibraries.Standard.\\1)\n\\1.UserForm_Activate()\nActiveDialog.execute()"
AddSubst {Unload Me} {ActiveDialog.EndExecute()}
AddSubst {UserForm\w+\.Caption = } {ActiveDialog.Title = }
AddSubst {\.StatusBar = (.+)$} {.CurrentController.StatusIndicator.Start(\1,0)}
#This also registers subst for recordset:
AddSubst {Dim (.+) As ADODB\.Recordset} {Dim \1 As Object[AR {\1}]}
AddSubst {As ADODB\.\w+} {As Object}
AddSubst {As Currency} {As Double}
AddSubst {As WorkSheet} {As Object}
AddSubst {As MSComctlLib\.\w+} {As Object}
#This fixes frequent error in VBA programs, but can introduce it instead:
AddSubst {(Dim|Public|Private) (?!Sub|Function)(.+,.+ As .+)$} {[CDim \1 {\2}]}
AddSubst {ActiveWorkbook.Name} {FileNameOutOfPath(ThisComponent.getURL)}
AddSubst {ActiveWorkbook.Path} {ConvertFromURL(DirectoryNameoutofPath(ThisComponent.getURL, "/"))}
AddSubst {\.Visible} {.isVisible}
#Databases:
AddSubst {conn\.Open (.+)$} "DataSource = createUnoService(\"com.sun.star.comp.dba.ODatabaseSource\")\nDataSource.URL = \"sdbc:ado:\" \\& \\1\nconn = DataSource.GetConnection(\"\", \"\")"
#Not good, but still acceptable:
AddSubst {Module1.conn.ConnectionString = (.+)$} "DataSource = createUnoService(\"com.sun.star.comp.dba.ODatabaseSource\")\nDataSource.URL = \"sdbc:ado:\" \\& \\1\nModule1.conn = DataSource.GetConnection(\"\", \"\")"
#Destroyed, as ConnectionString must be set before:
AddSubst {.+conn\.Open$} {}
AddSubst {conn\.State = adStateClosed} {conn.isClosed()}
AddSubst {conn\.State <> adStateClosed} {Not conn.isClosed()}
AddSubst {Module1\.conn\.State <> adStateClosed} {Not Module1.conn.isClosed()}
AddSubst {\.EOF} {.isAfterLast}
AddSubst {\.MoveNext} {.next}
#Field values (by name):
AddSubst {CDbl\((\w+?)\.Fields\.Item\(\[S\]\)\.Value\)} {\1.Columns.getbyName([U [S]]).Double}
AddSubst {CDate\((\w+?)\.Fields\.Item\(\[S\]\)\.Value\)} {\1.Columns.getbyName([U [S]]).Date}
AddSubst {CStr\((\w+?)\.Fields\.Item\(\[S\]\)\.Value\)} {\1.Columns.getbyName([U [S]]).String}
AddSubst {CInt\((\w+?)\.Fields\.Item\(\[S\]\)\.Value\)} {\1.Columns.getbyName([U [S]]).Int}
AddSubst {CLng\((\w+?)\.Fields\.Item\(\[S\]\)\.Value\)} {\1.Columns.getbyName([U [S]]).Int}
#Field values (by index):
AddSubst {CDbl\((\w+?)\.Fields\.Item\(([^)]+?)\)\.Value\)} {\1.getDouble([CR {\2}])}
AddSubst {CDate\((\w+?)\.Fields\.Item\(([^)]+?)\)\.Value\)} {\1.getDate([CR {\2}])}
AddSubst {CStr\((\w+?)\.Fields\.Item\(([^)]+?)\)\.Value\)} {\1.getString([CR {\2}])}
AddSubst {CLng\((\w+?)\.Fields\.Item\(([^)]+?)\)\.Value\)} {\1.getInt([CR {\2}])}
AddSubst {CInt\((\w+?)\.Fields\.Item\(([^)]+?)\)\.Value\)} {\1.getInt([CR {\2}])}
#This uses accessory function to shimmer to number or date, if possible:
AddSubst {(\w+)\.Fields\.Item\(\[S\]\)\.Value} {FixType(\1.Columns.getbyName([U [S]]).string)}
AddSubst {(\w+)\.Fields\.Item\(([^)]+?)\)\.Value} {FixType(\1.getString([CR {\2}]))}
#Count of fields:
AddSubst {\.Fields\.Count} {.Columns.Count}
#Not correct, but can be tolerated (multiline fails):
AddSubst {\.CommandText = (.+)$} "Statement = conn.createStatement()\nStatement.QueryTimeOut = 0\nStatement.executeUpdate(\\1)\nStatement.close()"
convmfix.tcl:
#convmfix.tcl
#Tries to fix converted module:
#1. Removes useless 'With / End With'
#2. Deletes definitions of unused variables.
#3. Tries to replace FixType with something sensible.
#----------------------------------------------------------------
#AST is a list of nodes with structure: {root {children} {properties}}
#B -- binary operator, U -- unary/binary operator, E -- end of expression,
#UP --- unary preceeding. E -- end-of-expr.
array set G_TokenTypes {+ U - U if E then E else E do E while E set E ^ B \
* B and B or B xor B mod B not UP & B imp B eqv B \
/ B \\ B < B > B <= B >= B <> B = B ( ( ) ) , , : E \
with E case E select E do E new U . U dim E as B \
public E const E to B sub E function E on E end E \
error E resume E := B private E for E call E step E \
elseif E each E in E enum E exit E optional U}
#Node types: A U B V ( () , P F( F() T
array set G_OpPriorities {A 0 ( 0 F( 0 P 0 U 20 () 20 V 20 F() 20 to 1 \
imp 2 eqv 3 xor 4 or 5 and 6 not 7 \
< 8 <= 8 = 8 >= 8 > 8 <> 8 := 8 as 8 \
& 9 + 10 - 10 mod 11 \\ 12 * 13 / 13 ^ 14 . 15}
#---------------------------------------------------------
#For it to work, should be no "Operator" eq "Token type"
proc GetNodePriority {Node} {
upvar AST AST
foreach {NodeType OP} [lindex $AST $Node 2] break
if {$NodeType eq "B"} {
set Probe [string tolower $OP]
} else {
set Probe $NodeType
}
return $::G_OpPriorities($Probe)
}
proc DoUOpOrVConst {} {
upvar AST AST ctype ctype Token Token CNode CNode CNodeType CNodeType
set nnode [TreeCreateNode AST [list [string index $ctype 0] $Token]]
#If after VConst, ReMake CNode into Proc:
if {$CNodeType eq "V"} {lset AST $CNode 2 0 P}
TreeLinkChild AST $CNode $nnode
set CNode $nnode
return
}
proc DoBinOp {} {
upvar AST AST Token Token CNode CNode
set nnode [TreeCreateNode AST [list B $Token]]
set COPPriority [GetNodePriority $nnode]
while {1} {
set CNodeRoot [lindex $AST $CNode 0]
set CRootNodePriority [GetNodePriority $CNodeRoot]
if {$COPPriority>$CRootNodePriority} break
set CNode $CNodeRoot
}
TreeInsertNodeAsRoot AST $CNode $nnode
set CNode $nnode
return
}
proc Line2AST {line} {
global G_TokenTypes
set InStrFlag 0
set sidx 0
#Parser flags and vars:
set AST [list]
set CNode [TreeCreateNode AST [list A A]]
while {1} {
if {![regexp -indices -start $sidx \
{:=|\<\>|\<=|\>=|[^ ]|[0-9]+?\.?[0-9]*?|\.[0-9]+?|[0-9a-zA-Z_]+?} $line Res]} break
set Token [string trim [string range $line {*}$Res]]
#Set current index after this token:
set sidx [expr {[lindex $Res 1]+1}]
if {$Token eq "\""} {
#Must output string constant as whole at once:
while {1} {
set eidx [string first "\"" $line $sidx]
if {$eidx==-1} {error "Unterminated string constant"}
append Token [string range $line $sidx $eidx]
set sidx [expr {$eidx+1}]
if {[string index $line $sidx] eq "\""} {
append Token "\""
incr sidx
} else break
}
}
if {$Token eq "'"} {
set nnode [TreeCreateNode AST [list ' [string range $line $sidx-1 end]]]
TreeLinkChild AST 0 $nnode
break
}
#Now get token type:
set lToken [string tolower $Token]
if {[info exists G_TokenTypes($lToken)]} {
set ctype $G_TokenTypes($lToken)
} else {
set ctype V
}
#Process token here:
#Token types: U UP B V ( ) E ,
#Node types: A U B V ( () , P F( F() T
set CNodeType [lindex $AST $CNode 2 0]
switch -exact -- $ctype {
UP -
V {
if {$CNodeType in [list () F()]} {error "Misplaced uop/vconst $Token"}
DoUOpOrVConst
}
U {
if {$CNodeType in [list V () F()]} {
DoBinOp
} else {
DoUOpOrVConst
}
}
B {
if {$CNodeType ni [list V () F()]} {error "Misplaced binop $Token"}
DoBinOp
}
( {
if {$CNodeType in [list () F()]} {error "Misplaced ("}
if {$CNodeType eq "V"} {
#Remake CNode into function:
lset AST $CNode 2 0 F(
} else {
set nnode [TreeCreateNode AST [list ( (]]
TreeLinkChild AST $CNode $nnode
set CNode $nnode
}
}
) {
if {$CNodeType in [list U B]} {error "Misplaced )"}
while {[lindex $AST $CNode 2 0] ni [list ( F(]} {
set CNode [lindex $AST $CNode 0]
if {$CNode==-1} {
#error "Unmatched )" ; #Relaxed
TreeLinkChild AST 0 [TreeCreateNode AST [list T $Token]]
set CNode 0
break
}
}
if {$CNode>0} {
set CNType [lindex $AST $CNode 2 0]
lset AST $CNode 2 0 "$CNType)"
}
}
E {
if {$CNodeType eq "B"} {
set ctype V
DoUOpOrVConst
} else {
#Just add it to AST root:
TreeLinkChild AST 0 [TreeCreateNode AST [list T $Token]]
set CNode 0
}
}
, {
if {$CNodeType in [list U B]} {error "Misplaced ,"}
while {[lindex $AST $CNode 2 0] ni [list A P ( F(]} {
set CNode [lindex $AST $CNode 0]
}
#If 'A' is reached, turn "," into terminal:
if {[lindex $AST $CNode 2 0] eq "A"} {
TreeLinkChild AST $CNode [TreeCreateNode AST [list T ,]]
}
}
default {
error "Unknown TOKEN type $ctype"
}
}
}
if {[lindex $AST $CNode 2 0] in [list U B]} {
error "Operator at end of expression"
}
return $AST
}
#-----
proc TreeCreateNode {treename props} {
upvar $treename tree
set idx [llength $tree]
lappend tree [list -1 [list] $props]
return $idx
}
proc TreeLinkChild {treename parent child} {
upvar $treename tree
if {$parent>[llength $tree]} {error "Parent $parent > nodes in tree"}
if {$child>[llength $tree]} {error "Child $child > nodes in tree"}
#Add child node into list of root nodes:
set pchildren [lindex $tree $parent 1]
if {[lsearch -exact $pchildren $child]!=-1} {
error "$child is already child of $parent"
}
lappend pchildren $child
lset tree $parent 1 $pchildren
if {[lindex $tree $child 0] != -1} {error "Child $child already has parent"}
lset tree $child 0 $parent
return
}
# ->1 ->
#A->2 => A->
# ->5 -> + ->5
proc TreeInsertNodeAsRoot {treename node newnode} {
upvar $treename tree
if {$node>[llength $tree]} {error "Node $node > nodes in tree"}
if {$newnode>[llength $tree]} {error "Newnode $newnode > nodes in tree"}
if {[llength [lindex $tree $newnode 1]]>0} {error "Newnode $newnode has children"}
set NodeRoot [lindex $tree $node 0]
if {$NodeRoot == -1} {error "Node $node has no root"}
lset tree $newnode 0 $NodeRoot
lset tree $node 0 $newnode
lset tree $NodeRoot 1 end $newnode
lset tree $newnode 1 $node
return
}
proc AST2Line {AST} {
set Line ""
AST2LineWalkNode 0
return $Line
}
proc AST2LineWalkNode {nodeidx} {
upvar AST AST Line Line
foreach {Type Token} [lindex $AST $nodeidx 2] break
switch -exact -- $Type {
U {
append Line $Token
if {$Token ni [list . - +]} {append Line " "}
AST2LineWalkNode [lindex $AST $nodeidx 1 0]
}
B {
AST2LineWalkNode [lindex $AST $nodeidx 1 0]
if {$Token in [list . := :]} {
append Line $Token
if {$Token eq ":"} {append Line " "}
} else {
append Line " " $Token " "
}
AST2LineWalkNode [lindex $AST $nodeidx 1 1]
}
T {
if {$Token in [list , : )]} {set Line [string range $Line 0 end-1]}
append Line $Token
}
' -
V {
append Line $Token
}
F() {
append Line $Token "("
set eidx [lindex $AST $nodeidx 1 end]
foreach childidx [lindex $AST $nodeidx 1] {
AST2LineWalkNode $childidx
if {$childidx!=$eidx} {
append Line ", "
}
}
append Line ")"
}
F( {
append Line $Token "("
set eidx [lindex $AST $nodeidx 1 end]
foreach childidx [lindex $AST $nodeidx 1] {
AST2LineWalkNode $childidx
if {$childidx!=$eidx} {
append Line ", "
}
}
}
P {
#Don't add "," before comment:
append Line $Token " "
#Flag not first:
set fnf 0
foreach childidx [lindex $AST $nodeidx 1] {
if {$fnf } {
if {[lindex $AST $childidx 2 0] ne "'"} {
append Line ","
}
append Line " "
} else {
set fnf 1
}
AST2LineWalkNode $childidx
}
}
A {
set eidx [lindex $AST $nodeidx 1 end]
foreach childidx [lindex $AST $nodeidx 1] {
AST2LineWalkNode $childidx
if {$childidx!=$eidx} {
append Line " "
}
}
}
( {
append Line "("
AST2LineWalkNode [lindex $AST $nodeidx 1 0]
}
() {
append Line "("
AST2LineWalkNode [lindex $AST $nodeidx 1 0]
append Line ")"
}
default {
error "Unknown node type $Type"
}
}
return
}
#Must find types of nodes, as much as possible.
#Basic types are: Double (Int), String, Date and Unknown.
#Types are created by some nodes and moved down and up the tree.
proc InferTypesAST {AST} {
set NodeTypes [lrepeat [llength $AST] U]
InferASTNodeType 0 U
return $NodeTypes
}
#Result type, then argument types:
set G_FunTypes(fixtype) [list U S]
set G_FunTypes(cstr) [list S U]
set G_FunTypes(cdbl) [list N U]
set G_FunTypes(cdate) [list D U]
set G_FunTypes(cint) [list N U]
set G_FunTypes(getdouble) [list N N]
set G_FunTypes(getint) [list N N]
set G_FunTypes(getstring) [list S N]
set G_FunTypes(getdate) [list D N]
set G_FunTypes(year) [list N D]
set G_FunTypes(month) [list N D]
set G_FunTypes(day) [list N D]
set G_FunTypes(weekday) [list N D N]
set G_FunTypes(round) [list N N N]
set G_FunTypes(datediff) [list N S D D]
set G_FunTypes(ubound) [list N U]
set G_FunTypes(abs) [list N N]
#E is error, otherwise it's root type.
#If absent in the table, root type is unknown.
set G_InferRoot(-,D,D) N
set G_InferRoot(-,D,N) D
set G_InferRoot(-,N,D) E
set G_InferRoot(-,N,N) N
set G_InferRoot(+,S,S) S
set G_InferRoot(+,N,N) N
set G_InferRoot(+,N,D) D
set G_InferRoot(+,D,N) D
set G_InferRoot(+,D,D) E
proc InferASTNodeType {nodeidx RootType} {
upvar AST AST NodeTypes NodeTypes
global G_VarTypes G_FunTypes G_LocalVarTypes G_InferRoot
foreach {CNodeType Token} [lindex $AST $nodeidx 2] break
set Token [string tolower $Token]
switch -exact $CNodeType {
V {
#VConst --- accepts type from root, and passes its type up (can
#have type if Dim'ed or string/numeric constant).
set SelfType U
if {[info exists G_VarTypes($Token)]} {
set SelfType $G_VarTypes($Token)
} elseif {[info exists G_LocalVarTypes($Token)]} {
set SelfType $G_LocalVarTypes($Token)
} elseif {[string is double -strict $Token]} {
set SelfType N
} elseif {[string index $Token 0] eq "\""} {
set SelfType S
}
if {$SelfType eq "U"} {
lset NodeTypes $nodeidx $RootType
return $RootType
}
if {$RootType eq "U"} {
lset NodeTypes $nodeidx $SelfType
return $SelfType
}
if {$SelfType!=$RootType} {
error "Conflicting type for node $nodeidx: [lindex $AST $nodeidx]\n\
Root:$RootType\n $SelfType\n"
}
lset NodeTypes $nodeidx $SelfType
return $SelfType
}
U {
#Unary operators: + and - create, pass and return Numeric.
#/CHECK/ What if line starts with "+"?
if {$Token in [list + -]} {
lset NodeTypes $nodeidx N
if {$RootType ni [list N U]} {
error "Conflicting type for node\
$nodeidx: [lindex $AST $nodeidx]\n\
Root:$RootType\n N\n"
}
set ChildType [InferASTNodeType [lindex $AST $nodeidx 1 0] N]
if {$ChildType ne "N"} {
error "Conflicting type for node\
$nodeidx: [lindex $AST $nodeidx]\n\
Child:$ChildType\n N\n"
}
return N
} else {
#/CHECK/ IT:
InferASTNodeType [lindex $AST $nodeidx 1 0] U
lset NodeTypes $nodeidx U
return U
}
}
B {
# Operators + and - require complex processing.
switch -exact $Token {
+ {
foreach {ch1idx ch2idx} [lindex $AST $nodeidx 1] break
if {$RootType eq "S"} {
#Both children must be strings:
set ChildType1 [InferASTNodeType $ch1idx S]
set ChildType2 [InferASTNodeType $ch2idx S]
set res S
} elseif {$RootType eq "N"} {
#Both children must be numbers:
set ChildType1 [InferASTNodeType $ch1idx N]
set ChildType2 [InferASTNodeType $ch2idx N]
set res N
} else {
set ChildType1 [InferASTNodeType $ch1idx U]
set ChildType2 [InferASTNodeType $ch2idx U]
#Infer children:
#If S,U or U,S -> set another=S
if {$ChildType1 eq "S" && $ChildType2 eq "U"} {
set ChildType2 [InferASTNodeType $ch2idx S]
}
if {$ChildType1 eq "U" && $ChildType2 eq "S"} {
set ChildType1 [InferASTNodeType $ch1idx S]
}
#If RootType is D, can infer other child:
if {$RootType eq "D"} {
if {$ChildType1 eq "U" && $ChildType2 eq "D"} {
set ChildType1 [InferASTNodeType $ch1idx N]
}
if {$ChildType1 eq "D" && $ChildType2 eq "U"} {
set ChildType2 [InferASTNodeType $ch2idx N]
}
}
#Infer/check RootType:
if {($ChildType1 eq "S" && $ChildType2 ne "S") ||
($ChildType1 ne "S" && $ChildType2 eq "S")} {
error "Conflicting type for node $nodeidx:\
[lindex $AST $nodeidx]\n\
1:$ChildType1\n 2:$ChildType2\n"
}
set res U
if {[info exists G_InferRoot(+,$ChildType1,$ChildType2)]} {
set res $G_InferRoot(+,$ChildType1,$ChildType2)
if {$res eq "E"} {
error "Conflicting type for node $nodeidx:\
[lindex $AST $nodeidx]\n\
1:$ChildType1\n 2:$ChildType2\n"
}
}
}
#Check if RootType conflicts infered:
if {$RootType ne "U" && $res ne "U" && $RootType ne $res} {
error "Conflicting type for node $nodeidx:\
[lindex $AST $nodeidx]\n\
RootType:$RootType\n Inf.Root:$res\n"
}
lset NodeTypes $nodeidx $res
return $res
}
- {
if {$RootType eq "S"} {
error "Conflicting type for node $nodeidx:\
[lindex $AST $nodeidx]\n\
Root:$RootType\n"
}
foreach {ch1idx ch2idx} [lindex $AST $nodeidx 1] break
#So, if RootType is D, use it to infer:
if {$RootType eq "D"} {
set ChildType1 [InferASTNodeType $ch1idx D]
set ChildType2 [InferASTNodeType $ch2idx N]
set res D
} else {
set ChildType1 [InferASTNodeType $ch1idx U]
set ChildType2 [InferASTNodeType $ch2idx U]
#In this case: U,D => D,D->N
if {$ChildType1 eq "U" && $ChildType2 eq "D"} {
set ChildType1 [InferASTNodeType $ch1idx D]
}
#In this case: N,U => N,N->N
if {$ChildType1 eq "N" && $ChildType2 eq "U"} {
set ChildType2 [InferASTNodeType $ch2idx N]
}
#Check/infer root type:
if {$ChildType1 eq "S" || $ChildType2 eq "S"} {
error "Conflicting type for node $nodeidx:\
[lindex $AST $nodeidx]\n\
1:$ChildType1\n 2:$ChildType2\n"
}
set res U
if {[info exists G_InferRoot(-,$ChildType1,$ChildType2)]} {
set res $G_InferRoot(-,$ChildType1,$ChildType2)
if {$res eq "E"} {
error "Conflicting type for node $nodeidx:\
[lindex $AST $nodeidx]\n\
1:$ChildType1\n 2:$ChildType2\n"
}
}
}
#Check if RootType conflicts infered:
if {$RootType ne "U" && $res ne "U" && $RootType ne $res} {
error "Conflicting type for node $nodeidx:\
[lindex $AST $nodeidx]\n\
RootType:$RootType\n Inf.Root:$res\n"
}
lset NodeTypes $nodeidx $res
return $res
}
^ - * - \\ - to - and - or - xor - imp - eqv - mod - / {
#Root must be U or N:
if {$RootType ni [list U N]} {
error "Conflicting type for node $nodeidx: [lindex $AST $nodeidx]\n\
Root:$RootType\n N\n"
}
lset NodeTypes $nodeidx N
foreach childidx [lindex $AST $nodeidx 1] {
set ChildType [InferASTNodeType $childidx N]
if {$ChildType ne "N"} {
error "Conflicting type returned: $ChildType"
}
}
return N
}
& {
#Root must be U or S:
if {$RootType ni [list U S]} {
error "Conflicting type for node $nodeidx: [lindex $AST $nodeidx]\n\
Root:$RootType\n S\n"
}
lset NodeTypes $nodeidx S
foreach childidx [lindex $AST $nodeidx 1] {
set ChildType [InferASTNodeType $childidx S]
if {$ChildType ne "S"} {
error "Conflicting type returned: $ChildType"
}
}
return S
}
. {
#Must transfer type of root to right child, and raise from it:
foreach {ch1idx ch2idx} [lindex $AST $nodeidx 1] break
InferASTNodeType $ch1idx U
set ChildType2 [InferASTNodeType $ch2idx $RootType]
if {$RootType ne "U" && $ChildType2 ne "U" \
&& $RootType ne $ChildType2} {
error "Conflicting type for node $nodeidx: [lindex $AST $nodeidx]\n\
Root:$RootType\n ChildType2:$ChildType2\n"
}
lset NodeTypes $nodeidx $ChildType2
return $ChildType2
}
< - > - <= - >= - <> - = {
#Root must be U or N:
if {$RootType ni [list U N]} {
error "Conflicting type for node $nodeidx: [lindex $AST $nodeidx]\n\
Root:$RootType\n N\n"
}
lset NodeTypes $nodeidx N
#All children must be of the same type:
foreach {ch1idx ch2idx} [lindex $AST $nodeidx 1] break
set ChildType1 [InferASTNodeType $ch1idx U]
#Use infered type right now:
set ChildType2 [InferASTNodeType $ch2idx $ChildType1]
if {$ChildType1 ne "U" && $ChildType2 ne "U"} {
if {$ChildType1 ne $ChildType2} {
error "Conflicting type for children of\
node $nodeidx: [lindex $AST $nodeidx]\n\
1:$ChildType1\n 2:$ChildType2\n"
}
return N
}
if {$ChildType1 eq "U" && $ChildType2 eq "U"} {return N}
#So, just one of them is "U":
if {$ChildType1 eq "U"} {
set ChildType1 [InferASTNodeType $ch1idx $ChildType2]
} else {
set ChildType2 [InferASTNodeType $ch2idx $ChildType1]
}
if {$ChildType1 ne "U" && $ChildType2 ne "U"} {
if {$ChildType1 ne $ChildType2} {
error "Conflicting type for children of\
node $nodeidx: [lindex $AST $nodeidx]\n\
1:$ChildType1\n 2:$ChildType2\n"
}
}
return N
}
default {
#Don't care, just pass inferation down:
foreach chidx [lindex $AST $nodeidx 1] {
InferASTNodeType $chidx U
}
return U
}
}
}
F() -
F( {
#Some functions set types of their arguments (use lists of types).
#Types DON'T pass thru them, but can be set on it if return type is U.
#Examples: Date DateSerial(Int, Int, Int), Variant FixType(Variant)
if {[info exists G_FunTypes($Token)]} {
set FType [lindex $G_FunTypes($Token) 0]
set NumChildren [llength [lindex $AST $nodeidx 1]]
set ArgTypes [lrange $G_FunTypes($Token) 1 $NumChildren]
if {$FType eq "U"} {
lset NodeTypes $nodeidx $RootType
} else {
lset NodeTypes $nodeidx $FType
if {$FType ne "U" && $RootType ne "U" && $FType ne $RootType} {
error "Conflicting type for node\
$nodeidx: [lindex $AST $nodeidx]\n\
Root: $RootType\n $FType\n"
}
}
foreach childidx [lindex $AST $nodeidx 1] childtype $ArgTypes {
InferASTNodeType $childidx $childtype
}
return [lindex $NodeTypes $nodeidx]
} else {
#Accepts and returns root type:
lset NodeTypes $nodeidx $RootType
foreach childidx [lindex $AST $nodeidx 1] {
InferASTNodeType $childidx U
}
return $RootType
}
}
( -
() {
#Just pass types up and down:
set ChildType [InferASTNodeType [lindex $AST $nodeidx 1 0] $RootType]
if {$ChildType ne "U" && $RootType ne "U" && $ChildType ne $RootType} {
error "Conflicting type for node $nodeidx: [lindex $AST $nodeidx]\n\
Root:$RootType\n $ChildType\n"
}
if {$RootType ne "U"} {
set SelfType $RootType
} else {
set SelfType $ChildType
}
lset NodeTypes $nodeidx $SelfType
return $SelfType
}
A -
P -
T {
#Root, Terminals and Procs generate unknowns, passing them down.
#They are impassable up.
lset NodeTypes $nodeidx U
foreach childidx [lindex $AST $nodeidx 1] {
InferASTNodeType $childidx U
}
return U
}
}
}
#This must return new string with FixType replaced, if possible:
proc RemoveFixType {AST NodeTypes} {
RemoveFixNode 0
return $AST
}
proc RemoveFixNode {nodeidx} {
upvar AST AST NodeTypes NodeTypes
foreach {Type Token} [lindex $AST $nodeidx 2] break
if {$Type in [list F() F(] && [string tolower $Token] eq "fixtype" \
&& [lindex $NodeTypes $nodeidx] ne "U"} {
#So, this FixType can be replaced:
set FtRoot [lindex $AST $nodeidx 0]
set FtChild [lindex $AST $nodeidx 1 0]
set NewFtRootChildren [list]
foreach nidx [lindex $AST $FtRoot 1] {
if {$nidx == $nodeidx} {set nidx $FtChild}
lappend NewFtRootChildren $nidx
}
lset AST $FtRoot 1 $NewFtRootChildren
lset AST $FtChild 0 $FtRoot
#"getstring" node index:
set getstridx [lindex $AST $FtChild 1 1]
set NewType [lindex $NodeTypes $nodeidx]
set NewFunc getString
switch -exact -- $NewType {
N {set NewFunc getDouble}
D {set NewFunc getDate}
}
lset AST $getstridx 2 1 $NewFunc
}
#Remove unneeded conversions, too:
if {$Type in [list F() F(] \
&& [string tolower $Token] in [list cdbl cstr cdate]} {
set FunType [lindex $::G_FunTypes([string tolower $Token]) 0]
set ConvChild [lindex $AST $nodeidx 1 0]
if {[lindex $NodeTypes $ConvChild] eq $FunType} {
lset AST $nodeidx 2 [list () (]
}
}
foreach chidx [lindex $AST $nodeidx 1] {
RemoveFixNode $chidx
}
return
}
#----------------------------------------------------------------
proc StartWith {line} {
upvar WithsLevel WithsLevel NoWithUseFlag NoWithUseFlag WithsStack WithsStack
upvar WithStart WithStart CLines CLines
lappend WithsStack $WithStart $CLines $NoWithUseFlag
incr WithsLevel
set WithStart $line
set NoWithUseFlag 1
set CLines ""
}
proc EndWith {line} {
upvar WithsLevel WithsLevel NoWithUseFlag NoWithUseFlag WithsStack WithsStack
upvar WithStart WithStart CLines CLines
if {!$WithsLevel} {error "Unclosed WITH!"}
set CClines $CLines
set CNoWithUseFlag $NoWithUseFlag
set CWithStart $WithStart
lassign [lrange $WithsStack end-2 end] WithStart CLines NoWithUseFlag
set WithsStack [lrange $WithsStack 0 end-3]
if {$CNoWithUseFlag} {
append CLines $CClines
} else {
append CLines $CWithStart "\n"
append CLines $CClines
append CLines $line "\n"
}
incr WithsLevel -1
}
proc FixModuleFile {fname ofname} {
global G_Cfdata
set fd [open $fname]
fconfigure $fd -encoding cp1251
set fdata [read $fd]
close $fd
set G_Cfdata ""
set WithsLevel 0
set NoWithUseFlag 1
set CLines ""
set WithStart ""
set WithsStack [list]
foreach nline [split $fdata "\n"] {
#Check first, as it can be: "With .Something"
if {[regexp {[ \t(]\.} $nline]} {set NoWithUseFlag 0}
if {[regexp {^[ \t]*With } $nline]} {
StartWith $nline
continue
}
if {[regexp {^[ \t]*End With$} $nline]} {
EndWith $nline
if {!$WithsLevel} {
append G_Cfdata $CLines
set CLines ""
}
continue
}
#It's usual line here:
if {$WithsLevel} {
append CLines $nline "\n"
} else {
append G_Cfdata $nline "\n"
}
}
RemoveUnusedVariables
ReplaceFixTypes
ReIndentModule
set ofd [open $ofname w]
fconfigure $ofd -encoding cp1251
puts -nonewline $ofd $G_Cfdata
close $ofd
}
proc ConvTypeName2Type {TypeName} {
switch -exact -- $TypeName {
Double {set VarType N}
Integer {set VarType N}
Byte {set VarType N}
Long {set VarType N}
Boolean {set VarType N}
String {set VarType S}
Date {set VarType D}
default {set VarType U}
}
return $VarType
}
proc ReplaceFixTypes {} {
global G_Cfdata G_VarTypes G_LocalVarTypes G_FunTypes
set State 0
set odata ""
set FlagCollectFun 0
set funline ""
foreach nline [split $G_Cfdata "\n"] {
#Start processing the line:
#Try to collect multiline functions:
if {$FlagCollectFun \
|| [regexp -nocase {^\s*(?:Private )?Function } $nline]} {
set State 1
#Get this function name and types here, if possible:
append funline " " $nline
if {[string index $nline end] eq "_"} {
set FlagCollectFun 1
} else {
set FlagCollectFun 0
set fargs [list]
#So, function ended, process it:
#Get its name first:
regexp {Function (\w+)} $funline All FName
set FName [string tolower $FName]
#Basic units are: "VarName as SomeType"
set sidx 0
while {1} {
if {![regexp -indices -start $sidx \
{(?:\w+) As (\w+)} $funline All VTypeI]} break
set sidx [expr {[lindex $All 1]+1}]
set VType [string range $funline {*}$VTypeI]
lappend fargs [ConvTypeName2Type $VType]
}
#Not get function type: ") as SomeType"
regexp -start $sidx {\) As (\w+)} $funline All VType
set G_FunTypes($FName) [linsert $fargs 0 [ConvTypeName2Type $VType]]
set funline ""
}
#Anyway:
append odata $nline "\n"
continue
}
if {[regexp -nocase {^\s*(?:Private )?Sub } $nline]} {
set State 1
append odata $nline "\n"
continue
}
if {[regexp {^\s*End (?:Function|Sub)} $nline]} {
unset -nocomplain G_LocalVarTypes
set State 0
append odata $nline "\n"
continue
}
#Arrays are defined as functions (can cause subtle bugs if global
#array is redefined as local in some sub/function):
if {[regexp -nocase {^\s*(?:Dim|Public) (\w+)\(.*\) As (\w+)} \
$nline All VName VType]} {
set FName [string tolower $VName]
set FType [ConvTypeName2Type $VType]
set G_FunTypes($FName) [list $FType N N N N N]
append odata $nline "\n"
continue
}
if {[regexp -nocase {^\s*(?:Dim|Public|Private) (\w+)[^()]* As (\w+)} \
$nline All VName VType]} {
set VName [string tolower $VName]
set VarType [ConvTypeName2Type $VType]
if {$VarType ne "U"} {
if {$State} {
set G_LocalVarTypes($VName) $VarType
} else {
set G_VarTypes($VName) $VarType
}
}
append odata $nline "\n"
continue
}
if {[regexp -nocase {fixtype\(} $nline]} {
set AST [Line2AST $nline]
set NodeTypes [InferTypesAST $AST]
set AST [RemoveFixType $AST $NodeTypes]
set nline [AST2Line $AST]
}
append odata $nline "\n"
}
set G_Cfdata $odata
}
proc RemoveUnusedVariables {} {
global G_Cfdata
set CLineNum 0
set LinesToRemove [list]
#In global definitions:
set State 0
#Global and local REs:
set GRE ""
set LRE ""
foreach nline [split $G_Cfdata "\n"] {
incr CLineNum
#Remove string constants:
set nline [regsub -all {"[^\"]*"} $nline {}]
#As strings are removed now, take out comment:
set CSt [string first ' $nline]
if {$CSt != -1} {
set nline [string range $nline 0 $CSt-1]
}
#Start processing the line:
if {[regexp -nocase {^\s*(?:Function|Sub) } $nline]} {
set State 1
continue
}
if {[regexp {^\s*End (?:Function|Sub)} $nline]} {
#Must mark all lines, clear LocalArray and LRE:
foreach {Name Idx} [array get LocalArray] {
lappend LinesToRemove $Idx
}
array unset LocalArray
set LRE ""
set State 0
continue
}
if {[regexp -nocase {^\s*(?:Dim|Public) (\w+).* As .+} $nline All VName]} {
set VName [string tolower $VName]
if {$State} {
#Local:
set LocalArray($VName) $CLineNum
if {$LRE eq ""} {
set LRE "\\m$VName\\M"
} else {
append LRE "|\\m$VName\\M"
}
} else {
#Global:
set GlobalArray($VName) $CLineNum
if {$GRE eq ""} {
set GRE "\\m$VName\\M"
} else {
append GRE "|\\m$VName\\M"
}
}
continue
}
if {$GRE ne ""} {
foreach VName [regexp -nocase -inline -all $GRE $nline] {
unset -nocomplain GlobalArray([string tolower $VName])
}
}
if {$LRE ne ""} {
foreach VName [regexp -nocase -inline -all $LRE $nline] {
unset -nocomplain LocalArray([string tolower $VName])
}
}
}
foreach {Name Idx} [array get GlobalArray] {
lappend LinesToRemove $Idx
}
#Sort, then strip lines marked for deletion:
set LinesToRemove [lsort -integer $LinesToRemove]
set odata ""
set CLineNum 0
set CIndex 0
set CLineToRemove [lindex $LinesToRemove $CIndex]
foreach nline [split $G_Cfdata "\n"] {
incr CLineNum
if {$CLineNum == $CLineToRemove} {
incr CIndex
set CLineToRemove [lindex $LinesToRemove $CIndex]
continue
}
append odata $nline "\n"
}
#Set result as new data:
set G_Cfdata $odata
}
FixModuleFile [lindex $argv 0] [lindex $argv 1]