# GrindTree.pm -- invoke a function for every file in a directory tree
# Author: Noah Friedman <friedman@splode.com>
# Created: 1995-11-09
# Public domain.

# $Id: GrindTree.pm,v 1.4 2000/01/17 03:51:47 friedman Exp $

# Commentary:
# Code:

package NF::GrindTree;
use Symbol;
use Cwd;

use strict;

use Exporter ();
use vars qw($VERSION @ISA @EXPORT);
$VERSION     = 1.00;
@ISA         = qw(Exporter);
@EXPORT      = qw(grind_over_tree
                  expand_file_name
                  mkdirhier
                  dereference_symlinks);

sub grind_over_tree ($$;$)
{
  my $dir = shift;
  my $fn  = shift;
  my $fn_on_dirs = shift;

  return &$fn ($dir) if (-f $dir);

  my $dfh = gensym;
  if (!opendir ($dfh, $dir))
    {
      print STDERR "opendir: ", $dir, ": ", $!, ".\n";
      return undef;
    }
  my @files = sort grep (!/^\.\.?$/o, readdir ($dfh));
  closedir ($dfh);

  for my $ent (@files)
    {
      my $file = join ("/", $dir, $ent);
      my $dirp = -d $file;
      &$fn ($file) if (!$dirp || $fn_on_dirs);
      grind_over_tree ($file, $fn, $fn_on_dirs) if ($dirp);
    }
  return undef;
}

# Args: basename, default-directory
#
# Convert basename to absolute, and canonicalize it.  Second arg
# default-directory is directory to start with if basename is relative
# (does not start with slash); if default-directory is undefined, the
# current working directory is used.  File name components that are `.' are
# removed, and so are file name components followed by `..', along with the
# `..' itself; note that these simplifications are done without checking
# that the file name actually exists in the file system.
sub expand_file_name ($;$)
{
  local $_ = shift;

  $_ = join ('/', (shift || getcwd ()), $_) if ($_ !~ m|^/|o);

  # These substitutions must be done in loops to handle overlapping `/'
  # characters in adjacent patterns.
  s|/\./|/|o         while (m|/\./|o);
  s|//|/|o           while (m|//|o);
  s|/[^/]+/\.\./|/|o while (m|/[^/]+/\.\./|o);
  s|/[^/]+/\.\.$||o;
  s|/.$||go;
  # Eliminate leading `..'.
  # It may be harmful to do it if the filesystem interprets `/..' as
  # something not equivalent to `/'.
  #s|^/\.\./|/|o     while (m|^/\.\./|o);
  return $_;
}

sub dereference_symlinks ($)
{
  my $file = shift;
  my @p = split (m|/|, $file);
  my $link_count = 0;
  for (my $j = 0; $j <= $#p; $j++)
    {
      my $k = join ("/", @p[0 .. $j]);
      my $orig_component = $k;
      while (my $l = readlink ($k))
        {
          $k = $l;
          # Simple way of detecting symlink loops (it unfortunately causes
          # the system to give up when there are simply too many levels,
          # even if resolution would eventually occur).  This parameter is
          # adjustable, of course.  Most unix kernels allow a depth of 8.
          if ($link_count++ == 64)
            {
              print STDERR "$0: $file: Too many levels of symbolic links\n";
              return undef;
            }
        }
      next if ($k eq $orig_component);
      if (substr ($k, 0, 1) eq "/")
        {
          # Absolute link.  Trash $p[0]-$p[$j+1] and replace with readlinked
          # path components.  Set $j to -1 so that next iteration of loop
          # will check array @p from start.
          splice (@p, 0, $j + 1, split (m|/|, $k));
          $j = -1;
        }
      else
        {
          # Insert partial (relative) path component into array in place of
          # current element $p[$j]
          splice (@p, $j, 1, split (m|/|, $k));
          $j--;
        }
    }
  join ("/", @p);
}

sub mkdirhier ($)
{
  my @full = split (/\//, shift);
  my $name = "";

  if ($full[0] eq '')
    {
      shift @full;
      $full[0] = "/" . $full[0];
    }

  while ($#full >= 0)
    {
      $name .= shift @full;
      mkdir ($name, 0777) unless (-d $name);
      if ($! != 0)
        {
          print STDERR "mkdirhier: $name: $! (errno=", ($!+0), ")\n";
          return 0;
        }
      $name .= "/";
    }
  return 1;
}

1;