1508 lines
45 KiB
Perl
1508 lines
45 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::File::Tools
|
|
# Author : Scott Beck
|
|
# CVS Info :
|
|
# $Id: Tools.pm,v 1.61 2005/05/13 01:48:23 jagerman 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
|
|
/;
|
|
$REGEX = '^([^\0]+)$';
|
|
|
|
use bases 'GT::Base' => '';
|
|
|
|
use Cwd;
|
|
require Exporter;
|
|
use GT::AutoLoader;
|
|
$VERSION = sprintf "%d.%03d", q$Revision: 1.61 $ =~ /(\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;
|
|
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, "/") ) = ""
|
|
unless $opts->{no_chdir};
|
|
}
|
|
next;
|
|
}
|
|
if ($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.61 2005/05/13 01:48:23 jagerman Exp $
|
|
|
|
=cut
|
|
|