File Coverage

blib/lib/Git/Deploy.pm

Criterion	Covered	Total	%
statement	45	619	7.2
branch	0	412	0.0
condition	0	201	0.0
subroutine	15	75	20.0
pod	0	53	0.0
total	60	1360	4.4

package Git::Deploy;

use strict;
use warnings;
use Exporter;

# generic utilities we use
use POSIX qw(strftime);
use Carp qw(confess);
use Sys::Hostname qw(hostname);
use Fcntl qw(:DEFAULT :flock);
use Cwd qw(cwd abs_path);
use File::Spec::Functions qw(catdir);
use Git::Deploy::Timing qw(push_timings);
use Git::Deploy::Say;
use Data::Dumper;

our $VERSION = '6.01'; # VERSION: generated by DZP::OurPkgVersion

our @ISA= qw(Exporter);

our @EXPORT= qw(
    $DEBUG
    $SKIP_HOOKS
    $VERBOSE

    check_if_working_dir_is_clean
    check_for_unpushed_commits
    check_rollouts_blocked
    clear_ref_info
    fetch
    fetch_tag_info
    fetch_tags
    filter_names_by_date
    filter_names_matching_head
    find_refs_matching_head
    find_tags_matching_head
    get_branches
    get_commit_for_name
    get_config
    get_config_int
    get_config_path
    get_config_bool
    get_current_branch
    get_deploy_file_name
    get_hook_dir
    get_ref_info
    get_sha1_for_name
    get_sorted_list_of_tags
    git_cmd
    git_errorcode
    git_result
    is_name_annotated_tag
    make_dated_tag
    make_tag
    parse_rollout_status
    print_refs
    pull
    push_all
    push_remote
    push_tag
    push_tags
    read_deploy_file
    read_rollout_status
    remote
    store_tag_info
    unlink_rollout_status_file
    what_branches_can_reach_head
    write_deploy_file
    write_rollout_status
    execute_deploy_hooks
    execute_log_hooks
    process_deploy_hooks
    execute_hook
    get_hook
    get_sync_hook

    _slurp
    init_gitdir
    log_directory
    reset_to_name

    _expand_template_variables
);

our $DEBUG = $ENV{GIT_DEPLOY_DEBUG} || 0;
our $SKIP_HOOKS;
our $VERBOSE;


my $gitdir;
sub init_gitdir {
    return $gitdir if $gitdir;
# test that we actually are in a git repository before we do anything non argument processing related
    $gitdir= git_result( 'git rev-parse --git-dir', 128 );
    _die "current working directory is not part of a git repository\n"
        if !$gitdir
            or $gitdir =~ /Not a git repository/;

    # XXX: Assume the root of the workdir is the parent of the gitdir
    # change directory to the root dir of the tree, so that we have a normalized
    # perspective of the repo (so .deploy and similar things end up in the expected
    # place regardless of where the tool was run from).
    chdir "$gitdir/.."
        or _die "Failed to chdir to root of git working tree:'$gitdir/..': $!";
    return $gitdir;
}


# execute a command and capture and return both its output result and its error code
sub git_cmd {
    my $cmd= shift;

    # Hack because we don't want to log in the _die, _info and _warn
    # calls below because that'll call Git::Deploy::log_directory(),
    # which will call Git::Deploy::_get_config() which will call us
    # again.
    local $Git::Deploy::Say::SKIP_LOGING_DUE_TO_DEEP_RECURSION_WITH_GIT_DEPLOY_DEBUG = 1 if $DEBUG;

    $cmd .= " 2>&1";
    my $res= `$cmd`;
    my $error_code= $?;
    if ( $error_code == -1 ) {
        _die "failed to execute '$cmd': $!\n";
    }
    elsif ( $error_code & 127 ) {
        _die sprintf "'$cmd' died with signal %d, %s coredump\n%s", ( $error_code & 127 ),
            ( $error_code & 128 ) ? 'with' : 'without', $res;
    }
    if ($DEBUG) {
        _info $cmd;
        _warn "got error code: $error_code"
            if $error_code;
        _info "result: $res";
    }
    chomp($res) if defined $res;
    return ( $res, $error_code >> 8 );
}

#execute a command and return what it output
sub git_result {
    my ( $cmd, @accept )= @_;
    my ( $res, $error_code )= git_cmd($cmd);
    if ( $error_code and !grep { $error_code == $_ } @accept ) {
        _die sprintf "'$cmd' resulted in an unexpected exit code: %d\n%s", $error_code, $res;
    }
    return $res;
}

BEGIN {
my $config_prefix= "deploy";
my %config;

my $config_file;
my $repo_name;
my $repo_name_detection;
my %repo_name_detection_values = (
    'dot-git-parent-dir' => sub {
        my $cwd = cwd();
        $cwd =~ s[.*/][];
        return $cwd;
    }
);

# _get_config($opts,$setting) # setting is mandatory!
# _get_config($opts,$setting,$default); # setting will default to $default
# $setting may either be a *fully* qualified setting name like "user.name" otherwise
# if $setting does not contain a period it will become "$config_prefix.$setting"
# if $setting _starts_ with a period it will become "$config_prefix.$setting" as well.
# $opts is any additional arguments to feed to git-config
# Note that if the setting "$config_prefix.config-file" is set then we will always
# check it first when looking up values that start with $config_prefix (others we wont bother).

sub _get_config {
    if (!defined $config_file) {
        # on first run we check to see if there is a deploy.config-file specified
        $config_file= ""; # prevent infinite loops
        $config_file= _get_config("--path","$config_prefix.config-file",""); # and now we read this from the normal configs
    }
    if (defined $config_file
        and $config_file ne ''
        and !defined $repo_name_detection) {
        $repo_name_detection = '';
        $repo_name_detection = _get_config("--path","$config_prefix.repo-name-detection","");
        if ($repo_name_detection) {
            _die "The detection method <$repo_name_detection> is invalid"
                unless my $detect = $repo_name_detection_values{$repo_name_detection};

            $repo_name = $detect->();
        }
    }
    my $opts= shift;
    my $setting= shift;
    my $has_default= @_;
    my $default= shift;
    if ( $setting =~ m/^\./ ) {
        $setting= $config_prefix . $setting;
    } elsif ( $setting !~ m/\./ )  {
        $setting= "$config_prefix.$setting";
    }
    unless ( exists $config{$setting}{$opts} ) {
        # If we have a $config_file specified and we are looking for a $config_prefix
        # config item we will want to look first in the config file, and only then look
        # in the normal git config files if there is nothing specified in the $config_file.

        my @setting_internal_name = $setting;
        if ($setting=~/^\Q$config_prefix\E\./ and $repo_name) {
            my $repo_name_setting = $setting;
            $repo_name_setting =~ s/^\Q$config_prefix\E\./${config_prefix}.repository $repo_name./;
            unshift @setting_internal_name => $repo_name_setting;
        }
        SETTING_NAME:
        for my $setting_internal_name (@setting_internal_name) {
            my $last = $setting_internal_name eq $setting_internal_name[-1];
            CONF_SOURCE:
            foreach my $source (
                  ($config_file && $setting=~/^\Q$config_prefix\E\./)
                  ? ("--file $config_file","")
                  : ("")
            ) {
                my $cmd= "git config $source --get $opts '$setting_internal_name'";
                my ($res,$error_code)= git_cmd($cmd);
                if ($error_code == 1) {
                    if ($source=~/--file/) { # missing from our config file, but the rest?
                        next CONF_SOURCE;
                    } elsif ($has_default) {
                        $res= $default;
                    } else {
                        _die "Missing mandatory config setting $setting (internal name $setting_internal_name)" if $last;
                    }
                } elsif ($error_code == 2) {
                    _die "Bad config, multiple entries from $cmd: $res";
                } elsif ($error_code == 255) {
                    _die "Bad config value, maybe change '_' to '-'?";
                } elsif ($error_code) {
                    _die "Got unexpected error code $error_code from $cmd: $res";
                } elsif ( $res =~ m/\A\s*`\s*(.*)\s*`\s*\z/ ) {
                    my $opt_cmd= $1;
                    ($res, $error_code)= git_cmd($opt_cmd);
                    if ( $error_code ) {
                        die "config option $setting_internal_name = $res returned a non-zero exit code: $!\n";
                    }
                }
                $config{$setting}{$opts}= $res;

                last SETTING_NAME if !$error_code and $res;
                last CONF_SOURCE;
            }
        }
    }
    return $config{$setting}{$opts};
}

sub get_config { return _get_config("",@_) }
sub get_config_path { return _get_config("--path",@_) }
sub get_config_int  { return _get_config("--int",@_) }
sub get_config_bool { return 'true' eq _get_config("--bool",@_) }

}



#execute a command and return its error code
sub git_errcode {
    my ( $cmd, )= @_;
    my ( $res, $error_code )= git_cmd($cmd);
    return $error_code;
}


{    # lexical scope for the definition of locally static variables. Not just static in the sense
        # of C static vars, but also static in the sense the var is not modifiable once defined.
    my @gfer_names= (
        '%(*author)',           '%(*authordate:iso)', '%(*authoremail)',       '%(*authorname)',
        '%(*body)',             '%(*committer)',      '%(*committerdate:iso)', '%(*committeremail)',
        '%(*committername)',    '%(*contents)',       '%(*objectname)',        '%(*parent)',
        '%(*subject)',          '%(*tree)',           '%(author)',             '%(authordate:iso)',
        '%(authoremail)',       '%(authorname)',      '%(body)',               '%(committer)',
        '%(committerdate:iso)', '%(committeremail)',  '%(committername)',      '%(contents)',
        '%(objectname)',        '%(parent)',          '%(refname)',            '%(subject)',
        '%(tag)',               '%(tree)',
    );
    my %gfer_fields= map { $gfer_names[$_] => $_ } 0 .. $#gfer_names;
    my $gfer_format= join( "%01%01%01", @gfer_names ) . "%00%00%00";

    my $ref_info;
    my $ref_info_loaded;

    sub clear_ref_info {
        _info "Clearing ref info\n";
        undef $ref_info;
    }

    sub get_ref_info {

        #my $repo= shift;
        return $ref_info if $ref_info_loaded;
        undef $ref_info;
        _info "reading tag and branch info - this might take a second or two.\n"
            if $DEBUG;

        push_timings("gdt_internal__get_ref_info__git_for_each_ref__start");
        my $start_time= time;
        my $generated_code= `git for-each-ref --format '$gfer_format'`;
        push_timings("gdt_internal__get_ref_info__git_for_each_ref__end");

        my $elapsed= time - $start_time;
        _info "git for-each-ref took $elapsed seconds\n" if $DEBUG;

        #print "git for-each-ref --perl --format '$gfer_format'\n";
        if ( !$generated_code ) {
            _die "No refs were returned from git for-each-ref (which shouldn't be possible)\n";
        }

        _info "processing result\n" if $DEBUG;
        $start_time= time;
        push_timings("gdt_internal__get_ref_info__process_ref_info__start");

        my %ref;
        my %commit;

        # seems gfer adds a newline each record
        foreach my $chunk ( split /\x00\x00\x00\n?/, $generated_code ) {
            my %info;
            @info{@gfer_names}= split /\x01\x01\x01/, $chunk;

            local $_= $info{'%(refname)'};
            ( my $typename= $_ ) =~ s!^refs/!!;
            my %ref_data= (
                commit => $info{'%(*objectname)'} || $info{'%(objectname)'},
                refname  => $info{'%(refname)'},
                typename => $typename, (
                    s!^refs/(heads)/!!
                    ? (
                        refsdir  => $1,
                        category => "branch",
                        type     => "local",
                        barename => $_
                        )
                    : s!^refs/(remotes)/!! ? (
                        refsdir  => $1,
                        category => "branch",
                        type     => "remote",
                        barename => $_
                        )
                    : s!^refs/(tags)/!! ? (
                        refsdir  => $1,
                        category => "tag",
                        $info{'%(tag)'}
                        ? ( type => "object", barename => $info{'%(tag)'} )
                        : ( type => "symbolic", barename => $_ ) )
                    : s!^refs/(stash)!! ? (
                        refsdir  => $1,
                        category => "stash",
                        type     => "stash",
                        barename => $_
                        )
                    : s!^refs/(bisect)!! ? (
                        refsdir  => $1,
                        category => "bisect",
                        type     => "bisect",
                        barename => $_
                        )
                    : _die "Cant parse type from refname: ",
                    Dumper( \%info ) ) );
            my $commitname;
            if ( $ref_data{category} eq "tag" and $ref_data{type} eq "object" ) {
                $ref_data{sha1}= $info{'%(objectname)'};
                $ref_data{message}= {
                    body     => $info{'%(body)'},
                    subject  => $info{'%(subject)'},
                    contents => $info{'%(contents)'} };
                $commitname= $info{'%(*objectname)'};
                $commit{$commitname} ||= {
                    sha1   => $info{'%(*objectname)'},
                    author => {
                        author => $info{'%(*author)'},
                        date   => $info{'%(*authordate:iso)'},
                        email  => $info{'%(*authoremail)'},
                        name   => $info{'%(*authorname)'}
                    },
                    committer => {
                        committer => $info{'%(*committer)'},
                        date      => $info{'%(*committerdate:iso)'},
                        email     => $info{'%(*committeremail)'},
                        name      => $info{'%(*committername)'}
                    },
                    parent  => [ split /\s+/, $info{'%(*parent)'} ],
                    tree    => $info{'%(*tree)'},
                    message => {
                        body     => $info{'%(*body)'},
                        subject  => $info{'%(*subject)'},
                        contents => $info{'%(*contents)'}
                    },
                };
            }
            else {
                $commitname= $info{'%(objectname)'};
                $commit{$commitname} ||= {
                    sha1   => $info{'%(objectname)'},
                    author => {
                        author => $info{'%(author)'},
                        date   => $info{'%(authordate:iso)'},
                        email  => $info{'%(authoremail)'},
                        name   => $info{'%(authorname)'}
                    },
                    committer => {
                        committer => $info{'%(committer)'},
                        date      => $info{'%(committerdate:iso)'},
                        email     => $info{'%(committeremail)'},
                        name      => $info{'%(committername)'}
                    },
                    parent  => [ split /\s+/, $info{'%(parent)'} ],
                    tree    => $info{'%(tree)'},
                    message => {
                        body     => $info{'%(body)'},
                        subject  => $info{'%(subject)'},
                        contents => $info{'%(contents)'}
                    },
                };
            }
            $ref{all}{$typename}= \%ref_data;
            $ref{ $ref_data{category} }{ $ref_data{type} }{ $ref_data{barename} }= \%ref_data;
            push @{ $commit{$commitname}{refs} }, $typename;
        }
        push_timings("gdt_internal__get_ref_info__process_ref_info__end");

        $elapsed= time - $start_time;
        _info "processing ref data took $elapsed seconds\n", "returning from ref_info\n"
            if $DEBUG;
        $ref_info_loaded= 1;
        return $ref_info= { refs => \%ref, commit => \%commit };
    }



    sub _get_name_data {
        my ($name)= @_;
        return if $name eq 'HEAD';
        my $ri= get_ref_info();
        my $all= $ri->{refs}{all};
        return
               $all->{$name}
            || $all->{"tags/$name"}
            || $all->{"heads/$name"}
            || $all->{"remotes/$name"};
    }
}

# $commit_sha1= get_commit_for_name($name)
# $sha1= get_sha1_for_name($name)
#
# These two routines are very similar, and in most cases return the exact same result.
# They differ for tags however. A lightweight tag will return the same commit id for both.
# An annotated tag will return the tag's id for get_sha1_for_name() and will return the
# commit id it points at from get_commit_for_name().  This is one way to distinguish the
# two types of tags (of course there are other ways).
#
#

BEGIN {
    my %name2commit;

    sub get_commit_for_name {
        my ($name)= @_;
        return '' if !$name;
        $name ne 'HEAD'
            and exists $name2commit{$name}
            and return $name2commit{$name};

        if ( my $name_data= _get_name_data($name) ) {
            return $name2commit{$name}= $name_data->{commit};
        }
        else {
            _info "$name not in cache!" if $DEBUG and $name ne 'HEAD';
            my $cmd= qq(git log -1 --pretty="format:%H" $name);
            my $sha1= `$cmd 2>/dev/null`;
            $sha1 ||= '';
            chomp($sha1);
            $name2commit{$name}= $sha1 if $sha1;
            return $sha1;
        }

    }

    my %name2sha1;

    sub get_sha1_for_name {
        my ($name)= @_;
        return '' if !$name;
        $name ne 'HEAD'
            and exists $name2sha1{$name}
            and return $name2sha1{$name};
        if ( my $name_data= _get_name_data($name) ) {
            return $name2commit{$name}= $name_data->{sha1};
        }
        else {
            my $sha1= `git rev-parse $name 2>/dev/null`;
            $sha1 ||= '';
            chomp($sha1);
            $name2sha1{$name}= $sha1 if $sha1;
            return $sha1;
        }
    }
}


# check if a name is an annotated tag.
sub is_name_annotated_tag {
    my ($name)= @_;
    my $name_data= _get_name_data($name);
    return
        unless $name_data->{category} eq 'tag'
            and $name_data->{type} eq 'object';
    return ( $name_data->{commit}, $name_data->{sha1} );
}

my %type;


# returns the tags sorted by their date stamp, with undated tags last alphabetically
# the idea is we want a list where we find a match for head ASAP
sub get_sorted_list_of_tags {
    my $ref_info= get_ref_info();
    my $all_refs= $ref_info->{refs}{all};
    my @tags= map { s!^tags/!!; $_ }
        grep { $all_refs->{$_}{category} eq 'tag' } keys %$all_refs;

    # ST: parse out datestamps first so we can use them as a key to sort by
    @tags= map { $_->[0] }
        sort { $b->[1] cmp $a->[1] || $a->[0] cmp $b->[0] }
        map {
        $type{$_}= 'tag';
        [ $_, m/\D(20\d{6})[_-]?(\d+)?/ ? $1 . ( $2 || '' ) : '' ]
        } @tags;

    return @tags;
}


# list filter to remove names that contain a date tag which is older than a specific date.
#
# my @filtered=filter_names_by_date($date,@list);

sub filter_names_by_date {
    my $ignore_older_than= shift;
    return grep {
        m/\D(20\d{6})[_-]?(\d+)?/    # does it have a date?
            ? ( $1 . ( $2 || '' ) ge $ignore_older_than )    # yes - compare
            : 1;                                             # no - keep
    } @_;
}

# get a list of branches includes remote tracking branches as well as local.

sub get_branches {
    return map {
        chomp;
        s/^\s*(?:\*\s*)?//;
        if ( $_ ne '(no branch)' ) {
            $type{$_}= "branch";
            $_;
        }
        else {
            ();
        }
    } `git branch -a`;
}

# find the current branch
# returns an empty list/undef if no branch found
# returns the empty string if the current branch is reported as '(no branch)'
sub get_current_branch {
    for (`git branch`) {
        chomp;
        if ( $_ =~ s/^\s*\*\s*// ) {
            return $_ ne '(no branch)' ? $_ : '';
        }
    }
    return undef;
}



sub what_branches_can_reach_head {
    my $head= get_commit_for_name("HEAD");
    my %special= (
        'trunk'         => 1,
        'master'        => 2,
        'origin/trunk'  => 3,
        'origin/master' => 4,
    );
    my @branch=
        sort { ( $special{$a} || 100 ) <=> ( $special{$b} || 100 ) || $a cmp $b }
        grep { $_ ne "(no branch)" } map {
        chomp;
        s/^\s*(?:\*\s*)?//;
        $_;
        } `git branch -a --contains HEAD`;
    return wantarray ? @branch : $branch[0];
}



# filter through a list of items finding either the first or all
# items, (as controlled via $find_all).
#
# my @match_head= filter_names_matching_head($find_all, @names);

sub filter_names_matching_head {
    my $find_all= shift;
    $find_all= "" if $find_all and $find_all eq 'first';

    # get the currently checked out commit sha1
    my $head_sha1= get_commit_for_name('HEAD');

    # now loop through the tags to find a match
    my @matched_names;
    foreach my $name (@_) {
        my $sha1= get_commit_for_name($name);

        # check if the sha1 is the same as HEAD
        next unless $sha1 eq $head_sha1;

        # either return a singleton,
        return $name unless $find_all;

        # or gether the results in a list for later return
        push @matched_names, $name;

    }

    return @matched_names;
}


# find tags that match head,
#
# my $tag= find_tags_matching_head();
# my @tags= find_tags_matching_head('list');

sub find_tags_matching_head {
    my ($list)= @_;

    # report on existing tags
    return filter_names_matching_head( $list, get_sorted_list_of_tags() );
}

# find refs that match head,
#
# my $ref= find_refs_matching_head();
# my @refs= find_refs_matching_head('list');
#
# note this prefers tags over branches in the scalar form.

sub find_refs_matching_head {
    my ($list)= @_;

    # report on existing tags
    return filter_names_matching_head( $list, get_sorted_list_of_tags(), get_branches, );
}



# verify that the working directory is clean. If it is not clean returns the status output.
# if it is clean returns nothing.
sub check_if_working_dir_is_clean {
    push_timings("gdt_internal__git_status__start");
    my $status= `git status`;
    push_timings("gdt_internal__git_status__end");
    return if $status =~ /\(working directory clean\)/;
    return $status;
}

# make_tag($name,@message);
#
# @message will be in place modified such that %TAG is replaced by the
# new tagname.
#
# returns the new tagname.
#
sub make_tag {
    my $tag_name= shift;

    #my @message= @_; # except that we actually modify @_ in place

    _die "\$tag_name not optional in 'make_tag'\n"
        if !$tag_name;
    _die "\$message not optional in 'make_tag'\n"
        if !@_;

    # It is possible that start and rollout tags collide,
    # at least while testing the script. So we play some suffix
    # games to make them unique. It's unlikely to ever happen in
    # practice as there is always a non trivial amount of time between
    # the two steps.
    if ( get_commit_for_name($tag_name) ) {
        my $suffix= "A";
        while ( get_commit_for_name( $tag_name . "_" . $suffix ) ) {
            $suffix++;
        }
        $tag_name .= "_$suffix";
    }

    # the space after the -m is *required* on cyan
    my $message_opt= join " ", map { s/%TAG/$tag_name/g; "-m '$_'" } @_;

    my $cmd= "git tag $message_opt $tag_name";
    my $error= `$cmd 2>&1`;
    _die "failed to create tag $tag_name\n$error"
        if $error;
    _info "created tag '$tag_name'\n" if $VERBOSE;
    clear_ref_info();    # spoil the tag info cache
    return $tag_name;
}


# make_dated_tag($prefix,$date_fmt,@message);
#
# @message will be in place modified such that %TAG is replaced by the
# new tagname.
#
# returns the new tagname.
#
sub make_dated_tag {
    my $prefix= shift;
    my $date_fmt= shift;

    #my @message= @_; # except that we actually modify @_ in place
    my $date= strftime $date_fmt, localtime;
    my $tag_name= "$prefix-$date";
    return make_tag( $tag_name, @_ );
}

# preform an action against a remote site.
sub remote {
    my ( $action, $remote_site, $remote_branch )= @_;
    push_timings("gdt_internal__remote__action_${action}__start");
    if ( !$remote_site ) {
        _info "Note: not performing $action, as it is disabled\n";
    }
    return if !$remote_site or $remote_site eq 'none';

    #$remote_branch ||= get_current_branch()
    #    or _die "Not on a branch currently!"
    #    if !$remote_branch and defined $remote_branch;
    $remote_branch ||= '';
    my $cmd= "git $action $remote_site $remote_branch";
    _info "$cmd", $action =~ /pull/ ? "" : "\n(not updating working directory)\n", "\n"
        if $VERBOSE;
    my ( $res, $error )= git_cmd($cmd);
    my $name= "$remote_site" . ( $remote_branch ? ":$remote_branch" : "" );

    # if there is nothing new to fetch then we get error code 1, which does not
    # really mean an error, so we will just pretend it is not.
    if ( $action =~ /fetch/ and $error == 1 ) {
        _info "got exit code 1 - nothing to fetch\n" if $VERBOSE;
        $error= 0;
    }

    _die "failed to git $action from '$name' errorcode: $error\n$cmd\n$res\n"
        if $error;
    _info "$res", "\n" if $VERBOSE and $res;
    push_timings("gdt_internal__remote__action_${action}__end");
}

# fetch tags from a remote site
sub fetch_tags {
    my ( $remote_site )= @_;
    remote( "fetch --tags", $remote_site, undef );
}


# push tags to a remote site
sub push_tags {
    my ( $remote_site )= @_;
    remote( "push --tags", $remote_site, undef );
}

sub push_tag {
    my ( $remote_site, $tag )= @_;
    remote( "push", $remote_site, $tag );
}

# push tags and all references to a remote site.
sub push_all {
    my ( $remote_site )= @_;
    remote( "push --tags --all", $remote_site, undef );
}

# fetch a branch from a remote site.
sub fetch {
    my ( $remote_site, $remote_branch )= @_;
    remote( "fetch", $remote_site, $remote_branch );
}

# pull a branch from a remote site.
sub pull {
    my ( $remote_site, $remote_branch )= @_;
    remote( "pull", $remote_site, $remote_branch );
}

# push a branch to a remote site.
sub push_remote {
    my ( $remote_site, $remote_branch )= @_;
    remote( "push", $remote_site, $remote_branch );
}


# take a list of references and print them out in a formatted way.
# Currently the list is
#
# SHA1 *TYPE: NAME #NAME
# where the * may be a star or space and indicates that the ref points at HEAD,
# and the #NAME is optional, and points at the most recent tag with the same SHA1

sub print_refs {
    my $opts= shift;
    my $array= shift;
    my $head= get_commit_for_name('HEAD')
        or _die "panic: no sha1 for HEAD?! wtf!";
    if ( !$opts->{list} ) {
        return if !@$array;
        print shift @$array;
        print "\n" if -t STDOUT;
        return;
    }
    my %seen_sha1;
    my $start= time;
    foreach my $name ( reverse @$array ) {
        if ( !ref $name ) {
            my $sha1= get_commit_for_name($name);
            push @{$seen_sha1{$sha1}}, $name
		if !$seen_sha1{$sha1} or (!$opts->{prefix} or $name=~/^$opts->{prefix}/);
        }
    }
    my $elapsed= time - $start;
    _info "First loop took $elapsed seconds\n" if $DEBUG;
    my $count= 0;
    my $filtered= 0;
    $start= time;

    _info "Filtering list by m/^$opts->{prefix}-[0-9]+/"
        . (
        $opts->{prefix} eq '.'
        ? "\n"
        : " (use `git-deploy show .` to see all).\n"
        ) if $opts->{prefix} and !$opts->{tag_only};
    _info "SHA1........  tag: PREFIX-YYYYMMDD-HHMM == Original rollout of same sha1\n"
        if !$opts->{tag_only};
    _info "Tags against active commit are marked with a '"
          . color(COLOR_WARN) . "*" . color('reset') . color(COLOR_INFO)
          . "' and are "
          . color(COLOR_WARN) . "highlighted" . color('reset') . color(COLOR_INFO)
          . " differently\n"
        if !$opts->{tag_only};

    my @printed;

    my $last_sha1= "";
    foreach my $name_idx (0..$#$array) {
    my $name= $array->[$name_idx];
        next if ref $name;
        ++$filtered and next
            if $opts->{prefix} and $name !~ m/^$opts->{prefix}-[0-9]+/;
        last if $opts->{count} and $opts->{count} < ++$count;

    my $next_name= $array->[ $name_idx + 1 ];
    my $next_sha1= $next_name ? get_commit_for_name($next_name) : "";
        my $sha1= get_commit_for_name($name);

        if ( $opts->{tag_only} ) {
            _print $name, ( $opts->{action} && $opts->{action} eq 'showtag' ) ? "" : "\n";
            push @printed, $name;
        }
        else {
            if ( $opts->{for_interactive} ) {
                # next if $sha1 eq $head;
                push @printed, $name;
            }
        my $tags_for_commit= $seen_sha1{$sha1};
        pop @$tags_for_commit;

            _printf "%s%s%s %1s%s: %-25s%s%s%s\n",
                @printed ? sprintf( "%4d.\t", 0 + @printed ) : "",
                color( $sha1 eq $head ? COLOR_WARN : COLOR_SAY ),
                $opts->{long_digest} ? $sha1 : substr( $sha1, 0, 12 ) . "..",
                $sha1 eq $head ? "*" : " ",
                $type{$name},
                $name,
                @$tags_for_commit ? " ==\t" . join("\t",reverse @$tags_for_commit) : '',
        #$last_sha1 eq $next_sha1 ? " ***PROBABLY BAD***" : # XXX this doesnt work so leave it disabled for now
        "",
                color('reset'),
                ;
        $last_sha1= $sha1;
        }
    }
    if ( @$array and @$array > $count ) {
        my $filtered_str= $filtered ? " ($filtered filtered)" : "";
        my $showing_str=
            ( $opts->{count} && $opts->{count} < ( @$array - $filtered ) )
            ? "Showing first $opts->{count}, "
            : "";
        _info "$showing_str", @$array - $count, " of ", 0 + @$array,
            " not shown$filtered_str. Use --count=N or different filter to show more (N=0 shows all)\n"
            if !$opts->{tag_only};
    }
    $elapsed= time - $start;
    _info "Second loop took $elapsed seconds\n" if $DEBUG;
    _warn "No tags match HEAD\n" if !@$array and !$opts->{tag_only};
    return @printed;
}




sub get_deploy_file_name {
    my ($file)= @_;
    $file ||= get_config("deploy-file",".deploy");
    return $file;
}


# Write a deploy file about what has been deployed.
# This should be available to be parsed by the code being deployed to know where it came from
#
sub write_deploy_file {
    my ( $tag, $message, $file )= @_;

    $file= get_deploy_file_name($file);

    my $sha1= get_commit_for_name($tag)
        or _die "panic: no sha1 for tag '$tag'!";
    open my $out, ">", $file
        or _die "Failed to open deploy file '$file' for write: $!";

    my $text= join "",
        "commit: $sha1\n",
        "tag: $tag\n",
        "deploy-date: " . strftime( "%Y-%m-%d %H:%M:%S", localtime ) . "\n",
        "deployed-from: " . hostname() . "\n",
        "deployed-by: " . $ENV{USER} . "\n",
        ( $message && @$message ) ? join( "\n", "", @$message, "", "" ) : "\n",
        ;

    print $out $text
        or _die "panic: failed to write to deploy file handle for '$file': $!";
    close $out
        or _die "panic: failed to close deploy file handle for '$file': $!";
    _info "wrote deploy file '$file'\n" if $VERBOSE;
    $text;
}

# read the deploy file
# Unless $skip_check is true we will verify that the .deploy file corresponds to HEAD
# If things are good we return the files contents as a string.
# If there are any problems we return the empty string (not undef!)



sub read_deploy_file {
    my ( $file, $skip_check )= @_;
    $file= get_deploy_file_name($file);
    return "" unless $file and -e $file;

    my $deploy_file_text= _slurp($file);
    $deploy_file_text ||= "";

    my $sha1= $deploy_file_text =~ /^commit: ([a-f0-9]{40})\n/ ? $1 : undef;
    return ""
        if !$skip_check
            and ( !defined $sha1 or $sha1 ne get_commit_for_name('HEAD') );
    return $deploy_file_text;
}

sub _slurp {
    my ($file_like,$no_die)= @_;
    my $fh;
    if ( !ref $file_like ) {
        if (!open $fh, "<", $file_like) {
            if ($no_die) {
                return "";
            } else {
                _die "Failed to read '$file_like': $!";
            }
        }
    }
    else {
        $fh= $file_like;
    }
    if (wantarray) {
        my @lines= <$fh>;
        return @lines;
    }
    else {
        local $/;
        return <$fh>;
    }
}

sub _expand_template_variables {
    my ($message_ref, $variables) = @_;

    while (my ($tag, $string) = each %$variables) {
        $$message_ref =~ s/\{$tag\}/$string/g;
    }
    return;
}

BEGIN {

    # This block contains the logic necessary to manage an advisory locking scheme,
    # enforce a particular sequence of steps, as well as cross process storage of
    # necessary reference data like the rollout status.
    # One thing to keep in mind is that the tool is going to invoked multiple times
    # with differing steps in between.

    # The basic idea is we maintain a "lock" directory, and within it a file whose
    # presence tells others that they cannot do a rollout, and whose contents can
    # be used to ensure a specific order of actions is followed, and which can be
    # used as an advisory to others about the status, who is performing it and etc.
    my $lockdirname= "git-deploy";
    my $lockfilename= "lock-state";

    # additonally we maintain a file per rollout and start tag
    # these files only existing during a rollout and are erased afterwards
    my @tag_file_names= qw(rollout start);

    # utility sub, returns the lock_directory and the lockfilename for other subs
    # with some standard checking.
    my $lock_dir;
    sub _rollout_lock_dir_and_file {
        if (!$lock_dir) {
            my $lock_dir_root= get_config("lock-dir-root","");
            if (!$lock_dir_root) {
                _die "panic: directory '$gitdir' must exist for a rollout lock step to occur"
                    if !-d $gitdir;
                $lock_dir_root= $gitdir;
            }
            $lock_dir= "$lock_dir_root/$lockdirname";
        }
        return ( $lock_dir, "$lock_dir/$lockfilename" );
    }

    # write the details of a tag into a file so it can be accessed by a later
    # step of the process
    sub store_tag_info {
        my ( $type, $tag )= @_;

        _die "Bad type '$type'"
            unless grep { $type eq $_ } @tag_file_names;

        my ($lock_dir)= _rollout_lock_dir_and_file();
        open my $out_fh, ">", "$lock_dir/$type"
            or _die "Failed to open '$lock_dir/$type' for writing: $!";
        my $sha1= get_commit_for_name($tag)
            or _die "Invalid tag!";
        print $out_fh "$sha1 $tag";
        close $out_fh;
    }


    # fetch the details about a tag from the file
    sub fetch_tag_info {
        my ( $type )= @_;

        _die "Bad type '$type'"
            unless grep { $type eq $_ } @tag_file_names;

        my ($lock_dir)= _rollout_lock_dir_and_file();
        my $tag_info= _slurp("$lock_dir/$type","no-die");
        my ( $sha1, $tag )= split /\s+/, $tag_info;

        # validate tag is matches the sha1 as a crude sanity check
        return $tag if $tag and $sha1 and $sha1 eq get_commit_for_name($tag);
        return "";
    }




    # read the rollout status file takes the gitdir as an argument
    sub read_rollout_status {
        my ( $lock_dir, $lock_file )= _rollout_lock_dir_and_file();
        return "" if !-d $lock_dir;
        return "" if !-e $lock_file;
        unless (wantarray) {
            my $content= _slurp($lock_file);
            return $content;
        }
        else {
            my @content= _slurp($lock_file);
            return @content;
        }
    }

    # read the rollout status file and parses it into hashes.
    # in list context returns a list of hashes, in scalar context
    # returns an AoH.
    sub parse_rollout_status {
        my @lines= map {
            chomp;
            my %hash;
            @hash{qw(action time branch sha1 uid username)}= split /\t/, $_;
            $hash{branch}= "" if $hash{branch} eq '(no branch)';
            $hash{action} =~ s/:\z//;
            \%hash
        } read_rollout_status(@_);
        return wantarray ? @lines : \@lines;
    }


    sub check_rollouts_blocked {
        my ($force,$no_die)= @_;
        my $msg= "";
        $msg ||= get_config('block-reason','');
        if ($msg) {
            $msg= "Rollouts locally blocked: $msg\nUse `git config --unset deploy.block-reason` to unblock.";
        } elsif (my $sysadmin_lock= get_config_path('block-file','')) {
            if ($sysadmin_lock and -e $sysadmin_lock and !$force) {
                $msg= _slurp($sysadmin_lock);

                $msg= "Rollout blockfile '$sysadmin_lock' exists, cannot rollout!\n"
                   . $msg;
            }
        }
        if ($msg) {
            if ($no_die) {
                return $msg;
            } else {
                _die $msg;
            }
        }
    }
    # write_rollout_status($dir,$status,$force,$other_checks)
    #
    # $dir is the directory to write the file to, a string.
    # $status is the type of action we are performing, 'start','sync','finish','abort'
    # $force is a flag that overrides the security checks
    # $other_checks is a code ref of other checks that should be performed prior to creating
    # the file, it should die if the step should not proceed.
    #
    # returns nothing, dies if the status file cannot be created or updated properly or if any
    # of the necessary preconditions are not satisfied.
    #
    # Note this is called before we create a tag.
    # so we do not know the tagname that will be used for the step at the time
    # we write the data out, and thus cant include it in the file.
    #
    sub write_rollout_status {
        my $status= shift;
        my $force= shift;
        my $other_checks= shift;

        my ( $lock_dir, $lock_file )= _rollout_lock_dir_and_file();

        my ( $opened_ok, $out_fh, @file );

        my $somethings_wrong=
            $force
            ? sub { 0 }
            : sub {
            my $first_line= shift || "It looks like somethings wrong:";
            my $last_line= shift;
            $first_line =~ s/\n+\z//;

            #$first_line .= ":" if $fl !~ /:\z/;

            _die join "\n", $first_line, @file ? "Log:\n\t" . join( "\t", @file ) : (), $last_line ? $last_line : (),
                "";
            };

        if ( $status eq 'start' ) {
            check_rollouts_blocked($force);
            mkdir $lock_dir
                or do {
                my $message= "You may not start a new rollout as it looks like one is already in progress!\n"
                    . "Failed to create lock dir '$lock_dir' because '$!'\n";
                @file= _slurp($lock_file);
                $somethings_wrong->($message) if @file;
                };
            $opened_ok= sysopen( $out_fh, $lock_file, O_WRONLY | O_EXCL | O_CREAT )
                or do {
                my $message= "Can't start a new rollout, one is already in progress\n"
                    . "Failed to create lock file '$lock_file' because '$!'\n";
                @file= _slurp($lock_file);
                $somethings_wrong->($message);
                };
        }
        elsif ( !-d $lock_dir ) {
            _die "It looks like you havent started yet!\n";
        }
        elsif ( $opened_ok= sysopen( $out_fh, $lock_file, O_RDWR ) ) {
            @file= _slurp($out_fh);
            if ( @file == 3 ) {
                $somethings_wrong->(
                    "It looks like someone is just finishing a rollout",
                    "Wait a minute or two and retry."
                );
            }
            if ( !@file ) {
                _die "It looks like you havent started yet!\n";
            }
            if ( !$file[0] or $file[0] !~ /^start:/ or @file > 2 ) {
                $somethings_wrong->();
            }
            if ( $status eq 'sync' and @file != 1 ) {
                $somethings_wrong->("It looks like maybe you already synced");
            }
            if ( $status eq 'finish' ) {
                if ( @file == 1 ) {
                    $somethings_wrong->("It looks like maybe you havent synced yet");
                }
                elsif ( @file == 2 and $file[1] !~ /^(sync|release|manual-sync):/ ) {
                    $somethings_wrong->("Can't $status in the current state:");
                }
            }
            if ( $status eq 'finnish' ) {
                $somethings_wrong->("git-deploy ole saatavilla suomeksi! (maybe you meant 'finish' instead?)");
            }
            if ( $status eq 'abort' ) {
                if ( @file == 2 and $file[1] !~ /^(sync|release|manual-sync):/ ) {
                    $somethings_wrong->("Can't $status in the current state:");
                }
            }
            if ( $file[0] !~ /\t\Q$ENV{USER}\E$/ ) {
                $somethings_wrong->("Someone else is doing a rollout. You cannot proceed.");
            }
        }
        if ( !$opened_ok ) {
            _die "Failed to open lockfile '$lock_file': $!\n"
                . "There is a good chance this means someone is already rolling out.";
        }
        flock( $out_fh, LOCK_EX | LOCK_NB )
            or _die "Failed to lock file:$!\nSomebody already rolling out?\n";
        $other_checks->();
        my $status_line= join(
            "\t",
            "$status:",    # must be first
            strftime( "%Y-%m-%d %H:%M:%S", localtime() ),
            get_current_branch() || '(no branch)',
            get_commit_for_name('HEAD'),
            $<,
            $ENV{USER}     # must be last
            ).
            "\n";
        _log($status_line);
        print $out_fh $status_line
            or _die "panic: failed to print to deployment status lock file: $!";
        close $out_fh
            or _die "panic: failed to close deployment status lock file: $!";

    }


    sub unlink_rollout_status_file {
        my ( $lock_dir, $lock_file )= _rollout_lock_dir_and_file();

        for my $type (@tag_file_names) {
            if ( -e "$lock_dir/$type" ) {
                unlink "$lock_dir/$type"
                    or _die "Failed to delete '$lock_dir/$type':$!";
            }
        }
        unlink $lock_file
            or _die "Failed to delete '$lock_file':$!";
        if ( -e "$lock_file~" ) {
            unlink $lock_file
                or _die "Failed to delete '$lock_file~':$!";
        }
        rmdir $lock_dir
            or _die "Failed to rmdir '$lock_dir':$!";
        _info "Removed rollout status locks\n" if $VERBOSE > 1;
    }
}


sub check_for_unpushed_commits {
    my ( $remote_site, $remote_branch, $force )= @_;
    push_timings("gdt_internal__check_for_unpushed_commits__start");
    $remote_branch ||= get_current_branch();

    #print "git cherry $remote_site/$remote_branch\n";# if $DEBUG;
    my @cherry= grep { /[0-9a-f]/ } `git cherry $remote_site/$remote_branch`;
    if (@cherry) {
        _warn "It looks like there are unpushed commits.\n",
            "Most likely this is harmless and you should just\n",
            "\tgit push\n",
            "and then continue with the deployment but you should review the following...\n";
        foreach my $cherry (@cherry) {
            chomp $cherry;
            my ( $type, $sha1 )= split /\s/, $cherry;
            if ( $type eq '-' ) {
                _warn "This commit appears to already be applied upstream:\n";
            }
            else {
                _warn "Unpushed commit:\n";
            }
            _print `git log -1 $sha1`;
        }
    }
    push_timings("gdt_internal__check_for_unpushed_commits__end");
    _die "Will not proceed.\n" if @cherry and !$force;
    return 0;
}


sub reset_to_name {
    my ( $action, $name, $prefix )= @_;
    my ($rbinfo)= parse_rollout_status();
    push_timings("gdt_internal__reset_to_name__start");
    my @cmd;
    my $cur_branch= get_current_branch();
    if ( $rbinfo->{branch} ne $cur_branch ) {
        _say "Will switch branch back to '$rbinfo->{branch}' from the current branch '$cur_branch'\n";
        push @cmd, [ "git reset --hard", qr/^HEAD is now at /m ];
        push @cmd, [ "git checkout $rbinfo->{branch}", qr/^Switched to branch /m ];
    }
    push @cmd, [ "git reset --hard $name", qr/^HEAD is now at /m ];
    push @cmd, [ "git checkout -f", '' ]; # we do this to guarantee that we execute git-hooks
    foreach my $tuple (@cmd) {
        my ( $cmd, $expect )= @$tuple;
        _info "$cmd\n" if $VERBOSE and $VERBOSE > 1;
        my $result= `$cmd 2>&1`;
        _die "command '$cmd' failed to produce expected output: $result"
            if $expect and $result !~ m/$expect/;
        _info "$result\n" if $expect and $VERBOSE and $VERBOSE > 1;
    }
    _say "Rolled back to '$name' succesfully\n";

    execute_deploy_hooks(
        action  => $action,
        phase   => $_,
        prefix  => $prefix,

        # We don't want the abort to fail just because the
        # webserver didn't restart or something. This will warn if
        # the hooks fail, but will continue.
        ignore_exit_code => 1,
    ) for qw(post-tree-update post-reset);

    push_timings("gdt_internal__reset_to_name__end");
    return;
}


{
    my $root;

    sub get_hook_dir {
        my ( $prefix )= @_;
        return $root if defined $root;

        $root = get_config_path('hook-dir',undef);

        if ($SKIP_HOOKS) {
            $root= "";
            _warn "ALL HOOKS HAVE BEEN DISABLED.\n";
        }
        if ( not $root or not -e $root ) {
            $root= "";
            _info "Note: no deploy directory found. Directory '$root' does not exist\n"
                if $VERBOSE and $VERBOSE > 1;
            return;
        }
        else {
            _info "Note: Checking for hooks in '$root'\n"
                if $VERBOSE and $VERBOSE > 1;
        }
        return $root;
    }
}


sub get_hook {
    my ( $hook_name, $prefix )= @_;
    my $root= get_hook_dir( $prefix )
        or return;
    my $file= "$root/$hook_name/$prefix.$hook_name";
    return unless -e $file;
    if ( -x $file ) {
        return $file;
    }
    else {
        _warn "Found a $hook_name hook for '$prefix': '$file' however it is not executable! Ignoring!\n";
    }
    return;
}

sub get_sync_hook { return get_hook( "sync", @_ ) }


sub execute_hook {
    my ($cmd, $ignore_exit_code)= @_;

    my ($file)= $cmd =~ m/([^\/]+)$/;

    push_timings("gdt_internal__execute_hook__${file}__start");
    system("$cmd 2>&1");
    if ( $? == -1 ) {
        my $msg = "failed to execute '$cmd': $!\n";
        $ignore_exit_code ? _warn $msg : _die $msg;
    }
    elsif ( $? & 127 ) {
        my $msg = sprintf "'$cmd' _died with signal %d, %s coredump\n", ( $? & 127 ), ( $? & 128 ) ? 'with' : 'without';
        $ignore_exit_code ? _warn $msg : _die $msg;
    }
    elsif ( $? >> 8 ) {
        my $msg = sprintf "error: '$cmd' exited with value %d\n", $? >> 8;
        $ignore_exit_code ? _warn $msg : _die $msg;
    }
    push_timings("gdt_internal__execute_hook__${file}__end");
    return 1;
}

sub process_deploy_hooks {
    my ( $hook_dir, $appname, $phase, $ignore_exit_code )= @_;
    _info "Checking for '$phase' hooks for '$appname' ",
        $appname eq 'common' ? '(generic hooks)' : '(appliction specific)', "\n"
        if $VERBOSE > 1;

    my $appdir= "$hook_dir/apps/$appname";
    my @checks= sort grep { !/\.bak\z/ and !/~\z/ } glob "$appdir/$phase.*";
    if ( !@checks ) {
        _info "No '$phase' hooks found '$appdir' ", -e $appdir ? "is empty." : "does not exist.", "\n" if $DEBUG;
        return;
    }
    else {
        _info "Found ", 0 + @checks, " '$phase' hooks to execute in '$appdir'\n" if $DEBUG;
    }

    push_timings("gdt_internal__process_deploy_hooks__phase_${phase}__start");
    foreach my $spec (@checks) {
        my $cmd= "";
        unless ( -x $spec ) {
            _warn "Deploy hook '$spec' is not executable! IGNORING!\n";
            next;
        }
        $cmd= $spec;
        _info "Executing $phase hook: $cmd";
        execute_hook($cmd, $ignore_exit_code);
    }
    push_timings("gdt_internal__process_deploy_hooks__phase_${phase}__end");
    _info "All '$phase' checks for '$appname' were successful\n" if $DEBUG;
}

sub execute_deploy_hooks {
    my (%args) = @_;

    my $action           = $args{action}           || _die "Missing action argument";
    my $phase            = $args{phase}            || _die "Missing phase argument";
    my $prefix           = $args{prefix}           || _die "Missing prefix argument";
    my $ignore_exit_code = $args{ignore_exit_code} || 0;

    my $root= get_hook_dir( $prefix )
        or return;

    local $ENV{GIT_DEPLOY_ACTION}     = $action;
    local $ENV{GIT_DEPLOY_PHASE}      = $phase;
    local $ENV{GIT_DEPLOY_PREFIX}     = $prefix;

    # the tag information, if provided
    local $ENV{GIT_DEPLOY_START_TAG}  = $args{start_tag} if defined $args{start_tag};
    local $ENV{GIT_DEPLOY_ROLLOUT_TAG}  = $args{rollout_tag} if defined $args{rollout_tag};

    # the common 'app' is executed for everyone
    local $ENV{GIT_DEPLOY_HOOK_PREFIX}     = 'common';
    process_deploy_hooks( $root, "common", $phase, $ignore_exit_code );

    # and then the 'app' specific stuff as determined by $prefix
    local $ENV{GIT_DEPLOY_HOOK_PREFIX}     = $prefix;
    process_deploy_hooks( $root, $prefix, $phase, $ignore_exit_code );
}

sub execute_log_hooks {
    my (%args) = @_;

    my $level            = $args{log_level}            || _die "Missing log_level argument";
    my $message          = $args{log_message}          || _die "Missing log_message argument";
    my $announce         = $args{log_announce}         || 0;
    my $ignore_exit_code = exists $args{ignore_exit_code} ? $args{ignore_exit_code} : 1;

    local $ENV{GIT_DEPLOY_LOG_LEVEL}    = $level;
    local $ENV{GIT_DEPLOY_LOG_MESSAGE}  = $message;
    local $ENV{GIT_DEPLOY_LOG_ANNOUNCE} = $announce;

    execute_deploy_hooks(
        phase            => "log",
        ignore_exit_code => $ignore_exit_code,
        %args,
    );
}

sub log_directory {
    my $log_directory = get_config_path("log-directory", '/tmp');
    return unless $log_directory;
    return $log_directory;
}

1;