home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / perl5 / URI / file / Base.pm next >
Encoding:
Perl POD Document  |  2004-09-07  |  1.4 KB  |  81 lines
  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;
  81.