symlink_farm.pl

#! /usr/bin/perl

use Getopt::Long qw(:config no_auto_abbrev no_getopt_compat require_order no_ignore_case);
use File::Find;
use File::stat;
use File::Spec::Functions qw(abs2rel file_name_is_absolute catdir catfile splitpath);
use Fcntl ':mode';
use Cwd qw(abs_path cwd);
use autodie ':filesys';
use strict;

package main;

$main::USAGE = <<EOT ;
SYNOPSIS
  symlink_farm [OPTION ...] SRCDIR ...
OPTIONS
  -h, --help                    print this summary on stderr
  -e NAME, --exclude_name NAME  don't link NAME
                                  exact match with bare filename w/o dirname
                                  may be repeated
  -p PATH, --exclude_path PATH  don't link PATH
                                  regexp match with full path incl. SRCDIR
                                  only the last value is effective
  -v, --verbose                 print semi-readable log of actions on stdout
  -n, --not_really              only print log of actions that _would_ be done
EOT

$| = 1;
$main::verbose;
$main::not_really;
@main::exclude_name;
%main::exclude_name_set = ();
$main::exclude_path;
$main::pwd = abs_path(cwd);
$main::SRCDIR;
$main::real_srcdir;
$main::is_absolute;

sub e { die "Error: $_[0]\n"; }

sub usage {
  print STDERR $main::USAGE;
  e 'command line arguments';
}

# determine if p1 is an ancestor of p2
# and return a relative path from p1 to p2; otherwise the empty string.
sub subpath {
  my ($p1, $p2) = @_;
  my $relpath = abs2rel($p2, $p1);
  return '' if $relpath =~ qr( ^[.][.] (/.*)? $ )x;
  return $relpath;
}

sub do_symlink {
  our ($verbose, $not_really);
  my ($target, $farmpath) = @_;
  # If the path already exists, check that it is a symlink with the same target
  if (-e $farmpath) {
    my $stb = lstat $farmpath;
    e(qq($farmpath exists and is not a symlink to $target))
      unless S_ISLNK($stb->mode) && readlink($farmpath) eq $target;
    return;
  }
  printf(qq(%s -> %s\n), $farmpath, $target) if $verbose || $not_really;
  symlink($target, $farmpath) unless $not_really;
}

sub do_mkdir {
  our ($verbose, $not_really);
  my ($farmpath) = @_;
  # If the path already exists, check that it is a directory
  if (-e $farmpath) {
    my $stb = lstat $farmpath;
    e(qq($farmpath exists and is not a directory))
      unless S_ISDIR($stb->mode);
    return;
  }
  printf(qq(%s/\n), $farmpath) if $verbose || $not_really;
  mkdir $farmpath  unless $not_really;
}

sub wanted {
  our ($SRCDIR, $real_srcdir);
  our ($pwd, %exclude_name_set, $exclude_path, $is_absolute);
  # This is ugly, but there is no straight way to check if I am processing
  # the top of the source tree :-(
  return if $SRCDIR eq $File::Find::name;
  # Make the rest behave as if no_chdir were not in effect.
  $_ = (splitpath($File::Find::name))[2];

  $File::Find::prune = 1, return if exists $exclude_name_set{$_};
  $File::Find::prune = 1, return
    if defined $exclude_path && $File::Find::name =~ qr($exclude_path);

  my $rel_src = abs2rel($File::Find::dir, $SRCDIR);
  my $farmdir = catdir($pwd, $rel_src);
  my $farmpath = catfile($farmdir, $_);
  my $stb = lstat $File::Find::name;
  # If I am looking at a symlink, and the target of the symlink is a directory,
  # check that the target directory is within the source tree.
  if (S_ISLNK($stb->mode)) {
    my $stb_real = stat $File::Find::name;
    if (S_ISDIR($stb_real->mode)) {
      my $real_target = subpath($real_srcdir, abs_path($File::Find::name));
      e(qq(Cannot farm $File::Find::name as it's not within $real_srcdir))
        unless $real_target;
      my $uptarget = catfile($pwd, $real_target);
      do_symlink(abs2rel($uptarget, $farmdir), $farmpath);
      return;
    }
  }
  if (!S_ISDIR($stb->mode)) {
    if ($is_absolute || $farmdir eq $pwd) {
      do_symlink($File::Find::name, $farmpath);
    } else {
      my $farm_rel = abs2rel($pwd, $farmdir);
      my $target = catfile($farm_rel, $File::Find::name);
      do_symlink($target, $farmpath);
    }
  } else {
    # If it is a real directory (not a symlink to one), recreate it.
    do_mkdir($farmpath);
  }
}

GetOptions('verbose|v' => \$main::verbose,
           'help|h' => sub { print STDERR $main::USAGE; exit 0 },
           'not_really|n' => \$main::not_really,
           'exclude_path=s' => \$main::exclude_path,
           'exclude_name|e=s@' => \@main::exclude_name)
  or usage;

foreach (@main::exclude_name) { $main::exclude_name_set{$_} = 1 }

foreach $main::SRCDIR (@ARGV) {
  our ($pwd, $real_srcdir, $SRCDIR, $is_absolute);
  my $stb = stat $SRCDIR;
  S_ISDIR($stb->mode) or usage;

  # Remove trailing slashes that would confuse us.
  $SRCDIR = $1 if $SRCDIR =~ qr( ^ ( / | .* [^/] ) [/]+ $ )x;
  $real_srcdir = abs_path($SRCDIR);

  # Check that SRCDIR is not above pwd; madness would surely ensue.
  # The converse is not a problem, in general.
  e(qq(Cannot farm $real_srcdir as it is an ancestor of $pwd))
    if subpath($real_srcdir, $pwd);

  $is_absolute = file_name_is_absolute($SRCDIR);
  find({wanted => \&wanted, no_chdir => 1}, $SRCDIR);
}

exit 0;

Maybe a dumb question, but as you mentioned this as an example for a problem best-solved-using-Perl I still remain without a grasp of its use case.

Of cause I see the high syscall and string wrangling, in fact I have my own examples where I prefer perl over anything else.

To anybody else reading this: Perl is nice, don't disregard a language on it's reputation alone. I grew to love it for its power and clarity when written nicely.

It does more-or-less the same thing as lndir from the Xorg codebase. Is that enough of a use case? :-)

if not: how about out-of-source builds independent of whether the project builds with [ make | cmake | automake | cons | scons ] et cetera ...