Test :/string form for checkout
[git/dscho.git] / git-relink.perl
blob15fb932021e03e2b7b856b3a2285021be2ebac61
1 #!/usr/bin/env perl
2 # Copyright 2005, Ryan Anderson <ryan@michonline.com>
3 # Distribution permitted under the GPL v2, as distributed
4 # by the Free Software Foundation.
5 # Later versions of the GPL at the discretion of Linus Torvalds
7 # Scan two git object-trees, and hardlink any common objects between them.
9 use 5.006;
10 use strict;
11 use warnings;
12 use Getopt::Long;
14 sub get_canonical_form($);
15 sub do_scan_directory($$$);
16 sub compare_two_files($$);
17 sub usage();
18 sub link_two_files($$);
20 # stats
21 my $total_linked = 0;
22 my $total_already = 0;
23 my ($linked,$already);
25 my $fail_on_different_sizes = 0;
26 my $help = 0;
27 GetOptions("safe" => \$fail_on_different_sizes,
28            "help" => \$help);
30 usage() if $help;
32 my (@dirs) = @ARGV;
34 usage() if (!defined $dirs[0] || !defined $dirs[1]);
36 $_ = get_canonical_form($_) foreach (@dirs);
38 my $master_dir = pop @dirs;
40 opendir(D,$master_dir . "objects/")
41         or die "Failed to open $master_dir/objects/ : $!";
43 my @hashdirs = grep { ($_ eq 'pack') || /^[0-9a-f]{2}$/ } readdir(D);
45 foreach my $repo (@dirs) {
46         $linked = 0;
47         $already = 0;
48         printf("Searching '%s' and '%s' for common objects and hardlinking them...\n",
49                 $master_dir,$repo);
51         foreach my $hashdir (@hashdirs) {
52                 do_scan_directory($master_dir, $hashdir, $repo);
53         }
55         printf("Linked %d files, %d were already linked.\n",$linked, $already);
57         $total_linked += $linked;
58         $total_already += $already;
61 printf("Totals: Linked %d files, %d were already linked.\n",
62         $total_linked, $total_already);
65 sub do_scan_directory($$$) {
66         my ($srcdir, $subdir, $dstdir) = @_;
68         my $sfulldir = sprintf("%sobjects/%s/",$srcdir,$subdir);
69         my $dfulldir = sprintf("%sobjects/%s/",$dstdir,$subdir);
71         opendir(S,$sfulldir)
72                 or die "Failed to opendir $sfulldir: $!";
74         foreach my $file (grep(!/\.{1,2}$/, readdir(S))) {
75                 my $sfilename = $sfulldir . $file;
76                 my $dfilename = $dfulldir . $file;
78                 compare_two_files($sfilename,$dfilename);
80         }
81         closedir(S);
84 sub compare_two_files($$) {
85         my ($sfilename, $dfilename) = @_;
87         # Perl's stat returns relevant information as follows:
88         # 0 = dev number
89         # 1 = inode number
90         # 7 = size
91         my @sstatinfo = stat($sfilename);
92         my @dstatinfo = stat($dfilename);
94         if (@sstatinfo == 0 && @dstatinfo == 0) {
95                 die sprintf("Stat of both %s and %s failed: %s\n",$sfilename, $dfilename, $!);
97         } elsif (@dstatinfo == 0) {
98                 return;
99         }
101         if ( ($sstatinfo[0] == $dstatinfo[0]) &&
102              ($sstatinfo[1] != $dstatinfo[1])) {
103                 if ($sstatinfo[7] == $dstatinfo[7]) {
104                         link_two_files($sfilename, $dfilename);
106                 } else {
107                         my $err = sprintf("ERROR: File sizes are not the same, cannot relink %s to %s.\n",
108                                 $sfilename, $dfilename);
109                         if ($fail_on_different_sizes) {
110                                 die $err;
111                         } else {
112                                 warn $err;
113                         }
114                 }
116         } elsif ( ($sstatinfo[0] == $dstatinfo[0]) &&
117              ($sstatinfo[1] == $dstatinfo[1])) {
118                 $already++;
119         }
122 sub get_canonical_form($) {
123         my $dir = shift;
124         my $original = $dir;
126         die "$dir is not a directory." unless -d $dir;
128         $dir .= "/" unless $dir =~ m#/$#;
129         $dir .= ".git/" unless $dir =~ m#\.git/$#;
131         die "$original does not have a .git/ subdirectory.\n" unless -d $dir;
133         return $dir;
136 sub link_two_files($$) {
137         my ($sfilename, $dfilename) = @_;
138         my $tmpdname = sprintf("%s.old",$dfilename);
139         rename($dfilename,$tmpdname)
140                 or die sprintf("Failure renaming %s to %s: %s",
141                         $dfilename, $tmpdname, $!);
143         if (! link($sfilename,$dfilename)) {
144                 my $failtxt = "";
145                 unless (rename($tmpdname,$dfilename)) {
146                         $failtxt = sprintf(
147                                 "Git Repository containing %s is probably corrupted, " .
148                                 "please copy '%s' to '%s' to fix.\n",
149                                 $tmpdname, $dfilename);
150                 }
152                 die sprintf("Failed to link %s to %s: %s\n%s" .
153                         $sfilename, $dfilename,
154                         $!, $dfilename, $failtxt);
155         }
157         unlink($tmpdname)
158                 or die sprintf("Unlink of %s failed: %s\n",
159                         $dfilename, $!);
161         $linked++;
165 sub usage() {
166         print("Usage: $0 [--safe] <dir> [<dir> ...] <master_dir> \n");
167         print("All directories should contain a .git/objects/ subdirectory.\n");
168         print("Options\n");
169         print("\t--safe\t" .
170                 "Stops if two objects with the same hash exist but " .
171                 "have different sizes.  Default is to warn and continue.\n");
172         exit(1);