# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::File::Tools
#   Author : Scott Beck
#   CVS Info : 087,071,086,086,085      
#   $Id: Tools.pm,v 1.64 2007/02/10 17:45:41 sbeck Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================
#
# Description: Basic file tools
#

package GT::File::Tools;
# ==================================================================

use strict;
use vars qw/
    $VERSION
    @EXPORT_OK
    %EXPORT_TAGS
    $MAX_DEPTH
    $GLOBBING
    $ERRORS
    $MAX_READ
    $DEBUG
    $NO_CHDIR
    $REGEX
    $UNTAINT
    $error
/;
$REGEX = '^([^\0]+)$';

use bases 'GT::Base' => '';

use Cwd;
require Exporter;
use GT::AutoLoader;
$VERSION = sprintf "%d.%03d", q$Revision: 1.64 $ =~ /(\d+)\.(\d+)/;

# Exporter variables
@EXPORT_OK = qw/
    copy
    move
    del
    deldir
    find
    mkpath rmkdir
    parsefile
    basename
    filename
    dirname
    expand 
/;
%EXPORT_TAGS = ( all => \@EXPORT_OK );
*import = \&Exporter::import;

# Options
$MAX_DEPTH = 1000;
$GLOBBING = 0;
$NO_CHDIR = 0;
$MAX_READ = 1024 * 64;
$UNTAINT  = 0;
$DEBUG = 0;
$ERRORS = {
    UNLINK    => "Could not unlink '%s': %s",
    RMDIR     => "Could not rmdir '%s': %s",
    MOVE      => "Could not move '%s' to '%s': %s",
    RENAME    => "Could not rename '%s' to '%s': %s",
    SYMLINK   => "Could not symlink '%s' to '%s': %s",
    NOTAFILE  => "File to copy, move, or del ('%s') is not a regular file",
    NOTADIR   => "Path passed to find ('%s') is not a directory",
    TOODEEP   => "Recursive find surpassed max depth. Last path was %s",
    RECURSIVE => "Circular symlinks detected",
    OPENDIR   => "Could not open directory '%s': %s",
    READOPEN  => "Could not open '%s' for reading: %s",
    WRITEOPEN => "Could not open '%s' for writing: %s"
};

$COMPILE{move} = __LINE__ . <<'END_OF_SUB';
sub move {
# ----------------------------------------------------------------------------
    my $class = 'GT::File::Tools';

    $class->fatal( BADARGS => "No arguments passed to move()" )
        unless @_;

    my $opts = ref $_[-1] eq 'HASH' ? pop : {};

    my $to = pop;
    $class->fatal( BADARGS => "No place to move files to specified for move()" )
        unless defined $to;

    my $globbing = delete $opts->{globbing};
    $globbing = $GLOBBING unless defined $globbing;

    my $untaint = delete $opts->{untaint};
    $untaint = $UNTAINT unless defined $untaint;

    my $untaint_regex = delete $opts->{untaint_regex};
    $untaint_regex = $REGEX unless defined $untaint_regex;

    my @files = @_;
    @files = expand( @files ) if $globbing;

    $class->fatal( BADARGS => "No files to move" )
        unless @files;

    my $error_handler = delete $opts->{error_handler};
    $error_handler = sub { $class->warn( @_ ); 1 }
        unless defined $error_handler;

    $class->fatal(
        BADARGS => "error_handler option must be a code reference"
    ) unless ref $error_handler eq 'CODE';

    my $max_depth = delete $opts->{max_depth};
    $max_depth = $MAX_DEPTH unless defined $max_depth;

    $class->fatal(
        BADARGS => "Unknown option " . ( join ", ", keys %$opts )
    ) if keys %$opts;

    my %seen;
    for my $from_file ( @files ) {
        my $to_file = $to;
        if ( !-d $to and $seen{$to}++ ) {
            $class->fatal(
                BADARGS => "Trying to move multiple files into one file"
            );
        }
        if ( -d $from_file ) {
            $class->debug( "movedir $from_file, $to_file" ) if $DEBUG > 1;
            movedir(
                $from_file, $to_file,
                {
                    error_handler   => $error_handler,
                    max_depth       => $max_depth,
                    untaint         => $untaint,
                    untaint_regex   => $untaint_regex,
                }
            ) or return;
            next;
        }
        if ( -d $to_file ) {
            $to_file = $to . '/' . basename( $from_file );
        }
        if ($untaint) {
            $to_file =~ $untaint_regex and $to_file = $1;
            is_tainted($to_file) and die "bad file $to_file";
            $from_file =~ $untaint_regex and $from_file = $1;
            is_tainted($from_file) and die "bad file $from_file";
        }
        if ( -l $from_file ) {
            my ( $link ) = _fix_symlink( $from_file );
            if ( !symlink $link, $to_file ) {
                $error_handler->( SYMLINK => $from_file, $to_file, "$!" )
                    or return;
            }
            if ( !unlink $from_file ) {
                $error_handler->( UNLINK => $from_file, "$!" )
                    or return;
            }
            next;
        }
        my ( $to_size_before, $to_mtime_before ) = ( stat( $to_file ) )[7, 9];
        my $from_size = -s $from_file;
        $class->debug( "rename $from_file, $to_file" ) if $DEBUG > 1;
        next if rename $from_file, $to_file;
        my $err = "$!";
        my $errno = 0+$!;

# Under NFS rename can work but still return an error, check for that
        my ( $to_size_after, $to_mtime_after ) = ( stat( $to_file ) )[7, 9];
        if ( defined $from_size and -e $from_file ) {
            if (
                defined $to_mtime_before and
                ( 
                    $to_size_before != $to_size_after or
                    $to_mtime_before != $to_mtime_after
                ) and
                $to_size_after == $from_size
            )
            {
                $class->debug( "rename over NFS worked" ) if $DEBUG > 1;
                next;
            }
        }

        $class->debug( "copy $from_file, $to_file" ) if $DEBUG > 1;
        next if copy( $from_file, $to_file,
            {
                preserve_all    => 1,
                max_depth       => $max_depth,
                error_handler   => $error_handler,
                untaint         => $untaint,
                untaint_regex   => $untaint_regex,
            }
        ) and unlink $from_file;

# Remove if a particial copy happened
        if (
            !defined( $to_mtime_before )        or
            $to_mtime_before != $to_mtime_after or
            $to_size_before != $to_size_after
        )
        {
            unlink $to_file;
        }
        $error_handler->( RENAME => $from_file, $to_file, $err, $errno )
            or return;
    }
    return 1;
}
END_OF_SUB

$COMPILE{movedir} = __LINE__ . <<'END_OF_SUB';
sub movedir {
# ----------------------------------------------------------------------------
    my ( $from, $to, $opts ) = @_;
    my $class = 'GT::File::Tools';

    my $error_handler = delete $opts->{error_handler};
    $error_handler = sub { $class->warn( @_ ); 1 }
        unless defined $error_handler;

    $class->fatal(
        BADARGS => "error_handler option must be a code reference"
    ) unless ref $error_handler eq 'CODE';

    my $max_depth = delete $opts->{max_depth};
    $max_depth = $MAX_DEPTH unless defined $max_depth;

    my $untaint = delete $opts->{untaint};
    $untaint = $UNTAINT unless defined $untaint;

    my $untaint_regex = delete $opts->{untaint_regex};
    $untaint_regex = $REGEX unless defined $untaint_regex;

    $class->fatal(
        BADARGS => "Unknown option " . ( join ", ", keys %$opts )
    ) if keys %$opts;

    $from .= '/' unless $from =~ m,/\Z,;
    $to .= '/' unless $to =~ m,/\Z,;

# To move a directory inside an already existing directory
    $to .= basename( $from ) if -d $to;

# Try the easy way out first
    return 1 if rename $from, $to;

    my $cwd;
    if ( ( parsefile( $from ) )[2] ) {
        $cwd = mycwd();
        $from = "$cwd/$from";
    }
    if ( ( parsefile( $to ) )[2] ) {
        $cwd ||= mycwd();
        $to = "$cwd/$to";
    }
    if ($untaint) {
        $to =~ $untaint_regex and $to = $1;
        is_tainted($to) and die "bad file $to";
        $from =~ $untaint_regex and $from = $1;
        is_tainted($from) and die "bad file $from";
    }

    return find(
        $from,
        sub {
            my ( $path ) = @_;
            if ( -l $path ) {
                $path .= '/' if ( -d _ and $path !~ m,/\Z, );
                my ( $link, $relative ) = _fix_symlink( $path );
                ( my $new_path = $path ) =~ s!\A\Q$from!$to!;
                $class->debug( "link $link, $new_path" ) if $DEBUG > 1;
                unless (-l $new_path) {
                    symlink $link, $new_path
                        or $error_handler->( SYMLINK =>  $link, $new_path, "$!" )
                        or return;
                }
                _preserve( $path, $new_path,
                    set_owner => 1,
                    set_time  => 1
                );
                unlink $path
                    or $error_handler->( UNLINK =>  $path, "$!" )
                    or return;
                return 1;
            }
            elsif ( -d $path ) {
                $path .= '/' unless $path =~ m,/\Z,;
                ( my $new_path = $path ) =~ s!\A\Q$from!$to!;
                $class->debug( "mkdir $new_path" ) if $DEBUG > 1;
                unless (-d $new_path) {
                    mkdir $new_path, 0777
                        or $error_handler->( MKDIR =>  $new_path, "$!" )
                        or return;
                }
                _preserve( $path, $new_path,
                    set_perms => 1,
                    set_owner => 1,
                    set_time  => 1
                );
                rmdir $path
                    or $error_handler->( RMDIR => $path, "$!" )
                    or return;
            }
            elsif ( -f _ ) {
                ( my $new_path = $path ) =~ s!\A\Q$from!$to!;
                $class->debug( "move $path, $new_path" ) if $DEBUG > 1;
                move( $path, $new_path,
                    {
                        error_handler   => $error_handler,
                        max_depth       => $max_depth,
                    }
                )   or $error_handler->( MOVE => $path, $new_path, "$!" )
                    or return;
            }
            else {
                $error_handler->( NOTAFILE => $path ) or return;
            }
            return 1;
        },
        {
            dirs_first      => 1,
            error_handler   => $error_handler,
            max_depth       => $max_depth,
            untaint         => $untaint,
            untaint_regex   => $untaint_regex,
        }
    );
}
END_OF_SUB

$COMPILE{del} = __LINE__ . <<'END_OF_SUB';
sub del {
# ----------------------------------------------------------------------------
    my $class = 'GT::File::Tools';
    my $opts = ref $_[-1] eq 'HASH' ? pop : {};

    my $error_handler = delete $opts->{error_handler};
    $error_handler = sub { $class->warn( @_ ); 1 } unless $error_handler;

    $class->fatal(
        BADARGS => "error_handler option must be a code reference"
    ) unless ref $error_handler eq 'CODE';

    my $globbing = delete $opts->{globbing};
    $globbing = $GLOBBING unless defined $globbing;

    my @files = @_;
    @files = expand( @files ) if $globbing;

    $class->fatal( BADARGS => "No directories to delete" )
        unless @files;

    my $untaint = delete $opts->{untaint};
    $untaint = $UNTAINT unless defined $untaint;

    my $untaint_regex = delete $opts->{untaint_regex};
    $untaint_regex = $REGEX unless defined $untaint_regex;

    $class->fatal(
        BADARGS => "Unknown option " . ( join ", ", keys %$opts )
    ) if keys %$opts;

    for my $path ( @files ) {
        if ($untaint) {
            $path =~ $untaint_regex and $path = $1;
            is_tainted($path) and die "bad file $path";
        }
        if ( -l $path ) {
            $class->debug( "unlink $path" ) if $DEBUG > 1;
            unlink $path
                or $error_handler->( UNLINK => $path, "$!" )
                or return;
        }
        elsif ( -d $path ) {
            $error_handler->( NOTAFILE => $path )
                or return;
        }
        else {
            unlink $path
                or $error_handler->( UNLINK => $path, "$!" )
                or return;
        }
    }
    return 1;
}
END_OF_SUB

$COMPILE{deldir} = __LINE__ . <<'END_OF_SUB';
sub deldir {
# ----------------------------------------------------------------------------
    my $class = 'GT::File::Tools';
    my $opts = ref $_[-1] eq 'HASH' ? pop : {};

    my $error_handler = delete $opts->{error_handler};
    $error_handler = sub { $class->warn( @_ ); 1 } unless $error_handler;

    $class->fatal(
        BADARGS => "error_handler option must be a code reference"
    ) unless ref $error_handler eq 'CODE';

    my $globbing = delete $opts->{globbing};
    $globbing = $GLOBBING unless defined $globbing;

    my @dirs = @_;
    @dirs = expand( @dirs ) if $globbing;

    $class->fatal( BADARGS => "No directories to delete" )
        unless @dirs;

    my $max_depth = delete $opts->{max_depth};
    $max_depth = $MAX_DEPTH unless defined $max_depth;

    my $untaint = delete $opts->{untaint};
    $untaint = $UNTAINT unless defined $untaint;

    my $untaint_regex = delete $opts->{untaint_regex};
    $untaint_regex = $REGEX unless defined $untaint_regex;

    $class->fatal(
        BADARGS => "Unknown option " . ( join ", ", keys %$opts )
    ) if keys %$opts;

    for my $dir ( @dirs ) {
        if ($untaint) {
            $dir =~ $untaint_regex and $dir = $1;
            is_tainted($dir) and die "bad file $dir";
        }
        next unless -e $dir or -l $dir;

# Try the easy way out first
        next if rmdir $dir or unlink $dir;

        find(
            $dir,
            sub {
                my ( $path ) = @_;
                if ( -l $path ) {
                    $class->debug( "unlink $path" ) if $DEBUG > 1;
                    unlink $path
                        or $error_handler->( UNLINK => $path, "$!" )
                        or return;
                }
                elsif ( -d $path ) {
                    $class->debug( "rmdir $path" ) if $DEBUG > 1;
                    rmdir $path
                        or $error_handler->( RMDIR => $path, "$!" )
                        or return;
                }
                else {
                    $class->debug( "unlink $path" ) if $DEBUG > 1;
                    unlink $path
                        or $error_handler->( UNLINK => $path, "$!" )
                        or return;
                }
                return 1;
            },
            {
                dirs_first      => 0,
                error_handler   => $error_handler,
                max_depth       => $max_depth,
                untaint         => $untaint,
                untaint_regex   => $untaint_regex,
            }
        );
    }
    return 1;
}
END_OF_SUB

$COMPILE{copy} = __LINE__ . <<'END_OF_SUB';
sub copy {
# ----------------------------------------------------------------------------
    my $class = 'GT::File::Tools';

    $class->fatal( BADARGS => "No arguments passed to move()" )
        unless @_;

    my $opts = ref $_[-1] eq 'HASH' ? pop : {};
    my $to = pop;
    $class->fatal( BADARGS => "No place to move files to specified for move()" )
        unless defined $to;

    my $globbing = delete $opts->{globbing};
    $globbing = $GLOBBING unless defined $globbing;

    my $untaint = delete $opts->{untaint};
    $untaint = $UNTAINT unless defined $untaint;

    my $untaint_regex = delete $opts->{untaint_regex};
    $untaint_regex = $REGEX unless defined $untaint_regex;

    my @files = @_;
    @files = expand( @files ) if $globbing;

    $class->fatal( BADARGS => "No files to move" )
        unless @files;

    my $error_handler = delete $opts->{error_handler};
    $error_handler = sub { $class->warn( @_ ); 1 }
        unless defined $error_handler;

    $class->fatal(
        BADARGS => "error_handler option must be a code reference"
    ) unless ref $error_handler eq 'CODE';

    my %preserve_opts = (set_perms => 1);
    if ( delete $opts->{preserve_all} ) {
        @preserve_opts{qw/set_perms set_owner set_time/} = ( 1, 1 ,1 );
    }
    else {
        $preserve_opts{set_perms} = delete $opts->{set_perms} if defined $opts->{set_perms};
        @preserve_opts{qw/set_owner set_time/} =
        (
            delete $opts->{set_owner},
            delete $opts->{set_time}
        );
    }

    my $max_depth = delete $opts->{max_depth};
    $max_depth = $MAX_DEPTH unless defined $max_depth;

    $class->fatal(
        BADARGS => "Unknown option " . ( join ", ", keys %$opts )
    ) if keys %$opts;

    my %seen;
    for my $from_file ( @files ) {
        my $to_file = $to;
        if ( !-d $to_file and $seen{$to_file}++ ) {
            $class->fatal(
                BADARGS => "Trying to copy multiple files into one file $from_file => $to"
            );
        }
        if ( -d $from_file ) {
            $class->debug( "copydir $from_file, $to_file" ) if $DEBUG > 1;
            copydir( $from_file, $to_file, {
                error_handler   => $error_handler,
                max_depth       => $max_depth,
                untaint         => $untaint,
                untaint_regex   => $untaint_regex,
                %preserve_opts
            });
            next;
        }
        if ( -d $to_file ) {
            $to_file = $to . '/' . basename( $from_file );
        }
        if ($untaint) {
            $to_file =~ $untaint_regex and $to_file = $1;
            is_tainted($to_file) and die "bad file $to_file";

            $from_file =~ $untaint_regex and $from_file = $1;
            is_tainted($from_file) and die "bad file $from_file";
        }

        if ( -l $from_file ) {
            my ( $link ) = _fix_symlink( $from_file );
            if ($untaint) {
                $link =~ $untaint_regex and $link = $1;
                is_tainted($link) and die "bad file $link";
            }

            if ( !symlink $link, $to_file ) {
                $error_handler->( SYMLINK => $from_file, $to_file, "$!" )
                    or return;
            }
            next;
        }

        local( *FROM, *TO );
        $class->debug( "open $from_file" ) if $DEBUG > 1;
        unless ( open FROM, "< $from_file" ) {
            $error_handler->( READOPEN => $from_file, "$!" ) or return;
            next;
        }
        $class->debug( "open $to_file" ) if $DEBUG > 1;
        unless ( open TO, "> $to_file" ) {
            $error_handler->( WRITEOPEN => $to_file, "$!" ) or return;
            next;
        }
        binmode FROM or $class->fatal( BINMODE => "$!" );
        binmode TO or $class->fatal( BINMODE => "$!" );
        my $size = -s FROM;
        $size = $MAX_READ if $size > $MAX_READ;

        while () {
            my ( $ret, $buf );
            $ret = sysread FROM, $buf, $size;
            $class->fatal( READ => "$!" )
                unless defined $ret;
            last unless $ret;
            $ret = syswrite TO, $buf, length $buf;
            $class->fatal( WRITE => "$!" )
                unless defined $ret;
        }

        close FROM;
        close TO;

# Set permissions, mtime, and owner
        _preserve( $from_file, $to_file, %preserve_opts );

    }
    return 1;
}
END_OF_SUB

$COMPILE{copydir} = __LINE__ . <<'END_OF_SUB';
sub copydir {
# ----------------------------------------------------------------------------
    my ( $from, $to, $opts ) = @_;
    my $class = 'GT::File::Tools';

    $class->fatal( BADARGS => "No from directory specified" )
        unless defined $from;
    $class->fatal( BADARGS => "From file specified must be a directory" )
        unless -d $from;
    $class->fatal( BADARGS => "No to directory specified" )
        unless defined $from;
    my $error_handler = delete $opts->{error_handler};

    $error_handler = sub { $class->warn( @_ ); 1 }
        unless defined $error_handler;

    $class->fatal(
        BADARGS => "error_handler option must be a code reference"
    ) unless ref $error_handler eq 'CODE';

    my %preserve_opts = (set_perms => 1);
    if ( delete $opts->{preserve_all} ) {
        @preserve_opts{qw/set_perms set_owner set_time/} = ( 1, 1 ,1 );
    }
    else {
        $preserve_opts{set_perms} = delete $opts->{set_perms} if defined $opts->{set_perms};
        @preserve_opts{qw/set_owner set_time/} =
        (
            delete $opts->{set_owner},
            delete $opts->{set_time}
        );
    }

    my $untaint = delete $opts->{untaint};
    $untaint = $UNTAINT unless defined $untaint;

    my $untaint_regex = delete $opts->{untaint_regex};
    $untaint_regex = $REGEX unless defined $untaint_regex;

    my $max_depth = delete $opts->{max_depth};
    $max_depth = $MAX_DEPTH unless defined $max_depth;

    $class->fatal(
        BADARGS => "Unknown option " . ( join ", ", keys %$opts )
    ) if keys %$opts;

    $from .= '/' unless $from =~ m,/\Z,;
    $to .= '/' unless $to =~ m,/\Z,;

# To move a directory inside an already existing directory
    $to .= basename( $from ) if -d $to;

    my $cwd;
    if ( ( parsefile( $from ) )[2] ) {
        $cwd = mycwd();
        if ($untaint) {
            $cwd =~ $untaint_regex and $cwd = $1;
            is_tainted($cwd) and die "bad file $cwd";
        }

        $from = "$cwd/$from";
    }
    if ( ( parsefile( $to ) )[2] ) {
        $cwd ||= mycwd();
        $to = "$cwd/$to";
    }
    if ($untaint) {
        $to =~ $untaint_regex and $to = $1;
        is_tainted($to) and die "bad file $to";
        $from =~ $untaint_regex and $from = $1;
        is_tainted($from) and die "bad file $from";
    }
    $from =~ s{/\Z}{};
    $to =~ s{/\Z}{};

    return find(
        $from,
        sub {
            my ( $path ) = @_;
            if ( -l $path ) {
                $path .= '/' if ( -d _ and $path !~ m,/\Z, );
                my ( $link, $relative ) = _fix_symlink( $path );
                ( my $new_path = $path ) =~ s!\A\Q$from!$to!;
                $class->debug( "link $link, $new_path" ) if $DEBUG > 1;
                unless (-l $new_path) {
                    if ($untaint) {
                        $link =~ $untaint_regex and $link = $1;
                        is_tainted($link) and die "bad file $link";
                    }

                    symlink $link, $new_path
                        or $error_handler->( SYMLINK =>  $link, $new_path, "$!" )
                        or return;
                }
                _preserve( $path, $new_path, %preserve_opts );
                return 1;
            }
            elsif ( -d $path ) {
                $path .= '/' unless $path =~ m,/\Z,;
                ( my $new_path = $path ) =~ s!\A\Q$from!$to!;
                $class->debug( "mkdir $new_path" ) if $DEBUG > 1;
                unless (-d $new_path) {
                    mkdir $new_path, 0777
                        or $error_handler->( MKDIR =>  $new_path, "$!" )
                        or return;
                }
                _preserve( $path, $new_path, %preserve_opts );
            }
            elsif ( -f $path ) {
                $from =~ s{/\Z}{};
                $to =~ s{/\Z}{};

                ( my $new_path = $path ) =~ s!\A\Q$from!$to!;
                $class->debug( "copy $path, $new_path" ) if $DEBUG > 1;
                copy( $path, $new_path,
                    {
                        %preserve_opts,
                        error_handler   => $error_handler,
                        max_depth       => $max_depth,
                        untaint         => $untaint,
                        untaint_regex   => $untaint_regex
                    }
                )
                    or $error_handler->( MOVE => $path, $new_path, "$GT::File::Tools::error" )
                    or return;
# copy() will handle setting permission and such
            }
            else {
                $error_handler->( NOTAFILE => $path )
                    or return;
            }
            return 1;
        }, 
        {
            dirs_first      => 1,
            error_handler   => $error_handler,
            max_depth       => $max_depth,
            untaint         => $untaint,
            untaint_regex   => $untaint_regex,
        }
    );
}
END_OF_SUB

$COMPILE{filename} = __LINE__ . <<'END_OF_SUB';
sub filename {
# -----------------------------------------------------------------------------
# Deprecated name for basename
#
    goto &basename;

}
END_OF_SUB

sub basename {
# -----------------------------------------------------------------------------
    return ( parsefile( $_[0] ) )[1];
}

sub dirname {
# ----------------------------------------------------------------------------
    return ( parsefile( $_[0] ) )[0];
}

$COMPILE{parsefile} = __LINE__ . <<'END_OF_SUB';
sub parsefile {
# ----------------------------------------------------------------------------
    my ( $in ) = @_;
    my ( @path, @normal, $relative, $win32 );
    if ( $^O eq 'MSWin32' ) {
        $win32 = $1 if $in =~ s/\A(\w:)//;
        @path = split m|[/\\]|, $in;
        $relative = 1 unless $in =~ m,\A[/\\],;
    }
    else {
        @path = split m|/|, $in;
        $relative = 1 unless $in =~ m,\A/,;
    }
    my $start = 0;
    for ( @path ) {
        if ( $_ eq '.' or !length ) { next }
        elsif ( $_ eq '..' ) { $start-- }
        else { $start++ }

        if ( !$relative and $start < 0 and $_ eq '..' ) { next }
        elsif ( $start < 0 and $_ eq '..' ) { push @normal, ".." }
        elsif ( $start >= 0 and $_ eq '..' ) { pop @normal }
        else { push @normal, $_ }
    }
    my $file = pop @normal;
    my $new_path = join "/", @normal;
    $new_path = $relative ? "./$new_path" : "/$new_path";
    $new_path = "$win32$new_path" if $win32;
    if ($new_path =~ /$REGEX/) {
        $new_path = $1 ;
    }
    else {
        die "Bad path $new_path";
    }
    if (length $file) {
        if ($file =~ /$REGEX/) {
            $file = $1 ;
        }
        else {
            die "Bad path $file";
        }
    }

    return ( $new_path, $file, $relative );
}
END_OF_SUB


$COMPILE{mkpath} = __LINE__ . <<'END_OF_SUB';
sub mkpath {
    my ($full_path, $perms, $opts) = @_;
    my $class = 'GT::File::Tools';
    $opts ||= {};

    my $untaint = delete $opts->{untaint};
    $untaint = $UNTAINT unless defined $untaint;

    my $untaint_regex = delete $opts->{untaint_regex};
    $untaint_regex = $REGEX unless defined $untaint_regex;

    $class->fatal(
        BADARGS => "Unknown option " . ( join ", ", keys %$opts )
    ) if keys %$opts;

    my ($path, $target, $is_relative) = parsefile($full_path);
    GT::File::Tools->fatal(BADARGS => 'You cannot pass a relative path to mkpath')
        if $is_relative;
    my $cwd = mycwd();
    if ($untaint) {
        $cwd =~ $untaint_regex and $cwd = $1;
        is_tainted($cwd) and die "bad file $cwd";
    }
    my @tomake = (split(m|/|, $path), $target);
    my $err = sub {
        my $bang = 0+$!;
        chdir $cwd;
        $! = $bang;
        $class->warn(@_) if @_;
        return;
    };

    # Find the deepest directory that exists, chdir into it, then mkdir all
    # remaining paths from that point on, chdir()ing, for performance reasons,
    # into each path as it is created.  This is necessary as permissions on
    # some OSes (Windows, and potentially unix systems with advanced
    # permissions) can have a path such as:
    # /foo/bar
    # where -e '/foo' is 0, but -e '/foo/bar' is 1

    my $start = '/';
    my @subpath; # /foo/bar/baz -> ('/foo/bar/baz/', '/foo/bar/', '/foo/', '/')
    for (reverse 0 .. $#tomake) {
        push @subpath, join '/', @tomake[0 .. $_], '';
    }
    SUBPATH: for my $i (0 .. $#subpath) {
        my $path = $subpath[$i];

        if ($untaint) {
            $path =~ $untaint_regex and $path = $1;
            is_tainted($path) and die "bad file $_";
        }

        if (-d $path) {
            return 1 if $i == 0; # The first path is the target
            $start = $path;
            splice @tomake, 0, -$i;
            last SUBPATH;
        }
    }

    chdir $start or return $err->("chdir: $!");

    for (@tomake) {
        next unless length;
        if ($untaint) {
            $_ =~ $untaint_regex and $_ = $1;
            is_tainted($_) and die "bad file $_";
        }
        if (!-d $_) {
            mkdir $_, 0777 or return $err->("mkdir $_: $!");
            if (defined $perms) {
                chmod $perms, $_ or return $err->("chmod: $!");
            }
        }
        chdir $_ or return $err->("chdir: $!");
    }
    chdir $cwd or return $err->("chdir $cwd: $!");
    return 1;
}
END_OF_SUB

$COMPILE{rmkdir} = __LINE__ . <<'END_OF_SUB';
# goto &foo didn't call AUTOLOAD until 5.005_03:
sub rmkdir { if ($] >= 5.005_03) { goto &mkpath } else { &mkpath } }
END_OF_SUB

$COMPILE{find} = __LINE__ . <<'END_OF_SUB';
sub find {
# ----------------------------------------------------------------------------
    my $class = 'GT::File::Tools';

    $class->fatal( BADARGS => "No arguments passed to find()" )
        unless @_;

    my $opts = ref $_[-1] eq 'HASH' ? pop : {};
    my $callback = pop;

    $class->fatal(
        BADARGS => "Argument after files list must be a code reference"
    ) unless ref $callback eq 'CODE';

    my $globbing = delete $opts->{globbing};
    $globbing = $GLOBBING unless defined $globbing;

    my @files = @_;
    @files = expand( @files ) if $globbing;

    $class->fatal( BADARGS => "No files to find" )
        unless @files;

    my $error_handler = delete $opts->{error_handler};
    $error_handler = sub { $class->warn( @_ ); 1 }
        unless defined $error_handler;

    $class->fatal(
        BADARGS => "error_handler option must be a code reference"
    ) unless ref $error_handler eq 'CODE';

    my $no_chdir = delete $opts->{no_chdir};
    $no_chdir = $NO_CHDIR unless defined $no_chdir;

    my $dirs_first = delete $opts->{dirs_first};
    $dirs_first = 1 unless defined $dirs_first;

    my $files_only = delete $opts->{files_only};
    $files_only = 0 unless defined $files_only;

    my $dirs_only = delete $opts->{dirs_only};
    $dirs_only = 0 unless defined $dirs_only;

    my $untaint = delete $opts->{untaint};
    $untaint = $UNTAINT unless defined $untaint;

    my $untaint_regex = delete $opts->{untaint_regex};
    $untaint_regex = $REGEX unless defined $untaint_regex;

    my $max_depth = delete $opts->{max_depth};
    $max_depth = $MAX_DEPTH unless defined $max_depth;

    $class->fatal(
        BADARGS => "You may only specify one of files_only or dirs_only"
    ) if $files_only and $dirs_only;

    $class->fatal(
        BADARGS => "Unknown option " . ( join ", ", keys %$opts )
    ) if keys %$opts;

    for my $path ( @files ) {
        if ($untaint) {
            $path =~ $untaint_regex and $path = $1;
            is_tainted($path) and die "bad file $path";
        }

        next unless -e $path;

        unless ( -d _ ) {
            $error_handler->( NOTADIR => $path ) or return;
            next;
        }

        my $relative = ( parsefile( $path ) )[2];
        my $cwd;
        if ( !$no_chdir or $relative ) {
            $cwd = mycwd();
            if ($untaint) {
                $cwd =~ $untaint_regex and $cwd = $1;
                is_tainted($cwd) and die "bad file $cwd";
            }
        }
        if ( $relative ) {
            $path = "$cwd/$path";
        }
        $class->debug( "find $path" ) if $DEBUG > 1;
        eval {
            _find( $path, $callback, {
                error_handler   => $error_handler,
                dirs_first      => $dirs_first,
                files_only      => $files_only,
                max_depth       => $max_depth,
                no_chdir        => $no_chdir,
                untaint         => $untaint,
                untaint_regex   => $untaint_regex,
                dirs_only       => $dirs_only
            }) or do {
                chdir $cwd unless $no_chdir;
                return;
            };
        };
        chdir $cwd unless $no_chdir;
        die "$@\n" if $@;
    }
    return 1;
}
END_OF_SUB

sub mycwd { getcwd || cwd || die "Could not get cwd; tried getcwd and cwd" }

$COMPILE{_find} = __LINE__ . <<'END_OF_SUB';
sub _find {
# ----------------------------------------------------------------------------
# This is so we can initialize from variable and cleanup in the main find
# function.
#
    my ( $path, $callback, $opts ) = @_;
    my $error_handler = $opts->{error_handler};
    local *DIR;
    if ( $opts->{dirs_first} and !$opts->{files_only} ) {
        $callback->( $path ) or return;
    }
    my $refs = 0;
    my $depth = 0;
    my $opened;
    if ( $opts->{no_chdir} ) {
        $opened = opendir DIR, $path;
    }
    else {
        if ( chdir $path ) {
            $opened = opendir DIR, ".";
        }
        else {
            $error_handler->( CHDIR => $path )
                or return;
        }
    }
    if ( $opened ) {
        my @files =
            map { s,/\Z,,; $opts->{no_chdir} ? "$path/$_" : $_ }
            grep { $_ ne '.' and $_ ne '..' } readdir DIR;
        closedir DIR;
        for ( my $i = 0; $i < @files; $i++ ) {
            my $file = $files[$i];

            if ( ref $file ) {
                if ($opts->{untaint}) {
                    $$file =~ $opts->{untaint_regex} and $$file = $1;
                    is_tainted($$file) and die "bad file $$file";
                }
                if ( !$opts->{dirs_first} and !$opts->{files_only} ) {
                    $callback->( $$file ) or return;
                }
                $depth-- if $opts->{max_depth};
                unless ( $opts->{no_chdir} ) {
                    chdir "..";
                    substr( $path, rindex($path, "/") ) = "";
                }
                next;
            }
            elsif ($opts->{untaint}) {
                $file =~ $opts->{untaint_regex} and $file = $1;
                is_tainted($file) and die "bad file $file";
            }

            if ( $opts->{max_depth} and $depth > $opts->{max_depth} ) {
                GT::File::Tools->fatal( 'TOODEEP' );
            }
            my $is_sym = -l $file;
            my $is_dir = -d $file;
            if ( $opts->{dirs_only} ) {
                next unless $is_dir;
            }
            if ($is_sym) {
                $callback->(  $opts->{no_chdir} ? $file : "$path/$file" ) or return;
            }
            elsif ( $is_dir ) {
                if ( $opts->{dirs_first} and !$opts->{files_only} ) {
                    $callback->( $opts->{no_chdir} ? $file : "$path/$file" ) or return;
                }
                local *DIR;
                $depth++;
                my @new_files;
                if ( $opts->{no_chdir} ) {
                    if ( opendir DIR, $file ) {
                        @new_files =
                            map { s,/\Z,,; "$file/$_" }
                            grep { $_ ne '.' and $_ ne '..' } readdir DIR;
                        closedir DIR;
                    }
                    else {
                        $error_handler->( OPENDIR => $file ) or return;
                    }
                }
                else {
                    my $opened;
                    if ( chdir $file ) {
                        $opened = opendir DIR, ".";
                    }
                    else {
                        $error_handler->( CHDIR => $file )
                            or return;
                    }
                    if ( $opened ) {
                        @new_files = map { s,/\Z,,; $_ } grep { $_ ne '.' and $_ ne '..' } readdir DIR;
                        closedir DIR;
                    }
                    else {
                        $error_handler->( OPENDIR => $file ) or return;
                    }
                    $path .= '/' . $file;
                }
                splice @files, $i + 1, 0, @new_files, ( $opts->{no_chdir} ? \$file : \$path );
            }
            else {
                next unless -e _;
                $callback->( $opts->{no_chdir} ? $file : "$path/$file" ) or return;
            }
        }
    }
    else {
        $error_handler->( OPENDIR => $path ) or return;
    }
    if ( !$opts->{dirs_first} and !$opts->{files_only} ) {
        $callback->( $path ) or return;
    }
    return 1;
}
END_OF_SUB

$COMPILE{_fix_symlink} = __LINE__ . <<'END_OF_SUB';
sub _fix_symlink {
# ----------------------------------------------------------------------------
# Tries to get the full path to what a symlink is pointing to. Returns the
# path (full or relative) and a value that is true if the path is relative and
# false otherwise.
#
    my ( $path ) = @_;
    my $link = readlink $path;
    my ( $relative1, $relative2 );
    ( undef, undef, $relative1 ) = parsefile( $link );
    ( undef, undef, $relative2 ) = parsefile( $path );
    if ( $relative1 and !$relative2 ) {
        $relative1 = 0;
        $link = dirname( $path ) . '/' . $link;
    }
    return ( $link, $relative1 );
}
END_OF_SUB

$COMPILE{_preserve} = __LINE__ . <<'END_OF_SUB';
sub _preserve {
# ----------------------------------------------------------------------------
# Set permissions, owner, mtime given file from, file to, and options:
#       set_time
#       set_owner
#       set_perms
#
    my ( $from, $to, %opts ) = @_;
    my $class = 'GT::File::Tools';

    my ( $mode, $uid, $gid, $mtime );
    if ( $opts{set_time} or $opts{set_owner} or $opts{set_perms} ) {
        ( $mode, $uid, $gid, $mtime ) = (stat($from))[2, 4, 5, 9];
    }
    if ( $opts{set_time} ) {
        utime time, $mtime, $to;
    }

    if ( $opts{set_owner} ) {
        chown $uid, $gid, $to
            if ( $> == 0 and $^O ne "MaxOS" and $^O ne "MSWin32" );
    }

    if ( $opts{set_perms} and !-l $to ) {
        chmod $mode, $to or return $class->warn( 'CHMOD', $to, "$!" );
    }
}
END_OF_SUB

$COMPILE{expand} = __LINE__ . <<'END_OF_SUB';
sub expand {
# ----------------------------------------------------------------------------
# Implement globbing for files. Perl's glob function has issues.
#
    my $class = 'GT::File::Tools';
    my ( @files ) = @_;
    my (@ret, $cwd);
    for ( @files ) {
        my ( $dirname, $filename, $relative ) = parsefile( $_ );
        if ($relative) {
            $cwd ||= mycwd();
            ($dirname, $filename) = parsefile( "$cwd/$_" );
        }
        if (
            index( $filename, '*' ) == -1 and
            index( $filename, '?' ) == -1
        )
        {
            push @ret, "$dirname/$filename";
            next;
        }
        $filename = quotemeta $filename;
        $filename =~ s[(^|\G|[^\\])((?:\\{4})*)\\(\\\\)?(\\(?!\\)|[?*])]{
            $1 . ('\\' x (length($2) / 2)) . ($3 ? "\\$4" : $4 eq '*' ? '.*' : $4 eq '?' ? '.' : '\\')
        }eg;
        local *DIR;
        opendir DIR, $dirname
            or $class->fatal( OPENDIR => $dirname, "$!" );
        push @ret, map "$dirname/$_", grep  { /\A$filename\Z/ and $_ ne '.' and $_ ne '..' } readdir DIR;
        closedir DIR;
    }
    return @ret;
}
END_OF_SUB


sub is_tainted { return ! eval { my $no_warn = join('',@_), kill 0; 1; } }

1;

__END__

=head1 NAME

GT::File::Tools - Export tools for dealing with files

=head1 SYNOPSIS

    use GT::File::Tools qw/:all/;
    
    # Find all files in a users home directory.
    find "/home/user", sub { print shift };
    
    # Rename a file1 to file2.
    move "file1", "file2";

    # Remove a list of files.
    del @files;

    # Remove a users home directory
    deldir "/home/foo";

    # Copy a file
    copy "file1", "file2";

    # Recursively copy a directory.
    copy "/home/user", "/home/user.bak";

    # Recursively make a directory.
    mkpath "/home/user/www/cgi-bin", 0755;

    # Parse a filename into directory, file and is_relative components
    my ($dir, $file, $is_rel) = parsefile("/home/foo/file.txt");

    # Get the file portion of a filename
    my $file = basename("/home/foo/file.txt");

    # Get the directory portion of a filename.
    my $dir = dirname("/home/foo/file.txt");

    # Use shell like expansion to get a list of absolute files.
    my @src = expand("*.c", "*.h");

=head1 DESCRIPTION

GT::File::Tools is designed to export requested functions into your namespace.
These function perform various file operations.

=head1 FUNCTIONS

GT::File::Tools exports functions to your namespace. Here is a list of the
functions you can request to be exported.

=head2 find

C<find> takes three parameters: directory to search in, callback to run for
each file and/or directory found, and a hash ref of options. B<Note>: this is
the opposite order of File::Find's find() function! The following options
can be passed set:

=over 4

=item globbing

Expand filenames in the same way as the unix shell:

    find("/home/a*", sub { print shift; }, { globbing => 1 });

would fine all home directories starting with the letter a. This option is 
off by default.

=item error_handler

A code ref that is run whenever find encounters an error. If the callback 
returns 0, find will stop immediately, otherwise find will continue 
searching (default).

=item no_chdir

By default, find will chdir into the directories it is searching as
this results in a dramatic performance improvement. Upon completion, find
will chdir back to the original directory. This behavior is on by default.

=item dirs_first

This option controls the order find traverses. It defaults on, and means 
find will go down directories first before looking at files. This is 
essential for recursively deleting a directory.

=item files_only

This option tells find to run the callback only for each file found
and not for each directory. Off by default.

=item dirs_only

This option tells find to run the callback only for each directory found
and not for each file. Off by default.

=item max_depth

Defaults to 1000, this option controls how deep a directory structure find
will traverse. Meant mainly as a safety, and should not need to be adjusted.

=back

=head2 move

C<move> has the same syntax as the system mv command:

    move 'file', 'file2';
    move 'file1', 'file2', 'dir';
    move 'file1', 'file2', 'dir3', 'dir';
    move '*.c', 'dir', { globbing => 1 };

The only difference is the last argument can be a hash ref of options. The 
following options are allowed:

=over 4

=item globbing 

=item error_handler

=item max_depth

=back

=head2 del

C<del> has the same syntax as the rm system command, but it can not remove
directories. Use C<deldir> below to recursively remove files.

    del 'file1';
    del '*.c', { globbing => 1 };
    del 'a', 'b', 'c';

It takes a list of files or directories to delete, and an optional hash ref 
of options. The following options are allowed:

=over 4

=item error_handler

=item globbing

=back

=head2 deldir

C<deldir> is similiar to C<del>, but allows recursive deletes of directories:

    deldir 'file1';
    deldir 'dir11', 'dir2', 'dir3';
    deldir '/home/a*', { globbing => 1 };

It takes a list of files and/or directories to remove, and an optional hash ref
of options. The following options are allowed:

=over 4

=item error_handler

=item globbing

=item max_depth

=back

=head2 copy

C<copy> is similiar to the system cp command:

    copy 'file1', 'file2';
    copy 'file1', 'file2', 'file3', 'dir1';
    copy '*.c', '/usr/local/src', { globbing => 1 };
    copy 

It copies a source file to a destination file or directory. You can also 
specify multiple source files, and copy them into a single directory. The 
last argument should be a hash ref of options:

=over 4

=item set_perms

This option will preserve permissions. i.e.: if the original file is set 755,
the copy will also be set 755. It defaults on.

=item set_owner

This option will preserver file ownership. Note: you must be root to be able
to change ownerhsip of a file. This defaults off.

=item set_time

This option will preserve file modification time.

=item preserve_all

This option sets set_perms, set_owner and set_time on.

=item error_handler

=item globbing

=item max_depth

=back

=head2 mkpath

C<mkpath> recursively makes a directory. It takes the same arguments as 
perl's mkdir():

    mkpath("/home/alex/create/these/dirs", 0755) or die "Can't mkpath: $!";

For compatibility with older module versions, rmkdir() is an alias for
mkpath().

=head2 parsefile

This function takes any type of filename (relative, fullpath, etc) and 
returns the inputs directory, file, and whether it is a relative path or
not. For example:

    my ($directory, $file, $is_relative) = parsefile("../foo/bar.txt");

=head2 dirname

Returns the directory portion of a filename.

=head2 basename

Returns the last portion of a filename (typically, the filename itself without
any leading directory).  A deprecated C<filename()> alias for basename() also
exists.

=head2 expand

Uses shell like expansion to expand a list of filenames to full paths. For 
example:

    my @source   = expand("*.c", "*.h");
    my @homedirs = expand("/home/*");

If you pass in relative paths, expand always returns absolute paths of 
expanded files. B<Note>: this does not actually go to the shell.

=head1 SEE ALSO

This module depends on perl's Cwd module for getting the current working
directory. It also uses GT::AutoLoader to load on demand functions.

=head1 MAINTAINER

Scott Beck

=head1 COPYRIGHT

Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
http://www.gossamer-threads.com/

=head1 VERSION

Revision: $Id: Tools.pm,v 1.64 2007/02/10 17:45:41 sbeck Exp $

=cut