home *** CD-ROM | disk | FTP | other *** search
/ CLIX - Fazer Clix Custa Nix / CLIX-CD.cdr / mac / lib / URI / URL / file.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-18  |  4.3 KB  |  166 lines  |  [TEXT/McPL]
  1. package URI::URL::file;
  2. require URI::URL::_generic;
  3. @ISA = qw(URI::URL::_generic);
  4.  
  5. require Carp;
  6. require Config;
  7.  
  8. # First we try to determine what kind of system we run on
  9. my $os = $Config::Config{'osname'};
  10. OS: {
  11.     $ostype = 'vms', last if $os eq 'VMS';
  12.     $ostype = 'dos', last if $os =~ /^(?:os2|mswin32|msdos)$/i;
  13.     $ostype = 'mac', last if $os eq "MacOS";
  14.     $ostype = 'unix';  # The default
  15. }
  16. # NOTE: If you add more types to this list, remember to add a xxx_path
  17. # method as well.
  18.  
  19. # This is the BNF found in RFC 1738:
  20. #
  21. # fileurl        = "file://" [ host | "localhost" ] "/" fpath
  22. # fpath          = fsegment *[ "/" fsegment ]
  23. # fsegment       = *[ uchar | "?" | ":" | "@" | "&" | "=" ]
  24. # Note that fsegment can contain '?' (query) but not ';' (param)
  25.  
  26. sub _parse {
  27.     my($self, $init) = @_;
  28.     # The file URL can't have query
  29.     $self->URI::URL::_generic::_parse($init, qw(netloc path params frag));
  30. }
  31.  
  32. # sub local_path { ... }
  33. #
  34. # Returns a path suitable for use on the local system (we just
  35. # set up an alias (derived from $ostype) to one of the path methods
  36. # defined below)
  37. *local_path = \&{$ostype . "_path"};
  38.  
  39. *query  = \&URI::URL::bad_method;
  40. *equery = \&URI::URL::bad_method;
  41.  
  42. # A U T O  L O A D E R
  43. # Don't remove this comment, it keeps AutoSplit happy!!
  44. # @ISA = qw(AutoLoader)
  45. #
  46. # These methods are autoloaded as needed
  47. sub newlocal;
  48. sub unix_path;
  49. sub dos_path ;
  50. sub mac_path ;
  51. sub vms_path ;
  52. 1;
  53. __END__
  54.  
  55. sub newlocal {
  56.     my($class, $path) = @_;
  57.  
  58.     Carp::croak("Only implemented for Unix and OS/2 file systems")
  59.       unless $ostype eq "unix" or $^O =~ /os2|mswin32/i;
  60.     # XXX: Should implement the same thing for other systems
  61.  
  62.     my $url = new URI::URL "file:";
  63.     unless (defined $path and
  64.             ($path =~ m:^/: or 
  65.          ($^O eq 'os2' and Cwd::sys_is_absolute($path)) or
  66.          ($^O eq 'MSWin32' and $path =~ m<^[A-Za-z]:[\\/]|^[\\/]{2}>))) {
  67.     require Cwd;
  68.     my $cwd = Cwd::fastcwd();
  69.     $cwd =~ s:/?$:/:; # force trailing slash on dir
  70.     $path = (defined $path) ? $cwd . $path : $cwd;
  71.     }
  72.     $url->path($path);
  73.     $url;
  74. }
  75.  
  76. sub unix_path
  77. {
  78.     my $self = shift;
  79.     my @p;
  80.     for ($self->path_components) {
  81.     Carp::croak("Path component contains '/' or '\0'") if m|[\0/]|;
  82.     if (@p) {
  83.         next unless length $_;   # skip empty path segments
  84.         next if $_ eq '.';       # skip these too
  85.         if ($_ eq '..' && $p[-1] ne '..') {  # go up one level
  86.         pop(@p) if $p[-1] ne '';
  87.         next;
  88.         }
  89.     }
  90.     push(@p, $_);
  91.     }
  92.     shift(@p) if @p > 1 && $p[0] eq '.';   # './' rendundant if there is more
  93.     return '/' if !@p || (@p == 1 && $p[0] eq '');
  94.     join('/', @p);
  95. }
  96.  
  97. sub dos_path
  98. {
  99.     my $self = shift;
  100.     my @p;
  101.     for ($self->path_components) {
  102.     Carp::croak("Path component contains '/' or '\\'") if m|[/\\]|;
  103.     push(@p, uc $_);
  104.     }
  105.     my $p = join("\\", @p);
  106.     $p =~ s/^\\([A-Z]:)/$1/;  # Fix drive letter specification
  107.     $p;
  108. }
  109.  
  110. sub mac_path
  111. {
  112.     my $self = shift;
  113.     my @p;
  114.     for ($self->path_components) {
  115.     Carp::croak("Path component contains ':'") if /:/;
  116.     # XXX: Should probably want to do something about ".." and "."
  117.     # path segments.  I don't know how these are represented in
  118.     # the Machintosh file system.  If these are valid file names
  119.     # then we should split the path ourself, as $u->path_components
  120.     # loose the distinction between '.' and '%2E'.
  121.     push(@p, $_);
  122.     }
  123.     if (@p && $p[0] eq '') {
  124.     shift @p;
  125.     } else {
  126.     unshift(@p, '');
  127.     }
  128.     join(':', @p);
  129. }
  130.  
  131. sub vms_path
  132. {
  133.     # ????? Can some VMS people please redo this function ??????
  134.  
  135.     # This is implemented based on what RFC1738 (sec 3.10) says in the
  136.     # VMS file example:
  137.     #
  138.     #  DISK$USER:[MY.NOTES]NOTE123456.TXT
  139.     #
  140.     #      that might become
  141.     #
  142.     #  file:/disk$user/my/notes/note12345.txt
  143.     #
  144.     # BEWARE: I don't have a VMS machine myself so this is pure guesswork!!!
  145.  
  146.     my $self = shift;
  147.     my @p = $self->path_components;
  148.     my $abs = 0;
  149.     if (@p && $p[0] eq '') {
  150.     shift @p;
  151.     $abs = 1;
  152.     }
  153.     # First I assume there must be a dollar in a disk spesification
  154.     my $p = '';
  155.     $p = uc(shift(@p)) . ":"  if @p && $p[0] =~ /\$/;
  156.     my $file = pop(@p);
  157.     $p .= "[" . join(".", map{uc($_)} @p) . "]" if @p;
  158.     $p .= uc $file;
  159.     # XXX: How is an absolute path different from a relative one??
  160.     $p =~ s/\[/[./ unless $abs;
  161.     # XXX: How is a directory denoted??
  162.     $p;
  163. }
  164.  
  165. 1;
  166.