summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/site/lib/URI/file
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/site/lib/URI/file')
-rw-r--r--Master/tlpkg/tlperl/site/lib/URI/file/Base.pm85
-rw-r--r--Master/tlpkg/tlperl/site/lib/URI/file/FAT.pm28
-rw-r--r--Master/tlpkg/tlperl/site/lib/URI/file/Mac.pm122
-rw-r--r--Master/tlpkg/tlperl/site/lib/URI/file/OS2.pm33
-rw-r--r--Master/tlpkg/tlperl/site/lib/URI/file/QNX.pm21
-rw-r--r--Master/tlpkg/tlperl/site/lib/URI/file/Unix.pm59
-rw-r--r--Master/tlpkg/tlperl/site/lib/URI/file/Win32.pm88
7 files changed, 436 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/site/lib/URI/file/Base.pm b/Master/tlpkg/tlperl/site/lib/URI/file/Base.pm
new file mode 100644
index 00000000000..cbb0970c273
--- /dev/null
+++ b/Master/tlpkg/tlperl/site/lib/URI/file/Base.pm
@@ -0,0 +1,85 @@
+package URI::file::Base;
+
+use strict;
+use warnings;
+
+use URI::Escape qw();
+
+our $VERSION = '1.71';
+$VERSION = eval $VERSION;
+
+sub new
+{
+ my $class = shift;
+ my $path = shift;
+ $path = "" unless defined $path;
+
+ my($auth, $escaped_auth, $escaped_path);
+
+ ($auth, $escaped_auth) = $class->_file_extract_authority($path);
+ ($path, $escaped_path) = $class->_file_extract_path($path);
+
+ if (defined $auth) {
+ $auth =~ s,%,%25,g unless $escaped_auth;
+ $auth =~ s,([/?\#]), URI::Escape::escape_char($1),eg;
+ $auth = "//$auth";
+ if (defined $path) {
+ $path = "/$path" unless substr($path, 0, 1) eq "/";
+ } else {
+ $path = "";
+ }
+ } else {
+ return undef unless defined $path;
+ $auth = "";
+ }
+
+ $path =~ s,([%;?]), URI::Escape::escape_char($1),eg unless $escaped_path;
+ $path =~ s/\#/%23/g;
+
+ my $uri = $auth . $path;
+ $uri = "file:$uri" if substr($uri, 0, 1) eq "/";
+
+ URI->new($uri, "file");
+}
+
+sub _file_extract_authority
+{
+ my($class, $path) = @_;
+ return undef unless $class->_file_is_absolute($path);
+ return $URI::file::DEFAULT_AUTHORITY;
+}
+
+sub _file_extract_path
+{
+ return undef;
+}
+
+sub _file_is_absolute
+{
+ return 0;
+}
+
+sub _file_is_localhost
+{
+ shift; # class
+ my $host = lc(shift);
+ return 1 if $host eq "localhost";
+ eval {
+ require Net::Domain;
+ lc(Net::Domain::hostfqdn()) eq $host ||
+ lc(Net::Domain::hostname()) eq $host;
+ };
+}
+
+sub file
+{
+ undef;
+}
+
+sub dir
+{
+ my $self = shift;
+ $self->file(@_);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/site/lib/URI/file/FAT.pm b/Master/tlpkg/tlperl/site/lib/URI/file/FAT.pm
new file mode 100644
index 00000000000..081d94e2166
--- /dev/null
+++ b/Master/tlpkg/tlperl/site/lib/URI/file/FAT.pm
@@ -0,0 +1,28 @@
+package URI::file::FAT;
+
+use strict;
+use warnings;
+
+use parent 'URI::file::Win32';
+
+our $VERSION = '1.71';
+$VERSION = eval $VERSION;
+
+sub fix_path
+{
+ shift; # class
+ for (@_) {
+ # turn it into 8.3 names
+ my @p = map uc, split(/\./, $_, -1);
+ return if @p > 2; # more than 1 dot is not allowed
+ @p = ("") unless @p; # split bug? (returns nothing when splitting "")
+ $_ = substr($p[0], 0, 8);
+ if (@p > 1) {
+ my $ext = substr($p[1], 0, 3);
+ $_ .= ".$ext" if length $ext;
+ }
+ }
+ 1; # ok
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/site/lib/URI/file/Mac.pm b/Master/tlpkg/tlperl/site/lib/URI/file/Mac.pm
new file mode 100644
index 00000000000..f9eda0a8190
--- /dev/null
+++ b/Master/tlpkg/tlperl/site/lib/URI/file/Mac.pm
@@ -0,0 +1,122 @@
+package URI::file::Mac;
+
+use strict;
+use warnings;
+
+use parent 'URI::file::Base';
+
+use URI::Escape qw(uri_unescape);
+
+our $VERSION = '1.71';
+$VERSION = eval $VERSION;
+
+sub _file_extract_path
+{
+ my $class = shift;
+ my $path = shift;
+
+ my @pre;
+ if ($path =~ s/^(:+)//) {
+ if (length($1) == 1) {
+ @pre = (".") unless length($path);
+ } else {
+ @pre = ("..") x (length($1) - 1);
+ }
+ } else { #absolute
+ $pre[0] = "";
+ }
+
+ my $isdir = ($path =~ s/:$//);
+ $path =~ s,([%/;]), URI::Escape::escape_char($1),eg;
+
+ my @path = split(/:/, $path, -1);
+ for (@path) {
+ if ($_ eq "." || $_ eq "..") {
+ $_ = "%2E" x length($_);
+ }
+ $_ = ".." unless length($_);
+ }
+ push (@path,"") if $isdir;
+ (join("/", @pre, @path), 1);
+}
+
+
+sub file
+{
+ my $class = shift;
+ my $uri = shift;
+ my @path;
+
+ my $auth = $uri->authority;
+ if (defined $auth) {
+ if (lc($auth) ne "localhost" && $auth ne "") {
+ my $u_auth = uri_unescape($auth);
+ if (!$class->_file_is_localhost($u_auth)) {
+ # some other host (use it as volume name)
+ @path = ("", $auth);
+ # XXX or just return to make it illegal;
+ }
+ }
+ }
+ my @ps = split("/", $uri->path, -1);
+ shift @ps if @path;
+ push(@path, @ps);
+
+ my $pre = "";
+ if (!@path) {
+ return; # empty path; XXX return ":" instead?
+ } elsif ($path[0] eq "") {
+ # absolute
+ shift(@path);
+ if (@path == 1) {
+ return if $path[0] eq ""; # not root directory
+ push(@path, ""); # volume only, effectively append ":"
+ }
+ @ps = @path;
+ @path = ();
+ my $part;
+ for (@ps) { #fix up "." and "..", including interior, in relatives
+ next if $_ eq ".";
+ $part = $_ eq ".." ? "" : $_;
+ push(@path,$part);
+ }
+ if ($ps[-1] eq "..") { #if this happens, we need another :
+ push(@path,"");
+ }
+
+ } else {
+ $pre = ":";
+ @ps = @path;
+ @path = ();
+ my $part;
+ for (@ps) { #fix up "." and "..", including interior, in relatives
+ next if $_ eq ".";
+ $part = $_ eq ".." ? "" : $_;
+ push(@path,$part);
+ }
+ if ($ps[-1] eq "..") { #if this happens, we need another :
+ push(@path,"");
+ }
+
+ }
+ return unless $pre || @path;
+ for (@path) {
+ s/;.*//; # get rid of parameters
+ #return unless length; # XXX
+ $_ = uri_unescape($_);
+ return if /\0/;
+ return if /:/; # Should we?
+ }
+ $pre . join(":", @path);
+}
+
+sub dir
+{
+ my $class = shift;
+ my $path = $class->file(@_);
+ return unless defined $path;
+ $path .= ":" unless $path =~ /:$/;
+ $path;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/site/lib/URI/file/OS2.pm b/Master/tlpkg/tlperl/site/lib/URI/file/OS2.pm
new file mode 100644
index 00000000000..a089491cb09
--- /dev/null
+++ b/Master/tlpkg/tlperl/site/lib/URI/file/OS2.pm
@@ -0,0 +1,33 @@
+package URI::file::OS2;
+
+use strict;
+use warnings;
+
+use parent 'URI::file::Win32';
+
+our $VERSION = '1.71';
+$VERSION = eval $VERSION;
+
+# The Win32 version translates k:/foo to file://k:/foo (?!)
+# We add an empty host
+
+sub _file_extract_authority
+{
+ my $class = shift;
+ return $1 if $_[0] =~ s,^\\\\([^\\]+),,; # UNC
+ return $1 if $_[0] =~ s,^//([^/]+),,; # UNC too?
+
+ if ($_[0] =~ m#^[a-zA-Z]{1,2}:#) { # allow for ab: drives
+ return "";
+ }
+ return;
+}
+
+sub file {
+ my $p = &URI::file::Win32::file;
+ return unless defined $p;
+ $p =~ s,\\,/,g;
+ $p;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/site/lib/URI/file/QNX.pm b/Master/tlpkg/tlperl/site/lib/URI/file/QNX.pm
new file mode 100644
index 00000000000..2853ac0e0bc
--- /dev/null
+++ b/Master/tlpkg/tlperl/site/lib/URI/file/QNX.pm
@@ -0,0 +1,21 @@
+package URI::file::QNX;
+
+use strict;
+use warnings;
+
+use parent 'URI::file::Unix';
+
+our $VERSION = '1.71';
+$VERSION = eval $VERSION;
+
+sub _file_extract_path
+{
+ my($class, $path) = @_;
+ # tidy path
+ $path =~ s,(.)//+,$1/,g; # ^// is correct
+ $path =~ s,(/\.)+/,/,g;
+ $path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:"
+ $path;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/site/lib/URI/file/Unix.pm b/Master/tlpkg/tlperl/site/lib/URI/file/Unix.pm
new file mode 100644
index 00000000000..e75887b0227
--- /dev/null
+++ b/Master/tlpkg/tlperl/site/lib/URI/file/Unix.pm
@@ -0,0 +1,59 @@
+package URI::file::Unix;
+
+use strict;
+use warnings;
+
+use parent 'URI::file::Base';
+
+use URI::Escape qw(uri_unescape);
+
+our $VERSION = '1.71';
+$VERSION = eval $VERSION;
+
+sub _file_extract_path
+{
+ my($class, $path) = @_;
+
+ # tidy path
+ $path =~ s,//+,/,g;
+ $path =~ s,(/\.)+/,/,g;
+ $path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:"
+
+ return $path;
+}
+
+sub _file_is_absolute {
+ my($class, $path) = @_;
+ return $path =~ m,^/,;
+}
+
+sub file
+{
+ my $class = shift;
+ my $uri = shift;
+ my @path;
+
+ my $auth = $uri->authority;
+ if (defined($auth)) {
+ if (lc($auth) ne "localhost" && $auth ne "") {
+ $auth = uri_unescape($auth);
+ unless ($class->_file_is_localhost($auth)) {
+ push(@path, "", "", $auth);
+ }
+ }
+ }
+
+ my @ps = $uri->path_segments;
+ shift @ps if @path;
+ push(@path, @ps);
+
+ for (@path) {
+ # Unix file/directory names are not allowed to contain '\0' or '/'
+ return undef if /\0/;
+ return undef if /\//; # should we really?
+ }
+
+ return join("/", @path);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl/site/lib/URI/file/Win32.pm b/Master/tlpkg/tlperl/site/lib/URI/file/Win32.pm
new file mode 100644
index 00000000000..eac920f9ea3
--- /dev/null
+++ b/Master/tlpkg/tlperl/site/lib/URI/file/Win32.pm
@@ -0,0 +1,88 @@
+package URI::file::Win32;
+
+use strict;
+use warnings;
+
+use parent 'URI::file::Base';
+
+use URI::Escape qw(uri_unescape);
+
+our $VERSION = '1.71';
+$VERSION = eval $VERSION;
+
+sub _file_extract_authority
+{
+ my $class = shift;
+
+ return $class->SUPER::_file_extract_authority($_[0])
+ if defined $URI::file::DEFAULT_AUTHORITY;
+
+ return $1 if $_[0] =~ s,^\\\\([^\\]+),,; # UNC
+ return $1 if $_[0] =~ s,^//([^/]+),,; # UNC too?
+
+ if ($_[0] =~ s,^([a-zA-Z]:),,) {
+ my $auth = $1;
+ $auth .= "relative" if $_[0] !~ m,^[\\/],;
+ return $auth;
+ }
+ return undef;
+}
+
+sub _file_extract_path
+{
+ my($class, $path) = @_;
+ $path =~ s,\\,/,g;
+ #$path =~ s,//+,/,g;
+ $path =~ s,(/\.)+/,/,g;
+
+ if (defined $URI::file::DEFAULT_AUTHORITY) {
+ $path =~ s,^([a-zA-Z]:),/$1,;
+ }
+
+ return $path;
+}
+
+sub _file_is_absolute {
+ my($class, $path) = @_;
+ return $path =~ m,^[a-zA-Z]:, || $path =~ m,^[/\\],;
+}
+
+sub file
+{
+ my $class = shift;
+ my $uri = shift;
+ my $auth = $uri->authority;
+ my $rel; # is filename relative to drive specified in authority
+ if (defined $auth) {
+ $auth = uri_unescape($auth);
+ if ($auth =~ /^([a-zA-Z])[:|](relative)?/) {
+ $auth = uc($1) . ":";
+ $rel++ if $2;
+ } elsif (lc($auth) eq "localhost") {
+ $auth = "";
+ } elsif (length $auth) {
+ $auth = "\\\\" . $auth; # UNC
+ }
+ } else {
+ $auth = "";
+ }
+
+ my @path = $uri->path_segments;
+ for (@path) {
+ return undef if /\0/;
+ return undef if /\//;
+ #return undef if /\\/; # URLs with "\" is not uncommon
+ }
+ return undef unless $class->fix_path(@path);
+
+ my $path = join("\\", @path);
+ $path =~ s/^\\// if $rel;
+ $path = $auth . $path;
+ $path =~ s,^\\([a-zA-Z])[:|],\u$1:,;
+
+ return $path;
+}
+
+sub fix_path { 1; }
+
+1;