use v6-alpha;
module File::Spec::Unix-0.0.1;
sub curdir returns Str is export { '.' }
sub updir returns Str is export { '..' }
sub rootdir returns Str is export { '/' }
sub devnull returns Str is export { '/dev/null' }
sub case_tolerant returns Bool is export { 0 }
## Splitting
sub splitdir (Str $dir) returns Array is export { split('/', $dir) }
sub splitpath (Str $path, Bool $nofile?) returns Array is export {
my $volume = '';
my $directory = '';
my $file = '';
if ($nofile) {
$directory = $path;
}
else {
$path ~~ m:P5"^((?:.*/(?:\.\.?\Z(?!\n))?)?)([^/]*)";
$directory = ~$0;
$file = ~$1;
}
return ($volume, $directory, $file);
}
## Concatenating
sub catdir (*@path) returns Str is export { canonpath(join('/', (@path, ''))) }
sub catfile (*@_path) returns Str is export {
# take a copy of our args here, maybe
# replace this with 'is copy' parameter
# trait at some point
my @path = @_path;
my $file = canonpath(pop(@path));
return $file unless ?@path;
my $dir = catdir(@path);
$dir ~= "/" unless substr($dir, -1) eq "/";
return $dir ~ $file;
}
sub catpath (Str $volume, Str $directory, Str $file) returns Str is export {
if ('' ne ($directory & $file) &&
'/' ne (substr($directory, -1) & substr($file, 0, 1))) {
return $directory ~ "/$file";
}
else {
return $directory ~ $file;
}
}
## real to absolute
sub rel2abs (Str $_path, Str $_base?) returns Str is export {
# take a copy of our args here, maybe
# replace this with 'is copy' parameter
# trait at some point
my $path = $_path;
my $base = $_base;
if (!file_name_is_absolute($path)) {
if (!$base.defined || $base eq '') {
$base = cwd();
}
elsif (!file_name_is_absolute($base)) {
$base = rel2abs($base);
}
else {
$base = canonpath($base);
}
$path = catdir($base, $path);
}
return canonpath($path);
}
sub abs2rel (Str $_path, Str $_base) returns Str is export {
# take a copy of our args here, maybe
# replace this with 'is copy' parameter
# trait at some point
my $path = $_path;
my $base = $_base;
if (!file_name_is_absolute($path)) {
$path = rel2abs($path);
}
else {
$path = canonpath($path);
}
# Figure out the effective $base and clean it up.
if (!$base.defined || $base eq '') {
$base = cwd();
}
elsif (!file_name_is_absolute($base)) {
$base = rel2abs($base);
}
else {
$base = canonpath($base);
}
# Now, remove all leading components that are the same
my @pathchunks = splitdir($path);
my @basechunks = splitdir($base);
while (@pathchunks and @basechunks) {
@pathchunks[0] eq @basechunks[0] or last;
shift(@pathchunks);
shift(@basechunks);
}
$path = join('/', @pathchunks);
$base = join('/', @basechunks);
# $base now contains the directories the resulting relative path
# must ascend out of before it can descend to $path_directory. So,
# replace all names with $parentDir
$base ~~ s:P5:g"[^/]+"..";
# Glue the two together, using a separator if necessary, and preventing an
# empty result.
if ('' ne ($path & $base)) { # <<< refactored into junction
$path = "$base/$path";
} else {
$path = "$base$path";
}
return canonpath($path);
}
## Misc.
sub canonpath (Str $_path) returns Str is export {
# take a copy of our args here, maybe
# replace this with 'is copy' parameter
# trait at some point
my $path = $_path;
$path ~~ s:P5:g"/+"/"; # xx////xx -> xx/xx
$path ~~ s:P5:g"(/\.)+(/|\Z(?!\n))"/"; # xx/././xx -> xx/xx
$path ~~ s:P5:g"^(\./)+"" unless $path eq "./"; # ./xx -> xx
$path ~~ s:P5:g"^/(\.\./)+"/"; # /../../xx -> xx
$path ~~ s:P5:g"/\Z(?!\n)"" unless $path eq "/"; # xx/ -> xx
return $path;
}
# Refacted this into a Junction instead of the
# regexp since all it does it remove . and ..
sub no_upwards (*@filenames) returns Array is export {
@filenames.grep:{ $_ ne ('.' & '..') }
}
sub file_name_is_absolute (Str $file) returns Bool is export {
?($file ~~ m:P5"^/") # needs to work in the multi-line string
}
sub path returns Array is export {
return unless %*ENV{'PATH'}.defined;
return split(':', %*ENV{'PATH'}).map:{ $_ eq '' ?? '.' !! $_ };
}
# This HACK is worse than
# the File::Spec platform hack
#sub cwd returns Str { system("pwd") }
sub cwd returns Str is export {
# This seems wrong - limbic_region 2006-08-17
#return '\\';
return $*CWD;
}
sub tmpdir returns Str is export {
return '';
}
#
# ## TODO:
# # Refactor _tmpdir and tmpdir into class attributes
# my Str $tmpdir;
# method _tmpdir (*@dirlist) returns Str {
# return $tmpdir if $tmpdir.defined;
# ## QUESTION: How does Perl6 handle tainting??
# # {
# # no strict 'refs';
# # if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0
# # require Scalar::Util;
# # @dirlist = grep { ! Scalar::Util::tainted($_) }, @dirlist;
# # }
# # }
# for @dirlist -> $dir {
# next unless $dir.defined && -d -w $dir;
# $tmpdir = $dir;
# last;
# }
# $tmpdir = $.curdir unless $tmpdir.defined;
# $tmpdir = $tmpdir.defined && .canonpath($tmpdir);
# return $tmpdir;
# }
#
# method tmpdir () returns Str {
# return $tmpdir if $tmpdir.defined;
# $tmpdir = ._tmpdir(%*ENV{'TMPDIR'}, "/tmp");
# return $tmpdir;
# }
=kwid
= NAME
File::Spec::Unix - Part of Perl 6/Pugs Portable file handling
= SYNOPOSIS
use File::Spec::Unix;
= DESCRIPTION
This is a very primative port of the Perl 5 File::Spec::Unix module.
= FUNCTIONS
- `curdir returns Str`
- `updir returns Str`
- `rootdir returns Str`
- `devnull returns Str`
- `case_tolerant returns Bool`
- `splitdir (Str $dir) returns Array`
- `splitpath (Str $path, Bool $nofile?) returns Array`
- `catdir (*@path) returns Str`
- `catfile (*@_path) returns Str`
- `catpath (Str $volume, Str $directory, Str $file) returns Str`
- `rel2abs (Str $path, Str $base?) returns Str`
- `abs2rel (Str $path, Str $base) returns Str`
- `no_upwards (*@filenames) returns Array`
- `file_name_is_absolute (Str $file) returns Bool`
- `path returns Array`
- `canonpath (Str $_path) returns Str`
- `cwd returns Str`
= SEE ALSO
The Perl 5 version of File::Spec::Unix, although this version is more
akin to File::Spec::Functions.
= AUTHOR
Stevan Little <stevan@iinteractive.com>
Max Maischein <corion@cpan.org>
= ACKNOWLEDGEMENTS
This is a port of the Perl 5 File::Spec::Unix module which is currently
maintained by Ken Williams <KWILLIAMS@cpan.org>, and is written
by a number of people. Please see that module for more information.
= COPYRIGHT
Copyright (c) 2005. Stevan Little. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
See http://www.perl.com/perl/misc/Artistic.html
=cut