openaccess/source/modules/vcs.bas

Option Compare Database

Public Function vcsprompt()

    DoCmd.OpenForm "frm_vcs"

End Function


'Public Function vcsprompt()
'    Dim prompt, prompttext, warning As String
'    Dim continue As Boolean
'
'    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 & _
'                 "(see docs for more commands)"
'    prompt = ""
'    continue = True
'
'    While continue
'        prompt = InputBox(prompttext, "VCS", "")
'
'        If Right(prompt, 1) = "&" Then
'            prompt = Left(prompt, Len(prompt) - 1)
'        Else
'            continue = False
'        End If
'
'        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
'
'
'            Case Else
'                MsgBox "Unknown command"
'
'        End Select
'whil:
'    Wend
'
'Exit Function
'
'End Function


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

    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

    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 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 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

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