Applying patch submitted by wayland++ in https://trac.parrot.org/parr…

…ot/attachment/ticket/509/symlink_copier.patch. Needs testing in non-symlinkable situations. git-svn-id: https://svn.parrot.org/parrot/branches/tt509_install_files@40840 d31e2699-5ff4-0310-a27c-f18f2fbe73fe
ashgti · Aug 28, 2009 · 3ebc338 · 3ebc338
1 parent 1f0f0c5
commit 3ebc338
Showing 1 changed file with 27 additions and 1 deletion.
diff --git a/lib/Parrot/Install.pm b/lib/Parrot/Install.pm
@@ -211,7 +211,7 @@ sub install_files {
 
     ref($files) eq 'ARRAY' or die "Error: parameter \$files must be an array\n";
     print("Installing ...\n");
-    foreach my $el ( @$files ) {
+    FILE: foreach my $el ( @$files ) {
         unless(ref($el) eq 'HASH') {
             my($ref) = ref($el);
             warn "Bad reference passed in \$files (want a HASH, got a '$ref')\n";
@@ -226,6 +226,32 @@ sub install_files {
         else {
             next unless -e $src;
             next if $^O eq 'cygwin' and -e "$src.exe"; # stat works, copy not
+            SYMLINK: {
+                if (! -l $src) { last SYMLINK; }
+
+                # check if the *system* supports symbolic linking 
+                use Config; 
+                if (! ($Config{d_symlink} && $Config{d_readlink})) { last SYMLINK; }
+
+                # copy as symbolic link;
+                # be extra cautious about existence of symlinks
+                # on a given OS
+                use Errno;
+                if(! exists $!{EPERM}) { last SYMLINK; } # Doesn't seem to support this
+                my $symlink_exists = eval {
+                    symlink(readlink($src), $dest); 1;
+                };
+                $@ and die $@;
+                if (! $symlink_exists) {
+                    if($!{EPERM}) {
+                        warn "Warning: filesystem does not support symbolic links!\n";
+                        last SYMLINK;
+                    }
+                    die "Error copying symlink: $!";
+                }
+                print "$dest\n"; 
+                next FILE; 
+            }
             copy( $src, $dest ) or die "Error: couldn't copy $src to $dest: $!\n";
             print "$dest\n";
         }