| Current File : //var/wcp4/demo1812/public_html/file/private/lib/GT/File/Tools.pm |
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::File::Tools
# Author : Scott Beck
# $Id: Tools.pm,v 1.38 2002/05/24 18:31:32 alex Exp $
#
# Copyright (c) 2000 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
/;
use bases 'GT::Base' => '';
use Cwd;
use Exporter;
use GT::AutoLoader;
$VERSION = sprintf "%d.%03d", q$Revision: 1.38 $ =~ /(\d+)\.(\d+)/;
# Exporter variables
@EXPORT_OK = qw/
copy
move
del
deldir
find
rmkdir
parsefile
filename
dirname
expand
/;
%EXPORT_TAGS = ( all => \@EXPORT_OK );
*import = \&Exporter::import;
# Options
$MAX_DEPTH = 1000;
$GLOBBING = 0;
$NO_CHDIR = 0;
$MAX_READ = 1024 * 64;
$DEBUG = 0;
$ERRORS = {
UNLINK => "Could not unlink %s; Reason: %s",
RMDIR => "Could not rmdir %s; Reason: %s",
MOVE => "Could not move %s to %s; Reason: %s",
RENAME => "Could not rename %s to %s; Reason: %s",
SYMLINK => "Could not symlink %s to %s; Reason: %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; Reason: %s",
READOPEN => "Could not open %s for reading; Reason: %s",
WRITEOPEN => "Could not open %s for writing; Reason: %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 = pop if ref $_[$#_] eq 'HASH';
$opts = {} unless defined $opts;
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 @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
}
) or return;
next;
}
if ( -d $to_file ) {
$to_file = $to . '/' . filename( $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
}
) 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;
$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 .= filename( $from ) if -d $to;
# Try the easy way out first
return 1 if rename $from, $to;
my $cwd;
if ( ( parsefile( $from ) )[2] ) {
$cwd = getcwd;
$from = "$cwd/$from";
}
if ( ( parsefile( $to ) )[2] ) {
$cwd ||= getcwd;
$to = "$cwd/$to";
}
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,
}
);
}
END_OF_SUB
$COMPILE{del} = __LINE__ . <<'END_OF_SUB';
sub del {
# ----------------------------------------------------------------------------
my $class = 'GT::File::Tools';
my $opts = pop if ref $_[$#_] eq 'HASH';
$opts = {} unless defined $opts;
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;
$class->fatal(
BADARGS => "Unknown option " . ( join ", ", keys %$opts )
) if keys %$opts;
for my $path ( @files ) {
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 = pop if ref $_[$#_] eq 'HASH';
$opts = {} unless defined $opts;
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;
$class->fatal(
BADARGS => "Unknown option " . ( join ", ", keys %$opts )
) if keys %$opts;
for my $dir ( @dirs ) {
$class->fatal( BADARGS => "$dir is not a directory" )
if -e $dir and !-d _;
next if !-e _ and !-l $dir;
$dir .= '/' unless $dir =~ m,/\Z,;
# Try the easy way out first
next if rmdir $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,
}
);
}
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 = pop if ref $_[$#_] eq 'HASH';
$opts = {} unless defined $opts;
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 @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,
%preserve_opts
});
next;
}
if ( -d $to_file ) {
$to_file = $to . '/' . filename( $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;
}
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 $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 .= filename( $from ) if -d $to;
my $cwd;
if ( ( parsefile( $from ) )[2] ) {
$cwd = getcwd;
$from = "$cwd/$from";
}
if ( ( parsefile( $to ) )[2] ) {
$cwd ||= getcwd;
$to = "$cwd/$to";
}
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, %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 ) {
( 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,
}
)
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,
}
);
}
END_OF_SUB
$COMPILE{filename} = __LINE__ . <<'END_OF_SUB';
sub filename {
# ----------------------------------------------------------------------------
return ( parsefile( $_[0] ) )[1];
}
END_OF_SUB
$COMPILE{dirname} = __LINE__ . <<'END_OF_SUB';
sub dirname {
# ----------------------------------------------------------------------------
return ( parsefile( $_[0] ) )[0];
}
END_OF_SUB
$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;
return ( $new_path, $file, $relative );
}
END_OF_SUB
$COMPILE{rmkdir} = __LINE__ . <<'END_OF_SUB';
sub rmkdir {
my ($full_path, $perms) = @_;
my ($path, $target, $is_relative) = parsefile($full_path);
GT::File::Tools->fatal(BADARGS => 'You can not pass a relative path to rmkdir')
if $is_relative;
my @tomake = (split(m|/|, $path), $target);
my $cwd = getcwd;
my $err = sub {
my $bang = 0+$!;
chdir $cwd;
$! = $bang;
return;
};
chdir '/' or return $err->();
for (@tomake) {
next unless length;
if (!-d $_) {
mkdir $_, 0777 or return $err->();
if (defined $perms) {
chmod $perms, $_ or return $err->();
}
}
chdir $_ or return $err->();
}
chdir $cwd or return $err->();
return 1;
}
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 = pop if ref $_[$#_] eq 'HASH';
$opts = {} unless defined $opts;
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 $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 ) {
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 = getcwd;
}
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,
dirs_only => $dirs_only
}) or do {
chdir $cwd;
return;
};
};
chdir $cwd unless $no_chdir;
die "$@\n" if $@;
}
return 1;
}
END_OF_SUB
$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->{dirs_first} and !$opts->{files_only} ) {
$callback->( $$file ) or return;
}
$depth-- if $opts->{max_depth};
unless ( $opts->{no_chdir} ) {
chdir "..";
substr( $path, rindex($path, "/") ) = ""
unless $opts->{no_chdir};
}
next;
}
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 ) {
next unless -e _;
local *DIR;
$depth++;
my @new_files;
if ( $opts->{no_chdir} ) {
if ( opendir DIR, $file ) {
@new_files =
map { s,/\Z,,; $opts->{no_chdir} ? "$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;
}
if ( $opts->{dirs_first} and !$opts->{files_only} ) {
$callback->( $opts->{no_chdir} ? $file : $path ) or return;
}
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 ||= getcwd;
($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
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.
rmkdir "/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 = filename("/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 rmkdir
C<rmkdir> recursively makes a directory. It takes the same arguments as
perl's mkdir():
rmkdir("/home/alex/create/these/dirs", 0755) or die "Can't rmkdir: $!";
=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 filename
Returns the file portion of a filename.
=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) 2002 Gossamer Threads Inc. All Rights Reserved.
http://www.gossamer-threads.com/
=head1 VERSION
Revision: $Id: Tools.pm,v 1.38 2002/05/24 18:31:32 alex Exp $
=cut