home *** CD-ROM | disk | FTP | other *** search
/ CLIX - Fazer Clix Custa Nix / CLIX-CD.cdr / mac / lib / auto / URI / URL / file / newlocal.al < prev    next >
Encoding:
Text File  |  1997-08-18  |  3.5 KB  |  105 lines  |  [TEXT/McPL]
  1. # NOTE: Derived from ./blib/lib/URI/URL/file.pm.  Changes made here will be lost.
  2. #
  3. #  MacPerl assumptions: $path contains a local path (with :) not a network
  4. #                       path (with /).  $path *must* contain a : to be
  5. #                       considered absolute ($path = "Macintosh HD" will
  6. #                       be treated as a relative, $path = "Macintosh HD:"
  7. #                       will be treated as absolute.  This is annoying, but
  8. #                       then so are the MacOS rules for pathnames-in-string).
  9. #                       $path should be converted to network before passing
  10. #                       to $url->path.  It's yet to be determined whether
  11. #                       they should be generally escaped before that,
  12. #                       but / in names will be taken care of here as will
  13. #                       the legal names "." and "..".
  14. #
  15. package URI::URL::file;
  16.  
  17. sub newlocal {
  18.     my($class, $path) = @_;
  19.  
  20.     Carp::croak("This version only works for Mac filesystems")
  21.       unless $ostype eq "mac";
  22.     # XXX: Should implement the same thing for other systems
  23.  
  24.     my $url = new URI::URL "file://";
  25.     if (!defined $path or $path eq "") {
  26.         require Cwd;
  27.         my $cwd = Cwd::fastcwd();
  28. # force trailing : on dir
  29.         $cwd =~ s/:?$/:/;
  30.         $path = $cwd;
  31.     } elsif ($path =~ m/^:/ or $path !~ /:/) {
  32.         require Cwd;
  33.         my $cwd = Cwd::fastcwd();
  34. # force trailing : on dir, but only if the path doesn't already have one
  35.         $cwd =~ s/:?$/:/ unless $path =~ /^:/;
  36.         $path =  $cwd . $path;
  37.     }
  38.     $path = localtonet($path);
  39. #
  40. #  Now do something to prevent unpleasantness if the path contains either
  41. #  / or ., both of which, along with any %, have been trigraphed in localtonet
  42. #
  43.     my $hold = $URI::URL::reserved_no_slash;
  44.     $URI::URL::reserved_no_slash =~ s/%//;
  45.     $url->path($path);
  46.     $URI::URL::reserved_no_slash = $hold;
  47.     $url;
  48. }
  49. sub localtonet {
  50. #
  51. #  Mac path to the Unix like equivalent to be used in file URL's.
  52. #  This makes no attempt to detect illegal Mac paths (e.g. a:::a).
  53. #
  54.     my $inpath = $_[0];
  55. #
  56. #  First problem: if the path contains "/", we've go to do something.  You
  57. #  can just trigraph it, but then the % will get changed to a %25 in the
  58. #  subsequent call to $url->path above.  So we do two things, trigraph all
  59. #  the %'s here, and then trigraph the /'s (and, below, the .'s).  Then above
  60. #  we will kludge and prevent $url->path from trigraphing %'s.
  61. #
  62.     $inpath =~ s,%,%25,g;
  63.     $inpath =~ s,/,%2F,g;
  64. #
  65. #  If there are no :'s in the name at all, assume it's a single item in the
  66. #  current directory.  Return it
  67. #
  68.     return $inpath if ($inpath !~ m,:,);
  69. #
  70. #  If we now split on :, there will be just as many nulls in the list as
  71. #  there should be up requests, except if it begins with a :, where there
  72. #  will be one extra.
  73. #
  74.     my @names = split(/:/,$inpath);
  75.     shift(@names) unless $names[0];
  76.     my @outname = ();
  77. #
  78. #  Work from the end.
  79. #
  80.     my $i;
  81.     for($i = $#names; $i >= 0;$i--) {
  82.         if ($names[$i] eq "") {
  83.             unshift(@outname,"..");
  84.         } else {
  85. #
  86. #  There's a problem similar to the / problem here.  If we trigraph the .'s,
  87. #  you have to prevent the %'s from being trigraphed further on.
  88. #
  89. #
  90.         $names[$i] = "%2E%2E" if($names[$i] eq "..");
  91.         $names[$i] = "%2E" if($names[$i] eq ".");
  92.             unshift(@outname,$names[$i]);
  93.         }
  94.     }
  95.     my $netpath = join("/",@outname);
  96.     $netpath = $netpath . "/" if($inpath =~ /:$/);
  97.     if($inpath !~ m,^:,) {
  98.          return "/".$netpath;
  99.     } else {
  100.          return $netpath;
  101.     }
  102. }
  103.  
  104. 1;
  105.