PortIO.pm

   1 package PortIO;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 PortIO - semitransparent unicode filename support on windows
   9
  10 =head1 DESCRIPTION
  11
  12 This module implements several wrapper functions for file handling. They are
  13 intended to be used as a workaround when writing cross-platform code that needs
  14 to run on windows, since Perl doesn't support unicode filenames there. All
  15 functions defined here were tested to work on both windows and linux.
  16
  17 These functions also always try to use long absolute paths on windows, which
  18 allows have a length of up to 65536 characters. It can convert relative
  19 paths to absolute ones.
  20
  21 =head1 FUNCTIONS
  22
  23 All functions expect to receive utf8 strings as arguments and return utf8
  24 strings.
  25
  26 =head2 C<printout($)>
  27
  28 Prints a single string to STDOUT.
  29
  30 =head2 C<printerr($)>
  31
  32 Prints a single string to STDERR.
  33
  34 =head2 C<move($source,$destination)>
  35
  36 Moves a file from $source to $destination.
  37
  38 =head2 C<mkpath($path)>
  39
  40 Creates the $path folder with all needed parent folders.
  41
  42 =head2 C<rmpath($path)>
  43
  44 Recursively deletes $path.
  45
  46 =head2 C<stat($path)>
  47
  48 Returns a L<File::stat> object with information from the file pointed
  49 by $path. Follow symlinks on unix, not yet on windows.
  50
  51 =head2 C<lstat($path)>
  52
  53 Does the same as L</C<stat($path)>>, but doesn't follow symlinks.
  54
  55 =head2 C<file_exists($path)>
  56
  57 Equivalent to L<-e|-X>, returns true if $path exists.
  58
  59 =head2 C<file_size($path)>
  60
  61 Equivalent to L<-s|-X>, returns the file size in bytes.
  62
  63 =head2 C<is_dir($path)>
  64
  65 Equivalent to L<-d|-X>, returns 1 if $path is a directory.
  66
  67 =head2 C<is_file($path)>
  68
  69 Equivalent to L<-f|-X>, returns 1 if $path is a file.
  70
  71 =head2 C<file_open($mode, $path)>
  72
  73 Wrapper around three-argument L<open>(). Returns the opened PerlIO handle that
  74 can be used in any other regular perl function.
  75 Currently supports only the '>', '>>', '<', '+<' and '+>' modes.
  76 Also supports PerlIO layers.
  77
  78 =head2 C<file_unlink($file)>
  79
  80 Equivalent to L<unlink>, unlinks a file.
  81
  82 =head2 C<dir_rm($dir)>
  83
  84 Equivalent to L<rmdir>, Removes a directory if it is empty.
  85
  86 =head2 C<diropen($dir)>
  87
  88 Wrapper around L<opendir>. Opens a handle to $dir, returns the handle. Note
  89 that the returned handle is only compatible with PerlIO::dirread and
  90 PerlIO::dirclose.
  91
  92 =head2 C<dirread($handle)>
  93
  94 Wrapper around L<readdir>. Returns the next child item in the directory. The
  95 returned item is always the basename, so you need to prepend it with the
  96 directory path if you intend to do anything with a child item.
  97
  98 NOTE: This function expects the the filesystem to use UTF-8 filenames on non-windows.
  99
 100 =head2 C<dirclose($handle)>
 101
 102 Closes a $handle previously returned by L</"diropen">. This also makes the $handle
 103 invalid.
 104
 105 =cut
 106
 107 use Symbol;
 108 use Encode;
 109 use Fcntl ':mode';
 110
 111 require File::stat;
 112
 113 BEGIN {
 114         use Exporter ();
 115         our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
 116
 117         $VERSION = 0.1;
 118
 119         @ISA = qw(Exporter);
 120
 121         @EXPORT = qw(*printout *printerr *move *mkpath *rmpath
 122                      *file_exists *file_size *is_dir *is_file
 123                      *file_open *file_unlink *dir_rm
 124                      *diropen *dirread *dirclose);
 125 };
 126 our @EXPORT_OK;
 127
 128 ### Windows Unicode support wrappers
 129 if ($^O =~ /MSWin/) {
 130         require Win32API::File;
 131         Win32API::File->import qw(:FuncW :Func :MOVEFILE_ :GENERIC_ :FILE_
 132                                   :FILE_SHARE_ :FILE_TYPE_ :FILE_ATTRIBUTE_ :Misc);
 133         require Win32::API; Win32::API->import;
 134         require Win32API::File::Time;
 135
 136         # Enable output of UTF-8 text
 137
 138         my $WriteConsoleW = Win32::API->new('kernel32.dll', 'WriteConsoleW',
 139                                             'IPIPP', 'I') or die "WriteConsoleW: $^E";
 140
 141         my $stdout = GetOsFHandle(*STDOUT);
 142         my $stderr = GetOsFHandle(*STDERR);
 143
 144         # Use Win32::API to load needed functions not defined by Win32API::File
 145
 146         my $FindFirstFileW = Win32::API->new('kernel32.dll', 'FindFirstFileW',
 147                                              'PP', 'N') or die "FindFirstFileW: $^E";
 148         my $FindNextFileW  = Win32::API->new('kernel32.dll', 'FindNextFileW',
 149                                              'NP', 'I') or die "FindNextFileW: $^E";
 150         my $FindClose      = Win32::API->new('kernel32.dll', 'FindClose',
 151                                              'N', 'I') or die "FileClose: $^E";
 152
 153         my $CreateDirectoryW = Win32::API->new('kernel32.dll',
 154             'BOOL CreateDirectoryW(LPCWSTR lpPathName, LPVOID lpSecurityAttributes);')
 155                 or die "CreateDirectoryW: $^E";
 156
 157         my $RemoveDirectoryW = Win32::API->new('kernel32.dll',
 158             'BOOL RemoveDirectoryW(LPCWSTR lpPathName);') or die "RemoveDirectoryW: $^E";
 159
 160         my $GetFullPathNameW = Win32::API->new('kernel32.dll',
 161             'DWORD GetFullPathNameW(LPCWSTR lpFileName, DWORD nBufferLength, '.
 162             'LPWSTR lpBuffer, LPWSTR *lpFilePart);') or die "GetFullPathNameW: $^E";
 163
 164         my $GetFileTime = Win32::API->new('kernel32.dll', 'GetFileTime', [qw{N P P P}], 'I') or
 165                 die "GetFileTime: $^E";
 166
 167         my $GetCurrentDirectoryW = Win32::API->new('kernel32.dll',
 168             'DWORD GetCurrentDirectoryW(DWORD nBufferLength, LPWSTR lpBuffer);') or
 169                 die "GetCurrentDirectoryW: $^E";
 170
 171         my $utf16 = find_encoding("UTF-16LE");
 172
 173         my $abs_fname = sub {
 174                 my $str = shift;
 175                 return undef unless defined($str);
 176                 # Replaces special start sequences with meaningful values
 177                 # . = current working directory
 178                 # .. = parent of the cwd
 179                 # / = root directory of the cwd
 180                 if ($str =~ /^[\.\/]\.?/) {
 181                         my $len = $GetCurrentDirectoryW->Call(0, []);
 182                         my $dir = " " x ($len*2);
 183                         $len = $GetCurrentDirectoryW->Call($len, $dir);
 184                         $dir = substr($dir, 0, $len*2);
 185                         $dir = $utf16->decode($dir);
 186                         my @path = split(/\\/, $dir);
 187                         if ($str =~ /^\.\./) {
 188                                 $dir = join("\\", @path[0..$#path-1]);
 189                                 $str =~ s/^\.\./$dir/;
 190                         } elsif ($str =~ /^\./) {
 191                                 $str =~ s/^\./$dir/;
 192                         } else {
 193                                 $str =~ s/^\//$path[0]\//;
 194                         }
 195                 }
 196                 $str =~ s/\//\\/g;
 197                 my @inpath = split(/\\/, $str);
 198                 my @path = ();
 199                 # Remove . and .. from the path by resolving them
 200                 foreach (@inpath) {
 201                         if ($_ eq '.') {
 202                                 # Do nothing (stay on the current dir)
 203                         } elsif ($_ eq '..') {
 204                                 # Remove the last element (current dir) to get to the parent dir
 205                                 pop @path unless @path == 1;
 206                         } else {
 207                                 push @path, $_;
 208                         }
 209                 }
 210                 $str = join('\\', @path);
 211                 # Make sure the drive letter has a \\ right after it
 212                 $str .= "\\" if $str =~ /^\w:[^\\]$/;
 213                 my $in = "$str";
 214                 $in = "\\\\?\\$in" unless $in =~ m/^\\\\?\\/;
 215                 my $orig = $utf16->encode($in);
 216                 $in = $orig . "\0\0";
 217                 my $len = 0;
 218                 my $out = " " x (($len = $GetFullPathNameW->Call($in, 0, [], [])) * 2);
 219                 $len = $GetFullPathNameW->Call($in, $len, $out, []);
 220                 $out = substr($out, 0, $len*2);
 221                 if ($out eq $orig) {
 222                         $in = $utf16->encode("$str\0");
 223                         $out = " " x (($len = $GetFullPathNameW->Call($in, 0, [], [])) * 2);
 224                         $len = $GetFullPathNameW->Call($in, $len, $out, []);
 225                         $out = substr($out, 0, $len*2);
 226                         $out = $utf16->encode("\\\\?\\" . $utf16->decode($out) . "\0");
 227                         return $out;
 228                 } else {
 229                         return $out;
 230                 }
 231                 return $utf16->encode("$str\0");
 232         };
 233         my $print = sub {
 234                 my $fd = shift;
 235                 my $str = join(" ",@_);
 236                 my $len = length($str);
 237                 $str = $utf16->encode($str);
 238                 my $count = 0;
 239                 return $count if $WriteConsoleW->Call($fd, $str, $len, $count, []);
 240                 return 0;
 241         };
 242
 243         *printout = sub {
 244                 $print->($stdout, shift);
 245         };
 246         *printerr = sub {
 247                 $print->($stderr, shift);
 248         };
 249         *move = sub {
 250                 my ($src, $dest) = @_;
 251                 MoveFileExW($abs_fname->("$src"), $abs_fname->("$dest"),
 252                             fileConstant("MOVEFILE_COPY_ALLOWED")|
 253                             fileConstant("MOVEFILE_WRITE_THROUGH"));
 254         };
 255         *mkpath = sub {
 256                 my $path = shift;
 257                 my $p = $path;
 258                 unless (file_exists($path)) {
 259                         $! = 0;
 260                         unless ($CreateDirectoryW->Call($abs_fname->("$p"), undef)) {
 261                                 my $parent = $path;
 262                                 $parent =~ s/\/[^\/]*$//;
 263                                 if ($parent eq $path) {
 264                                         return undef;
 265                                 }
 266                                 unless (mkpath($parent)) {
 267                                         return undef;
 268                                 }
 269                                 # Parent made, try again making the child
 270                                 unless ($CreateDirectoryW->Call($abs_fname->("$p"), undef)) {
 271                                         return undef;
 272                                 }
 273                         }
 274                 }
 275                 return $path;
 276         };
 277         *rmpath = sub {
 278                 my $path = shift;
 279                 my $dir = diropen($path);
 280                 while ($_ = dirread($dir)) {
 281                         $_ = decode("UTF-8", $_, 1);
 282                         unless($_ eq '.' or $_ eq '..') {
 283                                 $_ = "$path/$_";
 284                                 if (is_dir($_)) {
 285                                         rmpath($_) or (dirclose($dir) and return 0);
 286                                 } else {
 287                                         file_unlink($_) or (dirclose($dir) and return 0);
 288                                 }
 289                         }
 290                 }
 291                 dirclose($dir);
 292                 dir_rm($path) or return 0;
 293                 return 1;
 294         };
 295         *lstat = sub {
 296             my $arg = shift;
 297                 my $attrib = GetFileAttributesW($abs_fname->("$arg"));
 298                 if ($attrib == INVALID_FILE_ATTRIBUTES()) {
 299                         return undef;
 300                 }
 301                 my $handle;
 302
 303                 # TODO: figure out how to get the 1st field. 2nd doesn't exist on windows.
 304                 my @stat = (0, 0);
 305                 my $mode = S_IRWXU | S_IRWXG | S_IRWXO;
 306                 $mode &= ~(S_IWUSR | S_IWGRP | S_IWOTH) if ($attrib & FILE_ATTRIBUTE_READONLY());
 307                 if ($attrib & FILE_ATTRIBUTE_DIRECTORY()) {
 308                         $mode |= S_IFDIR;
 309                 } else {
 310                         $handle = CreateFileW($abs_fname->("$arg"), 0,
 311                                               FILE_SHARE_READ() | FILE_SHARE_WRITE(), [],
 312                                               OPEN_EXISTING(), 0, []);
 313                         my $type = GetFileType($handle);
 314                         if ($type & FILE_TYPE_DISK()) {
 315                                 $mode |= S_IFREG;
 316                         } else {
 317                                 warn "Unknown filetype $type";
 318                         }
 319                 }
 320                 push @stat, $mode;
 321                 # TODO: figure out the next 4 fields.
 322                 push @stat, (1, 0, 0, 6);
 323                 if ($handle) {
 324                         push @stat, (getFileSize($handle)->numify());
 325                         my ($atime, $mtime, $ctime);
 326                         $atime = $mtime = $ctime = pack 'LL', 0, 0;
 327                         $GetFileTime->Call($handle, $ctime, $atime, $mtime);
 328                         push @stat, (Win32API::File::Time::_filetime_to_perltime($atime),
 329                                      Win32API::File::Time::_filetime_to_perltime($mtime),
 330                                      Win32API::File::Time::_filetime_to_perltime($ctime));
 331                 } else {
 332                         # TODO: implement ^ for directories
 333                         push @stat, (0, 0, 0, 0);
 334                 }
 335                 # Note: the last two fields are undefined on windows.
 336                 my $st = File::stat::populate(@stat);
 337                 return $st if $st;
 338                 return undef;
 339         };
 340         *stat = sub {
 341                 # TODO: actually follow symlinks
 342                 return PortIO::lstat(shift);
 343         };
 344         *file_exists = sub{
 345                 my $p = shift;
 346                 return undef unless $p;
 347                 return GetFileAttributesW($abs_fname->("$p")) != fileConstant("INVALID_FILE_ATTRIBUTES");
 348         };
 349         *file_size = sub{
 350                 my $p = shift;
 351                 return 0 unless file_exists($p);
 352                 my $handle = CreateFileW($abs_fname->("$p"), 0, fileConstant("FILE_SHARE_READ") |
 353                                                                 fileConstant("FILE_SHARE_WRITE"), [],
 354                                                                 fileConstant("OPEN_EXISTING"), 0, []);
 355                 my $size = getFileSize($handle)->numify();
 356                 CloseHandle($handle);
 357                 return $size;
 358         };
 359         *is_dir = sub {
 360                 my $p = shift;
 361                 return 0 unless file_exists($p);
 362                 return !!(GetFileAttributesW($abs_fname->("$p")) & FILE_ATTRIBUTE_DIRECTORY());
 363         };
 364         *is_file = sub {
 365                 my $p = shift;
 366                 return 0 unless file_exists($p);
 367                 my $handle = CreateFileW($abs_fname->("$p"), 0, fileConstant("FILE_SHARE_READ") |
 368                                                                 fileConstant("FILE_SHARE_WRITE"), [],
 369                                                                 fileConstant("OPEN_EXISTING"), 0, []);
 370                 my $is_file = GetFileType($handle) & FILE_TYPE_DISK();
 371                 CloseHandle($handle);
 372                 return $is_file;
 373         };
 374         *file_open = sub {
 375                 my $mode = shift;
 376                 my $file = shift;
 377                 $file = $abs_fname->("$file");
 378                 my @filters = split(':',$mode);
 379                 $mode = shift @filters;
 380                 die "File mode $mode not implemented" unless
 381                     scalar(grep { $mode eq $_ } ('<', '>', '>>', '+<', '+>'));
 382
 383                 my ($flags, $share, $create) = (GENERIC_READ(), FILE_SHARE_READ(), undef);
 384                 if ($mode eq '<') {
 385                         $share |= FILE_SHARE_WRITE();
 386                 } elsif ($mode eq '>' or $mode eq '>>') {
 387                         $flags = GENERIC_WRITE();
 388                 } else {
 389                         $flags |= GENERIC_WRITE();
 390                 }
 391                 if ($mode eq '<') {
 392                         $create = OPEN_EXISTING();
 393                 } elsif ($mode eq '>' or $mode eq '+>') {
 394                         $create = CREATE_ALWAYS();
 395                 } else {
 396                         $create = OPEN_ALWAYS();
 397                 }
 398                 my $handle = CreateFileW($file, $flags, $share, [], $create, 0, []);
 399                 unless ($handle) {
 400                         my $f = $utf16->decode($file);
 401                         printout("Error opening $f: $^E\n");
 402                         die;
 403                 }
 404                 setFilePointer($handle, 0, FILE_END()) if $mode eq '>>';
 405
 406                 my $f = gensym();
 407                 OsFHandleOpen($f, $handle, ($flags & GENERIC_READ() ? 'r' : '') .
 408                                            ($flags & GENERIC_WRITE() ? 'w' : '') .
 409                                            ($mode eq '>>' ? 'a' : '')) and $f or die "$!";
 410
 411                 if (@filters) {
 412                         binmode($f, ":". join(":", @filters));
 413                 }
 414
 415                 return $f;
 416         };
 417         *file_unlink = sub {
 418                 DeleteFileW($abs_fname->(shift));
 419         };
 420         *dir_rm = sub {
 421                 $RemoveDirectoryW->Call($abs_fname->(shift));
 422         };
 423         *diropen = sub {
 424                 my $path = $abs_fname->(($_ = shift) . "/*");
 425                 my $FileInfo = " " x 1140;
 426                 my $handle = $FindFirstFileW->Call($path, $FileInfo);
 427
 428                 return {
 429                         handle => $handle,
 430                         file_info => $FileInfo
 431                 };
 432         };
 433         *dirread = sub {
 434                 my $entry = shift;
 435                 return undef unless exists($entry->{file_info});
 436                 my $FileInfo = $entry->{file_info};
 437                 my ($attrib, $filename);
 438
 439                 $filename = unpack("x44A520", $FileInfo);
 440                 $filename = $utf16->decode("$filename\0", 1);
 441
 442                 $FileInfo = "\0" x (1140); # Clear the struct
 443
 444                 if ($FindNextFileW->Call($entry->{handle}, $FileInfo)) {
 445                         $entry->{file_info} = $FileInfo;
 446                 } else {
 447                         delete $entry->{file_info};
 448                 }
 449
 450                 my @path = split(/\\/, $filename);
 451                 return $path[$#path];
 452         };
 453         *dirclose = sub {
 454                 $FindClose->Call($_[0]->{handle});
 455                 delete $_[0]->{handle};
 456                 delete $_[0]->{file_info};
 457         }
 458 } else {
 459         require File::Copy;
 460         require File::Path;
 461         $|++;
 462         *printout = sub { STDOUT->print(shift); };
 463         *printerr = sub { STDERR->print(shift); };
 464         *move = sub { File::Copy::move(shift, shift); };
 465         *mkpath = sub { File::Path::mkpath(shift); };
 466         *rmpath = sub { File::Path::rmpath(shift); };
 467         *lstat = sub { File::stat::lstat(shift); };
 468         *stat = sub { File::stat::stat(shift); };
 469         *file_exists = sub { -e shift; };
 470         *file_size = sub { -s shift; };
 471         *is_dir = sub { -d shift; };
 472         *is_file = sub { -f shift; };
 473         *file_open = sub {
 474                 my ($mode, $file) = @_;
 475                 my @filters = split(':',$mode);
 476                 $mode = shift @filters;
 477                 die "File mode $mode not implemented" unless
 478                     scalar(grep { $mode eq $_ } ('<', '>', '>>', '+<', '+>'));
 479                 if (@filters) {
 480                         $mode .= ":" . join(":", @filters);
 481                 }
 482                 my $f;
 483                 open ($f, $mode, $file);
 484                 return $f;
 485         };
 486         *file_unlink = sub { unlink(shift); };
 487         *dir_rm = sub { rmdir(shift); };
 488         *diropen = sub { opendir $_, shift; return $_; };
 489         *dirread = sub { decode("UTF-8", readdir(shift), 1); };
 490         *dirclose = sub { closedir shift; }
 491 }
 492
 493 1;