File Coverage

blib/lib/Win32/Symlinks.pm
Criterion Covered Total %
statement 10 83 12.0
branch 1 46 2.1
condition 0 15 0.0
subroutine 4 7 57.1
pod 0 1 0.0
total 15 152 9.8


line stmt bran cond sub pod time code
1             package Win32::Symlinks;
2            
3 2     2   55648 use 5.006;
  2         10  
4 2     2   8 use strict;
  2         3  
  2         32  
5 2     2   8 use warnings;
  2         4  
  2         1990  
6            
7             =encoding latin1
8            
9             =head1 NAME
10            
11             Win32::Symlinks - A maintained, working implementation of Perl symlink built in features for Windows.
12            
13             =head1 VERSION
14            
15             Version 0.10
16            
17             =cut
18            
19             sub _mklink_works {
20 0 0   0     my $cmd = ($ENV{COMSPEC} =~ /^(.*?)$/) ? $1 : 'cmd.exe'; # Untaint
21 0           my $r = `"$cmd" /c mklink /? 2>&1`;
22 0 0 0       if ($r =~ m[/D]i and $r =~ m[/H]i and $r =~ m[/J]i) {
      0        
23 0           return 1;
24             }
25 0           return 0;
26             }
27            
28             BEGIN {
29 2     2   7 our $VERSION = '0.10';
30 2 50       297 if ($^O eq 'MSWin32') {
31 0           require Parse::Lnk;
32 0           require File::Spec;
33 0           require File::Basename;
34 0           my $mklink_works = _mklink_works();
35            
36 0 0         if ($] >= 5.016) {
37 0           require XSLoader;
38 0           XSLoader::load();
39 0           _override_link_test();
40             } else {
41 0 0         unless ($ENV{WIN32_SYMLINKS_SUPRESS_VERSION_WARNING}) {
42 0           print STDERR "Warning: ".__PACKAGE__." can't override the -l operator on Perl versions older than 5.016. You are running $].\n";
43 0           print STDERR "You can supress this warning by setting the environment variable WIN32_SYMLINKS_SUPRESS_VERSION_WARNING to a true value.\n";
44             }
45             }
46            
47 0 0         unless ($mklink_works) {
48 0 0         unless ($ENV{WIN32_SYMLINKS_SUPRESS_VERSION_WARNING}) {
49 0           print STDERR "Warning: ".__PACKAGE__." cannot override the function 'symlink' because mklink doesn't seem to be available in this system.\n";
50 0           print STDERR "You can supress this warning by setting the environment variable WIN32_SYMLINKS_SUPRESS_VERSION_WARNING to a true value.\n";
51             }
52             }
53            
54             *CORE::GLOBAL::readlink = sub ($) {
55 0           my $path = shift;
56 0           undef $Win32::Symlinks::Type;
57 0           $path = File::Spec->catdir(File::Spec->splitdir($path));
58 0 0         if ($path =~ /\.lnk$/i) {
59 0           my $target = Parse::Lnk->from($path);
60 0 0         if ($target) {
61 0           $Win32::Symlinks::Type = 'SHORTCUT';
62 0           return $target;
63             }
64             }
65 0   0       my $cmd = $ENV{COMSPEC} || 'cmd.exe';
66 0           my $directory = File::Basename::dirname($path);
67 0           my $item = File::Basename::basename($path);
68 0           my @r = `"$cmd" /c dir /A:l "$directory" 2>&1`;
69 0           for my $i (@r) {
70 0 0         if ($i =~ m[<(JUNCTION|SYMLINK|SYMLINKD)>\s+(.*?)\s+\Q[\E([^\]]+)\Q]\E]) {
71 0           my ($type, $name, $target) = ($1, $2, $3);
72 0           for my $i ($type, $name, $target) {
73 0           $i =~ s[(^\s+|\s+$)][]g;
74             }
75 0 0         if ($name eq $item) {
76 0           $Win32::Symlinks::Type = $type;
77 0           return $target;
78             }
79             }
80             }
81 0           return;
82 0           };
83            
84 0 0         if ($mklink_works) {
85             *CORE::GLOBAL::symlink = sub ($$) {
86 0           my ($old, $new) = (shift, shift);
87 0 0         return unless defined $old;
88 0 0         return unless defined $new;
89 0           $old = File::Spec->catdir(File::Spec->splitdir($old));
90 0           $new = File::Spec->catdir(File::Spec->splitdir($new));
91 0           my $r;
92 0 0         if (-d $old) {
93 0           $r = `mklink /d "$new" "$old" 2>&1`;
94             } else {
95 0           $r = `mklink "$new" "$old" 2>&1`;
96             }
97 0 0         return 1 if $r =~ /\Q<<===>>\E/;
98 0           return 0;
99 0           };
100             }
101            
102             *CORE::GLOBAL::unlink = sub ($) {
103 0           my $path = shift;
104 0 0         return unless defined $path;
105 0           $path = File::Spec->catdir(File::Spec->splitdir($path));
106 0   0       my $cmd = $ENV{COMSPEC} || 'cmd.exe';
107 0 0 0       if (_test_d($path) and l($path)) {
    0          
108 0           my $r = `"$cmd" /c rmdir "$path" 2>&1`;
109 0 0         return $r ? 0 : 1;
110             } elsif (l($path)) {
111 0           my $r = `"$cmd" /c del /Q "$path" 2>&1`;
112 0 0         return $r ? 0 : 1;
113             }
114 0           return CORE::unlink($path);
115 0           };
116             }
117             }
118            
119             sub l ($) {
120 0 0   0 0   return 1 if defined readlink($_[0]);
121 0           return 0;
122             }
123            
124             # We need this because some versions of Perl (seen in 5.18) return true for -f dir_symlink
125             # and false for -d dir_symlink. This breaks the unlink override.
126             sub _test_d {
127 0     0     my $path = shift;
128 0   0       my $cmd = $ENV{COMSPEC} || 'cmd.exe';
129 0           my $r = `"$cmd" /c cd "$path" 2>&1`;
130 0           $r =~ s/(^\s+|\s+$)//g;
131 0 0         return $r ? 0 : 1;
132             }
133            
134            
135             =head1 SYNOPSIS
136            
137             This module enables, on Windows, symlink related Perl features that don't work by default on Windows.
138            
139             Specifically, it enables the functionality that you would see on *nix OSes, for C<-l $filename>, C, C and C.
140            
141             This features have never properly been ported to Windows by the Perl development team. They were initially unimplemented due to the
142             limitations that Windows used to have prior to NTFS (e.g. when Windows used Fat32 as main file system).
143            
144             That situation has been different for at least two decades now. Yet, Perl continues to keep these functions unimplemented on Windows.
145            
146             The aim of this module is to allow Perl code to use C<-l $filename>, C, C and C seamlessly between *nix
147             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
148             expected to work.
149            
150             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
151             code, you'll ensure these functions don't break when being executed in a Windows based Perl distribution.
152            
153             Perhaps a little code snippet.
154            
155             use Win32::Symlinks;
156            
157             # That's it. Now symlink, readlink, unlink and -l will work correctly when
158             # executed under Windows.
159            
160             # Also, you don't need to call it everywhere. Calling it once is enough.
161            
162            
163            
164             =head1 EXPORT
165            
166             Only when running under Windows, the built in functions C, C and C,
167             as well as the file test C<-l>, are overriden.
168            
169             If at some point you really need to make sure you are calling the built in function,
170             you should explicitly use the CORE prefix (e.g. C).
171            
172             When running on any OS that is *not* Windows, it will default to the built in
173             Perl functions. This module doesn't do anything on non Windows platforms, which
174             makes it perfect if you are working on a non Windows machine but want to make
175             sure your symlink related functions will not break under Windows.
176            
177             =head1 AUTHOR
178            
179             Francisco Zarabozo, C<< >>
180            
181             =head1 BUGS
182            
183             I'm sure there are many that I haven't been able to trigger. If you find a bug,
184             please don't hesitate to report it. I promise I will make an effort to have it
185             resolved ASAP.
186            
187             Take into account that this implementation can only work on NTFS file systems.
188             Symlinks are not implemented in file systems like FAT32. Windows has been using
189             NTFS since Windows 2000, but it used FAT32 for Windows 95, 98, Millenium, etc.
190            
191             Also, external devices like USB sticks, SD cards, etc., are generally formatted
192             with FAT32 or ExFAT. So, if you try to use these functions over such devices,
193             it will fail, unless you format them with the NTFS file system first.
194            
195             Please report any bugs or feature requests to C, or through
196             the web interface at L. I will be notified, and then you'll
197             automatically be notified of progress on your bug as I make changes.
198            
199            
200            
201            
202             =head1 SUPPORT
203            
204             You can find documentation for this module with the perldoc command.
205            
206             perldoc Win32::Symlinks
207            
208            
209             You can also look for information at:
210            
211             =over 4
212            
213             =item * RT: CPAN's request tracker (report bugs here)
214            
215             L
216            
217             =item * AnnoCPAN: Annotated CPAN documentation
218            
219             L
220            
221             =item * CPAN Ratings
222            
223             L
224            
225             =item * Search CPAN
226            
227             L
228            
229             =back
230            
231            
232             =head1 ACKNOWLEDGEMENTS
233            
234             A small part of C code was taken from the Win32_Links project from Jlevens,
235             which has a GNU v2.0 license and can be found at
236             L.
237            
238            
239             =head1 LICENSE AND COPYRIGHT
240            
241             This software is copyright (c) 2021 by Francisco Zarabozo.
242            
243             This is free software; you can redistribute it and/or modify it under
244             the same terms as the Perl 5 programming language system itself.
245            
246            
247             =cut
248            
249             1; # End of Win32::Symlinks