r55009 - /scripts/qa/packagecheck.pl
jeremiah-guest at users.alioth.debian.org
jeremiah-guest at users.alioth.debian.org
Mon Mar 29 12:49:25 UTC 2010
Author: jeremiah-guest
Date: Mon Mar 29 12:46:48 2010
New Revision: 55009
URL: http://svn.debian.org/wsvn/?sc=1&rev=55009
Log:
Minor changes to packagecheck.pl. More changes coming.
Modified:
scripts/qa/packagecheck.pl
Modified: scripts/qa/packagecheck.pl
URL: http://svn.debian.org/wsvn/scripts/qa/packagecheck.pl?rev=55009&op=diff
==============================================================================
--- scripts/qa/packagecheck.pl (original)
+++ scripts/qa/packagecheck.pl Mon Mar 29 12:46:48 2010
@@ -1,6 +1,6 @@
#!/usr/bin/perl
-# Perlification Copyright 2009, Jeremiah C. Foster <jeremiah at jeremiahfoster.com>
+# Perlification Copyright 2009, 2010 Jeremiah C. Foster <jeremiah at jeremiahfoster.com>
# Copyright 2007, 2008, 2009 gregor herrmann <gregoa at debian.org>
# Copyright 2007, 2008 Damyan Ivanov <dmn at debian.org>
# Copyright 2007 David Paleino <d.paleino at gmail.com>
@@ -70,23 +70,19 @@
my %config; # hash holding configuration options
# Options
-my (
- $automatic, # flag for when this script gets called by other scripts
- $vcs, #
+my ($automatic, # flag for when this script gets called by other scripts
+ $vcs, #
$homepage, $maintainer, $depends, $watch,
- $create, $rules, $quilt, $all, $package, $help, $current,
- );
-
-GetOptions
- (
- 'help' => \$help, # print help message
- 'current|c=s' => \$current, # look for debian package in current dir
- 'auto' => \$automatic, # make assumptions about our environment
- );
+ $create, $rules, $quilt, $all, $package, $help, $current );
+
+GetOptions ( 'help' => \$help, # print help message
+ 'current|c=s' => \$current, # look for debian package in current dir
+ 'auto' => \$automatic, # make assumptions about our environment
+ );
# Print usage if there is no option or if the option is help
pod2usage(1) if $help;
-# pod2usage(1) if not $ARGV[0];
+pod2usage(1) unless $ARGV[0];
=head1 FUNCTIONS
@@ -126,25 +122,37 @@
=cut
sub append_control {
- my ($replacement, $ctrl_ref) = @_;
- open my $fh, '>', $control_file or croak "Cannot open $control_file: $!\n";
+ my ($orig, $replacement, $ctrl_ref) = @_;
+ open my $fh, '>', $orig or croak "Cannot open $control_file: $!\n";
# Should I write to a temporary file, instead of re-writing the control file?
map {
- if ($_ =~ /^Vcs-Svn/) { # Append Vcs-Svn line to control file after 'Standards' line
+ my $line_before = $_;
+ if ($line_before =~ /^Vcs-Svn/) { # Append Vcs-Svn line to control file after 'Standards' line
print {$fh} map {
- if ($_ =~ /Standards/) { $_ .= "@$replacement \n"; }
- else { $_; }
+ if ($line_before =~ /Standards/) { $line_before .= "@$replacement \n"; }
+ else { $line_before; }
} @$ctrl_ref;
}
- if ($_ =~ /^Vcs-Browser/) { # Append Vcs-Browser line to control file after 'Vcs-Svn' line
+ if ($line_before =~ /^Vcs-Browser/) { # Append Vcs-Browser line to control file after 'Vcs-Svn' line
print {$fh} map {
- if ($_ =~ /Vcs-Svn/) { $_ .= "@$replacement \n"; }
- else { $_; }
+ if ($line_before =~ /Vcs-Svn/) { $line_before .= "@$replacement \n"; }
+ else { $line_before; }
} @$ctrl_ref;
}
} @$replacement;
close $fh;
+}
+
+=item remove_old_urls
+
+Remove any reference to no longer used resources, like WebSVN or any old XS-Vcs- fields
+
+=cut
+
+sub remove_old_urls {
+ my $control_ref = shift;
+# print map { "->" . $_ . "\n" } @$control_ref;
}
=item testvcs
@@ -157,21 +165,22 @@
sub testvcs {
my $replacements =
[
- [ 'Vcs-Svn:', 'svn://svn.debian.org/pkg-perl/trunk/$package/'],
+ [ 'Vcs-Svn:', 'svn://svn.debian.org/pkg-perl/trunk/$package/' ],
[ 'Vcs-Browser:', 'http://svn.debian.org/viewsvn/pkg-perl/trunk/$package/' ],
];
map {
# we need to re-read the file to pick up changes
- my @file = slurp $control_file;
- my $control_ref = \@file;
+ my $control_file = shift;
+ my @contents = slurp "$fullpath/debian/control";
+ my $ctrl_ref = \@contents;
my $field = $replacements->[$_][0];
- if (grep /^$field/, @file) { print "Found \"$field\" field.\n"; }
+ if (grep /^$field/, @contents) { print "Found \"$field\" field.\n"; }
else {
print "Did not find $field, appending.\n";
- append_control($replacements->[$_], $control_ref);
- }
- undef $control_ref;
+ append_control("$fullpath/debian/control", $replacements->[$_], $ctrl_ref);
+ }
+ undef $ctrl_ref;
} 0..(@$replacements - 1);
}
@@ -179,8 +188,8 @@
if ($current) { # look for checked-out packages in the current dir
sanity_check("$current");
$fullpath = build_path($current);
- if (!$automatic) {
- # test for which VCS we're using, git or svn. Maybe should be factored out to a sub
+ if (!$automatic) {
+ # test which VCS we're using, git or svn. Maybe should be factored out to a sub?
if (capture([0..128], "ls $fullpath.svn")) {
$config{'vcs'} = "svn"; # svn is our VCS
print "Running svn up in $fullpath . . .\n"; # we use svn if we find it
@@ -197,18 +206,24 @@
}
}
else { # No subversion, let's try git
+ print "Checking for git repository.\n";
my $gitrepo;
- eval {$gitrepo = Git->repository (Directory => "$fullpath.git"); };
- if ($@) { # if we cannot find a git repo, we die
- die "Errors with Version Control System";
- }
+ $gitrepo = Git->repository (Directory => "$fullpath");
+ my $lastrev = $gitrepo->command_oneline( [ 'rev-list', '--all' ],
+ STDERR => 0 );
+ print "Lat revision: $lastrev\n"; # for debugging
$config{'vcs'} = "git"; # git is our VCS
- $config{'git_version'} = $gitrepo->version();
- print "Git version: $config{'git_version'}\n";
+ chdir($fullpath);
+ my $git_status = $gitrepo->command_oneline('status');
+ print "Checking for uncommitted modifications to directory . . .\n";
+ print "$git_status\n"; # <-- This doesn't seem to be working.
+ die "die for now.";
}
}
- $control_file = "$fullpath/debian/control";
- testvcs($current, $control_file); # check control file for correct URLs
+ my @contents = slurp "$fullpath/debian/control";
+ my $ctrl_ref = \@contents;
+ remove_old_urls($ctrl_ref); # remove links to old resources
+ testvcs("$fullpath/debian/control"); # add any missing URLs
}
=back
More information about the Pkg-perl-cvs-commits
mailing list