The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/tools/local/perl -w
use strict;
use File::Find;
use Getopt::Std;
use Cwd;
my %opt = ('p' => '3');
getopts('oeap:',\%opt);
my $path = getcwd();
chdir($path);
$path = getcwd();
my $dep;
my $rel;
my ($wh) = `p4 where ./...`;

if ($wh =~ m#^\s*(.*)/\.\.\.\s+(.*)/\.\.\.\s*$#)
 {
  $dep  = $1;
  $rel  = $2;
 }
else
 {
  die $wh;
 }

if ($opt{'o'})
 {
  foreach (`p4 opened $path/...`)
   {
    unless (/\(kx?text\)/)
     {
      warn "Not ktext : $_";
      next;
     }
    chomp;
    s/#\d+\s+-.*$//;
    $_ = `p4 have $_`;
    s/^.*#\d+\s+-\s+//;
    chomp;
    print "'$_'\n";
    push(@ARGV,$_);
   }
 }
elsif ($opt{'a'})
 {
  find(sub
       {
        $File::Find::prune = 1 if (/^blib$/);
        push(@ARGV,$File::Find::name) if (/\.pm$/)
       },'.');
 }

@ARGV = grep(!m#(Tk|Config)\.pm$#,@ARGV);

unless (@ARGV)
 {
  warn "No files specified\n";
  exit;
 }

my @undo = ();

$^I = ".old" if $opt{'e'};
my $seen = 0;
my $edit = 0;
while (<>)
 {
  $edit |= s/\r//g;
  s/ +$//;
  if (/^\$VERSION\s*=\s*'(\d+)\.(\d+)'\s*;\s*#\s*\$Id[:\s]+(.*)\$\s*(?:\+(\d+))?.*$/)
   {
    $seen = 1;
    my $maj  = $1;
    my $min  = $2;
    my $path = $3;
    my $inc  = $4;
    my $need = 0;
    unless ($path =~ /#(\d+)/)
     {
      my $have = `p4 have $ARGV`;
      ($path,$need)  = $have =~ /^(.*#(\d+))\s+-/;
      $need++;
     }
    else
     {
      $need = (-w $ARGV) ? $1+1 : $1;
     }
    if (defined($inc))
     {
      $need += $inc;
      $inc  = " +$inc";
     }
    else
     {
      $inc = '';
     }
    if ($maj != $opt{'p'} || $min != $need)
     {
      warn "-$ARGV:$_";
      $need++ unless -w $ARGV;
      $_ = sprintf("\$VERSION = '%d.%03d'; # \$Id: $path\$$inc\n",$opt{'p'},$need);
      warn "+$ARGV:$_";
      $edit = 1;
     }
   }
  elsif (/\$[\w:]*VERSION\s*=/)
   {
    if ($seen == 1)
     {
      warn "DUPLICATE $ARGV already had $_";
     }
   }
  elsif (/\$Id:/ || m#//depot#)
   {
    warn "Did not match:$_";
   }
  elsif (!$seen && /^\s*(\@ISA|bootstrap|use\s(Tk)|sub)/)
   {
    my $have = `p4 have $ARGV`;
    my ($dep,$ver)  = $have =~ /^(.*#(\d+))\s+-/;
    ++$ver;
    warn "$ARGV:$.:insert before\n$_\n";
    print "\nuse vars qw(\$VERSION);\n";
    printf "\$VERSION = '%d.%03d'; # \$Id: $dep\$\n\n",$opt{'p'},$ver;
    $seen = $edit = 1;
   }
  print if $opt{'e'};;
  if (!$seen && (eof || /__END__/))
   {
    warn "No insert point found in $ARGV\n";
    $seen = 1;
   }
  if (eof)
   {
    if ($opt{'e'})
     {
      if ($edit && $opt{'e'})
       {
        system('p4','edit','-t','ktext',$ARGV) unless -w $ARGV;
       }
      else
       {
        push(@undo,$ARGV);
       }
     }
    else
     {
      if ($edit)
       {
        warn "$ARGV needs changing?\n";
       }
     }
    $seen = $edit = 0;
    $.    = 0;
   }
 }

foreach my $file (@undo)
 {
  chmod(0666,$file) unless -w $file;
  unlink($file);
  rename("$file$^I",$file);
 }