tools/dev/symlink.pl

   1 #! perl -s
   2
   3 # Copyright (C) 2004-2008, Parrot Foundation.
   4 # $Id$
   5
   6 =head1 NAME
   7
   8 symlink.pl - create a symlink shadow of the Parrot source.
   9
  10 =head1 SYNOPSIS
  11
  12    # when in directory containing the checked out source in 'trunk'
  13    mkdir shadow
  14    cd shadow
  15    perl ../trunk/tools/dev/symlink.pl
  16
  17 =head1 DESCRIPTION
  18
  19 Create a symlink tree shadowing the Parrot source tree.  Nifty for
  20 having just one (read-only) copy of the sources but several different
  21 build trees.  The -v option displays the created symlinks.
  22
  23 =head1 CHANGES
  24
  25 1.1: Handle also:
  26       - being called with a relative path
  27       - being called through a symlink
  28
  29 =head1 AUTHOR
  30
  31 jhi@iki.fi
  32
  33 =cut
  34
  35 use strict;
  36 use warnings;
  37
  38 use File::Basename;
  39 use File::Spec;
  40 use Cwd;
  41
  42 my $self = $0;
  43 my $cwd  = getcwd();
  44
  45 $self = readlink($self) while -l $self;
  46
  47 $self = File::Spec->catfile( $cwd, $self )
  48     unless File::Spec->file_name_is_absolute($self);
  49
  50 my $toolsrcdir  = dirname($self);
  51 my $toolsrcbase = basename($self);
  52
  53 use vars qw($v);
  54
  55 if ( $toolsrcdir ne '' && -d $toolsrcdir && lc $toolsrcbase eq 'symlink.pl' ) {
  56     my $trydir  = File::Spec->catdir( 'include', 'parrot' );
  57     my $tryfile = File::Spec->catfile( 'src',    'main.c' );
  58     die "$0: Do not run this under the original Parrot tree.\n"
  59         if ( -d $trydir ) && ( -f $tryfile && !-l $tryfile );
  60 }
  61 else {
  62     die "$0: I am very confused.\n";
  63 }
  64
  65 my @toolsrcdir = File::Spec->splitdir($toolsrcdir);
  66 die "$self: not in tools/dev\n"
  67     unless @toolsrcdir >= 2
  68         && lc( $toolsrcdir[-1] ) eq 'dev'
  69         && lc( $toolsrcdir[-2] ) eq 'tools';
  70 my @topsrcdir = @toolsrcdir[ 0 .. $#toolsrcdir - 2 ];
  71 my $topsrcdir = File::Spec->catdir(@topsrcdir);
  72 my $manifest  = File::Spec->catfile( $topsrcdir, 'MANIFEST' );
  73 my @srcfiles;
  74 if ( open( my $MANIFEST, '<', $manifest ) ) {
  75     my %dstdir;
  76     while (<$MANIFEST>) {
  77         next if /^\#/;
  78         if (/^(.+?)\s+\[/) {
  79             my $manifile = $1;
  80             my @manifile = split( m!/!, $manifile );
  81             my $dstfile  = File::Spec->catfile(@manifile);
  82             my $srcfile  = File::Spec->catfile( $topsrcdir, @manifile );
  83             unless ( -f $srcfile ) {
  84                 warn "$self: cannot find $dstfile\n";
  85                 next;
  86             }
  87             push @srcfiles, $srcfile;
  88             if ( @manifile > 1 ) {
  89                 for my $i ( 0 .. $#manifile - 1 ) {
  90                     my $dstdir = File::Spec->catdir( @manifile[ 0 .. $i ] );
  91                     if ( !-d $dstdir && !$dstdir{$dstdir}++ ) {
  92                         unless ( mkdir( $dstdir, 0755 ) ) {
  93                             warn "$self: mkdir $dstdir failed: $!\n";
  94                         }
  95                     }
  96                 }
  97             }
  98             my $readlink;
  99             if ( -e $dstfile ) {
 100                 if ( -l $dstfile ) {
 101                     unless ( defined( $readlink = readlink($dstfile) ) ) {
 102                         warn "$self: readlink $dstfile failed: $!\n";
 103                     }
 104                 }
 105                 else {
 106                     warn "$self: $dstfile exists but is not a symlink\n";
 107                 }
 108             }
 109             if ( !defined $readlink || $readlink ne $srcfile ) {
 110                 print "$dstfile\n" if $v;
 111                 if ( defined $readlink ) {
 112                     unless ( unlink($dstfile) ) {
 113                         warn "$self: unlink $dstfile failed: $!\n";
 114                     }
 115                 }
 116                 unless ( symlink( $srcfile, $dstfile ) ) {
 117                     warn "$self: symlink $srcfile $dstfile failed: $!\n";
 118                 }
 119             }
 120         }
 121     }
 122     warn "$self: could not find any files to symlink\n" unless @srcfiles;
 123     close($MANIFEST);
 124 }
 125 else {
 126     die "$self: Failed to open $manifest: $!\n";
 127 }
 128
 129 exit(0);
 130
 131 # Local Variables:
 132 #   mode: cperl
 133 #   cperl-indent-level: 4
 134 #   fill-column: 100
 135 # End:
 136 # vim: expandtab shiftwidth=4: