git-lsu

#!/usr/bin/perl

######
# git-lsu, git-lsd: inspect unreachable or dangling objects
#
# version: 0.5 created on 01/07/2012 (DD/MM/YYYY)
# source: http://pub.devbox.be
###
#
# Copyright (C) 2012 Jimmy Scott #jimmy#inet-solutions#be#. Belgium.
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
#   1. Redistributions of source code must retain the above copyright notice,
#      this list of conditions and the following disclaimer.
#
#   2. Redistributions in binary form must reproduce the above copyright
#      notice, this list of conditions and the following disclaimer in the
#      documentation and/or other materials provided with the distribution.
#
#   3. The names of the authors may not be used to endorse or promote products
#      derived from this software without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY
# EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
# PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE
# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF
# THE POSSIBILITY OF SUCH DAMAGE.
#
######

use strict;
use warnings;

use Getopt::Long qw(:config pass_through require_order
	no_ignore_case no_auto_abbrev prefix_pattern=(--));

# Version string
my $version = "git-lsu version 0.4";

# Command and exec name in use
my $exe;
my $command;

# Mode it is executed in
my $dangle = 0;

# Catchall options
my $a_help = '';
my $a_version = '';
my $a_input_file = '';

# Command 'commit' options
my $c_nonewlines = '';	# Remove newlines between output
my $c_showtree = '';	# List tree for every commit
my $c_dumptree = '';	# Dump tree for every commit

# Command 'dump' options
my $d_commit = '';
my $d_tree = '';
my $d_blob = '';
my $d_tag = '';
my $d_force = '';
my $d_folder = '';

# Options to pass to git
my @gitopts = ();

# This structure is mostly for future use to support analyze mode
my %objects = ( 'commit' => {}, 'tree' => {}, 'blob' => {}, 'tree' => {} );


sub show_usage {
	my $spc = " " x length($exe);
	print STDERR
	"usage: $exe [--help] [--version]\n",
	"       $exe [list] [--input-file=<file>] [git-fsck options]\n",
	"       $exe dump [--input-file=<file>] [--commit] [--tree] [--blob]\n",
	"       $spc      [-tag] [--force] <folder>\n",
	"       $exe commit [--input-file=<file>] [--no-newlines]\n",
	"       $spc        [--show-tree] [--dump-tree] [git-show options]\n",
	"       $exe tree [--input-file=<file>] [git-ls-tree options]\n",
	"       $exe blob [--input-file=<file>]\n",
	"       $exe tag [--input-file=<file>]\n",
	"\n",
	"options:\n",
	"   --input-file=<file>    ",
		"Read data from file instead of running git fsck\n",
	"\n",
	"dump options:\n",
	"   --commit               ",
		"Dump commit objects (instead of everything)\n",
	"   --tree                 ",
		"Dump tree objects (instead of everything)\n",
	"   --blob                 ",
		"Dump blob objects (instead of everything\n",
	"   --tag                  ",
		"Dump tag objects (instead of everything\n",
	"   --force                ",
		"Force using the supplied folder name\n",
	"\n",
	"commit options:\n",
	"   --no-newlines          ",
		"Remove newlines between output blocks\n",
	"   --show-tree            ",
		"Show the tree of each commit\n",
	"   --dump-tree            ",
		"Show the tree of each commit recursively\n",
	"\n";
	exit(1);
}

sub show_version {
	print $version, "\n";
	exit(0);
}

sub main {
	$exe = $0;
	$exe =~ s/.+[\/]//;
	
	# Check in which mode we execute
	$dangle = 1 if ($exe =~ /lsd/);
	
	# Parse & check args
	parse_args();
	
	# Args look fine, so get items
	my $items = get_objects();
	exit(0) if ($items == 0);
	
	# Run requested command
	if ($command eq 'list') {
		list_objects();
	} elsif ($command eq 'commit') {
		show_commits();
	} elsif ($command eq 'tree') {
		show_trees();
	} elsif ($command eq 'blob') {
		show_blobs();
	} elsif ($command eq 'tag') {
		show_tags();
	} elsif ($command eq 'dump') {
		dump_objects();
	} else {
		# Never reached
		show_usage();
	}
}

sub parse_args {
	# If first arg is option, run as 'list' command
	if (@ARGV && ($ARGV[0] =~ /^\-\-/)) {
		$command = 'list';
	} else {
		$command = shift @ARGV || 'list';
	}
	
	my $optok;
	my %options;
	my %alloptions;
	
	# List of all supported commands
	my @commands = ('list', 'commit', 'tree', 'blob', 'dump', 'tag');
	
	# Catch these options for all commands
	%alloptions = (
		'help'		=>	\$a_help,
		'version'	=>	\$a_version,
		'input-file=s'	=>	\$a_input_file,
	);
	
	# Catch these options for individual commands
	if ($command eq 'commit') {
		%options = (
			'no-newlines'	=>	\$c_nonewlines,
			'show-tree'	=>	\$c_showtree,
			'dump-tree'	=>	\$c_dumptree,
		);
	} elsif ($command eq 'dump') {
		%options = (
			'commit'	=>	\$d_commit,
			'tree'		=>	\$d_tree,
			'blob'		=>	\$d_blob,
			'tag'		=>	\$d_tag,
			'force'		=>	\$d_force,
		);
	#} elsif ($command eq 'tree') {
	#} elsif ($command eq 'blob') {
	#} elsif ($command eq 'tag') {
	#} else {
	}
	
	# Verify we are running a known command
	show_usage() unless (grep(/^${command}$/, @commands));
	
	# Parse options, return help or version immediately
	$optok = GetOptions ((%options, %alloptions));
	
	# Check for help, version, or incorrect usage
	show_usage() if ((!$optok) || $a_help);
	show_usage() if ($command eq 'dump' && (!@ARGV));
	show_version() if ($a_version);
	
	# Assign remaining arguments
	$d_folder = pop @ARGV  if ($command eq 'dump');
	@gitopts = @ARGV;
	
	# Check pass_through options
	if (@gitopts) {
		# Why do I even bother using Getopt if I have to
		# do crap like this? If the options I provide have
		# invalid or missing parameters, they shouldn't be
		# passed on, even for pass_through mode it's stupid.
		show_usage() if ($gitopts[0] =~ /--input-file=?/);
		
		# These options to not support pass_through
		show_usage() if ($command eq 'blob');
		show_usage() if ($command eq 'dump');
		show_usage() if ($command eq 'tag');
	}
}

sub read_file {
	my $file = shift;
	my ($fh, $out);
	
	if (open($fh, '<', $file)) {
		local $/;
		$out = <$fh>;
	} else {
		print STDERR "$exe: $file: open failed: $!\n";
		return undef;
	}
	
	close($fh);
	return $out;
}

sub write_file {
	my $file = shift;
	my $data_ref = shift;
	my $fh;
	
	if (open($fh, '>', $file)) {
		my $ret = print $fh $${data_ref};
		unless ($ret) {
			print STDERR "$exe: $file: write failed: $!\n";
			return undef;
		}
	} else {
		print STDERR "$exe: $file: open failed: $!\n";
		return undef;
	}
	
	close($fh);
	return 1;
}

sub get_objects {
	my $filter = shift;
	my $items = 0;
	my ($cmd, $fsck);
	
	# Get unreachable or dangling objects
	# Expected format: <state> <type> <sha1>
	if ($a_input_file ne '') {
		# Read from file
		$fsck = read_file($a_input_file);
		
		if (!defined($fsck)) {
			print STDERR "$exe: failed to read `$a_input_file'.\n";
			exit(1);
		}
	} else {
		# Read from git command
		$cmd = "git fsck";
		$cmd .= " --unreachable" unless ($dangle);
		
		# List command may pass arguments to fsck
		if ($command eq 'list' && @gitopts) {
			$cmd .= " " . join(" ", @gitopts);
		}
		
		$fsck = `$cmd`;
		
		if (!defined($fsck)) {
			print STDERR "$exe: fialed to execute `$cmd'.\n";
			exit(1);
		}
	}
	
	# Structure will look like this:
	# %objects -> %type -> %sha1 -> %prop = 'value'
	for my $line (split /\n/, $fsck) {
		if ($line =~ /^(unreachable|dangling)\s+(commit|blob|tree|tag)\s+([a-f0-9]+)$/) {
			my $state = $1; my $type = $2; my $sha = $3;
			next if ($dangle && $state ne "dangling");
			next if ((!$dangle) && $state ne "unreachable");
			next if (defined $filter && $type ne $filter);
			$objects{$type}{$sha} = {};
			$items++;
		} else {
			# Enexpected format
			print STDERR "$exe: unknown format: `$line'\n";
		}
	}
	
	# Return the number of items
	return $items;
}

sub list_objects {
	my $sha;
	
	my $state = $dangle ? "dangling" : "unreachable";
	
	for $sha (keys %{$objects{'commit'}}) {
		print "$state commit $sha\n";
	}
	
	for $sha (keys %{$objects{'tree'}}) {
		print "$state tree $sha\n";
	}
	
	for $sha (keys %{$objects{'blob'}}) {
		print "$state blob $sha\n";
	}
	
	for $sha (keys %{$objects{'tag'}}) {
		print "$state tag $sha\n";
	}
}

sub show_commits {
	my %tss = ();
	my @stss = ();
	my @ssha = ();
	
	# Get timestamp and subject into temp structure
	for my $sha (keys %{$objects{'commit'}}) {
		my $out = `git show --format='%at%n%s' --quiet $sha`;
		my ($time, $subject) = split(/\n/, $out);
		$tss{$time}{$sha} = $subject;
	}
	
	# Get a sorted list of timestamp
	@stss = sort {$b <=> $a} keys %tss;
	
	# Sort objects with same timestamp by subject type
	for my $ts (@stss) {
		my (@wip, @ind, @oth);
		for my $sha (keys %{$tss{$ts}}) {
			my $subject = $tss{$ts}{$sha};
			if ($subject =~ /^WIP\son\s\S+:\s/) {
				push @wip, $sha;
			} elsif ($subject =~ /^index\son\s\S+:\s/) {
				push @ind, $sha;
			} else {
				push @oth, $sha;
			}
		}
		push @ssha, (@wip, @ind, @oth);
	}
	
	# Print commits
	for my $sha (@ssha) {
		my $cmd;
		
		if (@gitopts) {
			$cmd = "git show " . join(' ', @gitopts) . " $sha";
		} else {
			$cmd = "git show --quiet $sha";
		}
		
		my $out = `$cmd`;
		
		# Add or remove newlines
		$out =~ s/\n+$/\n/ if ($c_nonewlines);
		print $out;
		print "\n" unless ($c_nonewlines || ($out =~ /\n\n$/));
		
		# Print c_showtree or c_dumptree
		if ($c_dumptree) {
			$out = `git ls-tree -r --full-tree $sha`;
			print $out, "\n";
		} elsif ($c_showtree) {
			$out = `git ls-tree --full-tree $sha`;
			print $out, "\n";
		}
	}
}

sub show_trees {
	my $sha;
	my $cmd = "git ls-tree --full-tree";
	
	if (@gitopts) {
		$cmd .= " " . join(' ', @gitopts);
	}
	
	for $sha (keys %{$objects{'tree'}}) {
		print "tree ${sha}\n\n";
		my $out = `$cmd $sha`;
		print $out, "\n";
	}
}

sub show_blobs {
	my $sha;
	my $cmd = "git show";
	
	# Has no point AFAIK
	#if (@gitopts) {
	#	$cmd .= " " . join(' ', @gitopts);
	#}
	
	for $sha (keys %{$objects{'blob'}}) {
		print "blob ${sha}\n\n";
		print "[", "=" x 69, ">]", "\n\n";
		
		my $out = `$cmd $sha`;
		
		# Try not to screwup the terminal
		if (check_is_binary(\$out)) {
			print "(binary data: ", length($out), " bytes)\n";
		} else {
			print $out;
		}
		
		print "\n", "[<", "=" x 69, "]", "\n\n";
	}
}

sub show_tags {
	my $sha;
	my $cmd = "git show --quiet";
	
	# Has no point AFAIK
	#if (@gitopts) {
	#	$cmd .= " " . join(' ', @gitopts);
	#}
	
	for $sha (keys %{$objects{'tag'}}) {
		print "tag ${sha}\n\n";
		my $out = `$cmd $sha`;
		print $out, "\n";
	}
}

sub check_is_binary {
	my $data_ref = shift;
	
	my $data = substr($${data_ref}, 0, 8000);
	return 1 if ($data =~ /\0/); 
	return 0;
}

sub create_dump_folders {
	my @folders;
	
	# Abort if the file/folder exists and no --force used
	if ((-e $d_folder) && (!$d_force)) {
		print STDERR "$exe: $d_folder: file exists, ",
		"use --force to use this folder anyway.\n";
		exit(1);
	}
	
	# Build a list of folders to check/create
	push @folders, $d_folder;
	push @folders, $d_folder . '/commit' if ($d_commit);
	push @folders, $d_folder . '/tree' if ($d_tree);
	push @folders, $d_folder . '/blob' if ($d_blob);
	push @folders, $d_folder . '/tag' if ($d_tag);
	
	# Check and create each folder
	for my $folder (@folders) {
		if (-e $folder) {
			# File exists, check if folder, check perms
			if (!-d $folder) {
				print STDERR "$exe: $folder: ",
				"not a regular directory.\n";
				exit(1);
			} elsif (!-w $folder) {
				print STDERR "$exe: $folder: ",
				"directory not writable.\n";
				exit(1);
			} elsif (!-x $folder) {
				print STDERR "$exe: $folder: ",
				"directory not executable.\n";
				exit(1);
			}
		} else {
			# Create folder
			unless(mkdir $folder) {
				print STDERR "$exe: $folder: ",
				"mkdir failed: $!\n";
				exit(1);
			}
		}
	}
}

sub dump_objects {
	# Dump all if no type was specified
	unless ($d_commit || $d_tree || $d_blob || $d_tag) {
		$d_commit = $d_tree = $d_blob = $d_tag = 1;
	}
	
	# Dump commands for each type
	my $c_cmd = "git show -p --stat";
	my $tr_cmd = "git ls-tree -r --full-tree";
	my $b_cmd = "git show";
	my $tg_cmd = "git show --quiet";
	
	# Create dump folders
	create_dump_folders();
	
	# Dump files
	objdumper('commit', $c_cmd, $d_folder . "/commit") if ($d_commit);
	objdumper('tree', $tr_cmd, $d_folder . "/tree") if ($d_tree);
	objdumper('blob', $b_cmd, $d_folder . "/blob") if ($d_blob);
	objdumper('tag', $tg_cmd, $d_folder . "/tag") if ($d_tag);
}

sub objdumper {
	my $key = shift;
	my $cmd = shift;
	my $folder = shift;
	
	for my $sha (keys %{$objects{$key}}) {
		my $out = `$cmd $sha`;
		my $path = $folder . "/" . $sha;
		my $ret = write_file($path, \$out);
		unless ($ret) {
			print STDERR "$exe: ",
			"WARNING: dump failed for: $path\n";
		}
	}
}

main();