svn-keyword-check.pl [plain text]
BEGIN {
if ( $] >= 5.006_000) {
require warnings; import warnings;
} else {
$^W = 1;
}
}
use strict;
use Getopt::Long;
use Carp;
my $transaction;
my $revision;
my $repos;
my $svnlook = "/usr/bin/svnlook";
my @text;
my $disallowall = 0;
GetOptions(
'revision|r=s' => \$revision,
'transaction|t=s' => \$transaction,
'repos=s' => \$repos,
'svnlook=s' => \$svnlook,
'disallowall' => \$disallowall,
'text|x=s' => \@text,
);
if (defined($transaction) and !defined($revision)) {
croak "Can't define both revision and transaction!\n";
}
if (!defined($transaction) and !defined($revision)) {
croak "Need to pass a revision or a transaction!\n";
}
if (!defined($repos)) {
croak "Need to pass in repos path!\n";
}
my $flag = (defined($revision)) ? "-r" : "-t";
my $value = (defined($revision)) ? $revision : $transaction;
my @changed = read_from_process("$svnlook changed $flag $value $repos");
my @errors;
foreach my $change (@changed) {
chomp($change);
if ($change =~ m/^D /) {
next;
}
$change =~ s/^(?:A |U |UU| U)\s+(.*)/$1/;
if (check($change)) {
push(@errors, $change);
}
}
if (@errors) {
warn "The following files appear to be binary, and have svn:keywords set,\n";
warn "yet are not in the fixed width format. Please either fix the keyword,\n";
warn "or if the file is text, please set the right svn:mime-type or svn:eol-style\n";
foreach my $error (@errors) {
warn "\t$error\n";
}
exit 1;
}
sub check {
my $file = shift;
if (has_svn_property($file, "svn:keywords")) {
if (file_is_binary($file)) {
if ($disallowall) {
return 1;
} else {
my @keywords = get_svnkeywords($file);
my $fh = _pipe("$svnlook cat $flag $value $repos $file");
while (my $line = <$fh>) {
foreach my $keyword (@keywords) {
if ($line =~ m/$keyword/) {
close($fh);
return 1;
}
}
}
}
}
}
return 0;
}
sub file_is_binary {
my $file = shift;
if (has_svn_property($file, "svn:eol-style")) {
return 0;
}
if (has_svn_property($file, "svn:mime-type")) {
my ($mimetype) = read_from_process("$svnlook propget $flag $value $repos svn:mime-type $file");
chomp($mimetype);
$mimetype =~ s/^\s*(.*)/$1/;
if ($mimetype =~ m/^text\//) {
return 0;
}
}
foreach my $ext (@text) {
if ($file =~ m/\Q$ext\E$/) {
return 0;
}
}
return 1;
}
sub get_svnkeywords {
my $file = shift;
my @lines = read_from_process("$svnlook propget $flag $value $repos svn:keywords $file");
my @returnlines;
foreach my $line (@lines) {
$line =~ s/\s+/ /;
push(@returnlines, split(/ /, $line));
}
return @returnlines;
}
sub has_svn_property {
my $file = shift;
my $keyword = shift;
my @proplist = read_from_process("$svnlook proplist $flag $value $repos $file");
foreach my $prop (@proplist) {
chomp($prop);
if ($prop =~ m/\b$keyword\b/) {
return 1;
}
}
return 0;
}
sub safe_read_from_pipe {
unless (@_) {
croak "$0: safe_read_from_pipe passed no arguments.\n";
}
my $fh = _pipe(@_);
my @output;
while (<$fh>) {
chomp;
push(@output, $_);
}
close($fh);
my $result = $?;
my $exit = $result >> 8;
my $signal = $result & 127;
my $cd = $result & 128 ? "with core dump" : "";
if ($signal or $cd) {
warn "$0: pipe from `@_' failed $cd: exit=$exit signal=$signal\n";
}
if (wantarray) {
return ($result, @output);
} else {
return $result;
}
}
sub _pipe {
local *SAFE_READ;
my $pid = open(SAFE_READ, '-|');
unless (defined $pid) {
die "$0: cannot fork: $!\n";
}
unless ($pid) {
open(STDERR, ">&STDOUT") or die "$0: cannot dup STDOUT: $!\n";
exec(@_) or die "$0: cannot exec `@_': $!\n";
}
return *SAFE_READ;
}
sub read_from_process {
unless (@_) {
croak "$0: read_from_process passed no arguments.\n";
}
my ($status, @output) = &safe_read_from_pipe(@_);
if ($status) {
if (@output) {
die "$0: `@_' failed with this output:\n", join("\n", @output), "\n";
} else {
die "$0: `@_' failed with no output.\n";
}
} else {
return @output;
}
}