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