prj_install.pl

   1 #!/usr/bin/env perl
   2 eval '(exit $?0)' && eval 'exec perl -w -S $0 ${1+"$@"}'
   3     & eval 'exec perl -w -S $0 $argv:q'
   4     if 0;
   5
   6 # ******************************************************************
   7 #      Author: Chad Elliott
   8 # Create Date: 3/09/2004
   9 # ******************************************************************
  10
  11 # ******************************************************************
  12 # Pragma Section
  13 # ******************************************************************
  14
  15 use strict;
  16 use Cwd;
  17 use FileHandle;
  18 use File::Copy;
  19 use File::Basename;
  20 use File::Find;
  21
  22 # ******************************************************************
  23 # Data Section
  24 # ******************************************************************
  25
  26 my $insext   = 'ins';
  27 my $version  = '2.0';
  28 my %defaults = ('header_files'   => 1,
  29                 'idl_files'      => 1,
  30                 'inline_files'   => 1,
  31                 'pidl_files'     => 1,
  32                 'template_files' => 1,
  33                 'mpb_files'      => 1,
  34                );
  35
  36 my %special  = ('exe_output' => 1,
  37                 'lib_output' => 1,
  38                );
  39 my %extended;
  40 my %actual;
  41 my %base;
  42 my %override;
  43 my $keepgoing = 0;
  44 my $binarydir = '';
  45
  46 eval 'symlink("", "");';
  47 my $hasSymlink = ($@ eq '');
  48
  49 # ******************************************************************
  50 # Subroutine Section
  51 # ******************************************************************
  52
  53 sub rm_updirs {
  54   my $path  = shift;
  55   my @parts = split(/[\/\\]/, $path);
  56
  57   ## Split the path into parts and check for '..'.  If we find one
  58   ## and the previous entry wasn't one, then we can remove them both.
  59   for(my $i = 0; $i <= $#parts; $i++) {
  60     if ($i > 0 && $parts[$i] eq '..' && $parts[$i - 1] ne '..') {
  61       splice(@parts, $i - 1, 2);
  62       $i -= 2;
  63     }
  64   }
  65   return join('/', @parts);
  66 }
  67
  68 sub get_dest {
  69   my($file, $insdir) = @_;
  70   return rm_updirs($insdir . '/' .
  71                    (defined $actual{$file}
  72                     ? "$actual{$file}/" . basename($file)
  73                     : $file));
  74 }
  75
  76 sub copyFiles {
  77   my($files, $insdir, $symlink, $verbose) = @_;
  78   my $type = ($symlink ? 'link' : 'copy');
  79   my $cwd = getcwd();
  80
  81   # If > 1 file in @$files is a symlink to the same target, create one of the
  82   # files (the shorter-named one) as a symlink in the destination tree.
  83   my %localLink; # keys: files to create as symlinks in the destination
  84                  # values: symlink target (used in the main loop, below)
  85   my %linkTargets; # keys: link targets in the source tree
  86                    # values: name of the symlink in the source tree
  87   foreach my $file (@$files) {
  88     if (-l $file) {
  89       my $dest = readlink($file);
  90       if (exists $linkTargets{$dest} && $file ne $linkTargets{$dest}) {
  91         if (length $file <= length $linkTargets{$dest}) {
  92           $localLink{$file} = $linkTargets{$dest};
  93         }
  94         else {
  95           $localLink{$linkTargets{$dest}} = $file;
  96           $linkTargets{$dest} = $file;
  97         }
  98       }
  99       else {
 100         $linkTargets{$dest} = $file;
 101       }
 102     }
 103   }
 104
 105   foreach my $file (@$files) {
 106     my $dest = get_dest($file, $insdir);
 107     my $fulldir = dirname($dest);
 108     if (! -d $fulldir) {
 109       my $tmp = '';
 110       foreach my $part (split(/[\/\\]/, $fulldir)) {
 111         $tmp .= $part . '/';
 112         mkdir($tmp, 0755);
 113       }
 114     }
 115
 116     if (! -e $dest || (-M $file) < (-M $dest)) {
 117       if ($verbose) {
 118         print '', ($symlink ? 'Linking' : 'Copying'), " to $dest\n";
 119       }
 120       my $status;
 121       if ($symlink) {
 122         unlink($dest);
 123         $status = symlink("$cwd/$file", $dest);
 124       }
 125       elsif (exists $localLink{$file}) {
 126         my $target = get_dest($localLink{$file}, $insdir);
 127         if ($fulldir eq dirname($target)) {
 128           $target = basename($target);
 129         }
 130         if ($verbose) {
 131           print "\tCreating local symlink to $target\n";
 132         }
 133         unlink($dest);
 134         $status = symlink($target, $dest);
 135       }
 136       else {
 137         $status = copy($file, $dest);
 138         chmod(0755, $dest) if ($status && -x $file);
 139       }
 140       if (!$status) {
 141         print STDERR "ERROR: Unable to $type $file to $dest\n";
 142         if (!$keepgoing) {
 143           return 0;
 144         }
 145       }
 146     }
 147     else {
 148       print "Skipping $file\n" if ($verbose);
 149     }
 150   }
 151   return 1;
 152 }
 153
 154
 155 sub determineSpecialName {
 156   my($tag, $dir, $info) = @_;
 157
 158   my($insdir, $name) = split(/\s+/, $info);
 159   if (defined $name) {
 160     $insdir .= '/';
 161   }
 162   else {
 163     $name = $insdir;
 164     $insdir = '';
 165   }
 166
 167   my $odir = ($insdir =~ /^\// ? $insdir : ($dir . $insdir)) . $binarydir;
 168   $odir = '.' if $odir eq '';
 169   if ($tag eq 'exe_output') {
 170     my @exes;
 171     my $fh   = new FileHandle();
 172     if (opendir($fh, $odir)) {
 173       foreach my $file (grep(!/^\.\.?$/, readdir($fh))) {
 174         if ($file =~ /^$name$/ ||
 175             $file =~ /^$name.*\.exe$/i) {
 176           push(@exes, "$dir$insdir$binarydir$file");
 177         }
 178       }
 179       closedir($fh);
 180     }
 181     return @exes;
 182   }
 183   elsif ($tag eq 'lib_output') {
 184     my @libs;
 185     my $fh   = new FileHandle();
 186     if (opendir($fh, $odir)) {
 187       foreach my $file (grep(!/^\.\.?$/, readdir($fh))) {
 188         if ($file =~ /^lib$name(-[0-9]+(\.[0-9]+)*)?\.(a|so|sl|dylib)/ ||
 189             $file =~ /^(lib)?$name.*\.(dll|lib)$/i) {
 190           push(@libs, "$dir$insdir$binarydir$file");
 191         }
 192       }
 193       closedir($fh);
 194     }
 195     return @libs;
 196   }
 197
 198   return "$dir$name";
 199 }
 200
 201
 202 sub replaceVariables {
 203   my $line = shift;
 204   while($line =~ /(\$\(([^)]+)\))/) {
 205     my $whole = $1;
 206     my $name = $2;
 207     my $val = (defined $ENV{$name} ? $ENV{$name} : '');
 208     $line =~ s/\$\([^)]+\)/$val/;
 209   }
 210   return $line;
 211 }
 212
 213
 214 sub loadInsFiles {
 215   my($files, $tags, $verbose) = @_;
 216   my $fh = new FileHandle();
 217   my @copy;
 218
 219   foreach my $file (@$files) {
 220     if (open($fh, $file)) {
 221       if ($verbose) {
 222         print "Loading $file\n";
 223       }
 224       my $base = dirname($file);
 225       if ($base eq '.') {
 226         $base = '';
 227       }
 228       else {
 229         $base =~ s/^\.[\/\\]+//;
 230         $base .= '/';
 231       }
 232
 233       my $current;
 234       while(<$fh>) {
 235         my $line = $_;
 236         $line =~ s/^\s+//;
 237         $line =~ s/\s+$//;
 238
 239         if ($line ne '') {
 240           if ($line =~ /^(\w+):$/) {
 241             if (defined $$tags{$1}) {
 242               $current = $1;
 243             }
 244             else {
 245               $current = undef;
 246             }
 247           }
 248           elsif (defined $current) {
 249             $line = replaceVariables($line);
 250             my $perFileOverride = undef;
 251             my $start = $#copy + 1;
 252             if (defined $special{$current}) {
 253               push(@copy, determineSpecialName($current, $base, $line));
 254             }
 255             else {
 256               my($src, $dst);
 257               if ($line =~ /^\"([^"]+)\" (.*)/ || $line =~ /^(\S+) (\S+)/) {
 258                 ($src, $dst) = ($1, $2);
 259               }
 260               else {
 261                 ($src, $dst) = ($line, '');
 262               }
 263               if (defined $extended{$current}) {
 264                 push(@copy, "$base$src");
 265                 $perFileOverride = $dst;
 266               }
 267               else {
 268                 push(@copy, "$base$src");
 269               }
 270             }
 271             if (-d $copy[-1]) {
 272               my $dir = pop @copy;
 273               my $replace = $perFileOverride
 274                   ? ($perFileOverride . '/' . basename($dir)) : '';
 275               find({no_chdir => 1,
 276                     wanted => sub {
 277                       if (!(-d || /\.svn\// || /~$/)) {
 278                         push @copy, $_;
 279                         my $rel = $_;
 280                         $rel =~ s/^$dir/$replace/;
 281                         $actual{$_} =
 282                             (defined $override{$current} ? $override{$current}
 283                              : $base{$current}) . '/' . dirname($rel);
 284                       }
 285                     }
 286                    }, $dir);
 287             }
 288             elsif (defined $override{$current}) {
 289               for(my $i = $start; $i <= $#copy; ++$i) {
 290                 $actual{$copy[$i]} = $override{$current};
 291               }
 292             }
 293             elsif (defined $base{$current}) {
 294               for(my $i = $start; $i <= $#copy; ++$i) {
 295                 $actual{$copy[$i]} = $base{$current} . '/' .
 296                   ($perFileOverride ? $perFileOverride : dirname($copy[$i]));
 297               }
 298             }
 299           }
 300         }
 301       }
 302       close($fh);
 303     }
 304     else {
 305       print STDERR "Unable to open $file\n";
 306       return ();
 307     }
 308   }
 309
 310   return @copy;
 311 }
 312
 313
 314 sub getInsFiles {
 315   my $file  = shift;
 316   my @files;
 317
 318   if (-d $file) {
 319     my $fh = new FileHandle();
 320     if (opendir($fh, $file)) {
 321       foreach my $f (grep(!/^\.\.?$/, readdir($fh))) {
 322         push(@files, getInsFiles("$file/$f"));
 323       }
 324       closedir($fh);
 325     }
 326   }
 327   elsif ($file =~ /\.$insext$/) {
 328     push(@files, $file);
 329   }
 330   return @files;
 331 }
 332
 333
 334 sub usageAndExit {
 335   my $msg = shift;
 336
 337   print STDERR "$msg\n" if (defined $msg);
 338
 339   my $base = basename($0);
 340   my $spc  = ' ' x (length($base) + 8);
 341   print STDERR "$base v$version\n",
 342                "Usage: $base [-a tag1[,tagN]] [-b tag=dir] [-d dir]",
 343                ($hasSymlink ? '[-l] ' : ''), "[-o tag=dir]\n",
 344                $spc, "[-s tag1[,tagN]] [-x tag1[,tagN]] [-v] [-k] [-i]\n",
 345                $spc, "[install directory] [$insext files or directories]\n\n",
 346                "Install files matching the tag specifications found ",
 347                "in $insext files.\n\n",
 348                "-a  Adds to the default set of tags that get copied.\n",
 349                "-b  Install tag into dir underneath the install directory.\n",
 350                "-d  Libs/executables are copied from this sub-directory.\n",
 351                "-i  Read standard input in place of the $insext file.\n",
 352                "-k  Keep going if a file to be copied is missing.\n",
 353                ($hasSymlink ? "-l  Use symbolic links instead of copying.\n" : ''),
 354                "-o  Install tag into dir.\n",
 355                "-s  Sets the tags that get copied.\n",
 356                "-v  Enables verbose mode.\n",
 357                "-x  Enable extended behavior for the given tags:\n",
 358                "      These tags will use the 'gendir' setting from the\n",
 359                "      project as a relative target directory.\n",
 360                "\n",
 361                "The default set of tags are:\n";
 362   my $first = 1;
 363   foreach my $key (sort keys %defaults) {
 364     print STDERR '', ($first ? '' : ', '), $key;
 365     $first = 0;
 366   }
 367   print STDERR "\n";
 368
 369   exit(0);
 370 }
 371
 372 # ******************************************************************
 373 # Main Section
 374 # ******************************************************************
 375
 376 my $verbose;
 377 my $first = 1;
 378 my $insdir;
 379 my $symlink;
 380 my @insfiles;
 381 my %tags = %defaults;
 382
 383 for(my $i = 0; $i <= $#ARGV; ++$i) {
 384   my $arg = $ARGV[$i];
 385   if ($arg =~ /^-/) {
 386     if ($arg eq '-a') {
 387       ++$i;
 388       if (defined $ARGV[$i]) {
 389         foreach my $tag (split(',', $ARGV[$i])) {
 390           $tags{$tag} = 1;
 391         }
 392       }
 393       else {
 394         usageAndExit('-a requires a parameter.');
 395       }
 396     }
 397     elsif ($arg eq '-b') {
 398       ++$i;
 399       if (defined $ARGV[$i]) {
 400         if ($ARGV[$i] =~ /([^=]+)=(.*)/) {
 401           $base{$1} = $2;
 402         }
 403         else {
 404           usageAndExit("Invalid parameter to -b: $ARGV[$i]");
 405         }
 406       }
 407       else {
 408         usageAndExit('-b requires a parameter.');
 409       }
 410     }
 411     elsif ($arg eq '-d') {
 412       ++$i;
 413       if (defined $ARGV[$i]) {
 414         $binarydir = $ARGV[$i];
 415         $binarydir =~ s/\\/\//g;
 416         $binarydir .= '/' unless $binarydir =~ /\/$/;
 417       }
 418       else {
 419         usageAndExit('-d requires a parameter.');
 420       }
 421     }
 422     elsif ($arg eq '-i') {
 423       push(@insfiles, '-');
 424     }
 425     elsif ($arg eq '-k') {
 426       $keepgoing = 1;
 427     }
 428     elsif ($arg eq '-l') {
 429       $symlink = $hasSymlink;
 430     }
 431     elsif ($arg eq '-o') {
 432       ++$i;
 433       if (defined $ARGV[$i]) {
 434         if ($ARGV[$i] =~ /([^=]+)=(.*)/) {
 435           $override{$1} = $2;
 436         }
 437         else {
 438           usageAndExit("Invalid parameter to -o: $ARGV[$i]");
 439         }
 440       }
 441       else {
 442         usageAndExit('-o requires a parameter.');
 443       }
 444     }
 445     elsif ($arg eq '-s') {
 446       ++$i;
 447       if (defined $ARGV[$i]) {
 448         %tags = ();
 449         foreach my $tag (split(',', $ARGV[$i])) {
 450           $tags{$tag} = 1;
 451         }
 452       }
 453       else {
 454         usageAndExit('-s requires a parameter.');
 455       }
 456     }
 457     elsif ($arg eq '-v') {
 458       $verbose = 1;
 459     }
 460     elsif ($arg eq '-x') {
 461       ++$i;
 462       if (defined $ARGV[$i]) {
 463         foreach my $tag (split(',', $ARGV[$i])) {
 464           $extended{$tag} = 1;
 465         }
 466       }
 467       else {
 468         usageAndExit('-x requires a parameter.');
 469       }
 470     }
 471     else {
 472       usageAndExit('Unkown option: ' . $arg);
 473     }
 474   }
 475   elsif (!defined $insdir) {
 476     $arg =~ s/\\/\//g;
 477     $insdir = $arg;
 478   }
 479   else {
 480     if ($first) {
 481       $first = 0;
 482       if ($verbose) {
 483         print "Collecting $insext files...\n";
 484       }
 485     }
 486     $arg =~ s/\\/\//g;
 487     push(@insfiles, getInsFiles($arg));
 488   }
 489 }
 490
 491 if (!defined $insdir) {
 492   usageAndExit();
 493 }
 494 elsif (!defined $insfiles[0]) {
 495   print "No $insext files were found.\n";
 496   exit(1);
 497 }
 498
 499 my $status = 1;
 500 my @files  = loadInsFiles(\@insfiles, \%tags, $verbose);
 501 if (defined $files[0]) {
 502   $status = (copyFiles(\@files, $insdir, $symlink, $verbose) ? 0 : 1);
 503 }
 504
 505 exit($status);