!> Implementation for interacting with git repositories. module fpm_git use fpm_error, only: error_t, fatal_error use fpm_filesystem, only : get_temp_filename, getline, join_path, execute_and_read_output, run use tomlf, only: toml_table, toml_stat use fpm_toml, only: serializable_t, get_value, set_value, set_string implicit none public :: git_target_t, git_target_default, git_target_branch, git_target_tag, git_target_revision, git_revision, & & git_archive, git_matches_manifest, compressed_package_name !> Name of the compressed package that is generated temporarily. character(len=*), parameter :: compressed_package_name = 'compressed_package' !> Possible git target type :: enum_descriptor !> Default target integer :: default = 200 !> Branch in git repository integer :: branch = 201 !> Tag in git repository integer :: tag = 202 !> Commit hash integer :: revision = 203 !> Invalid descriptor integer :: error = -999 end type enum_descriptor !> Actual enumerator for descriptors type(enum_descriptor), parameter :: git_descriptor = enum_descriptor() !> Description of an git target type, extends(serializable_t) :: git_target_t !> Kind of the git target integer :: descriptor = git_descriptor%default !> Target URL of the git repository character(len=:), allocatable :: url !> Additional descriptor of the git object character(len=:), allocatable :: object contains !> Fetch and checkout in local directory procedure :: checkout !> Show information on instance procedure :: info !> Serialization interface procedure :: serializable_is_same => git_is_same procedure :: dump_to_toml procedure :: load_from_toml end type git_target_t !> Common output format for writing to the command line character(len=*), parameter :: out_fmt = '("#", *(1x, g0))' contains !> Default target function git_target_default(url) result(self) !> Target URL of the git repository character(len=*), intent(in) :: url !> New git target type(git_target_t) :: self self%descriptor = git_descriptor%default self%url = url end function git_target_default !> Target a branch in the git repository function git_target_branch(url, branch) result(self) !> Target URL of the git repository character(len=*), intent(in) :: url !> Name of the branch of interest character(len=*), intent(in) :: branch !> New git target type(git_target_t) :: self self%descriptor = git_descriptor%branch self%url = url self%object = branch end function git_target_branch !> Target a specific git revision function git_target_revision(url, sha1) result(self) !> Target URL of the git repository character(len=*), intent(in) :: url !> Commit hash of interest character(len=*), intent(in) :: sha1 !> New git target type(git_target_t) :: self self%descriptor = git_descriptor%revision self%url = url self%object = sha1 end function git_target_revision !> Target a git tag function git_target_tag(url, tag) result(self) !> Target URL of the git repository character(len=*), intent(in) :: url !> Tag name of interest character(len=*), intent(in) :: tag !> New git target type(git_target_t) :: self self%descriptor = git_descriptor%tag self%url = url self%object = tag end function git_target_tag !> Check that two git targets are equal logical function git_is_same(this,that) class(git_target_t), intent(in) :: this class(serializable_t), intent(in) :: that git_is_same = .false. select type (other=>that) type is (git_target_t) if (.not.(this%descriptor==other%descriptor)) return if (allocated(this%url) .neqv. allocated(other%url)) return if (allocated(this%url)) then if (.not.(this%url==other%url)) return end if if (allocated(this%object) .neqv. allocated(other%object)) return if (allocated(this%object)) then if (.not.(this%object==other%object)) return end if class default ! Not the same type return end select !> All checks passed! git_is_same = .true. end function git_is_same !> Check that a cached dependency matches a manifest request logical function git_matches_manifest(cached,manifest,verbosity,iunit) !> Two input git targets type(git_target_t), intent(in) :: cached,manifest integer, intent(in) :: verbosity,iunit git_matches_manifest = cached%url == manifest%url if (.not.git_matches_manifest) then if (verbosity>1) write(iunit,out_fmt) "GIT URL has changed: ",cached%url," vs. ", manifest%url return endif !> The manifest dependency only contains partial information (what's requested), !> while the cached dependency always stores a commit hash because it's built !> after the repo is available (saved as git_descriptor%revision==revision). !> So, comparing against the descriptor is not reliable git_matches_manifest = allocated(cached%object) .eqv. allocated(manifest%object) if (git_matches_manifest .and. allocated(cached%object)) & git_matches_manifest = cached%object == manifest%object if (.not.git_matches_manifest) then if (verbosity>1) write(iunit,out_fmt) "GIT OBJECT has changed: ",cached%object," vs. ", manifest%object end if end function git_matches_manifest subroutine checkout(self, local_path, error) !> Instance of the git target class(git_target_t), intent(in) :: self !> Local path to checkout in character(*), intent(in) :: local_path !> Error type(error_t), allocatable, intent(out) :: error integer :: stat character(len=:), allocatable :: object, workdir if (allocated(self%object)) then object = self%object else object = 'HEAD' end if workdir = "--work-tree="//local_path//" --git-dir="//join_path(local_path, ".git") call execute_command_line("git init "//local_path, exitstat=stat) if (stat /= 0) then call fatal_error(error,'Error while initiating git repository for remote dependency') return end if call execute_command_line("git "//workdir//" fetch --depth=1 "// & self%url//" "//object, exitstat=stat) if (stat /= 0) then call fatal_error(error,'Error while fetching git repository for remote dependency') return end if call execute_command_line("git "//workdir//" checkout -qf FETCH_HEAD", exitstat=stat) if (stat /= 0) then call fatal_error(error,'Error while checking out git repository for remote dependency') return end if end subroutine checkout subroutine git_revision(local_path, object, error) !> Local path to checkout in character(*), intent(in) :: local_path !> Git object reference character(len=:), allocatable, intent(out) :: object !> Error type(error_t), allocatable, intent(out) :: error integer :: stat, unit, istart, iend character(len=:), allocatable :: temp_file, line, iomsg, workdir character(len=*), parameter :: hexdigits = '0123456789abcdef' workdir = "--work-tree="//local_path//" --git-dir="//join_path(local_path, ".git") allocate(temp_file, source=get_temp_filename()) line = "git "//workdir//" log -n 1 > "//temp_file call execute_command_line(line, exitstat=stat) if (stat /= 0) then call fatal_error(error, "Error while retrieving commit information") return end if open(file=temp_file, newunit=unit) call getline(unit, line, stat, iomsg) if (stat /= 0) then call fatal_error(error, iomsg) return end if close(unit, status="delete") ! Tokenize: ! commit 0123456789abcdef (HEAD, ...) istart = scan(line, ' ') + 1 iend = verify(line(istart:), hexdigits) + istart - 1 if (iend < istart) iend = len(line) object = line(istart:iend) end subroutine git_revision !> Show information on git target subroutine info(self, unit, verbosity) !> Instance of the git target class(git_target_t), intent(in) :: self !> Unit for IO integer, intent(in) :: unit !> Verbosity of the printout integer, intent(in), optional :: verbosity integer :: pr character(len=*), parameter :: fmt = '("#", 1x, a, t30, a)' if (present(verbosity)) then pr = verbosity else pr = 1 end if if (pr < 1) return write(unit, fmt) "Git target" if (allocated(self%url)) then write(unit, fmt) "- URL", self%url end if if (allocated(self%object)) then select case(self%descriptor) case default write(unit, fmt) "- object", self%object case(git_descriptor%tag) write(unit, fmt) "- tag", self%object case(git_descriptor%branch) write(unit, fmt) "- branch", self%object case(git_descriptor%revision) write(unit, fmt) "- sha1", self%object end select end if end subroutine info !> Dump dependency to toml table subroutine dump_to_toml(self, table, error) !> Instance of the serializable object class(git_target_t), intent(inout) :: self !> Data structure type(toml_table), intent(inout) :: table !> Error handling type(error_t), allocatable, intent(out) :: error integer :: ierr call set_string(table, "descriptor", descriptor_name(self%descriptor), error, 'git_target_t') if (allocated(error)) return call set_string(table, "url", self%url, error, 'git_target_t') if (allocated(error)) return call set_string(table, "object", self%object, error, 'git_target_t') if (allocated(error)) return end subroutine dump_to_toml !> Read dependency from toml table (no checks made at this stage) subroutine load_from_toml(self, table, error) !> Instance of the serializable object class(git_target_t), intent(inout) :: self !> Data structure type(toml_table), intent(inout) :: table !> Error handling type(error_t), allocatable, intent(out) :: error !> Local variables character(len=:), allocatable :: descriptor_name call get_value(table, "descriptor", descriptor_name) self%descriptor = parse_descriptor(descriptor_name) if (self%descriptor==git_descriptor%error) then call fatal_error(error,"invalid descriptor ID <"//descriptor_name//"> in TOML entry") return end if !> Target URL of the git repository call get_value(table, "url", self%url) !> Additional descriptor of the git object call get_value(table,"object", self%object) end subroutine load_from_toml !> Parse git descriptor identifier from a string pure integer function parse_descriptor(name) character(len=*), intent(in) :: name select case (name) case ("default"); parse_descriptor = git_descriptor%default case ("branch"); parse_descriptor = git_descriptor%branch case ("tag"); parse_descriptor = git_descriptor%tag case ("revision"); parse_descriptor = git_descriptor%revision case default; parse_descriptor = git_descriptor%error end select end function parse_descriptor !> Code git descriptor to a string pure function descriptor_name(descriptor) result(name) integer, intent(in) :: descriptor character(len=:), allocatable :: name select case (descriptor) case (git_descriptor%default); name = "default" case (git_descriptor%branch); name = "branch" case (git_descriptor%tag); name = "tag" case (git_descriptor%revision); name = "revision" case default; name = "ERROR" end select end function descriptor_name !> Archive a folder using `git archive`. subroutine git_archive(source, destination, ref, additional_files, verbose, error) !> Directory to archive. character(*), intent(in) :: source !> Destination of the archive. character(*), intent(in) :: destination !> (Symbolic) Reference to be archived. character(*), intent(in) :: ref !> (Optional) list of additional untracked files to be added to the archive. character(*), optional, intent(in) :: additional_files(:) !> Print additional information if true. logical, intent(in) :: verbose !> Error handling. type(error_t), allocatable, intent(out) :: error integer :: stat,i character(len=:), allocatable :: cmd_output, archive_format, add_files call execute_and_read_output('git archive -l', cmd_output, error, verbose) if (allocated(error)) return if (index(cmd_output, 'tar.gz') /= 0) then archive_format = 'tar.gz' else call fatal_error(error, "Cannot find a suitable archive format for 'git archive'."); return end if allocate(character(len=0) :: add_files) if (present(additional_files)) then do i=1,size(additional_files) add_files = trim(add_files)//' --add-file='//adjustl(additional_files(i)) end do endif call run('git archive '//ref//' & & --format='//archive_format// & & add_files//' & & -o '//destination, & & echo=verbose, & & exitstat=stat) if (stat /= 0) then call fatal_error(error, "Error packing '"//source//"'."); return end if end end module fpm_git