r42540 - in /scripts/qa: fake-svn/ packagecheck.pl

[jeremiah-guest at users.alioth.debian.org]

Author: jeremiah-guest
Date: Sun Aug 23 15:24:04 2009
New Revision: 42540

URL: http://svn.debian.org/wsvn/?sc=1&rev=42540
Log:
Added new function: testvcs. The function is a copy of the same function in the packagecheck shell script, but does not yet have all the features of that function.

Removed:
    scripts/qa/fake-svn/
Modified:
    scripts/qa/packagecheck.pl

Modified: scripts/qa/packagecheck.pl
URL: http://svn.debian.org/wsvn/scripts/qa/packagecheck.pl?rev=42540&op=diff
==============================================================================
--- scripts/qa/packagecheck.pl (original)
+++ scripts/qa/packagecheck.pl Sun Aug 23 15:24:04 2009
@@ -7,7 +7,8 @@
 # Released under the terms of the GNU GPL version 2
 #
 # To be run one directory above trunk/
-# (package name can be specified as the first argument)
+# (package name can be specified as the first argument in a
+# different directory with --current)
 
 =head1 NAME
 
@@ -19,27 +20,30 @@
 
 =head1 DESCRIPTION
 
-This tool is used inside the debian perl group for checking packages
-maintained by that group. As a consequence, it is very debian perl centric,
+This tool is used inside the debian-perl group for checking packages
+maintained by that group. As a consequence, it is very debian-perl centric,
 and certain assumptions are made, like that you have the debian-perl svn repository
-checked out. The script might not be of much use outside the debian
-perl group. But you are welcome to use whatever code you find useful here.
+checked out.
+
+Caveat Emptor: The script might not be of much use outside the debian-perl group.
+But you are welcome to use whatever code you find useful here.
 
 =head1 SYNOPSIS
 
-packagecheck.pl [options]
+     packagecheck.pl [options]
+
+     # check a package in the current directory
+     packagecheck.pl --current libfoo-bar-perl
 
 =head1 OPTIONS
-
-=over 8
 
 =item B<--help>
 
 Print a brief help message, then exit.
 
-=item B<--current>
+=item B<--current> package
 
-Test a package that is in the current working directory
+Test a package that is in the current working directory.
 
 =cut
 
@@ -49,22 +53,45 @@
 use Pod::Usage;
 use Cwd;
 use IPC::System::Simple qw(system capture);
+use Perl6::Slurp;
+
+my $fullpath;      # a variable use to hold path information
 
 # Options
-my ($automatic, $vcs, $homepage, $maintainer, $depends, $watch,
+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,
-	    'current' => \$current,
-	    'auto' => \$automatic,
-          );
+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) if not $ARGV[0];
+
+=head1 FUNCTIONS
 
 =over 8
+
+=item build_path
+
+Build the path to the dir we are checking.
+
+=cut
+
+sub build_path {
+  my $cwd = &cwd;
+  my $package = shift;
+  my $dir = "$cwd/$package";
+  return $dir;
+}
 
 =item sanity_check
 
@@ -73,46 +100,60 @@
 =cut
 
 sub sanity_check {
-  my $dir = shift;
-  if (not -d $dir) {
-    die "Cannot find working directory $dir: $!";
+  my $sane = shift;
+  build_path($sane);
+  if (not -d $sane) { # we're not sane, so die
+    die "Cannot find working directory $sane: $!";
   }
 }
 
-=over 8
-
 =item testvcs
 
-Test for presence of Vcs fields in control file.
+Test for presence of Vcs-Svn fields in control file, if not present insert
+correct field name and URL.
 
 =cut
 
 sub testvcs {
-  my ($dir, $package) = @_;
-  print "Working directory is $dir and package name is $package\n";
+  my $working_dir = shift;
+  $fullpath = build_path($working_dir);
+  my @control_file = slurp "$fullpath/debian/control";
+  if (grep /^Vcs-Svn/, @control_file) { print "Found SVN field.\n"; }
+  else {
+    use Fatal qw( open close );
+    print "Adding missing Vcs-Svn field to $working_dir . . .\n";
+    open my $fh, '>', "$fullpath/debian/control";
+    print {$fh} map {
+      my $line = $_;
+      if ($line =~ /Standards/) { 
+	$line .= "Vcs-Svn: svn://svn.debian.org/pkg-perl/trunk/$working_dir/\n";
+      }
+      else { $line; }
+    } @control_file;
+    close $fh;
+  }
 }
 
 
 # Process options
 if ($current) {  # check for checked out packages in the current dir
-  my $cwd = cwd();
-  sanity_check($cwd);
-
+  sanity_check("$current");
+  $fullpath = build_path($current);
   if (!$automatic) {
-    print "Running svn up in $cwd\n";
-    my @svnrev = capture("svn up $cwd");
-    print $svnrev[-1];
+    print "Running svn up in $fullpath . . .\n";
+    my @svnrev = capture("svn up $fullpath");
+    print "SVN: $svnrev[-1]";
   }
-  print "Checking for uncommitted modifications to directory.\n";
-  my @svnmods = capture("svn st $cwd");
+  print "Checking for uncommitted modifications to directory . . .\n";
+  my @svnmods = capture("svn st $fullpath");
   if ($svnmods[-1]) {
     print map { $_ } @svnmods;
-    die "Exiting. $cwd appears to have uncommitted modifications.\n";
+    die "Exiting. $fullpath appears to have uncommitted modifications.\n";
   }
   else {
     print "It appears directory is clean.\n";
   }
-  testvcs($cwd, $current)
+  testvcs($current)
 }