emacs/nxhtml/nxhtml/html-wtoc/PerlLib/PathSubs.pm

   1 # Copyright 2006 Lennart Borgman, http://OurComments.org/. All rights
   2 # reserved.
   3 #
   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)
   7 # any later version.
   8 #
   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.
  13 #
  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.
  18
  19 package PathSubs;
  20
  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 #####################################################
  26 use strict;
  27
  28 use File::Spec;
  29
  30 ### Absolute path names
  31
  32 sub is_abs_path ($) {
  33    my $path = shift;
  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;
  42 }
  43 sub is_abs_netpath($) {
  44    my $path = shift;
  45    return 1 if $path =~ /^https?:/i;
  46    # New
  47    return 1 if $path =~ /^ftp:/i;
  48    return 1 if $path =~ /^mailto:/i;
  49 }
  50
  51
  52 sub uniq_file($) {
  53         my $fname = shift;
  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";
  59         }
  60         #print STDERR "uniq_file($fname)\n";
  61         $fname =~ tr!\\!/!;
  62         if (-e $fname)  {
  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";
  68                 ### Translate ..
  69                 if (substr($fname, 1, 1) eq ":") {
  70                     my $ffname = Win32::GetFullPathName($fname);
  71                     ### Get case
  72                     my $lfname = Win32::GetLongPathName($ffname);
  73                     #print STDERR "lexists $lfname\n";
  74                     $fname = $lfname if ($lfname ne "");
  75                 }
  76         } else {
  77                 #print STDERR "NOT exists $fname\n";
  78                 if (substr($fname, -1) eq "/") { chop $fname; }
  79                 my $head = "";
  80                 if (substr($fname, 0, 2) eq "//") {
  81                         $head = "//";
  82                         $fname = substr($fname, 2);
  83                 }
  84                 my @fname = split("/", $fname);
  85                 my $tail = pop @fname;
  86                 $fname = uniq_dir($head . join("/", @fname)) . $tail;
  87         }
  88         if (substr($fname, 1, 1) eq ":") {
  89                 $fname = uc(substr($fname, 0, 1)) . substr($fname, 1);
  90                 #print STDERR "fname $fname\n";
  91         }
  92         $fname =~ tr!\\!/!;
  93                 #print STDERR "fname ($fname)\n";
  94         return $fname;
  95 }
  96 sub uniq_dir($) {
  97         my $dir = shift;
  98         my $uq_dir = uniq_file($dir);
  99         if (substr($uq_dir, -1) ne "/") { $uq_dir .= "/"; }
 100         return $uq_dir;
 101 }
 102
 103
 104
 105 ### Relative paths
 106 sub _get_link_root($) {
 107         my $lnk = shift;
 108         if ($lnk =~ m!^(/|ftp://[^/]*|https?://[^/]*|[a-z]:/)!i) {
 109                 return $1;
 110         } else {
 111                 return "";
 112         }
 113 }
 114
 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 "/") {
 121                 chop $root;
 122                 $url = "/$url";
 123         }
 124         #die "$root\n$url";
 125         my $iPosSearch = 2;
 126         #print "url=$url\n";
 127         while ((my $iPos = index($url, "/../", $iPosSearch)) > -1) {
 128                 my $sLeft = substr($url, 0, $iPos);
 129                 if (substr($sLeft, -2) eq "..") {
 130                         $iPosSearch += 3;
 131                         next;
 132                 }
 133                 my $sRight = substr($url, $iPos+3);
 134                 #print "url=$url\n";
 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";
 142                 #print "url=$url\n";
 143         }
 144         if (index($url, "../") > -1) {
 145                 return $orig_url;
 146         }
 147         return $root . $url;
 148 }
 149
 150 sub mk_relative_link($$;$) {
 151     my $from = shift;
 152     my $to   = shift;
 153     my $norm = shift;
 154     if ($norm) {
 155         $from = uniq_file($from);
 156         $to   = uniq_file($to);
 157     }
 158     if (-e $from) {
 159         $from = uniq_file($from);
 160     } else {
 161         $from = resolve_dotdot($from);
 162     }
 163     if (-e $to) {
 164         $to   = uniq_file($to);
 165     } else {
 166         $to = resolve_dotdot($to);
 167     }
 168     my $root_from = _get_link_root($from);
 169     my $root_to   = _get_link_root($to  );
 170     if ($root_from ne $root_to) {
 171         return $to;
 172     }
 173     my @from = split "/", $from;
 174     my @to   = split "/", $to;
 175     while (@to) {
 176         last if ($to[0] ne $from[0]);
 177         shift @to;
 178         shift @from;
 179     }
 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]));
 184                         }
 185         }
 186     }
 187     my $rl;
 188     for (1..$#from) { $rl .= "../"; }
 189     $rl .= join("/", @to);
 190
 191     return $rl;
 192 }
 193
 194
 195
 196 sub mk_absolute_link($$) {
 197         my $from   = shift;
 198         my $rel_to = shift;
 199         my $abs = $from;
 200         $abs =~ s![^/]*$!!;
 201         $abs .= $rel_to;
 202         if (!is_abs_netpath($abs)) { $abs = uniq_file($abs); }
 203         $abs;
 204 }
 205
 206
 207 1;