vcs.maemo.org Git - pkg-perl/blob - deb-src/liburi-perl/liburi-perl-1.35.dfsg.1/URI/file/Win32.pm

   1 package URI::file::Win32;
   2
   3 require URI::file::Base;
   4 @ISA=qw(URI::file::Base);
   5
   6 use strict;
   7 use URI::Escape qw(uri_unescape);
   8
   9 sub _file_extract_authority
  10 {
  11     my $class = shift;
  12
  13     return $class->SUPER::_file_extract_authority($_[0])
  14         if defined $URI::file::DEFAULT_AUTHORITY;
  15
  16     return $1 if $_[0] =~ s,^\\\\([^\\]+),,;  # UNC
  17     return $1 if $_[0] =~ s,^//([^/]+),,;     # UNC too?
  18
  19     if ($_[0] =~ s,^([a-zA-Z]:),,) {
  20         my $auth = $1;
  21         $auth .= "relative" if $_[0] !~ m,^[\\/],;
  22         return $auth;
  23     }
  24     return undef;
  25 }
  26
  27 sub _file_extract_path
  28 {
  29     my($class, $path) = @_;
  30     $path =~ s,\\,/,g;
  31     #$path =~ s,//+,/,g;
  32     $path =~ s,(/\.)+/,/,g;
  33
  34     if (defined $URI::file::DEFAULT_AUTHORITY) {
  35         $path =~ s,^([a-zA-Z]:),/$1,;
  36     }
  37
  38     return $path;
  39 }
  40
  41 sub _file_is_absolute {
  42     my($class, $path) = @_;
  43     return $path =~ m,^[a-zA-Z]:, || $path =~ m,^[/\\],;
  44 }
  45
  46 sub file
  47 {
  48     my $class = shift;
  49     my $uri = shift;
  50     my $auth = $uri->authority;
  51     my $rel; # is filename relative to drive specified in authority
  52     if (defined $auth) {
  53         $auth = uri_unescape($auth);
  54         if ($auth =~ /^([a-zA-Z])[:|](relative)?/) {
  55             $auth = uc($1) . ":";
  56             $rel++ if $2;
  57         } elsif (lc($auth) eq "localhost") {
  58             $auth = "";
  59         } elsif (length $auth) {
  60             $auth = "\\\\" . $auth;  # UNC
  61         }
  62     } else {
  63         $auth = "";
  64     }
  65
  66     my @path = $uri->path_segments;
  67     for (@path) {
  68         return undef if /\0/;
  69         return undef if /\//;
  70         #return undef if /\\/;        # URLs with "\" is not uncommon
  71     }
  72     return undef unless $class->fix_path(@path);
  73
  74     my $path = join("\\", @path);
  75     $path =~ s/^\\// if $rel;
  76     $path = $auth . $path;
  77     $path =~ s,^\\([a-zA-Z])[:|],\u$1:,;
  78
  79     return $path;
  80 }
  81
  82 sub fix_path { 1; }
  83
  84 1;