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.