"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/site/lib/URI/file/Unix.pm" (10 Mar 2019, 1022 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 package URI::file::Unix;
    2 
    3 use strict;
    4 use warnings;
    5 
    6 use parent 'URI::file::Base';
    7 
    8 use URI::Escape qw(uri_unescape);
    9 
   10 our $VERSION = '1.76';
   11 
   12 sub _file_extract_path
   13 {
   14     my($class, $path) = @_;
   15 
   16     # tidy path
   17     $path =~ s,//+,/,g;
   18     $path =~ s,(/\.)+/,/,g;
   19     $path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:"
   20 
   21     return $path;
   22 }
   23 
   24 sub _file_is_absolute {
   25     my($class, $path) = @_;
   26     return $path =~ m,^/,;
   27 }
   28 
   29 sub file
   30 {
   31     my $class = shift;
   32     my $uri = shift;
   33     my @path;
   34 
   35     my $auth = $uri->authority;
   36     if (defined($auth)) {
   37     if (lc($auth) ne "localhost" && $auth ne "") {
   38         $auth = uri_unescape($auth);
   39         unless ($class->_file_is_localhost($auth)) {
   40         push(@path, "", "", $auth);
   41         }
   42     }
   43     }
   44 
   45     my @ps = $uri->path_segments;
   46     shift @ps if @path;
   47     push(@path, @ps);
   48 
   49     for (@path) {
   50     # Unix file/directory names are not allowed to contain '\0' or '/'
   51     return undef if /\0/;
   52     return undef if /\//;  # should we really?
   53     }
   54 
   55     return join("/", @path);
   56 }
   57 
   58 1;