view release on metacpan or  search on metacpan

lib/Win32/Symlinks.pm  view on Meta::CPAN

      }
      my $cmd = $ENV{COMSPEC} || 'cmd.exe';
      my $directory = File::Basename::dirname($path);
      my $item = File::Basename::basename($path);
      my @r = `"$cmd" /c dir /A:l "$directory" 2>&1`;
      for my $i (@r) {
        if ($i =~ m[<(JUNCTION|SYMLINK|SYMLINKD)>\s+(.*?)\s+\Q[\E([^\]]+)\Q]\E]) {
          my ($type, $name, $target) = ($1, $2, $3);
          for my $i ($type, $name, $target) {
            $i =~ s[(^\s+|\s+$)][]g;
          }
          if ($name eq $item) {
            $Win32::Symlinks::Type = $type;
            return $target;
          }
        }
      }
      return;
    };
    
    if ($mklink_works) {
      *CORE::GLOBAL::symlink = sub ($$) {
        my ($old, $new) = (shift, shift);
        return unless defined $old;
        return unless defined $new;
        $old = File::Spec->catdir(File::Spec->splitdir($old));
        $new = File::Spec->catdir(File::Spec->splitdir($new));
        my $r;
        if (-d $old) {
          $r = `mklink /d "$new" "$old" 2>&1`;
        } else {
          $r = `mklink "$new" "$old" 2>&1`;
        }
        return 1 if $r =~ /\Q<<===>>\E/;
        return 0;
      };
    }
    
    *CORE::GLOBAL::unlink = sub (@) {
      my $retval = 0;
      my @args = @_;
      for my $path (@args) {
        next unless defined $path;
        $path = File::Spec->catdir(File::Spec->splitdir($path));
        my $cmd = $ENV{COMSPEC} || 'cmd.exe';
        if (_test_d($path) and l($path)) {
          my $r = `"$cmd" /c rmdir "$path" 2>&1`;
          $retval += $r ? 0 : 1;
        } elsif (l($path)) {
          my $r = `"$cmd" /c del /Q "$path" 2>&1`;
          $retval += $r ? 0 : 1;
        } else {
          $retval += CORE::unlink($path);
        }
      }
      $retval;
    };
  }
}

sub l ($) {
  return 1 if defined readlink($_[0]);
  return 0;
}

# We need this because some versions of Perl (seen in 5.18) return true for -f dir_symlink
# and false for -d dir_symlink. This breaks the unlink override.
sub _test_d {
  my $path = shift;
  my $cmd = $ENV{COMSPEC} || 'cmd.exe';
  my $r = `"$cmd" /c cd "$path" 2>&1`;
  $r =~ s/(^\s+|\s+$)//g;
  return $r ? 0 : 1;
}


=head1 SYNOPSIS

This module enables, on Windows, symlink related Perl features that don't work by default on Windows.

Specifically, it enables the functionality that you would see on *nix OSes, for C<-l $filename>, C<symlink>, C<readlink> and C<unlink>.

This features have never properly been ported to Windows by the Perl development team. They were initially unimplemented due to the
limitations that Windows used to have prior to NTFS (e.g. when Windows used Fat32 as main file system).

That situation has been different for at least two decades now. Yet, Perl continues to keep these functions unimplemented on Windows.

The aim of this module is to allow Perl code to use C<-l $filename>, C<symlink>, C<readlink> and C<unlink> seamlessly between *nix
and Windows. Just by using the module, it will do its best effort to make these functions work exactly the same and as they are
expected to work.

The module doesn't do anything if it is run on a *nix machine, it defaults to the built in functions. But, by being present in your
code, you'll ensure these functions don't break when being executed in a Windows based Perl distribution.

Perhaps a little code snippet.

  use Win32::Symlinks;

  # That's it. Now symlink, readlink, unlink and -l will work correctly when
  # executed under Windows.
  
  # Also, you don't need to call it everywhere. Calling it once is enough.
    
    

=head1 EXPORT

Only when running under Windows, the built in functions C<symlink>, C<readlink> and C<unlink>,
as well as the file test C<-l>, are overriden.

If at some point you really need to make sure you are calling the built in function,
you should explicitly use the CORE prefix (e.g. C<CORE::readlink($file)>).

When running on any OS that is *not* Windows, it will default to the built in
Perl functions. This module doesn't do anything on non Windows platforms, which
makes it perfect if you are working on a non Windows machine but want to make
sure your symlink related functions will not break under Windows.

=head1 AUTHOR

Francisco Zarabozo, C<< <zarabozo at cpan.org> >>