1 # Copyright 2006 Lennart Borgman, http://OurComments.org/. All rights
4 # This program is free software; you can redistribute it and/or modify
5 # it under the terms of the GNU General Public License as published by
6 # the Free Software Foundation; either version 3, or (at your option)
9 # This program is distributed in the hope that it will be useful, but
10 # WITHOUT ANY WARRANTY; without even the implied warranty of
11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 # General Public License for more details.
14 # You should have received a copy of the GNU General Public License
15 # along with this program; see the file COPYING. If not, write to the
16 # Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
17 # Boston, MA 02110-1301, USA.
21 #####################################################
22 ### This package contains general path handling
23 ### routines and some win32 specific dito.
24 ### The latter should ev be moved to a new module!
25 #####################################################
30 ### Absolute path names
34 return 0 if $path eq "";
35 return 1 if File::Spec->file_name_is_absolute($path);
36 #return 1 if substr($path, 1, 1) eq ":"; # MSWin32
37 #return 1 if substr($path, 0, 1) eq "/";
38 return 1 if $path =~ /^https?:/i;
39 return 1 if $path =~ /^file:/i;
40 return 1 if $path =~ /^javascript:/i;
41 return 1 if $path =~ /^mailto:/i;
43 sub is_abs_netpath($) {
45 return 1 if $path =~ /^https?:/i;
47 return 1 if $path =~ /^ftp:/i;
48 return 1 if $path =~ /^mailto:/i;
54 $fname =~ s!^\s+|\s+$!!g;
55 return "" if ($fname eq "");
56 $fname = File::Spec->rel2abs($fname);
57 if (!File::Spec->file_name_is_absolute($fname)) {
58 die "File name is not absolute: $fname";
60 #print STDERR "uniq_file($fname)\n";
63 #print STDERR "exists $fname\n";
64 ### There is an error in 522, compensate for this!
65 #die substr($fname, -1);
66 if (substr($fname, -1) eq "/") { chop $fname; }
67 #print STDERR "exists $fname\n";
69 if (substr($fname, 1, 1) eq ":") {
70 my $ffname = Win32::GetFullPathName($fname);
72 my $lfname = Win32::GetLongPathName($ffname);
73 #print STDERR "lexists $lfname\n";
74 $fname = $lfname if ($lfname ne "");
77 #print STDERR "NOT exists $fname\n";
78 if (substr($fname, -1) eq "/") { chop $fname; }
80 if (substr($fname, 0, 2) eq "//") {
82 $fname = substr($fname, 2);
84 my @fname = split("/", $fname);
85 my $tail = pop @fname;
86 $fname = uniq_dir($head . join("/", @fname)) . $tail;
88 if (substr($fname, 1, 1) eq ":") {
89 $fname = uc(substr($fname, 0, 1)) . substr($fname, 1);
90 #print STDERR "fname $fname\n";
93 #print STDERR "fname ($fname)\n";
98 my $uq_dir = uniq_file($dir);
99 if (substr($uq_dir, -1) ne "/") { $uq_dir .= "/"; }
106 sub _get_link_root($) {
108 if ($lnk =~ m!^(/|ftp://[^/]*|https?://[^/]*|[a-z]:/)!i) {
115 sub resolve_dotdot($) {
116 my $orig_url = shift;
117 my $root = _get_link_root($orig_url);
118 return $orig_url if length($root) == length($orig_url);
119 my $url = substr($orig_url, length($root));
120 if (substr($root, -1) eq "/") {
127 while ((my $iPos = index($url, "/../", $iPosSearch)) > -1) {
128 my $sLeft = substr($url, 0, $iPos);
129 if (substr($sLeft, -2) eq "..") {
133 my $sRight = substr($url, $iPos+3);
135 #print "iPos=$iPos\n";
136 #print "sLeft=$sLeft\n";
137 $sLeft =~ s!/[^/]*$!!;
138 #print "sLeft=$sLeft\n";
139 #print "sRight=$sRight\n";
140 $url = $sLeft . $sRight;
141 #print "\t***url=$url\n";
144 if (index($url, "../") > -1) {
150 sub mk_relative_link($$;$) {
155 $from = uniq_file($from);
156 $to = uniq_file($to);
159 $from = uniq_file($from);
161 $from = resolve_dotdot($from);
164 $to = uniq_file($to);
166 $to = resolve_dotdot($to);
168 my $root_from = _get_link_root($from);
169 my $root_to = _get_link_root($to );
170 if ($root_from ne $root_to) {
173 my @from = split "/", $from;
174 my @to = split "/", $to;
176 last if ($to[0] ne $from[0]);
180 if (@to == 1 && @from == 1) {
181 if (length($to[0]) > length($from[0])) {
182 if (substr($to[0], 0, length($from[0])+1) eq ($from[0] . "#")) {
183 return substr($to[0], length($from[0]));
188 for (1..$#from) { $rl .= "../"; }
189 $rl .= join("/", @to);
196 sub mk_absolute_link($$) {
202 if (!is_abs_netpath($abs)) { $abs = uniq_file($abs); }