mirror of
https://github.com/KevinMidboe/linguist.git
synced 2025-10-29 17:50:22 +00:00
Add a bunch of Perl 6 sample files
This commit is contained in:
Rob Hoelz
207
samples/Perl6/Win32.pm
Normal file
207
samples/Perl6/Win32.pm
Normal file
@@ -0,0 +1,207 @@
|
||||
my class IO::Spec::Win32 is IO::Spec::Unix {
|
||||
|
||||
# Some regexes we use for path splitting
|
||||
my $slash = regex { <[\/ \\]> }
|
||||
my $notslash = regex { <-[\/ \\]> }
|
||||
my $driveletter = regex { <[A..Z a..z]> ':' }
|
||||
my $UNCpath = regex { [<$slash> ** 2] <$notslash>+ <$slash> [<$notslash>+ | $] }
|
||||
my $volume_rx = regex { <$driveletter> | <$UNCpath> }
|
||||
|
||||
method canonpath ($path, :$parent) {
|
||||
$path eq '' ?? '' !! self!canon-cat($path, :$parent);
|
||||
}
|
||||
|
||||
method catdir(*@dirs) {
|
||||
return "" unless @dirs;
|
||||
return self!canon-cat( "\\", |@dirs ) if @dirs[0] eq "";
|
||||
self!canon-cat(|@dirs);
|
||||
}
|
||||
|
||||
method splitdir($dir) { $dir.split($slash) }
|
||||
method catfile(|c) { self.catdir(|c) }
|
||||
method devnull { 'nul' }
|
||||
method rootdir { '\\' }
|
||||
|
||||
method tmpdir {
|
||||
first( { .defined && .IO.d && .IO.w },
|
||||
%*ENV<TMPDIR>,
|
||||
%*ENV<TEMP>,
|
||||
%*ENV<TMP>,
|
||||
'SYS:/temp',
|
||||
'C:\system\temp',
|
||||
'C:/temp',
|
||||
'/tmp',
|
||||
'/')
|
||||
|| self.curdir;
|
||||
}
|
||||
|
||||
method path {
|
||||
my @path = split(';', %*ENV<PATH>);
|
||||
@path».=subst(:global, q/"/, '');
|
||||
@path = grep *.chars, @path;
|
||||
unshift @path, ".";
|
||||
return @path;
|
||||
}
|
||||
|
||||
method is-absolute ($path) {
|
||||
# As of right now, this returns 2 if the path is absolute with a
|
||||
# volume, 1 if it's absolute with no volume, 0 otherwise.
|
||||
given $path {
|
||||
when /^ [<$driveletter> <$slash> | <$UNCpath>]/ { 2 }
|
||||
when /^ <$slash> / { 1 }
|
||||
default { 0 }
|
||||
} #/
|
||||
}
|
||||
|
||||
method split ($path as Str is copy) {
|
||||
$path ~~ s[ <$slash>+ $] = '' #=
|
||||
unless $path ~~ /^ <$driveletter>? <$slash>+ $/;
|
||||
|
||||
$path ~~
|
||||
m/^ ( <$volume_rx> ? )
|
||||
( [ .* <$slash> ]? )
|
||||
(.*)
|
||||
/;
|
||||
my ($volume, $directory, $basename) = (~$0, ~$1, ~$2);
|
||||
$directory ~~ s/ <?after .> <$slash>+ $//;
|
||||
|
||||
|
||||
if all($directory, $basename) eq '' && $volume ne '' {
|
||||
$directory = $volume ~~ /^<$driveletter>/
|
||||
?? '.' !! '\\';
|
||||
}
|
||||
$basename = '\\' if $directory eq any('/', '\\') && $basename eq '';
|
||||
$directory = '.' if $directory eq '' && $basename ne '';
|
||||
|
||||
return (:$volume, :$directory, :$basename);
|
||||
}
|
||||
|
||||
method join ($volume, $directory is copy, $file is copy) {
|
||||
$directory = '' if $directory eq '.' && $file.chars;
|
||||
if $directory.match( /^<$slash>$/ ) && $file.match( /^<$slash>$/ ) {
|
||||
$file = '';
|
||||
$directory = '' if $volume.chars > 2; #i.e. UNC path
|
||||
}
|
||||
self.catpath($volume, $directory, $file);
|
||||
}
|
||||
|
||||
method splitpath($path as Str, :$nofile = False) {
|
||||
|
||||
my ($volume,$directory,$file) = ('','','');
|
||||
if ( $nofile ) {
|
||||
$path ~~
|
||||
/^ (<$volume_rx>?) (.*) /;
|
||||
$volume = ~$0;
|
||||
$directory = ~$1;
|
||||
}
|
||||
else {
|
||||
$path ~~
|
||||
m/^ ( <$volume_rx> ? )
|
||||
( [ .* <$slash> [ '.' ** 1..2 $]? ]? )
|
||||
(.*)
|
||||
/;
|
||||
$volume = ~$0;
|
||||
$directory = ~$1;
|
||||
$file = ~$2;
|
||||
}
|
||||
|
||||
return ($volume,$directory,$file);
|
||||
}
|
||||
|
||||
method catpath($volume is copy, $directory, $file) {
|
||||
|
||||
# Make sure the glue separator is present
|
||||
# unless it's a relative path like A:foo.txt
|
||||
if $volume.chars and $directory.chars
|
||||
and $volume !~~ /^<$driveletter>/
|
||||
and $volume !~~ /<$slash> $/
|
||||
and $directory !~~ /^ <$slash>/
|
||||
{ $volume ~= '\\' }
|
||||
if $file.chars and $directory.chars
|
||||
and $directory !~~ /<$slash> $/
|
||||
{ $volume ~ $directory ~ '\\' ~ $file; }
|
||||
else { $volume ~ $directory ~ $file; }
|
||||
}
|
||||
|
||||
method rel2abs ($path is copy, $base? is copy) {
|
||||
|
||||
my $is_abs = self.is-absolute($path);
|
||||
|
||||
# Check for volume (should probably document the '2' thing...)
|
||||
return self.canonpath( $path ) if $is_abs == 2;
|
||||
|
||||
if $is_abs {
|
||||
# It's missing a volume, add one
|
||||
my $vol;
|
||||
$vol = self.splitpath($base)[0] if $base.defined;
|
||||
$vol ||= self.splitpath($*CWD)[0];
|
||||
return self.canonpath( $vol ~ $path );
|
||||
}
|
||||
|
||||
if not defined $base {
|
||||
# TODO: implement _getdcwd call ( Windows maintains separate CWD for each volume )
|
||||
# See: http://msdn.microsoft.com/en-us/library/1e5zwe0c%28v=vs.80%29.aspx
|
||||
#$base = Cwd::getdcwd( (self.splitpath: $path)[0] ) if defined &Cwd::getdcwd ;
|
||||
#$base //= $*CWD ;
|
||||
$base = $*CWD;
|
||||
}
|
||||
elsif ( !self.is-absolute( $base ) ) {
|
||||
$base = self.rel2abs( $base );
|
||||
}
|
||||
else {
|
||||
$base = self.canonpath( $base );
|
||||
}
|
||||
|
||||
my ($path_directories, $path_file) = self.splitpath( $path )[1..2] ;
|
||||
|
||||
my ($base_volume, $base_directories) = self.splitpath( $base, :nofile ) ;
|
||||
|
||||
$path = self.catpath(
|
||||
$base_volume,
|
||||
self.catdir( $base_directories, $path_directories ),
|
||||
$path_file
|
||||
) ;
|
||||
|
||||
return self.canonpath( $path ) ;
|
||||
}
|
||||
|
||||
|
||||
method !canon-cat ( $first, *@rest, :$parent --> Str) {
|
||||
|
||||
$first ~~ /^ ([ <$driveletter> <$slash>?
|
||||
| <$UNCpath>
|
||||
| [<$slash> ** 2] <$notslash>+
|
||||
| <$slash> ]?)
|
||||
(.*)
|
||||
/;
|
||||
my Str ($volume, $path) = ~$0, ~$1;
|
||||
|
||||
$volume.=subst(:g, '/', '\\');
|
||||
if $volume ~~ /^<$driveletter>/ {
|
||||
$volume.=uc;
|
||||
}
|
||||
elsif $volume.chars && $volume !~~ / '\\' $/ {
|
||||
$volume ~= '\\';
|
||||
}
|
||||
|
||||
$path = join "\\", $path, @rest.flat;
|
||||
$path ~~ s:g/ <$slash>+ /\\/; # /xx\\yy --> \xx\yy
|
||||
$path ~~ s:g/[ ^ | '\\'] '.' '\\.'* [ '\\' | $ ]/\\/; # xx/././yy --> xx/yy
|
||||
if $parent {
|
||||
while $path ~~ s:g { [^ | <?after '\\'>] <!before '..\\'> <-[\\]>+ '\\..' ['\\' | $ ] } = '' { };
|
||||
}
|
||||
$path ~~ s/^ '\\'+ //; # \xx --> xx NOTE: this is *not* root
|
||||
$path ~~ s/ '\\'+ $//; # xx\ --> xx
|
||||
if $volume ~~ / '\\' $ / { # <vol>\.. --> <vol>\
|
||||
$path ~~ s/ ^ '..' '\\..'* [ '\\' | $ ] //;
|
||||
}
|
||||
|
||||
if $path eq '' { # \\HOST\SHARE\ --> \\HOST\SHARE
|
||||
$volume ~~ s/<?after '\\\\' .*> '\\' $ //;
|
||||
$volume || '.';
|
||||
}
|
||||
else {
|
||||
$volume ~ $path;
|
||||
}
|
||||
}
|
||||
}
|
||||
Reference in New Issue
Block a user