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

   1 package URI::file::Base;
   2
   3 use strict;
   4 use URI::Escape qw();
   5
   6 sub new
   7 {
   8     my $class = shift;
   9     my $path  = shift;
  10     $path = "" unless defined $path;
  11
  12     my($auth, $escaped_auth, $escaped_path);
  13
  14     ($auth, $escaped_auth) = $class->_file_extract_authority($path);
  15     ($path, $escaped_path) = $class->_file_extract_path($path);
  16
  17     if (defined $auth) {
  18         $auth =~ s,%,%25,g unless $escaped_auth;
  19         $auth =~ s,([/?\#]),$URI::Escape::escapes{$1},g;
  20         $auth = "//$auth";
  21         if (defined $path) {
  22             $path = "/$path" unless substr($path, 0, 1) eq "/";
  23         } else {
  24             $path = "";
  25         }
  26     } else {
  27         return undef unless defined $path;
  28         $auth = "";
  29     }
  30
  31     $path =~ s,([%;?]),$URI::Escape::escapes{$1},g unless $escaped_path;
  32     $path =~ s/\#/%23/g;
  33
  34     my $uri = $auth . $path;
  35     $uri = "file:$uri" if substr($uri, 0, 1) eq "/";
  36
  37     URI->new($uri, "file");
  38 }
  39
  40 sub _file_extract_authority
  41 {
  42     my($class, $path) = @_;
  43     return undef unless $class->_file_is_absolute($path);
  44     return $URI::file::DEFAULT_AUTHORITY;
  45 }
  46
  47 sub _file_extract_path
  48 {
  49     return undef;
  50 }
  51
  52 sub _file_is_absolute
  53 {
  54     return 0;
  55 }
  56
  57 sub _file_is_localhost
  58 {
  59     shift; # class
  60     my $host = lc(shift);
  61     return 1 if $host eq "localhost";
  62     eval {
  63         require Net::Domain;
  64         lc(Net::Domain::hostfqdn()) eq $host ||
  65         lc(Net::Domain::hostname()) eq $host;
  66     };
  67 }
  68
  69 sub file
  70 {
  71     undef;
  72 }
  73
  74 sub dir
  75 {
  76     my $self = shift;
  77     $self->file(@_);
  78 }
  79
  80 1;