openaccess/source/modules/vcs.bas

Option Compare Database

Public Function vcsprompt()
    Dim prompt, prompttext, warning As String

    prompttext = "Write your command here:" & vbNewLine & _
                 "> 'makesources' to create or update the source files" & vbNewLine & _
                 "> 'update' to update the current application within the source files" & vbNewLine & _
                 "> 'ok' to close this input box" & vbNewLine & _
                 "(see docs for more commands)"
    prompt = ""
    
    While prompt <> "ok"
        prompt = InputBox(prompttext, "VCS", "")
        
        Select Case prompt
        
        Case "makesources"
        
            Call make_sources
            MsgBox "Done"
            
        Case "update"
        
            Call update_from_sources
            MsgBox "Done"
        
        Case "sync"
        
            Call sync
            MsgBox "Done"
        
        
        Case vbNullString
            MsgBox "Operation cancelled"
            prompt = "ok"
            
        Case "ok"
        
        Case Else
            MsgBox "Unknown command"
        
        End Select
whil:
    Wend

Exit Function

End Function


Public Function make_sources()
'creates the source-code of the app

    If CodeProject.Path = CurrentProject.Path Then
        MsgBox "ERROR: you should not run VSC for VCS from here, VCS modules would not be exported" & vbNewLine & _
                "Use VCS - AddIn instead"
        Exit Function
    End If

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

End Function


Public Function update_from_sources()
'updates the application from the sources
Dim backup As Boolean

    If CodeProject.Path = CurrentProject.Path Then
        MsgBox "ERROR: you should not run VSC for VCS from here, VCS modules would not be exported" & vbNewLine & _
                "Use VCS - AddIn instead"
        Exit Function
    End If

    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()
    get_include_tables = vcs_param("include_tables")
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 zip_app_file() As Boolean
    On Error GoTo err
    Dim command As String
    
    zip_app_file = False
    
    'run the shell comand
    Call cmd("cd " & CurrentProject.Path & " & " & _
             "zip tmp_" & CurrentProject.name & ".zip " & CurrentProject.name & _
             " & exit")
    
    'remove the old zip file
    If dir(CurrentProject.Path & "\" & CurrentProject.name & ".zip") <> "" Then
        Kill CurrentProject.Path & "\" & CurrentProject.name & ".zip"
    End If
    
    'rename the temporary zip
    Call cmd("cd " & CurrentProject.Path & " & " & _
            "ren tmp_" & CurrentProject.name & ".zip" & " " & CurrentProject.name & ".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