view release on metacpan or  search on metacpan

lib/App/Gitc/Util.pm  view on Meta::CPAN

            $msg = "failed to execute: $!";
        }
        elsif ( $? & 127 ) {
            $msg = sprintf "died with signal %d", ( $? & 127 );
        }
        else {
            $msg = sprintf "exited with value %d", ( $? >> 8 );
        }
        require Carp;
        Carp::croak("git $command_line failed: $msg");
    }
    elsif ( wantarray ) {  # list context
        warn "> git $command_line\n" if $ENV{DEBUG};
        my @output = qx{git $command_line};
        # there's no reliable way to check if this failed
        chomp @output;
        return @output;
    }

    # scalar context
    warn "> git $command_line\n" if $ENV{DEBUG};
    my $output = qx{git $command_line};
    if ( not defined $output ) {
        require Carp;
        Carp::croak("git $command_line failed: $!");
    }

    chdir $start unless $start eq $base;

    chomp $output;
    return $output;
}


sub git_config {
    our %config;

    if ( not keys %config ) {
        for my $line ( git "config -l" ) {
            my ($name, $value) = split /=/, $line;
            my @parts = split /[.]/, $name;
            my $here = \%config;
            for my $part ( @parts[ 0 .. $#parts-1 ] ) {
                $here->{$part} = {} if not $here->{$part};
                $here = $here->{$part};
            }
            $here->{ $parts[-1] } = $value;
        }
    }

    return \%config;
}


sub guarantee_a_clean_working_directory {
    my $arguments = "diff -C -M --name-status";
    my $staged    = git "$arguments --cached";
    my $changed   = git $arguments;
    return if not $staged and not $changed;

    # the tree is dirty, verify whether to continue
    warn "It looks like you have uncommitted changes. If this is expected,\n"
       . "type 'y' to continue.  If it's not expected, type 'n'.\n"
       . ( $staged  ? "staged:\n$staged\n"   : '' )
       . ( $changed ? "changed:\n$changed\n" : '' )
       ;
    die "Aborting at the user's request.\n" if not confirm('Continue?');

    # stash the changes to let them be restored later
    my $stash = git "stash create";
    git "reset --hard";
    return $stash;
}


sub let_user_edit {
    my ($filename) = @_;

    my $editor = $ENV{EDITOR} || $ENV{VISUAL} || '/usr/bin/vim';
    system "$editor $filename";
}

sub create_blob {
    my ($data_ref) = @_;

    my $tmp_file = "meta-$$.tmp";

    open my $tmp, ">", $tmp_file;
    print {$tmp} Dump($data_ref);
    print {$tmp} "\n";

    my $blob = git "hash-object -w $tmp_file";

    close $tmp;
    unlink $tmp_file;

    return $blob;
}

sub view_blob {
    my ($ref) = @_;

    my $output = git "show $ref";
    
    return ($output and $output !~ /^fatal:/) ? Load($output) : undef;
}

sub get_user_name {
    my $git_user = git 'config --get user.name';
    my $git_config = git_config();

    return $git_user || $git_config->{user}{name} || getpwuid $>;    
}

sub get_user_email {
    my ($user) = @_;
    return git 'config --get user.email' unless $user;
    fetch_tags();
    my $git_config = git_config();

    my $user_info = view_blob("user/$user") || {};

lib/App/Gitc/Util.pm  view on Meta::CPAN

sub history_status {
    my $history = shift;
    my $last
        = first { $_->{action} !~ m/^(touch|promote|demote)$/ } reverse @$history;
    my $action = $last->{action};
    return {
        open   => 'open',
        submit => 'submitted',
        review => 'reviewing',
        fail   => 'failed',
        pass   => 'merged',
        edit   => 'open',
    }->{$action};
}


sub history_submitter {
    my ($history) = @_;
    my $last = first { $_->{action} eq 'submit' } reverse @$history;
    return if not $last;
    return $last->{user};
}


sub is_auto_fetch {
    my $config = git_config();
    my $value = $config->{gitc}{fetch} || 'auto';
    return $value eq 'auto';
}


sub is_merge_commit {
    my ($ref)     = @_;
    my ($parents) = git "log -1 --no-color --pretty=format:%P $ref";
    return if not $parents;    # the root commit is not a merge
    my @parents = split / /, $parents;
    return @parents > 1;
}


sub is_suspendable {
    our $suspend_file = '.git/gitc-suspended-process';
    open my $fh, '>', $suspend_file
        or die "Unable to create $suspend_file: $!\n";
    print $fh "$$\n";
    my $command = command_name();
    print $fh "gitc $command is suspended.  Resume it with 'fg'\n";
    our $is_suspendable = 1;
    close $fh;
}
END {
    our $is_suspendable;
    our $suspend_file;
    unlink $suspend_file if $is_suspendable and -e $suspend_file;
}


sub is_valid_ref {
    my ($name) = @_;
    return if not defined $name;
    my $sha1 = eval { git "rev-parse --verify --quiet $name" };
    return $sha1 if $sha1;
    return;
}


sub open_packed_refs {
    my ($prefix) = @_;
    require File::Temp;
    if ( not defined $prefix ) {
        require Carp;
        Carp::croak("open_packed_refs requires a prefix argument");
    }
    my $git_dir = git_dir();
    my $packed_refs = "$git_dir/packed-refs";
    return if not -e $packed_refs;
    open my $old_fh, '<', $packed_refs or die "Can't open $packed_refs: $!";

    # verify that refs were packed with 'peeled'
    my $header = <$old_fh>;
    my ($technique) = $header =~ /^# pack-refs with: (\S+)/;
    $technique ||= '';
    die "Unknown ref packing technique: $technique\n"
        if $technique ne 'peeled';

    # open a temporary file to store the new tags
    my ( $new_fh, $new_filename )
        = File::Temp::tempfile( "$prefix-XXXX", DIR => $git_dir );

    print $new_fh $header;
    return ( $old_fh, $new_fh, $new_filename );
}


sub parse_changeset_spec {
    my ($spec) = @_;

    # no $spec means to infer everything from pwd
    if ( not defined $spec ) {
        my $changeset = current_branch();
        my $project   = project_name();
        return ( $project, $changeset );
    }

    # handle the traditional, full changeset name
    return ( $1, $2 ) if $spec =~ m/^(.*)#(.*)$/;

    my $project = project_name();
    die   "Unable to determine the project for changeset spec '$spec'.\n"
        . "You either need to be inside a gitc repository or specify\n"
        . "the full changeset name like project#changeset\n"
        if not $project;
    return ( $project, $spec );
}


sub project_name {
    our $project_name;
    return $project_name if defined $project_name;
    my ($line) = git "show HEAD:.gitc";
    die "You need to specify a project name in a .gitc file. See the HOWTO for more details." unless $line;
    my ($name) = $line =~ m/^\s*name\s*:\s*(.*)$/;
    return $project_name = $name;
}


sub project_root {
    my $git_dir = git_dir();
    if ( not $git_dir =~ s{/.git$}{} ) {
        require Carp;
        Carp::croak("Bare repositories don't have a meaningful project root");
    }
    return $git_dir;
}


sub remote_branch_exists {
    my ($branch) = @_;
    my @remote_branches = git "branch --no-color -r";