File-NCopy-0.36/ 40777 0 0 0 10722642445 6374 5File-NCopy-0.36/Changes100666 0 0 4221 10722642311 7673 Revision history for Perl extension File::NCopy. 0.36 Nov 26 2007 by Alexandr Ciornii - perl 5.5 compatibility in tests 0.35 Apr 14 2007 by Alexandr Ciornii - Marked distribution as deprecated - Added Readme 0.34_01 Apr 01 2007 by Alexandr Ciornii - better distribution - some small fixes - Added file 'Contributing.txt' - Request in Makefile.PL - test moved to t/, use strict - pod.t 0.34 Thu Apr 24 15:33:00 2003 by MZSANFORD - Added more File::Spec usage - Added a note in BUGS from Ken Healy - Fixed "preserve" option (thanks again Ken) 0.33 Mon May 20 00:00:00 2002 by MZSANFORD - Added version that uses File::Spec to make portable. - Added some basic tests - Added additional debug statements - tested code on Win32 0.32 Thu Jun 25 17:45:04 1998 - Added force-write option. Fixed a bug which kept the module working when not used in OO mode. Fixed lack of directory creation when encountering an empty directory. Added debug option and more debugging info printed. 0.31 Fri May 15 17:08:23 1998 - Changed the POSIX module to Cwd since it's more portable to non-Unix systems. 0.30 Fri Apr 18 23:13:47 1998 - Added the follow_links attribute so that links are now followed if the attribute is set. I also fixed the way symlinks are set, the previous behaviour wasn't the most desirable. 0.20 Tue Apr 15 23:30:24 1998 - Quite a few new features. You can now use it as an object oriented module with a few new attributes. Also it the first argument is a scalar reference and it's used as a straight forward module the scalar will be the value of the recursive flag. If copying a directory with the recursive flag non-zero then the directory is recursively copied over. There are several other new features. 0.12 Tue Apr 14 15:49:40 1998 - Set the file permissons and directory permissions to the same as we are copying from. 0.11 Mon Apr 13 16:37:30 1998 - Changed the return values to successes rather than failures since it makes more sense. 0.10 Fri Apr 10 22:29:41 1998 - original version File-NCopy-0.36/Contributing.txt100666 0 0 717 10603722546 11605 If you want better support for older Perls, use Test::Reporter. CPAN::Reporter is also required if you are using CPAN shell. Also you can run cpan smoking. That way module can be fixed even before you'll find that you need it. See CPAN::YACSmoke. Generally, you should use Test::Reporter - it's the only way to measure popularity of distribution. Why do anything with it, if it is not used. Patches welcome. Please write tests for error you found. File-NCopy-0.36/lib/ 40777 0 0 0 10722642442 7137 5File-NCopy-0.36/lib/File/ 40777 0 0 0 10722642442 10016 5File-NCopy-0.36/lib/File/NCopy.pm100666 0 0 45562 10722642376 11463 package File::NCopy; use 5.004; # just because I think you should upgrade :) =head1 NAME File::NCopy - Deprecated module. Use File::Copy::Recursive instead. Copy file, file. Copy file[s] | dir[s], dir =head1 SYNOPSIS use File::NCopy qw(copy); copy "file","other_file"; copy "file1","file2","file3","directory"; # we want to copy the directory recursively copy \1,"directory1","directory2"; copy \1,"file1","file2","directory1","file3","directory2","file4", "directory"; # can also use references to file handles, this is for backward # compatibility with File::Copy copy \*FILE1,\*FILE2; copy \*FILE1,"file"; copy "file1",\*FILE2; # we don't specify \1 as the first argument because we don't want to # copy directories recursively copy "*.c","*.pl","programs"; copy "*", "backup"; use File::NCopy; # the below are the default config values $file = File::NCopy->new( 'recursive' => 0, 'preserve' => 0, 'follow_links' => 0, 'force_write' => 0, 'set_permission' => \&File::NCopy::u_chmod, 'file_check' => \&File::NCopy::f_check, 'set_times' => \&File::NCopy::s_times, ); set_permission will take two file names, the original to get the file permissions from and the new file to set the file permissions for. file_check takes two parameters, the file names to check the file to copy from and the file to copy to. I am using flock for Unix systems. Default for this is \&File::NCopy::f_check. On Unix you can also use \&File::NCopy::unix_check. This one compares the inode and device numbers. set_times is used if the preserve attribute is true. It preserves the access and modification time of the file and also attempts to set the owner of the file to the original owner. This can be useful in a script used by root, though enyone can preserve the access and modification times. This also takes two arguments. The file to get the stats from and apply the stats to. On Unix boxes you shouldn't need to worry. On other system you may want to supply your own sub references. $file = File::NCopy->new(recursive => 1); $file->copy "file","other_file"; $file->copy "directory1","directory2"; $file = File::NCopy->new(u_chmod => \&my_chmod,f_check => \&my_fcheck); $file->copy "directory1","directory2"; =head1 DESCRIPTION B copies files to directories, or a single file to another file. You can also use a reference to a file handle if you wish whem doing a file to file copy. The functionality is very similar to B. If the argument is a directory to directory copy and the recursive flag is set then it is done recursively like B. In fact it behaves like cp on Unix for the most part. If called in array context, an array of successful copies is returned, otherwise the number of succesful copies is returned. If passed a file handle, it's difficult to make sure the file we are copying isn't the same that we are copying to, since by opening the file in write mode it gets pooched. To avoid this use file names instead, if at all possible, especially for the to file. If passed a file handle, it is not closed when copy returns, files opened by copy are closed. =over 4 =item B Copies a file to another file. Or a file to a directory. Or multiple files and directories to another directory. Or a directory to another directory. Wildcard arguments are expanded, except for the last argument which should not be expanded. The file and directory permissions are set to the orginating file's permissions and if preserve is set the access and modification times are also set. If preserve is set then the uid and gid will also be attempted to be set, though this may only for for the men in white hats. In list context it returns all the names of the files/directories that were successfully copied. In scalar context it returns the number of successful copies made. A directory argument is considerd a single successful copy if it manages to copy anything at all. To make a directory to directory copy the recursive flag must be set. =item B Just calls copy. It's there to be compatible with File::Copy. =item B If used then you can treat this as an object oriented module with some configuration abilities. =item B If used as an object then you can use this to set the recursive attribute. It can also be set when instantiating with new. The other attributes must all be set when instantiating the object. If it isn't specified then directories are not followed. =item B Attempt to preserve the last modification and access time as well as user and group id's. This is a useful feature for sysadmins, though the access and modification time should always be preservable, the uid and gid may not. =item B If the link is to a directory and this attribute is true then the directory is followed and recursively copied. Otherwise a link is made to the root directory the link points to. eg. /sys/ is a link to /usr/src/sys/ is a link to /usr/src/i386/sys then the link /sys/ is actually created in the source directory as a link to /usr/src/i386/sys/ rather than /usr/src/sys/ since if the link /usr/src/sys/ is removed then we lost the link even though the directory we originally intended to link to still exists. =item B Force the writing of a file even if the permissions are read only on it. =back =head1 EXAMPLE See SYNOPSIS. =head1 BUGS When following links the target directory might not exactly the same as the source directory. The reason is that we have to make sure we don't follow circular or dead links. This is really a feature though the result may not quite resemble the source dir, the overall content will be the same. :) From Ken Healy (Version 0.34) On Win32, The use of backslash for paths is required. =head1 AUTHOR Gabor Egressy B Copyright (c) 1998 Gabor Egressy. All rights reserved. All wrongs reversed. This program is free software; you can redistribute and/or modify it under the same terms as Perl itself. Some ideas gleaned from File::Copy by Aaron Sherman & Charles Bailey, but the code was written from scratch. Patch at versions 0.33, and 0.34 added by MZSANFORD. 0.35, 0.36 - Alexandr Ciornii (alexchorny AT gmail.com) =cut use Cwd (); use File::Spec; use strict; use vars qw(@EXPORT_OK @ISA $VERSION); @ISA = qw(Exporter); # we export nothing by default :) @EXPORT_OK = qw(copy cp); $VERSION = '0.36'; # this works on Unix sub u_chmod($$) { my ($file_from,$file_to) = @_; my ($mode) = (stat $file_from)[2]; chmod $mode & 0777,$file_to unless ref $file_to eq 'GLOB' || ref $file_to eq 'FileHandle'; 1; } # this also works on Unix sub f_check($$) { my ($file_from,$file_to) = @_; # get a shared lock on file to copy from flock $file_from,5 or return 0; # try and get an exclusive lock on the file to copy to flock $file_to,6 or do { flock $file_from,8; return 0; }; flock $file_from,8; flock $file_to,8; 1; } # this also works on Unix, it's not the default but you can easily use # it by using the module in an object oriented way # $copy = File::NCopy->new('file_check' => \&File::NCopy::unix_check); sub unix_check($$) { my ($file_from,$file_to) = @_; my ($fdev,$fino) = (stat $file_from)[0,1]; my ($tdev,$tino) = (stat $file_to)[0,1]; return 0 if $fdev == $tdev && $fino == $tino; 1; } sub s_times($$) { my ($file_from,$file_to) = @_; my ($uid,$gid,$atime,$mtime) = (stat $file_from)[4,5,8,9]; utime $atime,$mtime,$file_to unless ref $file_to eq 'GLOB' || ref $file_to eq 'FileHandle'; # this may only work for men in white hats; on Unix chown $uid,$gid,$file_to unless ref $file_to eq 'GLOB' || ref $file_to eq 'FileHandle'; 1; } # all the actual copying is done here, folks ;) sub _docopy_file_file($$$) { my $this = shift; my ($file_from,$file_to) = @_; local (*FILE_FROM,*FILE_TO); my ($was_handle); # did we get a file handle ? unless(ref $file_from eq 'GLOB' || ref $file_from eq 'FileHandle') { open FILE_FROM,"<$file_from" or do { print "*** Couldn\'t open from file <$!> ==> $file_from\n" if $this->{'_debug'}; return 0; }; } else { *FILE_FROM = *$file_from; } unless(ref $file_to eq 'GLOB' || ref $file_to eq 'FileHandle') { # we must open in update mode since on some systems exclusive # locks are only granted to files that are going to be written; open FILE_TO,"+<$file_to" or goto NO_FILE; # no file, so file can't be the same :) } else { *FILE_TO = *$file_to; $was_handle = 1; } unless(-t FILE_FROM || -t FILE_TO) { $this->{'file_check'}->(\*FILE_FROM,\*FILE_TO) or return 0; } NO_FILE: # files aren't the same; now open for writing unless we got a # filehandle if(! $was_handle && ! $this->{test}) { open FILE_TO,">$file_to" or chmod 0644, "$file_to" if $this->{'force_write'}; open FILE_TO,">$file_to" or do { print "*** Couldn\'t open to file <$!> ==> $file_to\n" if $this->{'_debug'}; return 0; }; } # and now for the braindead OS's binmode FILE_FROM unless ($this->{test}); binmode FILE_TO unless ($this->{test}); my $buf = ''; my ($len,$write_n); # read file and write to new file, recover from write errors and # read errors; we accept however much we read and try to write it # 8K is a nice buffer size for most file systems while(! $this->{test} && 1) { $len = sysread(FILE_FROM,$buf,8192); return 0 unless defined $len; last unless $len > 0; while($len) { $write_n = syswrite(FILE_TO,$buf,$len); return 0 unless defined $write_n; $len -= $write_n; } } $this->{'set_permission'}->($file_from,$file_to); # we only close files we opened unless ($this->{test}) { close FILE_FROM unless ref $file_from eq 'GLOB' || ref $file_from eq 'FileHandle'; close FILE_TO unless ref $file_to eq 'GLOB' || ref $file_to eq 'FileHandle'; } # this was moved from above the unless statement per Ken Healy in version 0.34 $this->{'set_times'}->($file_from,$file_to) if $this->{'preserve'}; print "$file_from ==> $file_to\n" if $this->{'_debug'}; 1; } sub get_path($) { my $dir = shift; my $save_dir = Cwd::cwd; chdir $dir or return undef; $dir = Cwd::cwd; chdir $save_dir; return $dir; } sub _recurse_from_dir($$$); # we never actually change the directory :) sub _recurse_from_dir($$$) { my $this = shift; my ($from_dir,$to_dir) = @_; local (*DIR); # MZS - v0.39 - Changed from slash to File::Spec; my $dir_sep = File::Spec->catfile('a','b'); $dir_sep =~ s/^a(.+)b$/$1/; opendir DIR,$from_dir or do { print "*** Couldn\'t opendir <$!> ==> $from_dir\n" if $this->{'_debug'}; return 0; }; my @files = readdir DIR or do { print "*** Couldn\'t read dir <$!> ==> $from_dir\n" if $this->{'_debug'}; return 0; }; closedir DIR; my $made_dir; unless(-e $to_dir && ! $this->{test}) { mkdir $to_dir,0777 or return 0; $made_dir = 1; } my ($retval,$ret,$link,$save_link); # make sure we don't end up with a recursive, circular link # this isn't totally foolproof, though it does prevent circular # links if($this->{'follow_links'}) { if(defined($save_link = get_path $from_dir)) { $this->{'_links'}->{$save_link} = 1; } } for (@files) { next if /^\.\.?$/; if(-f $from_dir . $dir_sep . $_) { $ret = _docopy_file_file $this, $from_dir . $dir_sep . $_ , $to_dir . $dir_sep . $_; } elsif(-d "$from_dir$dir_sep$_") { if($this->{'follow_links'} && -l "$from_dir$dir_sep$_") { $link = get_path "$from_dir$dir_sep$_"; } if(! -l "$from_dir$dir_sep$_" || $this->{'follow_links'} && defined $link && ! exists $this->{'_links'}->{$link}) { $ret = _recurse_from_dir $this,$from_dir . $dir_sep . $_ ,$to_dir . $dir_sep . $_; } else { if(defined($link = get_path "$from_dir$dir_sep$_")) { $ret = symlink $link, "$to_dir$dir_sep$_"; } } } $retval = $retval || $ret; } if($made_dir) { $this->{'set_permission'}->($from_dir,$to_dir); $this->{'set_times'}->($from_dir,$to_dir) if $this->{'preserve'}; } # remove the name so that there can be link to it from other dirs # that are not subdirs of this one if($this->{'follow_links'}) { delete $this->{'_links'}->{$save_link}; } return $retval; } sub _docopy_dir_dir($$$) { my $this = shift; my ($dir_from,$dir_to) = @_; my ($from_name); # MZS - v0.39 - Changed from slash to File::Spec; my $dir_sep = File::Spec->catfile('a','b'); $dir_sep =~ s/^a(.+)b$/$1/; $dir_from =~ s/$dir_sep$//; # remove trailing slash, if any if($dir_from =~ tr/$dir_sep//) { $from_name = substr $dir_from,rindex($dir_from,$dir_sep) + 1; } else { $from_name = $dir_from; if($from_name =~ /^\.\.?$/) { $from_name = ''; } } unless($dir_to =~ /$dir_sep$/) { $dir_to .= $dir_sep; } $dir_to .= $from_name; $this->{'_links'} = {}; _recurse_from_dir $this, $dir_from,$dir_to; } sub _docopy_file_dir($$$) { my $this = shift; my ($file,$dir) = @_; my $file_to; # MZS - v0.39 - Changed from slash to File::Spec; my $dir_sep = File::Spec->catfile('a','b'); $dir_sep =~ s/^a(.+)b$/$1/; if($file =~ tr/$dir_sep//) { $file_to = substr $file,rindex($file,$dir_sep) + 1; } else { $file_to = $file; } $dir =~ s/$dir_sep$//; # remove trailing slash _docopy_file_file $this, $file,$dir.$dir_sep.$file_to; } # this just redirects calls, like copy ;) sub _docopy_files_dir($$@) { my $this = shift; my $copies = shift; my $dir = pop; for (@_) { if(-d $_ && $this->{'recursive'}) { if ($this->{test}) { push @$copies, $_; } else { _docopy_dir_dir $this, $_, $dir and push @$copies, $_; } } elsif(-f $_) { if ($this->{test}) { push @$copies, $_; } else { _docopy_file_dir $this, $_, $dir and push @$copies, $_; } } } 1; } # does glob work on all systems? sub expand(@) { my @args; return if @_ < 2; for (my $i = 0;$i < $#_;++$i) { push @args,glob $_[$i]; } push @args,$_[$#_]; @args; } sub new(@); #prototype # this just redirects calls sub copy(@) { my $this; # were we called through an object reference? if(ref $_[0] eq 'File::NCopy') { $this = shift; } else { # no, so let's make one $this = new File::NCopy; if(ref $_[0] eq 'SCALAR') { my $rec = shift; $this->recursive($$rec); } } my @copies; my @args = expand @_; print "passed args ==> ".join(',',map {"'$_'"} @args)."\n" if $this->{'_debug'}; # one or more files/directories to a directory if(@args >= 2 && -d $args[$#args]) { print "Copy to dir started.\n" if ($this->{'_debug'}); _docopy_files_dir $this, \@copies, @args; } # file to file elsif(@args == 2 && -f $args[0]) { if ($this->{test}) { push @copies, $args[0]; } else { _docopy_file_file $this, $args[0],$args[1] and push @copies, $args[0]; } } @copies; } sub cp(@) { return copy @_; } # instantiate our object sub new(@) { my $this = shift; my $conf = { 'test' => 0, 'recursive' => 0, 'preserve' => 0, 'follow_links' => 0, 'force_write' => 0, '_debug' => 0, 'set_permission' => \&File::NCopy::u_chmod, 'file_check' => \&File::NCopy::f_check, 'set_times' => \&File::NCopy::s_times, '_links' => {}, }; my $ref; if(@_ % 2 == 0) { my %ref = @_; $ref = \%ref; } elsif(ref $_[0] eq 'HASH') { $ref = shift; } if(ref $ref eq 'HASH') { $conf->{'test'} = abs int $ref->{'test'} if defined $ref->{'test'}; $conf->{'recursive'} = abs int $ref->{'recursive'} if defined $ref->{'recursive'}; $conf->{'preserve'} = abs int $ref->{'preserve'} if defined $ref->{'preserve'}; $conf->{'follow_links'} = abs int $ref->{'follow_links'} if defined $ref->{'follow_links'}; $conf->{'force_write'} = abs int $ref->{'force_write'} if defined $ref->{'force_write'}; $conf->{'_debug'} = abs int $ref->{'_debug'} if defined $ref->{'_debug'}; $conf->{'set_permission'} = $ref->{'set_permission'} if defined $ref->{'set_permission'} && ref $ref->{'set_permission'} eq 'CODE'; $conf->{'file_check'} = $ref->{'file_check'} if defined $ref->{'file_check'} && ref $ref->{'file_check'} eq 'CODE'; $conf->{'set_times'} = $ref->{'set_times'} if defined $ref->{'set_times'} && ref $ref->{'set_times'} eq 'CODE'; } bless $conf,$this; } sub recursive($;$) { return if @_ < 1; my $this = shift; return unless ref $this eq 'File::NCopy'; @_ ? $this->{'recursive'} = abs int shift : $this->{'recursive'}; } sub preserve($;$) { return if @_ < 1; my $this = shift; return unless ref $this eq 'File::NCopy'; @_ ? $this->{'preserve'} = abs int shift : $this->{'preserve'}; } sub follow_links($;$) { return if @_ < 1; my $this = shift; return unless ref $this eq 'File::NCopy'; @_ ? $this->{'follow_links'} = abs int shift : $this->{'follow_links'}; } sub force_write($;$) { return if @_ < 1; my $this = shift; return unless ref $this eq 'File::NCopy'; @_ ? $this->{'force_write'} = abs int shift : $this->{'force_write'}; } 1; File-NCopy-0.36/Makefile.PL100666 0 0 1364 10710556165 10367 use 5.004; use ExtUtils::MakeMaker; print << 'EOT'; *** WARNING *** Deprecated module. Use only if required by other module. You can use File::Copy::Recursive instead. *** REQUEST *** Please use Test::Reporter to report test results - it's the only way to measure popularity of distribution. EOT WriteMakefile( 'NAME' => 'File::NCopy', 'VERSION_FROM' => 'lib/File/NCopy.pm', 'PREREQ_PM' => { 'File::Spec' => 0, 'Test::More'=>0}, ($ExtUtils::MakeMaker::VERSION gt '6.30'? ('LICENSE' => 'perl', ) : ()), ($] >= 5.005 ? ## Add these new keywords supported since 5.005 (ABSTRACT_FROM => './lib/File/NCopy.pm', # retrieve abstract from module AUTHOR => 'Alexandr Ciornii ') : ()), ); File-NCopy-0.36/MANIFEST100666 0 0 167 10603736147 7527 Changes lib/File/NCopy.pm Makefile.PL MANIFEST This list of files META.yml t/test.t t/pod.t Contributing.txt File-NCopy-0.36/META.yml100666 0 0 1052 10722642444 7657 --- #YAML:1.0 name: File-NCopy version: 0.36 abstract: Deprecated module. Use File::Copy::Recursive instead. Copy file, file. Copy file[s] | dir[s], dir license: perl generated_by: ExtUtils::MakeMaker version 6.32 distribution_type: module requires: File::Spec: 0 Test::More: 0 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.2.html version: 1.2 author: - Alexandr Ciornii File-NCopy-0.36/t/ 40777 0 0 0 10722642443 6635 5File-NCopy-0.36/t/pod.t100666 0 0 222 10573122207 7570 #!perl -T use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); File-NCopy-0.36/t/test.t100666 0 0 3131 10711600640 10003 use strict; use Test; use File::Spec; BEGIN { plan tests => 4 }; use File::NCopy 0.35; ok(1); # Loaded # New object my $test = File::NCopy->new(test => 1); ok($test); # Need this later my $dirsep = File::Spec->catfile('a','b'); $dirsep =~ s!a(.+)b$!$1!; my $rdirsep = ($dirsep eq '\\' ? '\\\\' : $dirsep ); # Test Defaults ok($test->{recursive} == 0 && $test->{preserve} == 0 && $test->{follow_links} == 0 && $test->{force_write} == 0); my $tmp_dir = File::Spec->tmpdir(); my $path = File::Spec->catfile($tmp_dir,'test_ncpy_inst'); mkdir $path,0777 unless (-e $path); #perl 5.5 requires both arguments to mkdir $test->{recursive} = 1; my @files = $test->copy($tmp_dir,$path); if ((scalar(@files) == 0)) { # Skip, no files to test with skip(1,0); } else { my $done = 0; foreach my $path (@files) { # Remove a leading one, if it has it if (index($path,$dirsep) == 0) { $path = substr($path,(length($path) - length($path) - 1),(length($path) - 1)); } my @parts = split(/$rdirsep/,$path); if (@parts > 0) { # it should contain a seperator $done = 1; if (index($path,$dirsep)) { # it has some in it. ok(1); $done = 1; } else { # this is bad. warn "Path '$path' (".scalar(@parts)." parts) did not contain a separator\n"; ok(0); $done = 1; } } else { # no seperator, try next one; next; } if ($done) { last; } } if (! $done) { ok(0); } }