r75999 - in /branches/upstream/libfile-ncopy-perl: ./ current/ current/Changes current/MANIFEST current/Makefile.PL current/lib/ current/lib/File/ current/lib/File/NCopy.pm current/test.pl
gregoa at users.alioth.debian.org
gregoa at users.alioth.debian.org
Sat Jun 18 20:18:36 UTC 2011
Author: gregoa
Date: Sat Jun 18 20:18:32 2011
New Revision: 75999
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=75999
Log:
[svn-inject] Installing original source of libfile-ncopy-perl (0.34)
Added:
branches/upstream/libfile-ncopy-perl/
branches/upstream/libfile-ncopy-perl/current/
branches/upstream/libfile-ncopy-perl/current/Changes
branches/upstream/libfile-ncopy-perl/current/MANIFEST
branches/upstream/libfile-ncopy-perl/current/Makefile.PL
branches/upstream/libfile-ncopy-perl/current/lib/
branches/upstream/libfile-ncopy-perl/current/lib/File/
branches/upstream/libfile-ncopy-perl/current/lib/File/NCopy.pm
branches/upstream/libfile-ncopy-perl/current/test.pl
Added: branches/upstream/libfile-ncopy-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-ncopy-perl/current/Changes?rev=75999&op=file
==============================================================================
--- branches/upstream/libfile-ncopy-perl/current/Changes (added)
+++ branches/upstream/libfile-ncopy-perl/current/Changes Sat Jun 18 20:18:32 2011
@@ -1,0 +1,47 @@
+Revision history for Perl extension File::NCopy.
+
+0.34 Thur Apr 24 15:33:00 2003
+ - MZSANFORD Added more File::Spec usage
+ - MZSANFORD Added a note in BUGS from Ken Healy
+ - MZSANFORD Fixed "preserve" option (thanks again Ken)
+
+0.33 Mon May 20 00:00:00 2002
+ - MZSANFORD Added version that uses File::Spec to make portable.
+ - MZSANFORD Added some basic tests
+ - MZSANFORD Added additional debug statements
+ - MZSANFORD 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
Added: branches/upstream/libfile-ncopy-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-ncopy-perl/current/MANIFEST?rev=75999&op=file
==============================================================================
--- branches/upstream/libfile-ncopy-perl/current/MANIFEST (added)
+++ branches/upstream/libfile-ncopy-perl/current/MANIFEST Sat Jun 18 20:18:32 2011
@@ -1,0 +1,5 @@
+Changes
+lib/File/NCopy.pm
+MANIFEST
+Makefile.PL
+test.pl
Added: branches/upstream/libfile-ncopy-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-ncopy-perl/current/Makefile.PL?rev=75999&op=file
==============================================================================
--- branches/upstream/libfile-ncopy-perl/current/Makefile.PL (added)
+++ branches/upstream/libfile-ncopy-perl/current/Makefile.PL Sat Jun 18 20:18:32 2011
@@ -1,0 +1,8 @@
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ 'NAME' => 'File::NCopy',
+ 'VERSION_FROM' => './lib/File/NCopy.pm',
+ 'PREREQ_PM' => { 'File::Spec' => 0 },
+);
Added: branches/upstream/libfile-ncopy-perl/current/lib/File/NCopy.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-ncopy-perl/current/lib/File/NCopy.pm?rev=75999&op=file
==============================================================================
--- branches/upstream/libfile-ncopy-perl/current/lib/File/NCopy.pm (added)
+++ branches/upstream/libfile-ncopy-perl/current/lib/File/NCopy.pm Sat Jun 18 20:18:32 2011
@@ -1,0 +1,695 @@
+package File::NCopy;
+require 5.004; # just because I think you should upgrade :)
+
+=head1 NAME
+
+B<File::NCopy> - 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<File::NCopy::copy> 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<cp>. If the argument is a directory to directory copy and the
+recursive flag is set then it is done recursively like B<cp -R>.
+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<copy>
+
+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<cp>
+
+Just calls copy. It's there to be compatible with File::Copy.
+
+=item B<new>
+
+If used then you can treat this as an object oriented module with some
+configuration abilities.
+
+=item B<recursive>
+
+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<preserve>
+
+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<follow_links>
+
+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_write>
+
+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<gabor at vmunix.com>
+
+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.
+
+=cut
+
+use Cwd ();
+use File::Spec;
+use strict;
+use vars qw(@EXPORT_OK @ISA $VERSION);
+ at ISA = qw(Exporter);
+# we export nothing by default :)
+ at EXPORT_OK = qw(copy cp);
+
+$VERSION = '0.34';
+
+# 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;
+
+ $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};
+ }
+
+ $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(@);
+
+# 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 ==> @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;
Added: branches/upstream/libfile-ncopy-perl/current/test.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-ncopy-perl/current/test.pl?rev=75999&op=file
==============================================================================
--- branches/upstream/libfile-ncopy-perl/current/test.pl (added)
+++ branches/upstream/libfile-ncopy-perl/current/test.pl Sat Jun 18 20:18:32 2011
@@ -1,0 +1,70 @@
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+#########################
+
+# change 'tests => 1' to 'tests => last_test_to_print';
+
+use Test;
+use File::Spec;
+BEGIN { plan tests => 4 };
+use File::NCopy;
+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!;
+$rdirsep = ($dirsep eq '\\' ? '\\\\' : $dirsep );
+
+# Test Defaults
+ok($test->{recursive} == 0 && $test->{preserve} == 0 && $test->{follow_links} == 0 && $test->{force_write} == 0);
+
+$tmp_dir = File::Spec->tmpdir();
+$path = File::Spec->catfile($tmp_dir,'test_ncpy_inst');
+mkdir $path unless (-e $path);
+$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 = scalar(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' ($parts parts) did not contain a seperator\n";
+ ok(0);
+ $done = 1;
+ }
+ } else {
+ # no seperator, try next one;
+ next;
+ }
+ if ($done) {
+ last;
+ }
+ }
+ if (! $done) {
+ ok(0);
+ }
+}
+
+
+
+
More information about the Pkg-perl-cvs-commits
mailing list