Subversion Repositories gelsvn

eval '(exit $?0)' && eval 'exec perl -w -S $0 ${1+"$@"}'

    & eval 'exec perl -w -S $0 $argv:q'

    if 0;

# ******************************************************************

#      Author: Chad Elliott

#        Date: 4/8/2004

#         $Id: clone_build_tree.pl,v 1.13 2006/02/02 13:04:19 elliott_c Exp $

# Description: Clone a build tree into an alternate location.

#              This script is a rewrite of create_ace_build.pl and

#              does not restrict the user to place the build

#              in any particular location or that it be used with

#              ACE_wrappers.  Some of the functions were barrowed

#              from create_ace_build.pl, but were modified quite a

#              bit.

# ******************************************************************

# ******************************************************************

# Pragma Section

# ******************************************************************

use strict;

use Cwd;

use FileHandle;

use File::Copy;

use File::Find;

use File::Path;

use File::stat;

use File::Basename;

# ******************************************************************

# Data Section

# ******************************************************************

my($exclude)    = undef;

my($verbose)    = 0;

my($lbuildf)    = 0;

my(@foundFiles) = ();

my($version)    = '$Id: clone_build_tree.pl,v 1.13 2006/02/02 13:04:19 elliott_c Exp $';

$version =~ s/.*\s+(\d+[\.\d]+)\s+.*/$1/;

eval 'symlink("", "");';

my($hasSymlink) = ($@ eq '');

# ******************************************************************

# Subroutine Section

# ******************************************************************

sub findCallback {

  my($matches) = !(/^CVS\z/s && ($File::Find::prune = 1)            ||

                   /^\.svn\z/s && ($File::Find::prune = 1)          ||

                   defined $exclude &&

                   /^$exclude\z/s && ($File::Find::prune = 1)       ||

                   /^\.cvsignore\z/s && ($File::Find::prune = 1)    ||

                   /^build\z/s && ($File::Find::prune = 1)          ||

                   /^\..*obj\z/s && ($File::Find::prune = 1)        ||

                   /^Templates\.DB\z/s && ($File::Find::prune = 1)  ||

                   /^Debug\z/s && ($File::Find::prune = 1)          ||

                   /^Release\z/s && ($File::Find::prune = 1)        ||

                   /^Static_Debug\z/s && ($File::Find::prune = 1)   ||

                   /^Static_Release\z/s && ($File::Find::prune = 1)

                  );

  if ($matches) {

    $matches &&= (! -l $_           &&

                  ! /^core\z/s      &&

                  ! /^.*\.rej\z/s   &&

                  ! /^.*\.state\z/s &&

                  ! /^.*\.so\z/s    &&

                  ! /^.*\.[oa]\z/s  &&

                  ! /^.*\.dll\z/s   &&

                  ! /^.*\.lib\z/s   &&

                  ! /^.*\.obj\z/s   &&

                  ! /^.*~\z/s       &&

                  ! /^\.\z/s        &&

                  ! /^\.#.*\z/s     &&

                  ! /^.*\.ncb\z/s   &&

                  ! /^.*\.opt\z/s   &&

                  ! /^.*\.bak\z/s   &&

                  ! /^.*\.suo\z/s   &&

                  ! /^.*\.ilk\z/s   &&

                  ! /^.*\.pdb\z/s   &&

                  ! /^.*\.pch\z/s   &&

                  ! /^.*\.log\z/s

                 );

    if ($matches) {

      if (!$lbuildf) {

        $matches = (! /^.*\.dsp\z/s       &&

                    ! /^.*\.dsw\z/s       &&

                    ! /^.*\.vcproj\z/s    &&

                    ! /^.*\.sln\z/s       &&

                    ! /^Makefile.*\z/s    &&

                    ! /^GNUmakefile.*\z/s &&

                    ! /^.*\.am\z/s        &&

                    ! /^\.depend\..*\z/s  &&

                    ! /^.*\.vcn\z/s       &&

                    ! /^.*\.vcp\z/s       &&

                    ! /^.*\.vcw\z/s       &&

                    ! /^.*\.vpj\z/s       &&

                    ! /^.*\.vpw\z/s       &&

                    ! /^.*\.cbx\z/s       &&

                    ! /^.*\.bpgr\z/s      &&

                    ! /^.*\.bmak\z/s      &&

                    ! /^.*\.bmake\z/s     &&

                    ! /^.*\.mak\z/s       &&

                    ! /^.*\.nmake\z/s     &&

                    ! /^.*\.bld\z/s       &&

                    ! /^.*\.icc\z/s       &&

                    ! /^.*\.icp\z/s

                  );

      }

      if ($matches) {

        ## Remove the beginning dot slash as we save the file

        push(@foundFiles, $File::Find::name);

        $foundFiles[$#foundFiles] =~ s/^\.[\\\/]+//;

      }

    }

  }

}

sub getFileList {

  File::Find::find({wanted => \&findCallback}, '.');

  return \@foundFiles;

}

sub backupAndMoveModified {

  my($realpath) = shift;

  my($linkpath) = shift;

  my($mltime)   = -M $linkpath;

  my($mrtime)   = -M $realpath;

  my($status)   = 1;

  ## -M returns the number of days since modification.  Therefore,

  ## a smaller time means that it has been modified more recently.

  ## This is different than what stat() returns.

  if ($mltime < $mrtime) {

    $status = 0;

    ## Move the real file to a backup

    unlink("$realpath.bak");

    if (rename($realpath, "$realpath.bak")) {

      ## Move the linked file to the real file name

      if (move($linkpath, $realpath)) {

        $status = 1;

      }

      else {

        ## The move failed, so we will attempt to put

        ## the original file back.

        unlink($realpath);

        rename("$realpath.bak", $realpath);

      }

    }

  }

  elsif ($mltime != $mrtime) {

    $status = 0;

  }

  elsif (-s $linkpath != -s $realpath) {

    $status = 0;

  }

  if (!$status) {

    ## We were not able to properly deal with this file.  We will

    ## attempt to preserve the modified file.

    unlink("$linkpath.bak");

    rename($linkpath, "$linkpath.bak");

  }

}

sub hardlink {

  my($realpath) = shift;

  my($linkpath) = shift;

  if ($^O eq 'MSWin32' && ! -e $realpath) {

    ## If the real file "doesn't exist", then we need to

    ## look up the short file name.

    my($short) = Win32::GetShortPathName($realpath);

    ## If we were able to find the short file name, then we need to

    ## try again.

    if (defined $short) {

      $realpath = $short;

    }

    else {

      ## This should never happen, but there appears to be a bug

      ## with the underlying Win32 APIs on Windows Server 2003.

      ## Long paths will cause an error which perl will ignore.

      ## Unicode versions of the APIs seem to work fine.

      ## To experiment try Win32 _fullpath() and CreateHardLink with

      ## long paths.

      print "WARNING: Skipping $realpath.\n";

      return 1;

    }

  }

  return link($realpath, $linkpath);

}

sub symlinkFiles {

  my($files)     = shift;

  my($fullbuild) = shift;

  my($dmode)     = shift;

  my($startdir)  = shift;

  my($absolute)  = shift;

  my($sdlength)  = length($startdir) + 1;

  my($partial)   = ($absolute ? undef :

                                substr($fullbuild, $sdlength,

                                       length($fullbuild) - $sdlength));

  foreach my $file (@$files) {

    my($fullpath) = "$fullbuild/$file";

    if (-e $fullpath) {

      ## We need to make sure that we're not attempting to mix hardlinks

      ## and softlinks.

      if (! -d $fullpath && ! -l $fullpath) {

        my($stat) = stat($fullpath);

        if ($stat->nlink() > 1) {

          print STDERR "ERROR: Attempting to mix softlinks ",

                       "with a hardlink build.\n",

                       "$fullpath has ", $stat->nlink(), " links.\n";

          return 1;

        }

      }

    }

    else {

      if (-d $file) {

        if ($verbose) {

          print "Creating $fullpath\n";

        }

        if (!mkpath($fullpath, 0, $dmode)) {

          return 1;

        }

      }

      else {

        if ($absolute) {

          if ($verbose) {

            print "symlink $startdir/$file $fullpath\n";

          }

          if (!symlink("$startdir/$file", $fullpath)) {

            return 1;

          }

        }

        else {

          my($buildfile) = "$partial/$file";

          my($slashcount) = ($buildfile =~ tr/\///);

          my($real) = ($slashcount == 0 ? './' : ('../' x $slashcount)) .

                      $file;

          if ($verbose) {

            print "symlink $real $fullpath\n";

          }

          if (!symlink($real, $fullpath)) {

            return 1;

          }

        }

      }

    }

  }

  ## Remove links that point to non-existant files

  sub lcheck {

    if (-l $_ && ! -e $_) {

      unlink($_);

      if ($verbose) {

        print "Removing $File::Find::dir/$_\n";

      }

    }

  }

  File::Find::find({wanted => \&lcheck}, $fullbuild);

  return 0;

}

sub hardlinkFiles {

  my($files)     = shift;

  my($fullbuild) = shift;

  my($dmode)     = shift;

  my($startdir)  = shift;

  my(@hardlinks) = ();

  foreach my $file (@$files) {

    my($fullpath) = "$fullbuild/$file";

    if (-d $file) {

      if (! -e $fullpath) {

        if ($verbose) {

          print "Creating $fullpath\n";

        }

        if (!mkpath($fullpath, 0, $dmode)) {

          return 1;

        }

      }

    }

    else {

      if (-e $fullpath) {

        ## We need to make sure that we're not attempting to mix hardlinks

        ## and softlinks.

        if (-l $fullpath) {

          print STDERR "ERROR: Attempting to mix hardlinks ",

                       "with a softlink build.\n",

                       "$fullpath is a softlink.\n";

          return 1;

        }

        backupAndMoveModified($file, $fullpath);

      }

      if (! -e $fullpath) {

        if ($verbose) {

          print "hardlink $file $fullpath\n";

        }

        if (!hardlink($file, $fullpath)) {

          return 1;

        }

      }

      ## If we successfully linked the file or it already exists,

      ## we need to keep track of it.

      push(@hardlinks, $file);

    }

  }

  ## Remove links that point to non-existant files

  my($lfh) = new FileHandle();

  my($txt) = "$fullbuild/clone_build_tree.links";

  if (open($lfh, $txt)) {

    while(<$lfh>) {

      my($line) = $_;

      $line =~ s/\s+$//;

      if (! -e $line) {

        unlink("$fullbuild/$line");

        if ($verbose) {

          print "Removing $fullbuild/$line\n";

        }

      }

    }

    close($lfh);

  }

  ## Rewrite the link file.

  unlink($txt);

  if (open($lfh, ">$txt")) {

    foreach my $file (@hardlinks) {

      print $lfh "$file\n";

    }

    close($lfh);

  }

  return 0;

}

sub linkFiles {

  my($absolute)  = shift;

  my($dmode)     = shift;

  my($hardlink)  = shift;

  my($builddir)  = shift;

  my($builds)    = shift;

  my($status)    = 0;

  my($starttime) = time();

  my($startdir)  = getcwd();

  ## Ensure that the build directory exists and is writable

  mkpath($builddir, 0, $dmode);

  if (! -d $builddir || ! -w $builddir) {

    return 1;

  }

  ## Search for the clonable files

  print "Searching $startdir for files...\n";

  my($files) = getFileList();

  my($findtime) = time() - $starttime;

  print 'Found ', scalar(@$files), ' files and directories in ',

        $findtime, ' second', ($findtime == 1 ? '' : 's'), ".\n";

  foreach my $build (@$builds) {

    my($fullbuild) = "$builddir/$build";

    ## Create all of the links for this build

    if (-d $fullbuild) {

      print "Updating $fullbuild\n";

    }

    else {

      print "Creating $fullbuild\n";

      mkpath($fullbuild, 0, $dmode);

    }

    if ($hardlink) {

      $status += hardlinkFiles($files, $fullbuild, $dmode, $startdir);

    }

    else {

      $status += symlinkFiles($files, $fullbuild,

                              $dmode, $startdir, $absolute);

    }

    print "Finished in $fullbuild\n";

  }

  if ($status == 0) {

    print 'Total time: ', time() - $starttime, " seconds.\n";

  }

  return $status;

}

sub usageAndExit {

  my($msg) = shift;

  if (defined $msg) {

    print STDERR "$msg\n";

  }

  my($base) = basename($0);

  my($spc)  = ' ' x (length($base) + 8);

  print STDERR "$base v$version\n\n",

               "Create a tree identical in layout to the current directory\n",

               "with the use of ", ($hasSymlink ? "symbolic links or " : ''),

               "hard links.\n\n",

               "Usage: $base [-b <builddir>] [-d <dmode>] [-f] ",

               ($hasSymlink ? "[-a] [-l] " : ''),

               "[-v]\n",

               $spc, "[build names...]\n\n",

               ($hasSymlink ?

               "-a  Use absolute paths when creating soft links.\n" .

               "-l  Use hard links instead of soft links.\n" : ''),

               "-b  Set the build directory. It defaults to the ",

               "<current directory>/build.\n",

               "-d  Set the directory permissions mode.\n",

               "-f  Link build files (Makefile, .dsw, .sln, .etc).\n",

               "-v  Enable verbose mode.\n";

  exit(0);

}

# ******************************************************************

# Main Section

# ******************************************************************

my($dmode)    = 0777;

my($absolute) = 0;

my($hardlink) = !$hasSymlink;

my($builddir) = getcwd() . '/build';

my(@builds)   = ();

for(my $i = 0; $i <= $#ARGV; ++$i) {

  if ($ARGV[$i] eq '-a') {

    $absolute = 1;

  }

  elsif ($ARGV[$i] eq '-b') {

    ++$i;

    if (defined $ARGV[$i]) {

      $builddir = $ARGV[$i];

      ## Convert backslashes to slashes

      $builddir =~ s/\\/\//g;

      ## Remove trailing slashes

      $builddir =~ s/\/+$//;

      ## Remove duplicate slashes

      while($builddir =~ s/\/\//\//g) {

      }

    }

    else {

      usageAndExit('-b requires an argument');

    }

  }

  elsif ($ARGV[$i] eq '-d') {

    ++$i;

    if (defined $ARGV[$i]) {

      $dmode = $ARGV[$i];

    }

    else {

      usageAndExit('-d requires an argument');

    }

  }

  elsif ($ARGV[$i] eq '-f') {

    $lbuildf = 1;

  }

  elsif ($ARGV[$i] eq '-l') {

    $hardlink = 1;

  }

  elsif ($ARGV[$i] eq '-v') {

    $verbose = 1;

  }

  elsif ($ARGV[$i] =~ /^-/) {

    usageAndExit('Unknown option: ' . $ARGV[$i]);

  }

  else {

    push(@builds, $ARGV[$i]);

  }

}

if (index($builddir, getcwd()) == 0) {

  $exclude = substr($builddir, length(getcwd()) + 1);

  $exclude =~ s/([\+\-\\\$\[\]\(\)\.])/\\$1/g;

}

else {

  $absolute = 1;

}

if (!defined $builds[0]) {

  my($cwd) = getcwd();

  if (chdir($builddir)) {

    @builds = glob('*');

    chdir($cwd);

  }

  else {

    usageAndExit('There are no builds to update.');

  }

}

exit(linkFiles($absolute, $dmode, $hardlink, $builddir, \@builds));