#!/usr/bin/perl -w

eval 'exec /usr/bin/perl -w -S $0 ${1+"$@"}'
    if 0; # not running under some shell
#========================================================================
#
# ttree
#
# DESCRIPTION
#   Script for processing all directory trees containing templates.
#   Template files are processed and the output directed to the 
#   relvant file in an output tree.  The timestamps of the source and
#   destination files can then be examined for future invocations 
#   to process only those files that have changed.  In other words,
#   it's a lot like 'make' for templates.
#
# AUTHOR
#   Andy Wardley   <abw@wardley.org>
#
# COPYRIGHT
#   Copyright (C) 1996-2003 Andy Wardley.  All Rights Reserved.
#   Copyright (C) 1998-2003 Canon Research Centre Europe Ltd.
#
#   This module is free software; you can redistribute it and/or
#   modify it under the same terms as Perl itself.
#
#------------------------------------------------------------------------
#
# $Id$
#
#========================================================================

use strict;
use Template;
use AppConfig qw( :expand );
use File::Copy;
use File::Path;
use File::Spec;
use File::Basename;
use Text::ParseWords qw(quotewords);

my $NAME     = "ttree";
my $VERSION  = 2.90;
my $HOME     = $ENV{ HOME } || '';
my $RCFILE   = $ENV{"\U${NAME}rc"} || "$HOME/.${NAME}rc";
my $TTMODULE = 'Template';

#------------------------------------------------------------------------
# configuration options
#------------------------------------------------------------------------

# offer create a sample config file if it doesn't exist, unless a '-f'
# has been specified on the command line
unless (-f $RCFILE or grep(/^(-f|-h|--help)$/, @ARGV) ) {
    print("Do you want me to create a sample '.ttreerc' file for you?\n",
      "(file: $RCFILE)   [y/n]: ");
    my $y = <STDIN>;
    if ($y =~ /^y(es)?/i) {
        write_config($RCFILE);
        exit(0);
    }
}

# read configuration file and command line arguments - I need to remember 
# to fix varlist() and varhash() in AppConfig to make this nicer...
my $config   = read_config($RCFILE);
my $dryrun   = $config->nothing;
my $verbose  = $config->verbose || $dryrun;
my $colour   = $config->colour;
my $summary  = $config->summary;
my $recurse  = $config->recurse;
my $preserve = $config->preserve;
my $all      = $config->all;
my $libdir   = $config->lib;
my $ignore   = $config->ignore;
my $copy     = $config->copy;
my $accept   = $config->accept;
my $absolute = $config->absolute;
my $relative = $config->relative;
my $suffix   = $config->suffix;
my $binmode  = $config->binmode;
my $depends  = $config->depend;
my $depsfile = $config->depend_file;
my ($n_proc, $n_unmod, $n_skip, $n_copy, $n_mkdir) = (0) x 5;

my $srcdir   = $config->src
    || die "Source directory not set (-s)\n";
my $destdir  = $config->dest
    || die "Destination directory not set (-d)\n";
die "Source and destination directories may not be the same:\n  $srcdir\n"
    if $srcdir eq $destdir;

# unshift any perl5lib directories onto front of INC
unshift(@INC, @{ $config->perl5lib });

# get all template_* options from the config and fold keys to UPPER CASE
my %ttopts   = $config->varlist('^template_', 1);
my $ttmodule = delete($ttopts{ module });
my $ucttopts = {
    map { my $v = $ttopts{ $_ }; defined $v ? (uc $_, $v) : () }
    keys %ttopts,
};

# get all template variable definitions
my $replace = $config->get('define');

# now create complete parameter hash for creating template processor
my $ttopts   = {
    %$ucttopts,
    RELATIVE     => $relative,
    ABSOLUTE     => $absolute,
    INCLUDE_PATH => [ $srcdir, @$libdir ],
    OUTPUT_PATH  => $destdir,
};

# load custom template module 
if ($ttmodule) {
    my $ttpkg = $ttmodule;
    $ttpkg =~ s[::][/]g;
    $ttpkg .= '.pm';
    require $ttpkg;
}
else {
    $ttmodule = $TTMODULE;
}


#------------------------------------------------------------------------
# inter-file dependencies
#------------------------------------------------------------------------

if ($depsfile or $depends) {
    $depends = dependencies($depsfile, $depends);
} 
else {
    $depends = { };
}

my $global_deps = $depends->{'*'} || [ ];

# add any PRE_PROCESS, etc., templates as global dependencies
foreach my $ttopt (qw( PRE_PROCESS POST_PROCESS PROCESS WRAPPER )) {
    my $deps = $ucttopts->{ $ttopt } || next;
    my @deps = ref $deps eq 'ARRAY' ? (@$deps) : ($deps);
    next unless @deps;
    push(@$global_deps, @deps);
}

# remove any duplicates
$global_deps = { map { ($_ => 1) } @$global_deps };
$global_deps = [ keys %$global_deps ];

# update $depends hash or delete it if there are no dependencies
if (@$global_deps) {
    $depends->{'*'} = $global_deps;
}
else {
    delete $depends->{'*'};
    $global_deps = undef;
}
$depends = undef
    unless keys %$depends;

my $DEP_DEBUG = $config->depend_debug();


#------------------------------------------------------------------------
# pre-amble
#------------------------------------------------------------------------

if ($colour) {
    no strict 'refs';
    *red    = \&_red;
    *green  = \&_green;
    *yellow = \&_yellow;
    *blue   = \&_blue;
}
else {
    no strict 'refs';
    *red    = \&_white;
    *green  = \&_white;
    *yellow = \&_white;
    *blue   = \&_white;
}

if ($verbose) {
    local $" = ', ';


    print "$NAME $VERSION (Template Toolkit version $Template::VERSION)\n\n";

    my $sfx = join(', ', map { "$_ => $suffix->{$_}" } keys %$suffix);

    print("      Source: $srcdir\n",
          " Destination: $destdir\n",
          "Include Path: [ @$libdir ]\n",
          "      Ignore: [ @$ignore ]\n",
          "        Copy: [ @$copy ]\n",
          "      Accept: [ @$accept ]\n",
          "      Suffix: [ $sfx ]\n");
    print("      Module: $ttmodule ", $ttmodule->module_version(), "\n")
        unless $ttmodule eq $TTMODULE;

    if ($depends && $DEP_DEBUG) {
        print "Dependencies:\n";
        foreach my $key ('*', grep { !/\*/ } keys %$depends) {
            printf( "    %-16s %s\n", $key, 
                    join(', ', @{ $depends->{ $key } }) ) 
                if defined $depends->{ $key };

        }
    }
    print "\n" if $verbose > 1;
    print red("NOTE: dry run, doing nothing...\n")
        if $dryrun;
}

#------------------------------------------------------------------------
# main processing loop
#------------------------------------------------------------------------

my $template = $ttmodule->new($ttopts)
    || die $ttmodule->error();

if (@ARGV) {
    # explicitly process files specified on command lines 
    foreach my $file (@ARGV) {
        my $path = $srcdir ? File::Spec->catfile($srcdir, $file) : $file;
        if ( -d $path ) {
            process_tree($file);
        }
        else {
            process_file($file, $path, force => 1);
        }
    }
}
else {
    # implicitly process all file in source directory
    process_tree();
}

if ($summary || $verbose) {
    my $format  = "%13d %s %s\n";
    print "\n" if $verbose > 1;
    print(
        "     Summary: ",
        $dryrun ? red("This was a dry run.  Nothing was actually done\n") : "\n",
        green(sprintf($format, $n_proc,  $n_proc  == 1 ? 'file' : 'files', 'processed')),
        green(sprintf($format, $n_copy,  $n_copy  == 1 ? 'file' : 'files', 'copied')),
        green(sprintf($format, $n_mkdir, $n_mkdir == 1 ? 'directory' : 'directories', 'created')),
        yellow(sprintf($format, $n_unmod, $n_unmod == 1 ? 'file' : 'files', 'skipped (not modified)')),
        yellow(sprintf($format, $n_skip,  $n_skip  == 1 ? 'file' : 'files', 'skipped (ignored)'))
    );
}

exit(0);


#========================================================================
# END 
#========================================================================


#------------------------------------------------------------------------
# process_tree($dir)
#
# Walks the directory tree starting at $dir or the current directory
# if unspecified, processing files as found.
#------------------------------------------------------------------------

sub process_tree {
    my $dir = shift;
    my ($file, $path, $abspath, $check);
    my $target;
    local *DIR;

    my $absdir = join('/', $srcdir ? $srcdir : (), defined $dir ? $dir : ());
    $absdir ||= '.';

    opendir(DIR, $absdir) || do { warn "$absdir: $!\n"; return undef; };

    FILE: while (defined ($file = readdir(DIR))) {
        next if $file eq '.' || $file eq '..';
        $path = defined $dir ? "$dir/$file" : $file;
        $abspath = "$absdir/$file";
        
        next unless -e $abspath;

        # check against ignore list
        foreach $check (@$ignore) {
            if ($path =~ /$check/) {
                printf yellow("  - %-32s (ignored, matches /$check/)\n"), $path
                    if $verbose > 1;
                $n_skip++;
                next FILE;
            }
        }

        # check against acceptance list
        if (@$accept) {
            unless ((-d $abspath && $recurse) || grep { $path =~ /$_/ } @$accept) {
                printf yellow("  - %-32s (not accepted)\n"), $path
                    if $verbose > 1;
                $n_skip++;
                next FILE;
            }
        }

        if (-d $abspath) {
            if ($recurse) {
                my ($uid, $gid, $mode);
                
                (undef, undef, $mode, undef, $uid, $gid, undef, undef,
                 undef, undef, undef, undef, undef)  = stat($abspath);
                
                # create target directory if required
                $target = "$destdir/$path";
                unless (-d $target || $dryrun) {
                    mkpath($target, $verbose, $mode) or 
                        die red("Could not mkpath ($target): $!\n");

                    # commented out by abw on 2000/12/04 - seems to raise a warning?
                    # chown($uid, $gid, $target) || warn "chown($target): $!\n";

                    $n_mkdir++;
                    printf green("  + %-32s (created target directory)\n"), $path
                        if $verbose;
                }
                # recurse into directory
                process_tree($path);
            }
            else {
                $n_skip++;
                printf yellow("  - %-32s (directory, not recursing)\n"), $path
                    if $verbose > 1;
            }
        }
        else {
            process_file($path, $abspath);
        }
    }
    closedir(DIR);
}
    

#------------------------------------------------------------------------
# process_file()
#
# File filtering and processing sub-routine called by process_tree()
#------------------------------------------------------------------------

sub process_file {
    my ($file, $absfile, %options) = @_;
    my ($dest, $destfile, $filename, $check, 
        $srctime, $desttime, $mode, $uid, $gid);
    my ($old_suffix, $new_suffix);
    my $is_dep = 0;
    my $copy_file = 0;

    $absfile ||= $file;
    $filename = basename($file);
    $destfile = $file;
    
    # look for any relevant suffix mapping
    if (%$suffix) {
        if ($filename =~ m/\.(.+)$/) {
            $old_suffix = $1;
            if ($new_suffix = $suffix->{ $old_suffix }) {
                $destfile =~ s/$old_suffix$/$new_suffix/;
            }
        }
    }
    $dest = $destdir ? "$destdir/$destfile" : $destfile;
                   
#    print "proc $file => $dest\n";
    
    # check against copy list
    foreach my $copy_pattern (@$copy) {
        if ($filename =~ /$copy_pattern/) {
            $copy_file = 1;
            $check = $copy_pattern;
            last;
        }
    }

    # stat the source file unconditionally, so we can preserve
    # mode and ownership
    ( undef, undef, $mode, undef, $uid, $gid, undef, 
      undef, undef, $srctime, undef, undef, undef ) = stat($absfile);
    
    # test modification time of existing destination file
    if (! $all && ! $options{ force } && -f $dest) {
        $desttime = ( stat($dest) )[9];

        if (defined $depends and not $copy_file) {
            my $deptime  = depend_time($file, $depends);
            if (defined $deptime && ($srctime < $deptime)) {
                $srctime = $deptime;
                $is_dep = 1;
            }
        }
    
        if ($desttime >= $srctime) {
            printf yellow("  - %-32s (not modified)\n"), $file
                if $verbose > 1;
            $n_unmod++;
            return;
        }
    }
    
    # check against copy list
    if ($copy_file) {
        $n_copy++;
        unless ($dryrun) {
            copy($absfile, $dest) or die red("Could not copy ($absfile to $dest) : $!\n");

            if ($preserve) {
                chown($uid, $gid, $dest) || warn red("chown($dest): $!\n");
                chmod($mode, $dest) || warn red("chmod($dest): $!\n");
            }
        }

        printf green("  > %-32s (copied, matches /$check/)\n"), $file
            if $verbose;

        return;
    }

    $n_proc++;
    
    if ($verbose) {
        printf(green("  + %-32s"), $file);
        print(green(" (changed suffix to $new_suffix)")) if $new_suffix;
        print "\n";
    }

    # process file
    unless ($dryrun) {
        $template->process($file, $replace, $destfile,
            $binmode ? {binmode => $binmode} : {})
            || print(red("  ! "), $template->error(), "\n");

        if ($preserve) {
            chown($uid, $gid, $dest) || warn red("chown($dest): $!\n");
            chmod($mode, $dest) || warn red("chmod($dest): $!\n");
        }
    }
}


#------------------------------------------------------------------------
# dependencies($file, $depends)
# 
# Read the dependencies from $file, if defined, and merge in with 
# those passed in as the hash array $depends, if defined.
#------------------------------------------------------------------------

sub dependencies {
    my ($file, $depend) = @_;
    my %depends = ();

    if (defined $file) {
        my ($fh, $text, $line);
        open $fh, $file or die "Can't open $file, $!";
        local $/ = undef;
        $text = <$fh>;
        close($fh);
        $text =~ s[\\\n][]mg;
        
        foreach $line (split("\n", $text)) {
            next if $line =~ /^\s*(#|$)/;
            chomp $line;
            my ($file, @files) = quotewords('\s*:\s*', 0, $line);
            $file =~ s/^\s+//;
            @files = grep(defined, quotewords('(,|\s)\s*', 0, @files));
            $depends{$file} = \@files;
        }
    }

    if (defined $depend) {
        foreach my $key (keys %$depend) {
            $depends{$key} = [ quotewords(',', 0, $depend->{$key}) ];
        }
    }

    return \%depends;
}



#------------------------------------------------------------------------
# depend_time($file, \%depends)
#
# Returns the mtime of the most recent in @files.
#------------------------------------------------------------------------

sub depend_time {
    my ($file, $depends) = @_;
    my ($deps, $absfile, $modtime);
    my $maxtime = 0;
    my @pending = ($file);
    my @files;
    my %seen;

    # push any global dependencies onto the pending list
    if ($deps = $depends->{'*'}) {
        push(@pending, @$deps);
    }

    print "    # checking dependencies for $file...\n"
        if $DEP_DEBUG;

    # iterate through the list of pending files
    while (@pending) {
        $file = shift @pending;
        next if $seen{ $file }++;

        if (File::Spec->file_name_is_absolute($file) && -f $file) {
            $modtime = (stat($file))[9];
            print "    #   $file [$modtime]\n"
                if $DEP_DEBUG;
        }
        else {
            $modtime = 0;
            foreach my $dir ($srcdir, @$libdir) {
                $absfile = File::Spec->catfile($dir, $file);
                if (-f $absfile) {
                    $modtime = (stat($absfile))[9];
                    print "    #   $absfile [$modtime]\n"
                        if $DEP_DEBUG;
                    last;
                }
            }
        }
        $maxtime = $modtime
            if $modtime > $maxtime;

        if ($deps = $depends->{ $file }) {
            push(@pending, @$deps);
            print "    #     depends on ", join(', ', @$deps), "\n"
                if $DEP_DEBUG;
        }
    }

    return $maxtime;
}


#------------------------------------------------------------------------
# read_config($file)
#
# Handles reading of config file and/or command line arguments.
#------------------------------------------------------------------------

sub read_config {
    my $file    = shift;
    my $verbose = 0;
    my $verbinc = sub {
        my ($state, $var, $value) = @_;
        $state->{ VARIABLE }->{ verbose } = $value ? ++$verbose : --$verbose;
    };
    my $config  = AppConfig->new(
        { 
            ERROR  => sub { die(@_, "\ntry `$NAME --help'\n") }
        }, 
        'help|h'      => { ACTION => \&help },
        'src|s=s'     => { EXPAND => EXPAND_ALL },
        'dest|d=s'    => { EXPAND => EXPAND_ALL },
        'lib|l=s@'    => { EXPAND => EXPAND_ALL },
        'cfg|c=s'     => { EXPAND => EXPAND_ALL, DEFAULT => '.' },
        'verbose|v'   => { DEFAULT => 0, ACTION => $verbinc },
        'recurse|r'   => { DEFAULT => 0 },
        'nothing|n'   => { DEFAULT => 0 },
        'preserve|p'  => { DEFAULT => 0 },
        'absolute'    => { DEFAULT => 0 },
        'relative'    => { DEFAULT => 0 },
        'colour|color'=> { DEFAULT => 0 },
        'summary'     => { DEFAULT => 0 },
        'all|a'       => { DEFAULT => 0 },
        'define=s%',
        'suffix=s%',
        'binmode=s',
        'ignore=s@',
        'copy=s@',
        'accept=s@',
        'depend=s%',
        'depend_debug|depdbg',
        'depend_file|depfile=s' => { EXPAND => EXPAND_ALL },
        'template_module|module=s',
        'template_anycase|anycase',
        'template_encoding|encoding=s',
        'template_eval_perl|eval_perl',
        'template_load_perl|load_perl',
        'template_interpolate|interpolate',
        'template_pre_chomp|pre_chomp|prechomp',
        'template_post_chomp|post_chomp|postchomp',
        'template_trim|trim',
        'template_pre_process|pre_process|preprocess=s@',
        'template_post_process|post_process|postprocess=s@',
        'template_process|process=s',
        'template_wrapper|wrapper=s',
        'template_recursion|recursion',
        'template_expose_blocks|expose_blocks',
        'template_default|default=s',
        'template_error|error=s',
        'template_debug|debug=s',
        'template_start_tag|start_tag|starttag=s',
        'template_end_tag|end_tag|endtag=s',
        'template_tag_style|tag_style|tagstyle=s',
        'template_compile_ext|compile_ext=s',
        'template_compile_dir|compile_dir=s' => { EXPAND => EXPAND_ALL },
        'template_plugin_base|plugin_base|pluginbase=s@' => { EXPAND => EXPAND_ALL },
        'perl5lib|perllib=s@' => { EXPAND => EXPAND_ALL },
    );

    # add the 'file' option now that we have a $config object that we 
    # can reference in a closure
    $config->define(
        'file|f=s@' => { 
            EXPAND => EXPAND_ALL, 
            ACTION => sub { 
                my ($state, $item, $file) = @_;
                $file = $state->cfg . "/$file" 
                    unless $file =~ /^[\.\/]|(?:\w:)/;
                $config->file($file) }  
        }
    );

    # process main config file, then command line args
    $config->file($file) if -f $file;
    $config->args();

    $config;
}


sub ANSI_escape {
    my $attr = shift;
    my $text = join('', @_);
    return join("\n",
        map {
            # look for an existing escape start sequence and add new
            # attribute to it, otherwise add escape start/end sequences
            s/ \e \[ ([1-9][\d;]*) m/\e[$1;${attr}m/gx
                ? $_
                : "\e[${attr}m" . $_ . "\e[0m";
        }
        split(/\n/, $text, -1)   # -1 prevents it from ignoring trailing fields
    );
}

sub _red(@)    { ANSI_escape(31, @_) }
sub _green(@)  { ANSI_escape(32, @_) }
sub _yellow(@) { ANSI_escape(33, @_) }
sub _blue(@)   { ANSI_escape(34, @_) }
sub _white(@)  { @_ }                   # nullop


#------------------------------------------------------------------------
# write_config($file)
#
# Writes a sample configuration file to the filename specified.
#------------------------------------------------------------------------

sub write_config {
    my $file = shift;

    open(CONFIG, ">$file") || die "failed to create $file: $!\n";
    print(CONFIG <<END_OF_CONFIG);
#------------------------------------------------------------------------
# sample .ttreerc file created automatically by $NAME version $VERSION
#
# This file originally written to $file
#
# For more information on the contents of this configuration file, see
# 
#     perldoc ttree
#     ttree -h
#
#------------------------------------------------------------------------

# The most flexible way to use ttree is to create a separate directory 
# for configuration files and simply use the .ttreerc to tell ttree where
# it is.  
#
#     cfg = /path/to/ttree/config/directory

# print summary of what's going on 
verbose 

# recurse into any sub-directories and process files
recurse

# regexen of things that aren't templates and should be ignored
ignore = \\b(CVS|RCS)\\b
ignore = ^#

# ditto for things that should be copied rather than processed.
copy = \\.png\$ 
copy = \\.gif\$ 

# by default, everything not ignored or copied is accepted; add 'accept'
# lines if you want to filter further. e.g.
#
#    accept = \\.html\$
#    accept = \\.tt2\$

# options to rewrite files suffixes (htm => html, tt2 => html)
#
#    suffix htm=html
#    suffix tt2=html

# options to define dependencies between templates
#
#    depend *=header,footer,menu
#    depend index.html=mainpage,sidebar
#    depend menu=menuitem,menubar
# 

#------------------------------------------------------------------------
# The following options usually relate to a particular project so 
# you'll prob.@$accept ]\n",
          "      Suffix: [ $sfx ]\n");
    print("      Module: $ttmodule ", $ttmodule->module_version(), "\n")
        unless $ttmodule eq $TTMODULE;

    if ($depends && $DEP_DEBUG) {
        print "Dependencies:\n";
        foreach my $key ('*', grep { !/\*/ } keys %$depends) {
            printf( "    %-16s %s\n", $key, 
                    join(', ', @{ $depends->{ $key } }) ) 
                if defined $depends->{ $key };

        }
    }
    print "\n" if $verbose > 1;
    print red("NOTE: dry run, doing nothing...\n")
        if $dryrun;
}

#------------------------------------------------------------------------
# main processing loop
#------------------------------------------------------------------------

my $template = $ttmodule->new($ttopts)
    || die $ttmodule->error();

if (@ARGV) {
    # explicitly process files specified on command lines 
    foreach my $file (@ARGV) {
        my $path = $srcdir ? File::Spec->catfile($srcdir, $file) : $file;
        if ( -d $path ) {
            process_tree($file);
        }
        else {
            process_file($file, $path, force => 1);
        }
    }
}
else {
    # implicitly process all file in source directory
    process_tree();
}

if ($summary || $verbose) {
    my $format  = "%13d %s %s\n";
    print "\n" if $verbose > 1;
    print(
        "     Summary: ",
        $dryrun ? red("This was a dry run.  Nothing was actually done\n") : "\n",
        green(sprintf($format, $n_proc,  $n_proc  == 1 ? 'file' : 'files', 'processed')),
        green(sprintf($format, $n_copy,  $n_copy  == 1 ? 'file' : 'files', 'copied')),
        green(sprintf($format, $n_mkdir, $n_mkdir == 1 ? 'directory' : 'directories', 'created')),
        yellow(sprintf($format, $n_unmod, $n_unmod == 1 ? 'file' : 'files', 'skipped (not modified)')),
        yellow(sprintf($format, $n_skip,  $n_skip  == 1 ? 'file' : 'files', 'skipped (ignored)'))
    );
}

exit(0);


#========================================================================
# END 
#========================================================================


#------------------------------------------------------------------------
# process_tree($dir)
#
# Walks the directory tree starting at $dir or the current directory
# if unspecified, processing files as found.
#------------------------------------------------------------------------

sub process_tree {
    my $dir = shift;
    my ($file, $path, $abspath, $check);
    my $target;
    local *DIR;

    my $absdir = join('/', $srcdir ? $srcdir : (), defined $dir ? $dir : ());
    $absdir ||= '.';

    opendir(DIR, $absdir) || do { warn "$absdir: $!\n"; return undef; };

    FILE: while (defined ($file = readdir(DIR))) {
        next if $file eq '.' || $file eq '..';
        $path = defined $dir ? "$dir/$file" : $file;
        $abspath = "$absdir/$file";
        
        next unless -e $abspath;

        # check against ignore list
        foreach $check (@$ignore) {
            if ($path =~ /$check/) {
                printf yellow("  - %-32s (ignored, matches /$check/)\n"), $path
                    if $verbose > 1;
                $n_skip++;
                next FILE;
            }
        }

        # check against acceptance list
        if (@$accept) {
            unless ((-d $abspath && $recurse) || grep { $path =~ /$_/ } @$accept) {
                printf yellow("  - %-32s (not accepted)\n"), $path
                    if $verbose > 1;
                $n_skip++;
                next FILE;
            }
        }

        if (-d $abspath) {
            if ($recurse) {
                my ($uid, $gid, $mode);
                
                (undef, undef, $mode, undef, $uid, $gid, undef, undef,
                 undef, undef, undef, undef, undef)  = stat($abspath);
                
                # create target directory if required
                $target = "$destdir/$path";
                unless (-d $target || $dryrun) {
                    mkpath($target, $verbose, $mode) or 
                        die red("Could not mkpath ($target): $!\n");

                    # commented out by abw on 2000/12/04 - seems to raise a warning?
                    # chown($uid, $gid, $target) || warn "chown($target): $!\n";

                    $n_mkdir++;
                    printf green("  + %-32s (created target directory)\n"), $path
                        if $verbose;
                }
                # recurse into directory
                process_tree($path);
            }
            else {
                $n_skip++;
                printf yellow("  - %-32s (directory, not recursing)\n"), $path
                    if $verbose > 1;
            }
        }
        else {
            process_file($path, $abspath);
        }
    }
    closedir(DIR);
}
    

#------------------------------------------------------------------------
# process_file()
#
# File filtering and processing sub-routine called by process_tree()
#------------------------------------------------------------------------

sub process_file {
    my ($file, $absfile, %options) = @_;
    my ($dest, $destfile, $filename, $check, 
        $srctime, $desttime, $mode, $uid, $gid);
    my ($old_suffix, $new_suffix);
    my $is_dep = 0;
    my $copy_file = 0;

    $absfile ||= $file;
    $filename = basename($file);
    $destfile = $file;
    
    # look for any relevant suffix mapping
    if (%$suffix) {
        if ($filename =~ m/\.(.+)$/) {
            $old_suffix = $1;
            if ($new_suffix = $suffix->{ $old_suffix }) {
                $destfile =~ s/$old_suffix$/$new_suffix/;
            }
        }
    }
    $dest = $destdir ? "$destdir/$destfile" : $destfile;
                   
#    print "proc $file => $dest\n";
    
    # check against copy list
    foreach my $copy_pattern (@$copy) {
        if ($filename =~ /$copy_pattern/) {
            $copy_file = 1;
            $check = $copy_pattern;
            last;
        }
    }

    # stat the source file unconditionally, so we can preserve
    # mode and ownership
    ( undef, undef, $mode, undef, $uid, $gid, undef, 
      undef, undef, $srctime, undef, undef, undef ) = stat($absfile);
    
    # test modification time of existing destination file
    if (! $all && ! $options{ force } && -f $dest) {
        $desttime = ( stat($dest) )[9];

        if (defined $depends and not $copy_file) {
            my $deptime  = depend_time($file, $depends);
            if (defined $deptime && ($srctime < $deptime)) {
                $srctime = $deptime;
                $is_dep = 1;
            }
        }
    
        if ($desttime >= $srctime) {
            printf yellow("  - %-32s (not modified)\n"), $file
                if $verbose > 1;
            $n_unmod++;
            return;
        }
    }
    
    # check against copy list
    if ($copy_file) {
        $n_copy++;
        unless ($dryrun) {
            copy($absfile, $dest) or die red("Could not copy ($absfile to $dest) : $!\n");

            if ($preserve) {
                chown($uid, $gid, $dest) || warn red("chown($dest): $!\n");
                chmod($mode, $dest) || warn red("chmod($dest): $!\n");
            }
        }

        printf green("  > %-32s (copied, matches /$check/)\n"), $file
            if $verbose;

        return;
    }

    $n_proc++;
    
    if ($verbose) {
        printf(green("  + %-32s"), $file);
        print(green(" (changed suffix to $new_suffix)")) if $new_suffix;
        print "\n";
    }

    # process file
    unless ($dryrun) {
        $template->process($file, $replace, $destfile,
            $binmode ? {binmode => $binmode} : {})
            || print(red("  ! "), $template->error(), "\n");

        if ($preserve) {
            chown($uid, $gid, $dest) || warn red("chown($dest): $!\n");
            chmod($mode, $dest) || warn red("chmod($dest): $!\n");
        }
    }
}


#------------------------------------------------------------------------
# dependencies($file, $depends)
# 
# Read the dependencies from $file, if defined, and merge in with 
# those passed in as the hash array $depends, if defined.
#------------------------------------------------------------------------

sub dependencies {
    my ($file, $depend) = @_;
    my %depends = ();

    if (defined $file) {
        my ($fh, $text, $line);
        open $fh, $file or die "Can't open $file, $!";
        local $/ = undef;
        $text = <$fh>;
        close($fh);
        $text =~ s[\\\n][]mg;
        
        foreach $line (split("\n", $text)) {
            next if $line =~ /^\s*(#|$)/;
            chomp $line;
            my ($file, @files) = quotewords('\s*:\s*', 0, $line);
            $file =~ s/^\s+//;
            @files = grep(defined, quotewords('(,|\s)\s*', 0, @files));
            $depends{$file} = \@files;
        }
    }

    if (defined $depend) {
        foreach my $key (keys %$depend) {
            $depends{$key} = [ quotewords(',', 0, $depend->{$key}) ];
        }
    }

    return \%depends;
}



#------------------------------------------------------------------------
# depend_time($file, \%depends)
#
# Returns the mtime of the most recent in @files.
#------------------------------------------------------------------------

sub depend_time {
    my ($file, $depends) = @_;
    my ($deps, $absfile, $modtime);
    my $maxtime = 0;
    my @pending = ($file);
    my @files;
    my %seen;

    # push any global dependencies onto the pending list
    if ($deps = $depends->{'*'}) {
        push(@pending, @$deps);
    }

    print "    # checking dependencies for $file...\n"
        if $DEP_DEBUG;

    # iterate through the list of pending files
    while (@pending) {
        $file = shift @pending;
        next if $seen{ $file }++;

        if (File::Spec->file_name_is_absolute($file) && -f $file) {
            $modtime = (stat($file))[9];
            print "    #   $file [$modtime]\n"
                if $DEP_DEBUG;
        }
        else {
            $modtime = 0;
            foreach my $dir ($srcdir, @$libdir) {
                $absfile = File::Spec->catfile($dir, $file);
                if (-f $absfile) {
                    $modtime = (stat($absfile))[9];
                    print "    #   $absfile [$modtime]\n"
                        if $DEP_DEBUG;
                    last;
                }
            }
        }
        $maxtime = $modtime
            if $modtime > $maxtime;

        if ($deps = $depends->{ $file }) {
            push(@pending, @$deps);
            print "    #     depends on ", join(', ', @$deps), "\n"
                if $DEP_DEBUG;
        }
    }

    return $maxtime;
}


#------------------------------------------------------------------------
# read_config($file)
#
# Handles reading of config file and/or command line arguments.
#------------------------------------------------------------------------

sub read_config {
    my $file    = shift;
    my $verbose = 0;
    my $verbinc = sub {
        my ($state, $var, $value) = @_;
        $state->{ VARIABLE }->{ verbose } = $value ? ++$verbose : --$verbose;
    };
    my $config  = AppConfig->new(
        { 
            ERROR  => sub { die(@_, "\ntry `$NAME --help'\n") }
        }, 
        'help|h'      => { ACTION => \&help },
        'src|s=s'     => { EXPAND => EXPAND_ALL },
        'dest|d=s'    => { EXPAND => EXPAND_ALL },
        'lib|l=s@'    => { EXPAND => EXPAND_ALL },
        'cfg|c=s'     => { EXPAND => EXPAND_ALL, DEFAULT => '.' },
        'verbose|v'   => { DEFAULT => 0, ACTION => $verbinc },
        'recurse|r'   => { DEFAULT => 0 },
        'nothing|n'   => { DEFAULT => 0 },
        'preserve|p'  => { DEFAULT => 0 },
        'absolute'    => { DEFAULT => 0 },
        'relative'    => { DEFAULT => 0 },
        'colour|color'=> { DEFAULT => 0 },
        'summary'     => { DEFAULT => 0 },
        'all|a'       => { DEFAULT => 0 },
        'define=s%',
        'suffix=s%',
        'binmode=s',
        'ignore=s@',
        'copy=s@',
        'accept=s@',
        'depend=s%',
        'depend_debug|depdbg',
        'depend_file|depfile=s' => { EXPAND => EXPAND_ALL },
        'template_module|module=s',
        'template_anycase|anycase',
        'template_encoding|encoding=s',
        'template_eval_perl|eval_perl',
        'template_load_perl|load_perl',
        'template_interpolate|interpolate',
        'template_pre_chomp|pre_chomp|prechomp',
        'template_post_chomp|post_chomp|postchomp',
        'template_trim|trim',
        'template_pre_process|pre_process|preprocess=s@',
        'template_post_process|post_process|postprocess=s@',
        'template_process|process=s',
        'template_wrapper|wrapper=s',
        'template_recursion|recursion',
        'template_expose_blocks|expose_blocks',
        'template_default|default=s',
        'template_error|error=s',
        'template_debug|debug=s',
        'template_start_tag|start_tag|starttag=s',
        'template_end_tag|end_tag|endtag=s',
        'template_tag_style|tag_style|tagstyle=s',
        'template_compile_ext|compile_ext=s',
        'template_compile_dir|compile_dir=s' => { EXPAND => EXPAND_ALL },
        'template_plugin_base|plugin_base|pluginbase=s@' => { EXPAND => EXPAND_ALL },
        'perl5lib|perllib=s@' => { EXPAND => EXPAND_ALL },
    );

    # add the 'file' option now that we have a $config object that we 
    # can reference in a closure
    $config->define(
        'file|f=s@' => { 
            EXPAND => EXPAND_ALL, 
            ACTION => sub { 
                my ($state, $item, $file) = @_;
                $file = $state->cfg . "/$file" 
                    unless $file =~ /^[\.\/]|(?:\w:)/;
                $config->file($file) }  
        }
    );

    # process main config file, then command line args
    $config->file($file) if -f $file;
    $config->args();

    $config;
}


sub ANSI_escape {
    my $attr = shift;
    my $text = join('', @_);
    return join("\n",
        map {
            # look for an existing escape start sequence and add new
            # attribute to it, otherwise add escape start/end sequences
            s/ \e \[ ([1-9][\d;]*) m/\e[$1;${attr}m/gx
                ? $_
                : "\e[${attr}m" . $_ . "\e[0m";
        }
        split(/\n/, $text, -1)   # -1 prevents it from ignoring trailing fields
    );
}

sub _red(@)    { ANSI_escape(31, @_) }
sub _green(@)  { ANSI_escape(32, @_) }
sub _yellow(@) { ANSI_escape(33, @_) }
sub _blue(@)   { ANSI_escape(34, @_) }
sub _white(@)  { @_ }                   # nullop


#------------------------------------------------------------------------
# write_config($file)
#
# Writes a sample configuration file to the filename specified.
#------------------------------------------------------------------------

sub write_config {
    my $file = shift;

    open(CONFIG, ">$file") || die "failed to create $file: $!\n";
    print(CONFIG <<END_OF_CONFIG);
#------------------------------------------------------------------------
# sample .ttreerc file created automatically by $NAME version $VERSION
#
# This file originally written to $file
#
# For more information on the contents of this configuration file, see
# 
#     perldoc ttree
#     ttree -h
#
#------------------------------------------------------------------------

# The most flexible way to use ttree is to create a separate directory 
# for configuration files and simply use the .ttreerc to tell ttree where
# it is.  
#
#     cfg = /path/to/ttree/config/directory

# print summary of what's going on 
verbose 

# recurse into any sub-directories and process files
recurse

# regexen of things that aren't templates and should be ignored
ignore = \\b(CVS|RCS)\\b
ignore = ^#

# ditto for things that should be copied rather than processed.
copy = \\.png\$ 
copy = \\.gif\$ 

# by default, everything not ignored or copied is accepted; add 'accept'
# lines if you want to filter further. e.g.
#
#    accept = \\.html\$
#    accept = \\.tt2\$

# options to rewrite files suffixes (htm => html, tt2 => html)
#
#    suffix htm=html
#    