@ISA
=
qw(URI::file::Base)
;
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
{
$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
)) {
@path
= (
""
,
$auth
);
}
}
}
my
@ps
=
split
(
"/"
,
$uri
->path, -1);
shift
@ps
if
@path
;
push
(
@path
,
@ps
);
my
$pre
=
""
;
if
(!
@path
) {
return
;
}
elsif
(
$path
[0] eq
""
) {
shift
(
@path
);
if
(
@path
== 1) {
return
if
$path
[0] eq
""
;
push
(
@path
,
""
);
}
@ps
=
@path
;
@path
= ();
my
$part
;
for
(
@ps
) {
next
if
$_
eq
"."
;
$part
=
$_
eq
".."
?
""
:
$_
;
push
(
@path
,
$part
);
}
if
(
$ps
[-1] eq
".."
) {
push
(
@path
,
""
);
}
}
else
{
$pre
=
":"
;
@ps
=
@path
;
@path
= ();
my
$part
;
for
(
@ps
) {
next
if
$_
eq
"."
;
$part
=
$_
eq
".."
?
""
:
$_
;
push
(
@path
,
$part
);
}
if
(
$ps
[-1] eq
".."
) {
push
(
@path
,
""
);
}
}
return
unless
$pre
||
@path
;
for
(
@path
) {
s/;.*//;
$_
= uri_unescape(
$_
);
return
if
/\0/;
return
if
/:/;
}
$pre
.
join
(
":"
,
@path
);
}
sub
dir
{
my
$class
=
shift
;
my
$path
=
$class
->file(
@_
);
return
unless
defined
$path
;
$path
.=
":"
unless
$path
=~ /:$/;
$path
;
}
1;