home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / lib / File / Spec / Mac.pm < prev    next >
Text File  |  2000-03-02  |  9KB  |  398 lines
  1. package File::Spec::Mac;
  2.  
  3. use strict;
  4. use vars qw(@ISA);
  5. require File::Spec::Unix;
  6. @ISA = qw(File::Spec::Unix);
  7.  
  8. =head1 NAME
  9.  
  10. File::Spec::Mac - File::Spec for MacOS
  11.  
  12. =head1 SYNOPSIS
  13.  
  14.  require File::Spec::Mac; # Done internally by File::Spec if needed
  15.  
  16. =head1 DESCRIPTION
  17.  
  18. Methods for manipulating file specifications.
  19.  
  20. =head1 METHODS
  21.  
  22. =over 2
  23.  
  24. =item canonpath
  25.  
  26. On MacOS, there's nothing to be done.  Returns what it's given.
  27.  
  28. =cut
  29.  
  30. sub canonpath {
  31.     my ($self,$path) = @_;
  32.     return $path;
  33. }
  34.  
  35. =item catdir
  36.  
  37. Concatenate two or more directory names to form a complete path ending with 
  38. a directory.  Put a trailing : on the end of the complete path if there 
  39. isn't one, because that's what's done in MacPerl's environment.
  40.  
  41. The fundamental requirement of this routine is that
  42.  
  43.       File::Spec->catdir(split(":",$path)) eq $path
  44.  
  45. But because of the nature of Macintosh paths, some additional 
  46. possibilities are allowed to make using this routine give reasonable results 
  47. for some common situations.  Here are the rules that are used.  Each 
  48. argument has its trailing ":" removed.  Each argument, except the first,
  49. has its leading ":" removed.  They are then joined together by a ":".
  50.  
  51. So
  52.  
  53.       File::Spec->catdir("a","b") = "a:b:"
  54.       File::Spec->catdir("a:",":b") = "a:b:"
  55.       File::Spec->catdir("a:","b") = "a:b:"
  56.       File::Spec->catdir("a",":b") = "a:b"
  57.       File::Spec->catdir("a","","b") = "a::b"
  58.  
  59. etc.
  60.  
  61. To get a relative path (one beginning with :), begin the first argument with :
  62. or put a "" as the first argument.
  63.  
  64. If you don't want to worry about these rules, never allow a ":" on the ends 
  65. of any of the arguments except at the beginning of the first.
  66.  
  67. Under MacPerl, there is an additional ambiguity.  Does the user intend that
  68.  
  69.       File::Spec->catfile("LWP","Protocol","http.pm")
  70.  
  71. be relative or absolute?  There's no way of telling except by checking for the
  72. existence of LWP: or :LWP, and even there he may mean a dismounted volume or
  73. a relative path in a different directory (like in @INC).   So those checks
  74. aren't done here. This routine will treat this as absolute.
  75.  
  76. =cut
  77.  
  78. sub catdir {
  79.     shift;
  80.     my @args = @_;
  81.     my $result = shift @args;
  82.     $result =~ s/:\z//;
  83.     foreach (@args) {
  84.     s/:\z//;
  85.     s/^://s;
  86.     $result .= ":$_";
  87.     }
  88.     return "$result:";
  89. }
  90.  
  91. =item catfile
  92.  
  93. Concatenate one or more directory names and a filename to form a
  94. complete path ending with a filename.  Since this uses catdir, the
  95. same caveats apply.  Note that the leading : is removed from the filename,
  96. so that 
  97.  
  98.       File::Spec->catfile($ENV{HOME},"file");
  99.  
  100. and
  101.  
  102.       File::Spec->catfile($ENV{HOME},":file");
  103.  
  104. give the same answer, as one might expect.
  105.  
  106. =cut
  107.  
  108. sub catfile {
  109.     my $self = shift;
  110.     my $file = pop @_;
  111.     return $file unless @_;
  112.     my $dir = $self->catdir(@_);
  113.     $file =~ s/^://s;
  114.     return $dir.$file;
  115. }
  116.  
  117. =item curdir
  118.  
  119. Returns a string representing the current directory.
  120.  
  121. =cut
  122.  
  123. sub curdir {
  124.     return ":";
  125. }
  126.  
  127. =item devnull
  128.  
  129. Returns a string representing the null device.
  130.  
  131. =cut
  132.  
  133. sub devnull {
  134.     return "Dev:Null";
  135. }
  136.  
  137. =item rootdir
  138.  
  139. Returns a string representing the root directory.  Under MacPerl,
  140. returns the name of the startup volume, since that's the closest in
  141. concept, although other volumes aren't rooted there.
  142.  
  143. =cut
  144.  
  145. sub rootdir {
  146. #
  147. #  There's no real root directory on MacOS.  The name of the startup
  148. #  volume is returned, since that's the closest in concept.
  149. #
  150.     require Mac::Files;
  151.     my $system =  Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk,
  152.                      &Mac::Files::kSystemFolderType);
  153.     $system =~ s/:.*\z/:/s;
  154.     return $system;
  155. }
  156.  
  157. =item tmpdir
  158.  
  159. Returns a string representation of the first existing directory
  160. from the following list or '' if none exist:
  161.  
  162.     $ENV{TMPDIR}
  163.  
  164. =cut
  165.  
  166. my $tmpdir;
  167. sub tmpdir {
  168.     return $tmpdir if defined $tmpdir;
  169.     $tmpdir = $ENV{TMPDIR} if -d $ENV{TMPDIR};
  170.     $tmpdir = '' unless defined $tmpdir;
  171.     return $tmpdir;
  172. }
  173.  
  174. =item updir
  175.  
  176. Returns a string representing the parent directory.
  177.  
  178. =cut
  179.  
  180. sub updir {
  181.     return "::";
  182. }
  183.  
  184. =item file_name_is_absolute
  185.  
  186. Takes as argument a path and returns true, if it is an absolute path.  In 
  187. the case where a name can be either relative or absolute (for example, a 
  188. folder named "HD" in the current working directory on a drive named "HD"), 
  189. relative wins.  Use ":" in the appropriate place in the path if you want to
  190. distinguish unambiguously.
  191.  
  192. =cut
  193.  
  194. sub file_name_is_absolute {
  195.     my ($self,$file) = @_;
  196.     if ($file =~ /:/) {
  197.     return ($file !~ m/^:/s);
  198.     } else {
  199.     return (! -e ":$file");
  200.     }
  201. }
  202.  
  203. =item path
  204.  
  205. Returns the null list for the MacPerl application, since the concept is 
  206. usually meaningless under MacOS. But if you're using the MacPerl tool under 
  207. MPW, it gives back $ENV{Commands} suitably split, as is done in 
  208. :lib:ExtUtils:MM_Mac.pm.
  209.  
  210. =cut
  211.  
  212. sub path {
  213. #
  214. #  The concept is meaningless under the MacPerl application.
  215. #  Under MPW, it has a meaning.
  216. #
  217.     return unless exists $ENV{Commands};
  218.     return split(/,/, $ENV{Commands});
  219. }
  220.  
  221. =item splitpath
  222.  
  223. =cut
  224.  
  225. sub splitpath {
  226.     my ($self,$path, $nofile) = @_;
  227.  
  228.     my ($volume,$directory,$file) = ('','','');
  229.  
  230.     if ( $nofile ) {
  231.         ( $volume, $directory ) = $path =~ m@((?:[^:]+(?::|\z))?)(.*)@s;
  232.     }
  233.     else {
  234.         $path =~ 
  235.             m@^( (?: [^:]+: )? ) 
  236.                 ( (?: .*: )? )
  237.                 ( .* )
  238.              @xs;
  239.         $volume    = $1;
  240.         $directory = $2;
  241.         $file      = $3;
  242.     }
  243.  
  244.     # Make sure non-empty volumes and directories end in ':'
  245.     $volume    .= ':' if $volume    =~ m@[^:]\z@ ;
  246.     $directory .= ':' if $directory =~ m@[^:]\z@ ;
  247.     return ($volume,$directory,$file);
  248. }
  249.  
  250.  
  251. =item splitdir
  252.  
  253. =cut
  254.  
  255. sub splitdir {
  256.     my ($self,$directories) = @_ ;
  257.     #
  258.     # split() likes to forget about trailing null fields, so here we
  259.     # check to be sure that there will not be any before handling the
  260.     # simple case.
  261.     #
  262.     if ( $directories !~ m@:\z@ ) {
  263.         return split( m@:@, $directories );
  264.     }
  265.     else {
  266.         #
  267.         # since there was a trailing separator, add a file name to the end, 
  268.         # then do the split, then replace it with ''.
  269.         #
  270.         my( @directories )= split( m@:@, "${directories}dummy" ) ;
  271.         $directories[ $#directories ]= '' ;
  272.         return @directories ;
  273.     }
  274. }
  275.  
  276.  
  277. =item catpath
  278.  
  279. =cut
  280.  
  281. sub catpath {
  282.     my $self = shift ;
  283.  
  284.     my $result = shift ;
  285.     $result =~ s@^([^/])@/$1@s ;
  286.  
  287.     my $segment ;
  288.     for $segment ( @_ ) {
  289.         if ( $result =~ m@[^/]\z@ && $segment =~ m@^[^/]@s ) {
  290.             $result .= "/$segment" ;
  291.         }
  292.         elsif ( $result =~ m@/\z@ && $segment =~ m@^/@s ) {
  293.             $result  =~ s@/+\z@/@;
  294.             $segment =~ s@^/+@@s;
  295.             $result  .= "$segment" ;
  296.         }
  297.         else {
  298.             $result  .= $segment ;
  299.         }
  300.     }
  301.  
  302.     return $result ;
  303. }
  304.  
  305. =item abs2rel
  306.  
  307. =cut
  308.  
  309. sub abs2rel {
  310.     my($self,$path,$base) = @_;
  311.  
  312.     # Clean up $path
  313.     if ( ! $self->file_name_is_absolute( $path ) ) {
  314.         $path = $self->rel2abs( $path ) ;
  315.     }
  316.  
  317.     # Figure out the effective $base and clean it up.
  318.     if ( !defined( $base ) || $base eq '' ) {
  319.         $base = cwd() ;
  320.     }
  321.     elsif ( ! $self->file_name_is_absolute( $base ) ) {
  322.         $base = $self->rel2abs( $base ) ;
  323.     }
  324.  
  325.     # Now, remove all leading components that are the same
  326.     my @pathchunks = $self->splitdir( $path );
  327.     my @basechunks = $self->splitdir( $base );
  328.  
  329.     while (@pathchunks && @basechunks && $pathchunks[0] eq $basechunks[0]) {
  330.         shift @pathchunks ;
  331.         shift @basechunks ;
  332.     }
  333.  
  334.     $path = join( ':', @pathchunks );
  335.  
  336.     # @basechunks now contains the number of directories to climb out of.
  337.     $base = ':' x @basechunks ;
  338.  
  339.     return "$base:$path" ;
  340. }
  341.  
  342. =item rel2abs
  343.  
  344. Converts a relative path to an absolute path. 
  345.  
  346.     $abs_path = File::Spec->rel2abs( $destination ) ;
  347.     $abs_path = File::Spec->rel2abs( $destination, $base ) ;
  348.  
  349. If $base is not present or '', then L<cwd()> is used. If $base is relative, 
  350. then it is converted to absolute form using L</rel2abs()>. This means that it
  351. is taken to be relative to L<cwd()>.
  352.  
  353. On systems with the concept of a volume, this assumes that both paths 
  354. are on the $base volume, and ignores the $destination volume. 
  355.  
  356. On systems that have a grammar that indicates filenames, this ignores the 
  357. $base filename as well. Otherwise all path components are assumed to be
  358. directories.
  359.  
  360. If $path is absolute, it is cleaned up and returned using L</canonpath()>.
  361.  
  362. Based on code written by Shigio Yamaguchi.
  363.  
  364. No checks against the filesystem are made. 
  365.  
  366. =cut
  367.  
  368. sub rel2abs($;$;) {
  369.     my ($self,$path,$base ) = @_;
  370.  
  371.     if ( ! $self->file_name_is_absolute( $path ) ) {
  372.         if ( !defined( $base ) || $base eq '' ) {
  373.             $base = cwd() ;
  374.         }
  375.         elsif ( ! $self->file_name_is_absolute( $base ) ) {
  376.             $base = $self->rel2abs( $base ) ;
  377.         }
  378.         else {
  379.             $base = $self->canonpath( $base ) ;
  380.         }
  381.  
  382.         $path = $self->canonpath("$base$path") ;
  383.     }
  384.  
  385.     return $path ;
  386. }
  387.  
  388.  
  389. =back
  390.  
  391. =head1 SEE ALSO
  392.  
  393. L<File::Spec>
  394.  
  395. =cut
  396.  
  397. 1;
  398.