#!/usr/bin/env perl

# Copyright (c) 2006, Eric Breck
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
# 1 Redistributions of source code must retain the above copyright notice, this
#   list of conditions and the following disclaimer.
#
# 2 Redistributions in binary form must reproduce the above copyright notice,
#   this list of conditions and the following disclaimer in the documentation
#   and/or other materials provided with the distribution.
#
# 3 The name of the author may not be used to endorse or promote products
#   derived from this software without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
# DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
# OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

=head1 NAME

whereami - discern true location

=head1 DESCRIPTION

This program follows chains of softlinks, and looks at the mount table,
to figure out, in a UNIX filesystem, where the current directory really is.
(i.e. what filesystem it's mounted on and the relative path to the root of
that filesystem).

$Revision: 1.4 $

=cut


use strict;

my @dirs = ();

# expand symbolic links
for (my $pwd=$ENV{PWD};$pwd;) {
  if (-l $pwd) {             
    my $nwd = readlink $pwd; # it's a link, read through it
    if ($nwd!~ m{^/}) {      # handle relative links
      $pwd=~s{/[^/]*$}{/};   # remove last component
      $nwd=$pwd.$nwd;
    }
    $nwd =~ s{/\./}{/}g;     # remove redundant . ' ... dir1/./dir2 ... '
    $nwd =~ s{/\.$}{}g;      # remove redundant . ' ... dir/.  '
    $nwd =~ s{/[^/]*/\.\./}{/}g; # remove ..s
    $pwd=$nwd;
  } elsif (-d $pwd) {        
    $pwd =~ s{/([^/]*)$}{};  # it's a real directory, so extract final part
    unshift @dirs,$1;
  } else {
    print STDERR "error, somehow I've ended up not in a directory (pwd=$pwd)\n";
    exit(1);
  }
}

# create a regular expression matching any prefix of the true directory.
my $endpat='/(?:' . (join '(?:/',@dirs) . (')?' x @dirs);

# call out to 'mount' to see where this directory is mounted, and what
# prefix of the true path is just a mountpoint
# FIXME: it'd be nice not to have to call out to 'mount' -- is there a syscall?
my $uname = `uname`;
my ($dev,$mountpoint,$fs);
my $mount;
if ($uname eq "CYGWIN_NT-5.0\n" or $uname eq "Linux\n") {
  $mount = `mount`;
  while ($mount =~ m{(\S+) on ($endpat) type (.*)}g) {
    if (length($2)>length($mountpoint)) {
      $dev=$1;
      $mountpoint=$2;
      $fs=$3;
    }
  }
} elsif ($uname eq "SunOS\n") {
  # note path on dev is reversed SunOS vs. Linux
  $mount = `/sbin/mount`;
  while ($mount =~ m{($endpat) on (\S+) (\S+)}g) {
    if (length($1)>length($mountpoint)) {
      $dev=$2;
      $mountpoint=$1;
      $fs=$3;
    }
  }
} elsif ($uname eq "Darwin\n") {
  # note path on dev is reversed SunOS vs. Linux
  $mount = `/sbin/mount`;
  while ($mount =~ m{(.*) on ($endpat) \(([^)]+)\)}gm) {
    if (length($2)>length($mountpoint)) {
      $dev=$1;
      $mountpoint=$2;
      $fs=$3;
    }
  }
}

my $truedir =  '/'.(join '/',@dirs);
# remove the mountpoint from the path
(my $path = $truedir) =~ s{^$mountpoint}{};

print "\n";
print "apparent directory:  $ENV{PWD}\n";
print "true directory:      $truedir\n";
print "filesystem:          $fs\n";
print "device:              $dev\n";
print "path:                $path\n";
print "\n";