File Coverage

RelDir.pm

Criterion	Covered	Total	%
statement	58	65	89.2
branch	26	30	86.6
condition	2	2	100.0
subroutine	8	8	100.0
pod	4	4	100.0
total	98	109	89.9

#
#===============================================================================
#
#         FILE:  RelDir.pm
#
#  DESCRIPTION:  This module provides a mechanism to determine the relative
#                path between two directory names.
#
#        FILES:  ---
#         BUGS:  ---
#        NOTES:  ---
#       AUTHOR:   (Dave Roberts),
#      COMPANY:
#      VERSION:  1.0
#      CREATED:  15/04/2010 20:30:39 GMT
#     REVISION:  $Revision: 1.0 $
#===============================================================================

use strict;
use warnings;
package File::RelDir;
use Carp;
require Exporter;

our @ISA = qw(Exporter);
our %EXPORT_TAGS = ( 'all' => [ qw( ) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw(

);

our $VERSION = "0.1";
sub Version {
return $VERSION;
}

sub New {
  if ($#_ != 1){
     printf "_  %s\n",$#_;
     carp "Usage: File::Repl->New(\$dir)";
  }
  my $class = shift;
  my($r);
  $r->{dira} = $_[0];
  ($r->{patha},$r->{w32a})=&_dc($r->{dira});
  bless  $r, $class;
  return $r;
}

sub _dc {   # Directory Check - sanity check the directory name
	my($dir) = @_;
	my($c) = $dir =~ s/\\/\//g;  # use forward slash as directory seperator
        if ($c>0){
		return $dir,1;   # return win32 status if \ directory seperators
	}elsif ($dir =~ m/^[a-z]{1}:/){
		return $dir,2;   # return win32 status if drive letter leads path
	}else{
		return $dir,0;
	}
	carp "sub _dc failed";
}

sub Path {
    my($r,$dirb,$w);
  if ( scalar(@_) eq 2 ) {
    ($r,$dirb) =@_;
}else{
     carp "Usage: \$ref->Path(\$dir)";
}
  $r->{dirb} = $dirb;
  ($r->{pathb},$r->{w32b})=&_dc($r->{dirb});
  # Set windows flag - drives case insensitive testing
  $w = $r->{w32a} || $r->{w32b} || 0;

# split both paths by dir seperators
   my(@dira,@dirb,$i,$j,$relpath);
   @dira = split(/\//,$r->{patha});
   @dirb = split(/\//,$r->{pathb});
   unless( $dira[0] eq $dirb[0] ){
	my($err) = "different file systems or not absolute paths";
	# for unix these values will be null ("")
	# for win32 a drive letter (need to deal with case differences here
	#if ( $dira[0] =~ m/^[a-z]{1}:$/i ){  # test logic for a drive letter
	if ( $dira[0] =~ m/^[a-z]{1}:$/i ){  # test logic for a drive letter
	   unless (lc($dira[0]) eq lc($dirb[0])){
		   carp $err;
		   return 0;
	   }
	}else{
	   carp $err;
		   return 0;
        }
}
my($min) = $#dira;
$min = $#dirb if ($#dirb < $min);
$j=-1;

for($i=0;$i<=$min;$i++){
	if (($w == 0) & ($dira[$i] eq $dirb[$i])){
		#	print "segment $i identical ( $dira[$i] eq $dirb[$i] )\n";
		$j=$i;
	}elsif (($w >= 1) & (lc($dira[$i]) eq lc($dirb[$i]))){
		#	print "segment $i identical ( $dira[$i] eq $dirb[$i] )\n";
		$j=$i;
	}else{
		#print "segment $i differ\n";
		last;
	}
}
if ($j >= 0){
  $i = $#dira - $j;
    $relpath = "." if ($i == 0);
    $relpath = sprintf "../" x $i unless ($i == 0);
    for ($i=$j+1;$i<=$#dirb;$i++){
      $relpath .= "/" unless ($relpath =~ m/\/$/);
      $relpath .= $dirb[$i];
    }

}else{
   carp "different file systems or not absolute paths";
}
$relpath =~ s/\//\\/g if ($r->{w32a} == 1);
return $relpath;

}

sub Diff ($$) {
# provide a relartive pathname from direcrtory a to directory b
  my ($dira, $dirb) = @_;
  my($ref)=File::RelDir->New($dira);
  return $ref->Path($dirb);
  }
1;

__END__