openaccess/source/modules/vcs.bas

Option Compare Database
Dim private_optimizer As Boolean

'****
'*
'* Main methods for VCS add-in
'*
'****

Public Function vcsprompt()

    DoCmd.OpenForm "frm_vcs"

End Function


Public Function make_sources(Optional ByVal options As String = "")
'exports the source-code of the app
On Error GoTo err
Dim step As String

    step = "Initialization"
    If Not InStr(options, "-f") > 0 Then
        Dim msg As String
        msg = msg_list_modified()
        
        If Not Len(msg) > 0 Then
            msg = "Nothing new to export" & vbNewLine & _
                        "Only the following will be exported:" & vbNewLine & _
                        " - included table data" & vbNewLine & _
                        " - relations" & vbNewLine & vbNewLine & _
                        "TIP: use 'makesources -f' to force a complete export (could be long)."
            If MsgBox(msg, vbOKCancel + vbExclamation, "Export") = vbCancel Then Exit Function
        Else
            msg = "** VCS OPTIMIZER **" & vbNewLine & "Seuls les objets suivant seront exportés:" & vbNewLine & msg
            If MsgBox(msg, vbOKCancel) = vbCancel Then Exit Function
        End If
        
        Call activate_optimizer
    End If

    step = "Updates sources date"
    Debug.Print step
    Call update_sources_date
    Debug.Print "> done"

    step = "Zip the app file"
    Debug.Print step
    Call zip_app_file
    Debug.Print "> done"
    
    step = "Run VCS Export"
    Debug.Print step
    Call ExportAllSource
    Debug.Print "> done"

    Exit Function
err:
    MsgBox "makesources - Unknown error at: " & step & vbNewLine & err.Description
End Function


Public Function update_from_sources(Optional ByVal options As String = "")
'updates the application from the sources
Dim backup As Boolean

    Debug.Print "Creates a backup of the app file"
    backup = make_backup()
    
    If backup Then
        Debug.Print "> done"
    Else
        MsgBox "Error: unable to backup the app file, do it manually, then click OK"
    End If

    If MsgBox("WARNING: the current application is going to be updated " & _
                "with the source files. " & _
                "Any non committed work would be lost, " & _
                "are you sure you want to continue?" & _
                "", vbOKCancel) = vbCancel Then Exit Function

    Debug.Print "Run VCS Import"
    Call ImportAllSource
    Debug.Print "> done"
    
End Function

Public Function config_git_repo()
'configure the application GIT repository for VCS use
    
    'verify that it is a git repository
    If Not is_git_repo() Then
        MsgBox "Not a git repository, please use 'git init on this directory first"
        Exit Function
    End If
    
    ' complete the gitignore file
    Call complete_gitignore

End Function

Public Function sync()
'complete command to synchronize this app with the distant master branch

    'verify that it is a git repository
    If Not is_git_repo() Then
        MsgBox "Not a git repository, please use 'git init on this directory first"
        Exit Function
    End If

    'Call make_sources

    Call cmd("echo --ADD FILES-- & git add *" & "& timeout 2", vbNormalFocus)
    
    Dim msg As String
    msg = InputBox("Commit message:", "VCS")
    If Not Len(msg) > 0 Then GoTo err_msg
    
    Call cmd("echo --COMMIT-- & git commit -a -m " & Chr(34) & msg & Chr(34) & "& timeout 2", vbNormalFocus)
    
    Call cmd("echo --PULL-- & git pull origin master & pause", vbNormalFocus)
    
    Call update_from_sources
    
    Call cmd("echo --PUSH-- & git push origin master" & "& timeout 2", vbNormalFocus)

Exit Function
err_msg:
    MsgBox "Invalid value", vbExclamation
End Function

Public Function is_git_repo() As Boolean
    is_git_repo = (dir(CurrentProject.Path & "\.git\", vbDirectory) <> "")
End Function

Public Function get_include_tables()

If CurrentProject.name = "VCS.accda" Then
    get_include_tables = "tbl_commands,modele_ztbl_vcs"
Else
    get_include_tables = vcs_param("include_tables")
End If
End Function

Public Function vcs_param(ByVal key As String, Optional ByVal default_value As String = "") As String
    vcs_param = default_value
    On Error GoTo err_vcs_table
        vcs_param = DFirst("val", "ztbl_vcs", "[key]='" & key & "'")
err_vcs_table:
End Function

Public Function gitcmd(args)

    Call cmd("echo -- " & args & " -- & git " & args & "& pause", vbNormalFocus)

End Function

Public Function zip_app_file() As Boolean
    On Error GoTo err
    Dim command, shortname As String
    
    zip_app_file = False
    
    shortname = Split(CurrentProject.name, ".")(0)
    
    'run the shell comand
    Call cmd("cd " & CurrentProject.Path & " & " & _
             "zip tmp_" & shortname & ".zip " & CurrentProject.name & _
             " & exit")
    
    'remove the old zip file
    If dir(CurrentProject.Path & "\" & shortname & ".zip") <> "" Then
        Kill CurrentProject.Path & "\" & shortname & ".zip"
    End If
    
    'rename the temporary zip
    Call cmd("cd " & CurrentProject.Path & " & " & _
            "ren tmp_" & shortname & ".zip" & " " & shortname & ".zip" & _
            " & exit")
    
    
    zip_app_file = True

fin:
    Exit Function
UnknownErr:
    MsgBox "Unknown error: unable to ZIP the app file, do it manually"
    GoTo fin
err:
    MsgBox "Error while zipping file app: " & err.Description
    GoTo fin
End Function

Public Function make_backup() As Boolean
    On Error GoTo err
    
    make_backup = False
    If dir(CurrentProject.Path & "\" & CurrentProject.name & ".old") <> "" Then
        Kill CurrentProject.Path & "\" & CurrentProject.name & ".old"
    End If
    

    'FileCopy CurrentProject.Path & "\" & CurrentProject.name, CurrentProject.Path & "\" & CurrentProject.name & ".old"
    Call cmd("copy " & Chr(34) & CurrentProject.Path & "\" & CurrentProject.name & Chr(34) & _
             " " & Chr(34) & CurrentProject.Path & "\" & CurrentProject.name & ".old" & Chr(34))
    
    make_backup = True
    Exit Function
err:
        MsgBox "Error during backup: " & err.Description
End Function

Public Function complete_gitignore()
    ' creates or complete the .gitignore file of the repo
    Dim gitignore_path, str_existing_keys, str As String
    
    Dim keys() As String
    keys = Split("*.accdb;*.laccdb;*.mdb;*.ldb;*.accde;*.mde;*.accda", ";")
    
    gitignore_path = CurrentProject.Path & "\.gitignore"
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim oFile As Object
    If Not fso.FileExists(gitignore_path) Then
        Set oFile = fso.CreateTextFile(gitignore_path)
    Else
        Set oFile = fso.OpenTextFile(gitignore_path, ForReading)
        str_existing_keys = ""
        
        While Not oFile.AtEndOfStream
            str = oFile.readline
            If Len(str_existing_keys) = 0 Then
                str_existing_keys = str
            Else
                str_existing_keys = str_existing_keys & ";" & str
            End If
        Wend
        oFile.Close
        
        Dim existing_keys() As String
        existing_keys = Split(str_existing_keys, ";")
        
        Set oFile = fso.OpenTextFile(gitignore_path, ForAppending)
    End If
    
    oFile.WriteBlankLines (2)
    oFile.WriteLine ("#[ automatically added by VCS")
    For Each key In keys
        If Not IsInArray(key, existing_keys) Then
            oFile.WriteLine key
        End If
    Next key
    oFile.WriteLine "#]"
    oFile.WriteBlankLines (2)
    
    oFile.Close
    Set fso = Nothing
    Set oFile = Nothing

End Function

Private Function IsInArray(ByVal stringToBeFound As String, ByRef arr As Variant) As Boolean
    IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function

Function vcs_tbl_exists()
On Error GoTo err
    vcs_tbl_exists = (CurrentDb.TableDefs("ztbl_vcs").name = "ztbl_vcs")
Exit Function
err:
    If err.number = 3265 Then
        vcs_tbl_exists = False
    Else
        MsgBox "Error: " & err.Description, vbCritical
    End If
End Function

Public Function create_vcs_tbl()
    CurrentDb.execute "SELECT 'include_tables' as key, '' as val INTO ztbl_vcs " & _
                       "FROM modele_ztbl_vcs;"
End Function

Public Function update_vcs_param(ByVal key As String, ByVal val As String)

    If DCount("key", "ztbl_vcs", "[key]='" & key & "'") = 1 Then
        CurrentDb.execute "UPDATE ztbl_vcs SET ztbl_vcs.val = '" & val & "' " & _
                            "WHERE (((ztbl_vcs.key)='" & key & "'));"
    Else
        CurrentDb.execute "INSERT INTO ztbl_vcs ( val, [key] ) " & _
                           "SELECT '" & val & "' AS Expr1, '" & key & "' AS Expr2;"
    End If

End Function

Public Sub activate_optimizer()

    private_optimizer = True

End Sub

Public Function optimizer_activated()

    optimizer_activated = private_optimizer

End Function