"Fossies" - the Fresh Open Source Software Archive

Member "Tk-804.036/add_version" (15 Nov 2013, 2865 Bytes) of package /linux/misc/Tk-804.036.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 #!/usr/local/bin/perl -w
    2 use strict;
    3 use File::Find;
    4 use Getopt::Std;
    5 use Cwd;
    6 my %opt = ('p' => '4');
    7 getopts('oqeap:',\%opt);
    8 my $path = getcwd();
    9 chdir($path);
   10 $path = getcwd();
   11 my $dep;
   12 my $rel;
   13 my ($wh) = `p4 where ./...`;
   14 
   15 if ($wh =~ m#^\s*(.*)/\.\.\.\s+(.*)/\.\.\.\s*$#)
   16  {
   17   $dep  = $1;
   18   $rel  = $2;
   19  }
   20 else
   21  {
   22   die $wh;
   23  }
   24 
   25 if ($opt{'o'})
   26  {
   27   foreach (`p4 opened $path/...`)
   28    {
   29     unless (/\(kx?text\)/)
   30      {
   31       warn "Not ktext : $_";
   32       next;
   33      }
   34     chomp;
   35     s/#\d+\s+-.*$//;
   36     $_ = `p4 have $_`;
   37     s/^.*#\d+\s+-\s+//;
   38     chomp;
   39     print "'$_'\n";
   40     push(@ARGV,$_);
   41    }
   42  }
   43 elsif ($opt{'a'})
   44  {
   45   find(sub
   46        {
   47         $File::Find::prune = 1 if (/^blib$/);
   48         push(@ARGV,$File::Find::name) if (/\.pm$/)
   49        },'.');
   50  }
   51 
   52 @ARGV = grep(!m#(Tk|Config)\.pm$#,@ARGV);
   53 
   54 unless (@ARGV)
   55  {
   56   warn "No files specified\n";
   57   exit;
   58  }
   59 
   60 my @undo = ();
   61 
   62 sub VERSION
   63 {
   64  my $have = `p4 have $ARGV`;
   65  my ($path,$need)  = $have =~ /^(.*#(\d+))\s+-/;
   66  $need++ if (-w $ARGV);
   67  return ($need,sprintf "\$VERSION = sprintf '%d.%%03d', q\$Revision: #%d\$ =~ /\\D(\\d+)\\s*\$/;\n",$opt{'p'},$need);
   68 }
   69 
   70 
   71 $^I = ".old" if $opt{'e'};
   72 my $seen = 0;
   73 my $edit = 0;
   74 while (<>)
   75  {
   76   $edit |= s/\r//g;
   77   s/ +$//;
   78   if (/^\s*\$VERSION\s*=\s*'(\d+)\.0*(\d+)'\s*;\s*#\s*\$Id[:\s]+(.*)\$\s*(?:\+(\d+))?.*$/)
   79    {
   80     $seen = 1;
   81     my $have = $2;
   82     my ($want,$str) = VERSION();
   83     if ($opt{q} && $have ne $want)
   84      {
   85       warn "!$ARGV:$have ne $want\n";
   86       warn "-$ARGV:$_";
   87       $_ = $str;
   88       warn "+$ARGV:$_";
   89       $edit = 1;
   90      }
   91    }
   92   elsif (/^\s*(our\s+)?\$VERSION\s*=[^#]*\$Revision[:\s]+#(\d+)\s*\$/)
   93    {
   94     $seen = 1;
   95     my $have = $2;
   96     my ($want,$str) = VERSION();
   97     if ($have ne $want)
   98      {
   99       warn "-$ARGV:$_";
  100       $_ = $str;
  101       warn "+$ARGV:$_";
  102       $edit = 1;
  103      }
  104    }
  105   elsif (/\$[\w:]*\bVERSION\s*=/)
  106    {
  107     if ($seen == 1)
  108      {
  109       warn "DUPLICATE $ARGV already had $_";
  110      }
  111    }
  112   elsif (/\$(Id|Revision):/ || m#//depot#)
  113    {
  114     warn "Did not match:$_";
  115    }
  116   elsif (!$seen && /^\s*(\@ISA|bootstrap|use\s+(Tk)|sub)/)
  117    {
  118     warn "$ARGV:$.:insert before\n$_\n";
  119     print "\nuse vars qw(\$VERSION);\n";
  120     my ($want,$str) = VERSION();
  121     print  $str;
  122     $seen = $edit = 1;
  123    }
  124   print if $opt{'e'};;
  125   if (!$seen && (eof || /__END__/))
  126    {
  127     warn "No insert point found in $ARGV\n";
  128     $seen = 1;
  129    }
  130   if (eof)
  131    {
  132     if ($opt{'e'})
  133      {
  134       if ($edit && $opt{'e'})
  135        {
  136         system('p4','edit','-t','ktext',$ARGV) unless -w $ARGV;
  137        }
  138       else
  139        {
  140         push(@undo,$ARGV);
  141        }
  142      }
  143     else
  144      {
  145       if ($edit)
  146        {
  147         warn "$ARGV needs changing?\n";
  148        }
  149      }
  150     $seen = $edit = 0;
  151     $.    = 0;
  152    }
  153  }
  154 
  155 foreach my $file (@undo)
  156  {
  157   chmod(0666,$file) unless -w $file;
  158   unlink($file);
  159   rename("$file$^I",$file);
  160  }