Permalink
Browse files

added IO::Spec, started work on IO::Path

  • Loading branch information...
labster committed Apr 27, 2013
1 parent 37c9956 commit 5b53365d8b774f94ccf371107e5c1544574bddcf
Showing with 518 additions and 5 deletions.
  1. +0 −1 src/RESTRICTED.setting
  2. +6 −4 src/core/IO.pm
  3. +55 −0 src/core/IO/Spec.pm
  4. +51 −0 src/core/IO/Spec/Cygwin.pm
  5. +175 −0 src/core/IO/Spec/Unix.pm
  6. +227 −0 src/core/IO/Spec/Win32.pm
  7. +4 −0 tools/build/Makefile.in
View
@@ -18,7 +18,6 @@ my class RESTRICTED is Mu {
method gist(|) { restricted(self.^name) }
}
my class IO is RESTRICTED { }
my class IO::Handle is RESTRICTED { }
my class IO::Socket is RESTRICTED { }
View
@@ -246,6 +246,7 @@ my class IO::Handle does IO::FileTestable {
}
my class IO::Path is Cool does IO::FileTestable {
my $Spec := IO::Spec.MODULE;
has Str $.basename;
has Str $.directory = '.';
has Str $.volume = '';
@@ -259,10 +260,11 @@ my class IO::Path is Cool does IO::FileTestable {
}
multi method new(Str:D $path) {
my @chunks = $path.split('/');
my $basename = @chunks.pop;
my $directory = @chunks ?? @chunks.join('/') !! '.';
self.new(:$basename, :$directory, :volume(""));
# my @chunks = $path.split('/');
# my $basename = @chunks.pop;
# my $directory = @chunks ?? @chunks.join('/') !! '.';
# self.new(:$basename, :$directory, :volume(""));
self.new( |$Spec.split($path).hash );
}
multi method Str(IO::Path:D:) {
View
@@ -0,0 +1,55 @@
my class IO::Spec {
my %module = (
'MSWin32' => 'Win32',
'os2' => 'Win32',
'dos' => 'Win32',
'symbian' => 'Win32',
'NetWare' => 'Win32',
'Win32' => 'Win32',
'cygwin' => 'Cygwin',
'Cygwin' => 'Cygwin',
# <MacOS Mac> »=>» 'Mac',
# 'VMS' => 'VMS'
);
# this is really just a way of getting $*OS when it's not in scope yet
my $submodule = %module{ nqp::atkey(nqp::atpos(pir::getinterp__P, pir::const::IGLOBALS_CONFIG_HASH), 'osname') };
my $SPEC := IO::Spec.WHO{ $submodule // 'Unix' };
method FSTYPE ($OS = $*OS) { %module{$OS} // 'Unix' }
#| Dispatches methods to the appropriate class for the current $*OS
#| Well, it should, if handles worked here. Still useful, though.
method MODULE
# handles
# <canonpath curdir updir rootdir devnull tmpdir
# file-name-is-absolute no-parent-or-current-test
# path split join splitpath catpath catfile
# splitdir catdir abs2rel rel2abs>
{ $SPEC }
#| Returns a copy of the module for the given OS string
#| e.g. IO::Spec.os('Win32') returns IO::Spec::Win32
method os (Str $OS = $*OS) {
IO::Spec.WHO{%module{$OS} // 'Unix'};
}
method canonpath( |c ) { $SPEC.canonpath( |c ) }
method curdir { $SPEC.curdir() }
method updir { $SPEC.updir() }
method rootdir { $SPEC.rootdir() }
method devnull { $SPEC.devnull() }
method tmpdir { $SPEC.tmpdir() }
method file-name-is-absolute( |c ) { $SPEC.file-name-is-absolute( |c ) }
method no-parent-or-current-test { $SPEC.no-parent-or-current-test }
method path { $SPEC.path() }
method split ( |c ) { $SPEC.split( |c ) }
method join ( |c ) { $SPEC.join( |c ) }
method splitpath( |c ) { $SPEC.splitpath( |c ) }
method catpath( |c ) { $SPEC.catpath( |c ) }
method catfile( |c ) { $SPEC.catfile( |c ) }
method splitdir( |c ) { $SPEC.splitdir( |c ) }
method catdir( |c ) { $SPEC.catdir( |c ) }
method abs2rel( |c ) { $SPEC.abs2rel( |c ) }
method rel2abs( |c ) { $SPEC.rel2abs( |c ) }
}
View
@@ -0,0 +1,51 @@
my class IO::Spec::Cygwin is IO::Spec::Unix {
#| Any C<\> (backslashes) are converted to C</> (forward slashes),
#| and then IO::Spec::Unix.canonpath() is called on the result.
method canonpath (Cool:D $path is copy) {
$path.=subst(:g, '\\', '/');
# Handle network path names beginning with double slash
my $node = '';
if $path ~~ s/^ ('//' <-[/]>+) [ '/' | $ ] /\// { #/
$node = ~$0;
}
$node ~ IO::Spec::Unix.canonpath($path);
}
#| Calls the Unix version, and additionally prevents
#| accidentally creating a //network/path.
method catdir ( *@paths ) {
my $result = IO::Spec::Unix.catdir(@paths);
# Don't create something that looks like a //network/path
$result.subst(/ <[\\\/]> ** 2..*/, '/');
}
#| Tests if the file name begins with C<drive_letter:/> or a slash.
sub file-name-is-absolute ($file) {
so $file ~~ / ^ [<[A..Z a..z]> ':']? <[\\/]>/; # C:/test
}
method tmpdir {
state $tmpdir;
return $tmpdir if defined $tmpdir;
$tmpdir = IO::Spec::Unix._firsttmpdir(
%*ENV<TMPDIR>,
"/tmp",
%*ENV<TMP>,
%*ENV<TEMP>,
'C:/temp',
self.curdir );
}
# Paths might have a volume, so we use Win32 splitpath and catpath instead
method splitpath (|c) { IO::Spec::Win32.splitpath(|c) }
method catpath (|c) { IO::Spec::Win32.catpath(|c).subst(:global, '\\', '/') }
method split ($path) { IO::Spec::Win32.split($path).map:
{ (.key => .value.subst(:global, '\\', '/')) } }
method join (|c) { IO::Spec::Win32.join(|c).subst(:global, '\\', '/') }
}
View
@@ -0,0 +1,175 @@
my class IO::Spec { ... }
my class IO::Spec::Unix {
method canonpath( $path is copy ) {
$path;
return unless $path.defined;
# Handle POSIX-style node names beginning with double slash (qnx, nto)
# (POSIX says: "a pathname that begins with two successive slashes
# may be interpreted in an implementation-defined manner, although
# more than two leading slashes shall be treated as a single slash.")
my $node = '';
if ( so $*OS eq 'qnx'|'nto' ) #double slashes special on these OSes
&& ( $path ~~ s {^ ( '//' <-[ / ]>+ ) '/'? $} = ''
|| $path ~~ s {^ ( '//' <-[ / ]>+ ) '/' } = '/' )
{ $node = ~ $0; }
$path ~~ s:g { '/'+ } = '/'; # xx////xx -> xx/xx
$path ~~ s:g { '/.'+ ['/' | $] } = '/'; # xx/././xx -> xx/xx
$path ~~ s { ^ './' <!before $> } = ''; # ./xx -> xx
$path ~~ s { ^ '/..'+ ['/' | $] } = '/'; # /../..(/xx) -> /(xx)
unless $path eq "/" {
$path ~~ s { '/' $ } = ''; # xx/ -> xx :)
}
return "$node$path";
}
method curdir { '.' }
method updir { '..' }
method rootdir { '/' }
method devnull { '/dev/null' }
method _firsttmpdir( *@dirlist ) {
my $tmpdir = @dirlist.first( { .defined && .IO.d && .IO.w } )
or fail "No viable candidates for a temporary directory found";
self.canonpath( $tmpdir );
}
method tmpdir {
state $tmpdir;
return $tmpdir if $tmpdir.defined;
return $tmpdir = self._firsttmpdir(
%*ENV{'TMPDIR'},
'/tmp',
self.curdir
);
}
method no-parent-or-current-test { none('.', '..') }
method file-name-is-absolute( $file ) {
so $file ~~ m/^\//
}
method path {
return () unless %*ENV{'PATH'};
my @path = %*ENV{'PATH'}.split( ':' );
for @path {
$_ = '.' if $_ eq ''
}
return @path
}
method splitpath( $path, $nofile = False ) {
my ( $directory, $file ) = ( '', '' );
if $nofile {
$directory = $path;
}
else {
$path ~~ m/^ ( [ .* \/ [ '.'**1..2 $ ]? ]? ) (<-[\/]>*) /;
$directory = ~$0;
$file = ~$1;
}
return ( '', $directory, $file );
}
method split (Cool:D $path is copy ) {
$path ~~ s/<?after .> '/'+ $ //;
$path ~~ m/^ ( [ .* \/ ]? ) (<-[\/]>*) /;
my ($directory, $basename) = ~$0, ~$1;
$directory ~~ s/<?after .> '/'+ $ //; #/
$basename = '/' if $directory eq '/' && $basename eq '';
$directory = '.' if $directory eq '' && $basename ne '';
# shell dirname '' produces '.', but we don't because it's probably user error
return (:volume(''), :$directory, :$basename );
}
method join ($volume, $directory is copy, $file) {
$directory = '' if all($directory, $file) eq '/'
or $directory eq '.' && $file.chars;
self.catpath($volume, $directory, $file);
}
method catpath( $volume, $directory is copy, $file ) {
if $directory ne ''
&& $file ne ''
&& $directory.substr( *-1 ) ne '/'
&& $file.substr( 0, 1 ) ne '/' {
$directory ~= "/$file"
}
else {
$directory ~= $file
}
return $directory
}
method catdir( *@parts ) { self.canonpath( (@parts, '').join('/') ) }
method splitdir( $path ) { $path.split( /\// ) }
method catfile( |c ) { self.catdir(|c) }
method abs2rel( $path is copy, $base is copy = Str ) {
$base = $*CWD unless $base.defined && $base.chars;
if self.file-name-is-absolute($path) || self.file-name-is-absolute($base) {
$path = self.rel2abs( $path );
$base = self.rel2abs( $base );
}
else {
# save a couple of cwd()s if both paths are relative
$path = self.catdir( self.rootdir, $path );
$base = self.catdir( self.rootdir, $base );
}
my ($path_volume, $path_directories) = self.splitpath( $path, 1 );
my ($base_volume, $base_directories) = self.splitpath( $base, 1 );
# Can't relativize across volumes
return $path unless $path_volume eq $base_volume;
# For UNC paths, the user might give a volume like //foo/bar that
# strictly speaking has no directory portion. Treat it as if it
# had the root directory for that volume.
if !$base_directories.chars && self.file-name-is-absolute( $base ) {
$base_directories = self.rootdir;
}
# Now, remove all leading components that are the same
my @pathchunks = self.splitdir( $path_directories );
my @basechunks = self.splitdir( $base_directories );
if $base_directories eq self.rootdir {
@pathchunks.shift;
return self.canonpath( self.catpath('', self.catdir( @pathchunks ), '') );
}
while @pathchunks && @basechunks && @pathchunks[0] eq @basechunks[0] {
@pathchunks.shift;
@basechunks.shift;
}
return self.curdir unless @pathchunks || @basechunks;
# $base now contains the directories the resulting relative path
# must ascend out of before it can descend to $path_directory.
my $result_dirs = self.catdir( self.updir() xx @basechunks.elems, @pathchunks );
return self.canonpath( self.catpath('', $result_dirs, '') );
}
method rel2abs( $path, $base is copy = $*CWD) {
return self.canonpath($path) if self.file-name-is-absolute($path);
if !self.file-name-is-absolute( $base ) {
$base = self.rel2abs( $base )
}
self.catdir( $base, $path );
}
}
Oops, something went wrong.

0 comments on commit 5b53365

Please sign in to comment.