view release on metacpan or  search on metacpan

git-client  view on Meta::CPAN

use strict;
use Cwd qw(abs_path);
use IO::Handle; # For non-blocking

our $VERSION = "0.045";

# Locate the real "git" later in the $PATH (after myself)
our $real_git = find_real_git();

# By default, silence any error spewages for internal git usage.
our $HANDLE_STDERR = sub { open STDERR, ">", "/dev/null" };

# Special $GIT_SSH shim to emulate $GIT_SSH_COMMAND behavior
!$ENV{DEBUG} || git("--version") !~ /version\s+([\d.]+)\s*$/ || warn "DEBUG: [".abs_path($0)."] Faking GIT_SSH_COMMAND behavior for incompetent git $1\n"
    and exec sh => -c => $ENV{GIT_SSH_COMMAND}.' "$@"' => ssh => @ARGV or die "exec: $!\n"
    if $0 eq ($ENV{GIT_SSH}||"") and $ENV{GIT_SSH_COMMAND}||="ssh";

if ("@ARGV" =~ /^(-v|(?:--|)version)$/ and $real_git =~ m{^(.*/)}) {
    my $nextpath = $1;
    print "[git-client v$VERSION] $0 => ";
    my $g;
    print $nextpath if open $g, "<", $real_git and $g = getc $g and $g ne "#";
    print git("--version");
    exit;
}

# Handle [ -C <dir> ] first
if (eval { require Getopt::Long; 1; } and
    Getopt::Long::Configure(qw[pass_through no_ignore_case bundling]) and
    Getopt::Long::GetOptions( "chdir|C=s" => (my $chdir=[]) ),
    ) {
    foreach (@$chdir) { chdir $_ or die "fatal: cannot change to '$_': $!\n"; }
}

# Grab special options for XMODIFIERS transport
pass_options();

# Scan for .gitconfig files in descent directories
scan_descent_override();

# Having a "git-deploy" command in the path works fine to pretend like "git deploy" is a command,
# but "git-config" will be ignored since /usr/libexec/git-core/git-config will always come first in the PATH.
# So we must handle all "git config" overrides within this "git" wrapper.
handle_config(@ARGV);

exec $real_git, @ARGV;

# Provide special options through "SendEnv XMODIFIERS" to make available in pre-hooks prior to running the real git command on the server
sub pass_options {
    my ($op) = grep { /^(clone|fetch|pull|ls-remote|push)$/ } @ARGV;
    return if !$op;
    # Need to search for special "-o" options for XMODIFIERS transport
    my $xmod = $ENV{XMODIFIERS} || "";
    my @options = ();
    my $pull_branch = "";
    push @options, "DEBUG=$ENV{DEBUG}" if defined $ENV{DEBUG} and $xmod !~ /^DEBUG=/m;
    if (eval { require Getopt::Long; 1; } and
        Getopt::Long::GetOptions( "O=s" => \@options )) { # Strip stealth -O args from ARGV so the real git doesn't choke on it
        if (my $rest_opt = ($op ne "clone" && "o|")."server-option|push-option=s") { # Ignore -o<origin> for "git clone"
            local @ARGV = @ARGV; # Don't monkey anything. Just peek.
            Getopt::Long::GetOptions( $rest_opt => \@options, "branch|b=s" => \$pull_branch ); # Handle "git clone -b <ref> <repo>"
        }
    }
    $pull_branch = $1 if $op =~ /^(fetch|pull)$/ and $xmod !~ /^pull_branch=/m and git("branch") =~ m{^\* ([\w/\-.@]+)\s*$}m;
    push @options, "pull_branch=$pull_branch" if $pull_branch;
    push @options, "client=".abs_path($0)."\@v$VERSION" if $xmod !~ /^client=/m;
    push @options, $xmod if $xmod;
    $ENV{XMODIFIERS} = join "\n", @options;
    $ENV{GIT_SSH_COMMAND} ||= git(qw[config core.sshCommand]) =~ /^(.+)/ ? $1 : "ssh";
    $ENV{GIT_SSH_COMMAND} = "$ENV{GIT_SSH_COMMAND} -o SendEnv=XMODIFIERS";
    $ENV{GIT_SSH} ||= $0; # Backward compatible in case $GIT_SSH_COMMAND is ignored (git < 2.3.x)
}

sub find_real_git {
    my $myself = (stat $0)[1] or die "$0: Can't find my inode?\n";
    my $found_git = "";
    $ENV{GIT_CLIENT_TRIED} ||= $0;
    require File::Spec;
    foreach my $path (File::Spec->path) {
        my $try = "$path/git";
        if (my @stat = stat $try) {
            if ($stat[1] == $myself) {
                # Ignore myself
            }
            elsif ($ENV{GIT_CLIENT_TRIED} =~ /^\Q$try\E$/m) {
                # Already tried
            }
            else {
                # First executable one in the path that isn't me is the winner
                $found_git = $try;
                $ENV{GIT_CLIENT_TRIED} = join "\n", $found_git, split /\n/, $ENV{GIT_CLIENT_TRIED};
                last;
            }
        }
    }

    $found_git ||= "/usr/bin/git";
    -x $found_git or die "$found_git: Unable to execute\n";
    return $found_git;
}

# Capture "git" command output
sub git {
    if (open my $fh_out, "-|") {
        # Parent: Read answer and wait for the child zombie to clear.
        local $/;
        return [scalar(<$fh_out>), close($fh_out)]->[0];
    }

    # Child runs the git command
    $HANDLE_STDERR->();
    # Secure exec @array method to avoid having to shell escape arguments containing spaces or other dangerous chars
    exec $real_git, @_ or exit 1;
}

# Jam equivalent "-c" config settings into @ARGV for any descent .gitconfig files and set GIT_CLIENT_OVERRIDE* env.
sub scan_descent_override {
    return if exists $ENV{GIT_CLIENT_OVERRIDE};
    $ENV{GIT_CLIENT_OVERRIDE} = "";
    my $descent_config_files = [];
    my $last = ".";
    $ENV{HOME} ||= (getpwnam $<)[7];
    while (1) {
        my $scan = abs_path( $last eq "." && !-d "$last/.git" ? $last : "$last/.." );
        last if $scan eq $last or $scan eq $ENV{HOME};
        $last = $scan;
        my $try = "$scan/.gitconfig";
        if (-r $try) {
            warn "DEBUG: $try: Override\n" if $ENV{DEBUG};
            unshift @$descent_config_files, $try;
        }
    }
    if (@$descent_config_files) {
        $ENV{GIT_CLIENT_OVERRIDE} = join "\n", @$descent_config_files;
        my $cmd_settings = [];
        my $descent_names = {};
        my $descent_counter = 0;
        foreach my $config_file (@$descent_config_files) {
            my $settings = git(qw[ config --list --file ], $config_file);
            $descent_counter++;
            while ($settings =~ s/^([^=\r\n]+)=(.*?)\r?\n?$//m) {
                my $name = $1;
                my $value = $2;
                push @$cmd_settings, "$name=$value";
                $descent_names->{$name} = $value;
                $ENV{"GIT_CLIENT_OVERRIDE_$descent_counter"}++;
            }
        }
        if (my $local_settings = git(qw[ config --list --local ])) {
            while ($local_settings =~ s/^([^=\r\n]+)=(.*?)\r?\n?$//m) {
                my $name = $1;
                my $value = $2;
                if (defined $descent_names->{$name}) {
                    # It seems better to double override than to completely leave out the duplicate descent setting
                    push @$cmd_settings, "$name=$value";
                    $ENV{GIT_CLIENT_OVERRIDE_0}++;
                }
            }
        }
        while (my $setting = pop @$cmd_settings) {
            unshift @ARGV, -c => $setting;
        }
    }
    else {
        # No effective .gitconfig files found in descent, so nothing to do
    }
}

# Special "config" handler to honor new --descent option
sub handle_config {
    my @args = @_;
    local @ARGV = @args;
    # Don't try to handle the "--help"-first case.
    return if join(" ", @ARGV) =~ /config --help\b/;
    if (grep {$_ eq "config"} @ARGV and
        # Smells like special "git config" command
        eval { require Getopt::Long; 1; } and
        Getopt::Long::Configure(qw[pass_through no_ignore_case require_order]) and
        Getopt::Long::GetOptions( "c=s" => (my $c=[]) ) and # XXX: Is is safe to ignore -c <name>=<value> args?
        $ARGV[0] eq "config" and
        do {
            # Handle naked "git config" case to make sure the usage can be updated before sending it
            push @_,"--usage" and push @ARGV,"--usage" if 1 == @ARGV;
            # Also handle new-fangled git >= 2.46.x "git config <command_without_dashes>" syntax:
            $ARGV[1]=~/^([a-z][a-z\-]+)$/ && ($ARGV[1]="--$1");
            1;
        } and
        Getopt::Long::Configure(qw[no_bundling no_require_order]) and
        Getopt::Long::GetOptions(
            # Scope
            "descent"      => \(my $descent),
            "global"       => \(my $global),
            "system"       => \(my $system),
            "local"        => \(my $local),
            "worktree"     => \(my $work),
            "f|file=s"     => \(my $file),

            # Action
            "l|list"       => \(my $list),
            "e|edit"       => \(my $edit),
            "get|get-all|get-regexp=s{1,2}" => \(my $get),
            "remove-section=s{1}" => \(my $action_1_arg),
            "set|get-urlmatch|rename-section=s{2}" => \(my $action_2_arg),
            "get-color|get-colorbool=s{1,2}" => \(my $action_1_2_arg),
            "replace-all=s{2,3}" => \(my $action_2_3_arg),

            # Other
            "all"          => \(my $all),
            "fixed-value"  => \(my $fixed),
            "z|null"       => \(my $null),
            "name-only"    => \(my $nameonly),
            "show-origin"  => \(my $origin),
            "show-scope"   => \(my $scope),
            "h|help|usage" => \(my $help),
        )
    ) {
        # Looks like this "config" command may need special attention
        my $descent_config_files = [ split /\n/, $ENV{GIT_CLIENT_OVERRIDE} ];
        if ($descent) {
            # Swap "--descent" for "--file <DESCENT_CONFIG_FILE>"
            # If more than one descent file, then just use the closest one
            @_ = map { $_ =~ /^--des/ ? ("--file" => ($descent_config_files->[-1] || "/dev/null")) : ($_) } @_;
        }
        # error: only one action at a time:
        map { ($_ eq "config" and ++$help) ? ($_,"--list","--edit") : ($_) } @_ if 1 < !!$list + !!$edit + !!$get + !!$action_1_arg + !!$action_2_arg + !!$action_1_2_arg + !!$action_2_3_arg;
        # error: only one config file at a time:
        map { ($_ eq "config" and ++$help) ? ($_,"--system","--global") : ($_) } @_ if 1 < !!$file + !!$descent + !!$global + !!$system + !!$local;
        # If it's not an implemented action or unrecognized args, then just let the regular git handle it:
        return @ARGV = @_ if !$help && !$list && !$get;
        my $exit_status;
        # Keep STDERR in case the usage spewage needs to be tweaked to mention the --descent option.
        my $err;