This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
5.005_54 (pod2html) Generate Relative URLs
[perl5.git] / lib / File / PathConvert.pm
1 #
2 # Copyright (c) 1996, 1997, 1998 Shigio Yamaguchi. All rights reserved.
3 # This program is free software; you can redistribute it and/or
4 # modify it under the same terms as Perl itself.
5 #
6 #       File::PathConvert.pm
7 #
8
9 package File::PathConvert;
10 require 5.002;
11
12 use strict ;
13
14 BEGIN {
15    use Exporter   ();
16    use vars       qw($VERSION @ISA @EXPORT_OK);
17    $VERSION       = 0.85;
18    @ISA           = qw(Exporter);
19    @EXPORT_OK     = qw(setfstype splitpath joinpath splitdirs joindirs realpat
20  abs2rel rel2abs $maxsymlinks $verbose $SL $resolved );
21 }
22
23 use vars      qw( $maxsymlinks $verbose $SL $resolved ) ;
24 use Cwd;
25
26 #
27 # Initialize @EXPORT_OK vars
28 #
29 $maxsymlinks   = 32;       # allowed symlink number in a path
30 $verbose       = 0;        # 1: verbose on, 0: verbose off
31 $SL            = '' ;      # Separator char export
32 $resolved      = '' ;      # realpath() intermediate value export
33
34 #############################################################################
35 #
36 #  Package Globals
37 #
38
39 my $fstype        ; # A name indicating the type of filesystem currently in us
40
41 my $sep           ; # separator
42 my $sepRE         ; # RE to match spearator
43 my $notsepRE      ; # RE to match anything else
44 my $volumeRE      ; # RE to match the volume name
45 my $directoryRE   ; # RE to match the directory name
46 my $isrootRE      ; # RE to match root path: applied to directory portion only
47 my $thisDir       ; # Name of this directory
48 my $thisDirRE     ; # Name of this directory
49 my $parentDir     ; # Name of parent directory
50 my $parentDirRE   ; # RE to match parent dir name
51 my $casesensitive ; # Set to non-zero for case sensitive name comprisions.  On
52 y
53                     # affects names, not any other REs, so $isrootRE for Win32
54                     # must be case insensitive
55 my $idempotent    ; # Set to non-zero if '//' is equivalent to '/'.  This
56                     # does not affect leading '//' and '\\' under Win32,
57                     # but will fold '///' and '////', etc, in to '//' on this
58                     # Win32
59
60
61
62 ###########
63 #
64 # The following globals are regexs used in the indicated routines.  These
65 # are initialized by setfstype, so they don't need to be rebuilt each time
66 # the routine that uses them is called.
67
68 my $basenamesplitRE ; # Used in realpath() to split filenames.
69
70
71 ###########
72 #
73 # This RE matches (and saves) the portion of the string that is just before
74 # the beginning of a name
75 #
76 my $beginning_of_name ;
77
78 #
79 # This whopper of an RE looks for the pattern "name/.." if it occurs
80 # after the beginning of the string or after the root RE, or after a separator
81
82 # We don't assume that the isrootRE has a trailing separator.
83 # It also makes sure that we aren't eliminating '../..' and './..' patterns
84 # by using the negative lookahead assertion '(?!' ... ')' construct.  It also
85 # ignores 'name/..name'.
86 #
87 my $name_sep_parentRE ;
88
89 #
90 # Matches '..$', '../' after a root
91 my $leading_parentRE ;
92
93 #
94 # Matches things like '/(./)+' and '^(./)+'
95 #
96 my $dot_sep_etcRE ;
97
98 #
99 # Matches trailing '/' or '/.'
100 #
101 my $trailing_sepRE ;
102
103
104 #############################################################################
105 #
106 #     Functions
107 #
108
109
110 #
111 # setfstype: takes the name of an operating system and sets up globals that
112 #            allow the other functions to operate on multiple OSs.  See
113 #            %fsconfig for the sets of settings.
114 #
115 #            This is run once on module load to configure for the OS named
116 #            in $^O.
117 #
118 # Interface:
119 #       i)     $osname, as in $^O or plain english: "MacOS", "DOS, etc.
120 #              This is _not_ usually case sensitive.
121 #       r)     Name of recognized name on success else undef.  Note that, as
122 #              shipped, 'unix' is the default is nothing else matches.
123 #       go)    $fstype and lots of internal parameters and regexs.
124 #       x)     Dies if a parameter required in @fsconfig is missing.
125 #
126 #
127 # There are some things I couldn't figure a way to parameterize by setting
128 # globals. $fstype is checked for filesystem type-specific logic, like
129 # VMS directory syntax.
130 #
131 # Setting up for a particular OS type takes two steps: identify the OS and
132 # set all of the 'atomic' global variables, then take some of the atomic
133 # globals which are regexps and build composite values from them.
134 #
135 # The atomic regexp terms are generally used to build the larger composite
136 # regexps that recognize and break apart paths.  This leads to
137 # two important rules for the atomic regexp terms:
138 #
139 # (1) Do not use '(' ... ')' in the regex terms, since they are used to build
140 # regexs that use '(' ... ')' to parse paths.
141 #
142 # (2) They must be built so that a '?' or other quantifier may be appended.
143 # This generally means using the '(?:' ... ')' or '[' ... ']' to group
144 # multicharacter patterns.  Other '(?' ... ')' may also do.
145 #
146 # The routines herein strive to preserve the
147 # original separator and root settings, and, it turns out, never need to
148 # prepend root to a string (although they do need to insert separators on
149 # occasion).  This is good, since the Win32 root expressions can be like
150 # '/', '\', 'A:/', 'a:/', or even '\\' or '//' for UNC style names.
151 #
152 # Note that the default root and default notsep are not used, and so are
153 # undefined.
154 #
155 # For DOS, MacOS, and VMS, we assume that all paths handed in are on the same
156 # volume.  This is not a significant limitation except for abs2rel, since the
157 # absolute path is assumed to be on the same volume as the base path.
158 #
159 sub setfstype($;) {
160    my( $osname ) = @_ ;
161
162    # Find the best match for OS and set up our atomic globals accordingly
163    if ( $osname =~ /^(?:(ms)?(dos|win(32|nt)?))/i )
164    {
165       $fstype           = 'Win32' ;
166       $sep              = '/' ;
167       $sepRE            = '[\\\\/]' ;
168       $notsepRE         = '[^\\\\/]' ;
169       $volumeRE         = '(?:^(?:[a-zA-Z]:|(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\
170 \\/]+)?)' ;
171       $directoryRE      = '(?:(?:.*[\\\\/](?:\.\.?$)?)?)' ;
172       $isrootRE         = '(?:^[\\\\/])' ;
173       $thisDir          = '.' ;
174       $thisDirRE        = '\.' ;
175       $parentDir        = '..' ;
176       $parentDirRE      = '(?:\.\.)' ;
177       $casesensitive    = 0 ;
178       $idempotent       = 1 ;
179    }
180    elsif ( $osname =~ /^MacOS$/i )
181    {
182       $fstype           = 'MacOS' ;
183       $sep              = ':' ;
184       $sepRE            = '\:' ;
185       $notsepRE         = '[^:]' ;
186       $volumeRE         = '(?:^(?:.*::)?)' ;
187       $directoryRE      = '(?:(?:.*:)?)' ;
188       $isrootRE         = '(?:^:)' ;
189       $thisDir          = '.' ;
190       $thisDirRE        = '\.' ;
191       $parentDir        = '..' ;
192       $parentDirRE      = '(?:\.\.)' ;
193       $casesensitive    = 0 ;
194       $idempotent       = 1 ;
195    }
196    elsif ( $osname =~ /^VMS$/i )
197    {
198       $fstype           = 'VMS' ;
199       $sep              = '.' ;
200       $sepRE            = '[\.\]]' ;
201       $notsepRE         = '[^\.\]]' ;
202       # volume is node::volume:, where node:: and volume: are optional
203       # and node:: cannot be present without volume.  node can include
204       # an access control string in double quotes.
205       # Not supported:
206       #     quoted full node names
207       #     embedding a double quote in a string ("" to put " in)
208       #     support ':' in node names
209       #     foreign file specifications
210       #     task specifications
211       #     UIC Directory format (use the 6 digit name for it, instead)
212       $volumeRE         = '(?:^(?:(?:[\w\$-]+(?:"[^"]*")?::)?[\w\$-]+:)?)' ;
213       $directoryRE      = '(?:(?:\[.*\])?)' ;
214
215       # Root is the lack of a leading '.', unless string is empty, which
216       # means 'cwd', which is relative.
217       $isrootRE         = '(?:^[^\.])' ;
218       $thisDir          = '' ;
219       $thisDirRE        = '\[\]' ;
220       $parentDir        = '-' ;
221       $parentDirRE      = '-' ;
222       $casesensitive    = 0 ;
223       $idempotent       = 0 ;
224    }
225    elsif ( $osname =~ /^URL$/i )
226    {
227       # URL spec based on RFC2396 (ftp://ftp.isi.edu/in-notes/rfc2396.txt)
228       $fstype           = 'URL' ;
229       $sep              = '/' ;
230       $sepRE            = '/' ;
231       $notsepRE         = '[^/]' ;
232       # Volume= scheme + authority, both optional
233       $volumeRE         = '(?:^(?:[a-zA-Z][a-zA-Z0-9+-.]*:)?(?://[^/?]*)?)' ;
234
235       # Directories do _not_ include the query component: we pretend that
236       # anything after a "?" is the filename or part of it.  So a '/'
237       # terminates and is part of the directory spec, while a '?' or '#'
238       # terminate and are not part of the directory spec.
239       #
240       # We pretend that ";param" syntax does not exist
241       #
242       $directoryRE      = '(?:(?:[^?#]*/(?:\.\.?(?:$|(?=[?#])))?)?)' ;
243       $isrootRE         = '(?:^/)' ;
244       $thisDir          = '.' ;
245       $thisDirRE        = '\.' ;
246       $parentDir        = '..' ;
247       $parentDirRE      = '(?:\.\.)' ;
248       # Assume case sensitive, since many (most?) are.  The user can override
249       # this if they so desire.
250       $casesensitive    = 1 ;
251       $idempotent       = 1 ;
252    }
253    else
254    {
255       $fstype           = 'Unix' ;
256       $sep              = '/' ;
257       $sepRE            = '/' ;
258       $notsepRE         = '[^/]' ;
259       $volumeRE         = '' ;
260       $directoryRE      = '(?:(?:.*/(?:\.\.?$)?)?)' ;
261       $isrootRE         = '(?:^/)' ;
262       $thisDir          = '.' ;
263       $thisDirRE        = '\.' ;
264       $parentDir        = '..' ;
265       $parentDirRE      = '(?:\.\.)' ;
266       $casesensitive    = 1 ;
267       $idempotent       = 1 ;
268    }
269
270    # Now set our composite regexps.
271
272    # Maintain old name for backward compatibility
273    $SL= $sep ;
274
275    # Build lots of REs used below, so they don't need to be built every time
276    # the routines that use them are called.
277    $basenamesplitRE   = '^(.*)' . $sepRE . '(' . $notsepRE . '*)$' ;
278
279    $leading_parentRE  = '(' . $isrootRE . '?)(?:' . $parentDirRE . $sepRE . ')
280 (?:' . $parentDirRE . '$)?' ;
281    $trailing_sepRE    = '(.)' . $sepRE . $thisDirRE . '?$' ;
282
283    $beginning_of_name = '(?:^|' . $isrootRE . '|' . $sepRE . ')' ;
284
285    $dot_sep_etcRE     =
286       '(' . $beginning_of_name . ')(?:' . $thisDirRE . $sepRE . ')+';
287
288    $name_sep_parentRE =
289       '(' . $beginning_of_name . ')'
290       . '(?!(?:' . $thisDirRE . '|' . $parentDirRE . ')' . $sepRE . ')'
291       . $notsepRE . '+'
292       . $sepRE . $parentDirRE
293       . '(?:' . $sepRE . '|$)'
294       ;
295
296    if ( $verbose ) {
297       print( <<TOHERE )  ;
298 fstype        = "$fstype"
299 sep           = "$sep"
300 sepRE         = /$sepRE/
301 notsepRE      = /$notsepRE/
302 volumeRE      = /$volumeRE/
303 directoryRE   = /$directoryRE/
304 isrootRE      = /$isrootRE/
305 thisDir       = "$thisDir"
306 thisDirRE     = /$thisDirRE/
307 parentDir     = "$parentDir"
308 parentDirRE   = /$parentDirRE/
309 casesensitive = "$casesensitive"
310 TOHERE
311    }
312
313    return $fstype ;
314 }
315
316
317 setfstype( $^O ) ;
318
319
320 #
321 # splitpath: Splits a path into component parts: volume, dirpath, and filename
322
323 #
324 #           Very much like File::Basename::fileparse(), but doesn't concern
325 #           itself with extensions and knows about volume names.
326 #
327 #           Returns ($volume, $directory, $filename ).
328 #
329 #           The contents of the returned list varies by operating system.
330 #
331 #           Unix:
332 #              $volume: always ''
333 #              $directory: up to, and including, final '/'
334 #              $filename: after final '/'
335 #
336 #           Win32:
337 #              $volume: drive letter and ':', if present
338 #              $directory and $filename are like on Unix, but '\' and '/' are
339 #              equivalent and the $volume is not in $directory..
340 #
341 #           VMS:
342 #              $volume: up to and including first ":"
343 #              $directory: "[...]" component
344 #              $filename: the rest.
345 #              $nofile is ignored
346 #
347 #           URL:
348 #              $volume: up to ':', then '//stuff/morestuff'.  No trailing '/'.
349 #              $directory: after $volume, up to last '/'
350 #              $filename: the rest.
351 #              $nofile is ignored
352 #
353 # Interface:
354 #       i)     $path
355 #       i)     $nofile: if true, then any trailing filename is assumed to
356 #              belong to the directory for non-VMS systems.
357 #       r)     list of ( $volume, $directory, $filename ).
358 #
359 sub splitpath {
360    my( $path, $nofile )= @_ ;
361    my( $volume, $directory, $file ) ;
362    if ( $fstype ne 'VMS' && $fstype ne 'URL' && $nofile ) {
363       $path =~ m/($volumeRE)(.*)$/ ;
364       $volume   = $1 ;
365       $directory= $2 ;
366       $file     = '' ;
367    }
368    else {
369       $path =~ m/($volumeRE)($directoryRE)(.*)$/ ;
370       $volume   = $1 ;
371       $directory= $2 ;
372       $file     = $3 ;
373    }
374
375    # For Win32 UNC, force the directory portion to be non-empty. This is
376    # because all UNC names are absolute, even if there's no trailing separator
377    # after the sharename.
378    #
379    # This is a bit of a hack, necesitated by the implementation of $isrootRE,
380    # which is only applied to the directory portion.
381    #
382    # A better long term solution might be to make the isroot test a member
383    # function in the future, object-oriented version of this.
384    #
385    $directory = $1
386      if ( $fstype eq 'Win32' && $volume =~ /^($sepRE)$sepRE/ && $directory eq
387 ' ) ;
388
389    return ( $volume, $directory, $file ) ;
390 }
391
392
393 #
394 # joinpath: joins the results of splitpath().  Not really necessary now, but
395 # good to have:
396 #
397 #     - API completeness
398 #     - Self documenting code
399 #     - Future handling of other filesystems
400 #
401 # For instance, if you leave the ':' or the '[' and ']' out of VMS $volume
402 # and $directory strings, this patches it up.  If you leave out the '['
403 # and provide the ']', or vice versa, it is not cleaned up.  This is
404 # because it's useful to automatically insert both '[' and ']', but if you
405 # leave off only one, it's likely that there's a bug elsewhere that needs
406 # looking in to.
407 #
408 # Automatically inserts a separator between directory and filename if needed
409 # for non-VMS OSs.
410 #
411 # Automatically inserts a separator between volume and directory or file
412 # if needed for Win32 UNC names.
413 #
414 sub joinpath($;$;$;) {
415    my( $volume, $directory, $filename )= @_ ;
416
417    # Fix up delimiters for $volume and $directory as needed for various OSs
418    if ( $fstype eq 'VMS' ) {
419       $volume .= ':'
420          if ( $volume ne '' && $volume !~ m/:$/ ) ;
421
422       $directory = join( '', ( '[', $directory, ']' ) )
423          if ( $directory ne '' && $directory !~ m/^\[.*\]$/ ) ;
424    }
425    else {
426       # Add trailing separator to directory names that require it and
427       # need it.  URLs always require it if there are any directory
428       # components.
429       $directory .= $sep
430          if (  $directory ne ''
431             && ( $fstype eq 'URL' || $filename ne '' )
432             && $directory !~ m/$sepRE$/
433             ) ;
434
435       # Add trailing separator to volume for UNC and HTML volume
436       # names that lack it and need it.
437       # Note that if a URL volume is a scheme only (ends in ':'),
438       # we don't require a separator: it's a relative URL.
439       $volume .= $sep
440          if (  (  ( $fstype eq 'Win32' && $volume =~ m#^$sepRE{2}# )
441                || ( $fstype eq 'URL'   && $volume =~ m#[^:/]$#     )
442                )
443             && $volume    !~ m#$sepRE$#
444             && $directory !~ m#^$sepRE#
445             && ( $directory ne '' || $filename ne '' )
446             ) ;
447    }
448
449    return join( '', $volume, $directory, $filename ) ;
450 }
451
452
453 #
454 # splitdirs: Splits a string containing directory portion of a path
455 # in to component parts.  Preserves trailing null entries, unlike split().
456 #
457 # "a/b" should get you [ 'a', 'b' ]
458 #
459 # "a/b/" should get you [ 'a', 'b', '' ]
460 #
461 # "/a/b/" should get you [ '', 'a', 'b', '' ]
462 #
463 # "a/b" returns the same array as 'a/////b' for those OSs where
464 # the seperator is idempotent (Unix and DOS, at least, but not VMS).
465 #
466 # Interface:
467 #     i) directory path string
468 #
469 sub splitdirs($;) {
470    my( $directorypath )= @_ ;
471
472    $directorypath =~ s/^\[(.*)\]$/$1/
473       if ( $fstype eq 'VMS' ) ;
474
475    #
476    # split() likes to forget about trailing null fields, so here we
477    # check to be sure that there will not be any before handling the
478    # simple case.
479    #
480    return split( $sepRE, $directorypath )
481       if ( $directorypath !~ m/$sepRE$/ ) ;
482
483    #
484    # since there was a trailing separator, add a file name to the end, then
485    # do the split, then replace it with ''.
486    #
487    $directorypath.= "file" ;
488    my( @directories )= split( $sepRE, $directorypath ) ;
489    $directories[ $#directories ]= '' ;
490
491    return @directories ;
492 }
493
494 #
495 # joindirs: Joins an array of directory names in to a string, adding
496 # OS-specific delimiters, like '[' and ']' for VMS.
497 #
498 # Note that empty strings '' are no different then non-empty strings,
499 # but that undefined strings are skipped by this algorithm.
500 #
501 # This is done the hard way to preserve separators that are already
502 # present in any of the directory names.
503 #
504 # Could this be made faster by using a join() followed
505 # by s/($sepRE)$sepRE+/$1/g?
506 #
507 # Interface:
508 #     i) array of directory names
509 #     o) string representation of directory path
510 #
511 sub joindirs {
512    my $directory_path ;
513
514    $directory_path = shift
515       while ( ! defined( $directory_path ) && @_ ) ;
516
517    if ( ! defined( $directory_path ) ) {
518       $directory_path = '' ;
519    }
520    else {
521       local $_ ;
522
523       for ( @_ ) {
524         next if ( ! defined( $_ ) ) ;
525
526         $directory_path .= $sep
527            if ( $directory_path !~ /$sepRE$/ && ! /^$sepRE/ ) ;
528
529         $directory_path .= $_ ;
530       }
531    }
532
533    $directory_path = join( '', '[', $directory_path, ']' )
534       if ( $fstype eq 'VMS' ) ;
535
536    return $directory_path ;
537 }
538
539
540 #
541 # realpath: returns the canonicalized absolute path name
542 #
543 # Interface:
544 #       i)      $path   path
545 #       r)              resolved name on success else undef
546 #       go)     $resolved
547 #                       resolved name on success else the path name which
548 #                       caused the problem.
549 $resolved = '';
550 #
551 #       Note: this implementation is based 4.4BSD version realpath(3).
552 #
553 # TODO: Speed up by using Cwd::abs_path()?
554 #
555 sub realpath($;) {
556     ($resolved) = @_;
557     my($backdir) = cwd();
558     my($dirname, $basename, $links, $reg);
559
560     $resolved = regularize($resolved);
561 LOOP:
562     {
563         #
564         # Find the dirname and basename.
565         # Change directory to the dirname component.
566         #
567         if ($resolved =~ /$sepRE/) {
568             ($dirname, $basename) = $resolved =~ /$basenamesplitRE/ ;
569             $dirname = $sep if ( $dirname eq '' );
570             $resolved = $dirname;
571             unless (chdir($dirname)) {
572                 warn("realpath: chdir($dirname) failed: $! (in ${\cwd()}).") i
573  $verbose;
574                 chdir($backdir);
575                 return undef;
576             }
577         } else {
578             $dirname = '';
579             $basename = $resolved;
580         }
581         #
582         # If it is a symlink, read in the value and loop.
583         # If it is a directory, then change to that directory.
584         #
585         if ( $basename ne '' ) {
586             if (-l $basename) {
587                 unless ($resolved = readlink($basename)) {
588                     warn("realpath: readlink($basename) failed: $! (in ${\cwd(
589 }).") if $verbose;
590                     chdir($backdir);
591                     return undef;
592                 }
593                 $basename = '';
594                 if (++$links > $maxsymlinks) {
595                     warn("realpath: too many symbolic links: $links.") if $ver
596 ose;
597                     chdir($backdir);
598                     return undef;
599                 }
600                 redo LOOP;
601             } elsif (-d _) {
602                 unless (chdir($basename)) {
603                     warn("realpath: chdir($basename) failed: $! (in ${\cwd()})
604 ") if $verbose;
605                     chdir($backdir);
606                     return undef;
607                 }
608                 $basename = '';
609             }
610         }
611     }
612     #
613     # Get the current directory name and append the basename.
614     #
615     $resolved = cwd();
616     if ( $basename ne '' ) {
617         $resolved .= $sep if ($resolved ne $sep);
618         $resolved .= $basename
619     }
620     chdir($backdir);
621     return $resolved;
622 } # end sub realpath
623
624
625 #
626 # abs2rel: make a relative pathname from an absolute pathname
627 #
628 # Interface:
629 #       i)      $path   absolute path(needed)
630 #       i)      $base   base directory(optional)
631 #       r)              relative path of $path
632 #
633 #       Note:   abs2rel doesn't check whether the specified path exist or not.
634 #
635 sub abs2rel($;$;) {
636     my($path, $base) = @_;
637     my($reg );
638
639     my( $path_volume, $path_directory, $path_file )= splitpath( $path,'nofile'
640 ;
641     if ( $path_directory !~ /$isrootRE/ ) {
642         warn("abs2rel: nothing to do: '$path' is relative.") if $verbose;
643         return $path;
644     }
645
646     $base = cwd()
647        if ( $base eq '' ) ;
648
649     my( $base_volume, $base_directory, $base_file )= splitpath( $base,'nofile'
650 ;
651     # check for a filename, since the nofile parameter does not work for OSs
652     # like VMS that have explicit delimiters between the dir and file portions
653     warn( "abs2rel: filename '$base_file' passed in \$base" )
654        if ( $base_file ne '' && $verbose ) ;
655
656     if ( $base_directory !~ /$isrootRE/ ) {
657         # Make $base absolute
658         my( $cw_volume, $cw_directory, $dummy ) = splitpath( cwd(), 'nofile' )
659 ;
660         # maybe we should warn if $cw_volume ne $base_volume and both are not
661 '
662         $base_volume= $cw_volume
663            if ( $base_volume eq '' && $cw_volume ne '' ) ;
664         $base_directory = join( '', $cw_directory, $sep, $base_directory ) ;
665     }
666
667 #print( "[$path_directory,$base_directory]\n" ) ;
668     $path_directory = regularize( $path_directory );
669     $base_directory = regularize( $base_directory );
670 #print( "[$path_directory,$base_directory]\n" ) ;
671     # Now, remove all leading components that are the same, so 'name/a'
672     # 'name/b' become 'a' and 'b'.
673     my @pathchunks = split($sepRE, $path_directory);
674     my @basechunks = split($sepRE, $base_directory);
675
676     if ( $casesensitive )
677     {
678         while (@pathchunks && @basechunks && $pathchunks[0] eq $basechunks[0])
679 +        {
680             shift @pathchunks ;
681             shift @basechunks ;
682         }
683     }
684     else {
685         while (  @pathchunks
686               && @basechunks
687               && lc( $pathchunks[0] ) eq lc( $basechunks[0] )
688               )
689         {
690             shift @pathchunks ;
691             shift @basechunks ;
692         }
693     }
694
695     # No need to use joindirs() here, since we know that the arrays
696     # are well formed.
697     $path_directory= join( $sep, @pathchunks );
698     $base_directory= join( $sep, @basechunks );
699 #print( "[$path_directory,$base_directory]\n" ) ;
700
701     # Convert $base_directory from absolute to relative
702     if ( $fstype eq 'VMS' ) {
703         $base_directory= $sep . $base_directory
704             if ( $base_directory ne '' ) ;
705     }
706     else {
707         $base_directory=~ s/^$sepRE// ;
708     }
709
710 #print( "[$base_directory]\n" ) ;
711     # $base_directory now contains the directories the resulting relative path
712 +    # must ascend out of before it can descend to $path_directory.  So,
713     # replace all names with $parentDir
714     $base_directory =~ s/$notsepRE+/$parentDir/g ;
715 #print( "[$base_directory]\n" ) ;
716
717     # Glue the two together, using a separator if necessary, and preventing an
718     # empty result.
719     if ( $path_directory ne '' && $base_directory ne '' ) {
720         $path_directory = "$base_directory$sep$path_directory" ;
721     } else {
722         $path_directory = "$base_directory$path_directory" ;
723     }
724
725     $path_directory = regularize( $path_directory ) ;
726
727     # relative URLs should have no name in the volume, only a scheme.
728     $path_volume=~ s#/.*##
729         if ( $fstype eq 'URL' ) ;
730     return joinpath( $path_volume, $path_directory, $path_file ) ;
731 }
732
733 #
734 # rel2abs: make an absolute pathname from a relative pathname
735 #
736 # Assumes no trailing file name on $base.  Ignores it if present on an OS
737 # like $VMS.
738 #
739 # Interface:
740 #       i)      $path   relative path (needed)
741 #       i)      $base   base directory  (optional)
742 #       r)              absolute path of $path
743 #
744 #       Note:   rel2abs doesn't check if the paths exist.
745 #
746 sub rel2abs($;$;) {
747     my( $path, $base ) = @_;
748     my( $reg );
749
750     my( $path_volume, $path_directory, $path_file )= splitpath( $path, 'nofile
751  ) ;
752     if ( $path_directory =~ /$isrootRE/ ) {
753         warn( "rel2abs: nothing to do: '$path' is absolute" )
754             if $verbose;
755         return $path;
756     }
757
758     warn( "rel2abs: volume '$path_volume' passed in relative path: \$path" )
759         if ( $path_volume ne '' && $verbose ) ;
760
761     $base = cwd()
762         if ( !defined( $base ) || $base eq '' ) ;
763
764     my( $base_volume, $base_directory, $base_file )= splitpath( $base, 'nofile
765  ) ;
766     # check for a filename, since the nofile parameter does not work for OSs
767     # like VMS that have explicit delimiters between the dir and file portions
768     warn( "rel2abs: filename '$base_file' passed in \$base" )
769         if ( $base_file ne '' && $verbose ) ;
770
771     if ( $base_directory !~ /$isrootRE/ ) {
772         # Make $base absolute
773         my( $cw_volume, $cw_directory, $dummy ) = splitpath( cwd(), 'nofile' )
774 ;
775         # maybe we should warn if $cw_volume ne $base_volume and both are not
776 '
777         $base_volume= $cw_volume
778             if ( $base_volume eq '' && $cw_volume ne '' ) ;
779         $base_directory = join( '', $cw_directory, $sep, $base_directory ) ;
780     }
781
782     $path_directory = regularize( $path_directory );
783     $base_directory = regularize( $base_directory );
784
785     my $result_directory ;
786     # Avoid using a separator if either directory component is empty.
787     if ( $base_directory ne '' && $path_directory ne '' ) {
788         $result_directory= joindirs( $base_directory, $path_directory ) ;
789     }
790     else {
791         $result_directory= "$base_directory$path_directory" ;
792     }
793
794     $result_directory = regularize( $result_directory );
795
796     return joinpath( $base_volume, $result_directory, $path_file ) ;
797 }
798
799 #
800 # regularize a path.
801 #
802 #    Removes dubious and redundant information.
803 #    should only be called on directory portion on OSs
804 #    with volumes and with delimeters that separate dir names from file names,
805 #    since the separators can take on different semantics, like "\\" for UNC
806 #    under Win32, or '.' in filenames under VMS.
807 #
808 sub regularize {
809     my( $in )= $_[ 0 ] ;
810
811     # Combine idempotent separators.  Do this first so all other REs only
812     # need to match one separator. Use the first sep found instead of
813     # sepRE to preserve slashes on Win32.
814     $in =~ s/($sepRE)$sepRE+/$1/g
815         if ( $idempotent ) ;
816
817     # We do this after deleting redundant separators in order to be consistent
818
819     # If a Win32 path ended in \/, we want to be sure that the \ is returned,
820     # no the /.
821     $in =~ /($sepRE)$sepRE*$/ ;
822     my $trailing_sep = defined( $1 ) ? $1 : '' ;
823
824     # Delete all occurences of 'name/..(/|$)'.  This is done with a while
825     # loop to get rid of things like 'name1/name2/../..'. We chose the pattern
826     # name/../ as the target instead of /name/.. so as to preserve 'rootness'.
827     while ($in =~ s/$name_sep_parentRE/$1/g) {}
828
829     # Get rid of ./ in '^./' and '/./'
830     $in =~ s/$dot_sep_etcRE/$1/g ;
831
832     # Get rid of trailing '/' and '/.' unless it would leave an empty string
833     $in =~ s/$trailing_sepRE/$1/ ;
834
835     # Get rid of '../' constructs from absolute paths
836     $in =~ s/$leading_parentRE/$1/
837       if ( $in =~ /$isrootRE/ ) ;
838
839 #    # Default to current directory if it's now empty.
840 #    $in = $thisDir if $_[0] eq '' ;
841 #
842     # Restore trailing separator if it was lost. We do this to preserve
843     # the 'dir-ness' of the path: paths that ended in a separator on entry
844     # should leave with one in case the caller is using trailing slashes to
845     # indicate paths to directories.
846     $in .= $trailing_sep
847         if ( $trailing_sep ne '' && $in !~ /$sepRE$/ ) ;
848
849     return $in ;
850 }
851
852 1;
853
854 __END__
855
856 =head1 NAME
857
858 abs2rel - convert an absolute path to a relative path
859
860 rel2abs - convert a relative path to an absolute path
861
862 realpath - convert a logical path to a physical path (resolve symlinks)
863
864 splitpath - split a path in to volume, directory and filename components
865
866 joinpath - join volume, directory, and filename components to form a path
867
868 splitdirs - split directory specification in to component names
869
870 joindirs - join component names in to a directory specification
871
872 setfstype - set the file system type
873
874
875 =head1 SYNOPSIS
876
877     use File::PathConvert qw(realpath abs2rel rel2abs setfstype splitpath
878       joinpath splitdirs joindirs $resolved);
879
880     $relpath = abs2rel($abspath);
881     $abspath = abs2rel($abspath, $base);
882
883     $abspath = rel2abs($relpath);
884     $abspath = rel2abs($relpath, $base);
885
886     $path = realpath($logpath) || die "resolution stopped at $resolved";
887
888     ( $volume, $directory, $filename )= splitpath( $path ) ;
889     ( $volume, $directory, $filename )= splitpath( $path, 'nofile' ) ;
890
891     $path= joinpath( $volume, $directory, $filename ) ;
892
893     @directories= splitdirs( $directory ) ;
894     $directory= joindirs( @directories ) ;
895
896 =head1 DESCRIPTION
897
898 File::PathConvert provides functions to convert between absolute and
899 relative paths, and from logical paths to physical paths on a variety of
900 filesystems, including the URL 'filesystem'.
901
902 Paths are decomposed internally in to volume, directory, and, sometimes
903 filename portions as appropriate to the operation and filesystem, then
904 recombined.  This preserves the volume and filename portions so that they may
905 be returned, and prevents them from interfering with the path conversions.
906
907 Here are some examples of path decomposition.  A '****' in a column indicates
908 the column is not used in C<abs2rel> and C<rel2abs> functions for that
909 filesystem type.
910
911
912     FS      VOLUME                  Directory       filename
913     ======= ======================= =============== =============
914     URL     http:                   /a/b/           c?query
915             http://fubar.com        /a/b/           c?query
916             //p.d.q.com             /a/b/c/         ?query
917
918     VMS     Server::Volume:         [a.b]           c
919             Server"access spec"::   [a.b]           c
920             Volume:                 [a.b]           c
921
922     Win32   A:                      \a\b\c          ****
923             \\server\Volume         \a\b\c          ****
924             \\server\Volume         \a/b/c          ****
925
926     Unix    ****                    \a\b\c          ****
927
928     MacOS   Volume::                a:b:c           ****
929
930 Many more examples abound in the test.pl included with this module.
931
932 Only the VMS and URL filesystems indicate if the last name in a path is a
933 directory or file.  For other filesystems, all non-volume names are assumed to
934 be directory names.  For URLs, the last name in a path is assumed to be a
935 filename unless it ends in '/', '/.', or '/..'.
936
937 Other assumptions are made as well, especially MacOS and VMS. THESE MAY CHANGE
938 BASED ON PROGRAMMER FEEDBACK!
939
940 The conversion routines C<abs2rel>, C<rel2abs>, and C<realpath> are the
941 main focus of this package.  C<splitpath> and C<joinpath> are provided to
942 allow volume oriented filesystems (almost anything non-unixian, actually)
943 to be accomodated.  C<splitdirs> and C<joindirs> provide directory path
944 grammar parsing and encoding, which is especially useful for VMS.
945
946 =over 4
947
948 =item setfstype
949
950 This is called automatically on module load to set the filesystem type
951 according to $^O. The user can call this later set the filesystem type
952 manually.  If the name is not recognized, unix defaults are used.  Names
953 matching /^URL$/i, /^VMS$/i, /^MacOS$/i, or /^(ms)?(win|dos)/32|nt)?$/i yield
954 the appropriate (hopefully) filesystem settings.  These strings may be
955 generalized in the future.
956
957 Examples:
958
959     File::PathConvert::setfstype( 'url' ) ;
960     File::PathConvert::setfstype( 'Win32' ) ;
961     File::PathConvert::setfstype( 'HAL9000' ) ; # Results in Unix default
962
963 =item abs2rel
964
965 C<abs2rel> converts an absolute path name to a relative path:
966 converting /1/2/3/a/b/c relative to /1/2/3 returns a/b/c
967
968     $relpath= abs2rel( $abspath ) ;
969     $relpath= abs2rel( $abspath, $base ) ;
970
971 If $abspath is already relative, it is returned unchanged.  Otherwise the
972 relative path from $base to $abspath is returned.  If $base is undefined the
973 current directory is used.
974
975 The volume and filename portions of $base are ignored if present.
976 If $abspath and $base are on different volumes, the volume from $abspath is
977 used.
978
979 No filesystem calls are made except for getting the current working directory
980 if $base is undefined, so symbolic links are not checked for or resolved, and
981 no check is done for existance.
982
983 Examples
984
985     # Unix
986     'a/b/c' == abs2rel( 'a/b/c', $anything )
987     'a/b/c' == abs2rel( '/1/2/3/a/b/c', '/1/2/3' )
988
989     # DOS
990     'a\\b/c' == abs2rel( 'a\\b/c', $anything )
991     'a\\b/c' == abs2rel( '/1\\2/3/a\\b/c', '/1/2/3' )
992
993     # URL
994     'http:a/b/c'           == abs2rel( 'http:a/b/c', $anything )
995     'http:a/b/c'           == abs2rel( 'http:/1/2/3/a/b/c',
996                                        'ftp://t.org/1/2/3/?z' )
997     'http:a/b/c?q'         == abs2rel( 'http:/1/2/3/a/b/c/?q',
998                                        'ftp://t.org/1/2/3?z'  )
999     'http://s.com/a/b/c?q' == abs2rel( 'http://s.com/1/2/3/a/b/c?q',
1000                                        'ftp://t.org/1/2/3/?z')
1001
1002 =item rel2abs
1003
1004 C<rel2abs> makes converts a relative path name to an absolute path:
1005 converting a/b/c relative to /1/2/3 returns /1/2/3/a/b/c.
1006
1007     $abspath= rel2abs( $relpath ) ;
1008     $abspath= rel2abs( $relpath, $base ) ;
1009
1010 If $relpath is already absolute, it is returned unchanged.  Otherwise $relpath
1011 is taken to be relative to $base and the resulting absolute path is returned.
1012 If $base is not supplied, the current working directory is used.
1013
1014 The volume portion of $relpath is ignored.  The filename portion of $base is
1015 also ignored. The volume from $base is returned if present. The filename
1016 portion of $abspath is returned if present.
1017
1018 No filesystem calls are made except for getting the current working directory
1019 if $base is undefined, so symbolic links are not checked for or resolved, and
1020 no check is done for existance.
1021
1022 C<rel2abs> will not return a path of the form "./file".
1023
1024 Examples
1025
1026     # Unix
1027     '/a/b/c'       == rel2abs( '/a/b/c', $anything )
1028     '/1/2/3/a/b/c' == rel2abs( 'a/b/c', '/1/2/3' )
1029
1030     # DOS
1031     '\\a\\b/c'                == rel2abs( '\\a\\b/c', $anything )
1032     '/1\\2/3\\a\\b/c'         == rel2abs( 'a\\b/c', '/1\\2/3' )
1033     'C:/1\\2/3\\a\\b/c'       == rel2abs( 'D:a\\b/c', 'C:/1\\2/3' )
1034     '\\\\s\\v/1\\2/3\\a\\b/c' == rel2abs( 'D:a\\b/c', '\\\\s\\v/1\\2/3' )
1035
1036     # URL
1037     'http:/a/b/c?q'            == rel2abs( 'http:/a/b/c?q', $anything )
1038     'ftp://t.org/1/2/3/a/b/c?q'== rel2abs( 'http:a/b/c?q',
1039                                            'ftp://t.org/1/2/3?z' )
1040
1041
1042 =item realpath
1043
1044 C<realpath> makes a canonicalized absolute pathname and
1045 resolves all symbolic links, extra ``/'' characters, and references
1046 to /./ and /../ in the path.
1047 C<realpath> resolves both absolute and relative paths.
1048 It returns the resolved name on success, otherwise it returns undef
1049 and sets the valiable C<$File::PathConvert::resolved> to the pathname
1050 that caused the problem.
1051
1052 All but the last component of the path must exist.
1053
1054 This implementation is based on 4.4BSD realpath(3).  It is not tested under
1055 other operating systems at this time.
1056
1057 If '/sys' is a symbolic link to '/usr/src/sys':
1058
1059     chdir('/usr');
1060     '/usr/src/sys/kern' == realpath('../sys/kern');
1061     '/usr/src/sys/kern' == realpath('/sys/kern');
1062
1063 =item splitpath
1064
1065 To be written...
1066
1067 =item joinpath
1068
1069 To be written...
1070
1071 Note that joinpath( splitpath( $path ) ) usually yields path.  URLs
1072 with directory components ending in '/.' or '/..' will be fixed
1073 up to end in '/./' and '/../'.
1074
1075 =item splitdirs
1076
1077 To be written...
1078
1079 =item joindirs
1080
1081
1082 =back
1083
1084 =head1 BUGS
1085
1086 C<realpath> is not fully multiplatform.
1087
1088
1089 =head1 LIMITATIONS
1090
1091 =over 4
1092
1093 =item *
1094
1095 In URLs, paths not ending in '/' are split such that the last name in the
1096 path is a filename.  This is not intuitive: many people use such URLs for
1097 directories, and most servers send a redirect.  This may cause programers
1098 using this package to code in bugs, it may be more pragmatic to always assume
1099 all names are directory names.  (Note that the query portion is always part
1100 of the filename).
1101
1102 =item *
1103
1104 If the relative and base paths are on different volumes, no error is
1105 returned.  A silent, hopefully reasonable assumption is made.
1106
1107 =item *
1108
1109 No detection of unix style paths is done when other filesystems are
1110 selected, like File::Basename does.
1111
1112 =back
1113
1114 =head1 AUTHORS
1115
1116 Barrie Slaymaker <rbs@telerama.com>
1117 Shigio Yamaguchi <shigio@wafu.netgate.net>
1118
1119 =cut