Add File::Compare

Subject: Re: Does File::Copy work as expected?

Nick Ing Simmons <Nick.Ing-Simmons@tiuk.ti.com> writes:
>I started on File::Compare and decided I wanted it 
>to work on open handles (e.g. pipes) as well as named files.
>So I have 'glommed' File::Copy as skeleton and re-plumbed
>the inner loop.
>

Please test.

p5p-msgid: <199612161844.SAA02152@pluto>

2 files changed, 293 insertions, 0 deletions

diff --git a/lib/File/Compare.pm b/lib/File/Compare.pm
new file mode 100644
index 0000000000..12d97e703b
--- /dev/null
+++ b/lib/File/Compare.pm
@@ -0,0 +1,100 @@
+package File::Compare;
+
+require Exporter;
+use Carp;
+use UNIVERSAL qw(isa);
+
+@ISA=qw(Exporter);
+@EXPORT=qw(compare);
+@EXPORT_OK=qw(compare cmp);
+
+$File::Compare::VERSION = '1.0';
+$File::Compare::Too_Big = 1024 * 1024 * 2;
+
+
+use strict;
+use vars qw($\ *FROM *TO);
+
+sub VERSION {
+    # Version of File::Compare
+    return $File::Compare::VERSION;
+}
+
+sub compare {
+    croak("Usage: compare( file1, file2 [, buffersize]) ")
+      unless(@_ == 2 || @_ == 3);
+
+    my $from = shift;
+    my $to = shift;
+    my $closefrom=0;
+    my $closeto=0;
+    my ($size, $status, $fr, $tr, $fbuf, $tbuf);
+    local(*FROM, *TO);
+    local($\) = '';
+
+    croak("from undefined") unless (defined $from);
+    croak("to undefined") unless (defined $to);
+
+    if (ref($from) && (isa($from,'GLOB') || isa($from,'IO::Handle'))) {
+	*FROM = *$from;
+    } elsif (ref(\$from) eq 'GLOB') {
+	*FROM = $from;
+    } else {
+	open(FROM,"<$from") or goto fail_open1;
+	binmode FROM;
+	$closefrom = 1;
+    }
+
+    if (ref($to) && (isa($to,'GLOB') || isa($to,'IO::Handle'))) {
+	*TO = *$to;
+    } elsif (ref(\$to) eq 'GLOB') {
+	*TO = $to;
+    } else {
+	open(TO,"<$to") or goto fail_open2;
+	binmode TO;
+	$closeto = 1;
+    }
+
+    if (@_) {
+	$size = shift(@_) + 0;
+	croak("Bad buffer size for compare: $size\n") unless ($size > 0);
+    } else {
+	$size = -s FROM;
+	$size = 1024 if ($size < 512);
+	$size = $File::Compare::Too_Big if ($size > $File::Compare::Too_Big);
+    }
+
+    $fbuf = '';
+    $tbuf = '';
+    while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) {
+	unless (defined($tr = read(TO,$tbuf,$fr)) and $tbuf eq $fbuf) {
+            goto fail_inner;
+	}
+    }
+    goto fail_inner if (defined($tr = read(TO,$tbuf,$size)) && $tr > 0);
+
+    close(TO) || goto fail_open2 if $closeto;
+    close(FROM) || goto fail_open1 if $closefrom;
+
+    return 0;
+    
+  # All of these contortions try to preserve error messages...
+  fail_inner:
+    close(TO) || goto fail_open2 if $closeto;
+    close(FROM) || goto fail_open1 if $closefrom;
+
+    return 1;
+
+  fail_open2:
+    if ($closefrom) {
+	$status = $!;
+	$! = 0;
+	close FROM;
+	$! = $status unless $!;
+    }
+  fail_open1:
+    return -1;
+}
+
+*cmp = \&compare;
+
diff --git a/t/lib/filecmp.t b/t/lib/filecmp.t
new file mode 100644
index 0000000000..209ee478e3
--- /dev/null
+++ b/t/lib/filecmp.t
@@ -0,0 +1,193 @@
+# $Id: test.pl,v 1.3 1996/10/19 10:49:54 joseph Exp joseph $
+# $Log: test.pl,v $
+# Revision 1.3  1996/10/19 10:49:54  joseph
+# oops, fixed a stupid bug in the test script
+#
+# Revision 1.2  1996/10/19 08:07:04  joseph
+# now has a real test script, i hope
+#
+# Revision 1.1  1996/10/15 08:42:55  joseph
+# Initial revision
+#
+#
+
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+######################### We start with some black magic to print on failure.
+
+# Change 1..1 below to 1..last_test_to_print .
+# (It may become useful if the test is moved to ./t subdirectory.)
+
+BEGIN { $| = 1; print "1..18\n"; }
+END {print "not ok 1\n" unless $loaded;}
+use File::Compare;
+$loaded = 1;
+print "ok 1\n";
+
+######################### End of black magic.
+
+# Insert your test code below (better if it prints "ok 13"
+# (correspondingly "not ok 13") depending on the success of chunk 13
+# of the test code):
+
+use Carp;
+use IO::File ();
+
+$test_num = 2;
+
+# Simple text file compare (this one!)
+
+if (compare(__FILE__, __FILE__) == 0) {
+	print "ok ", $test_num++, "\n";
+} else {
+	print "NOT ok (same file) ", $test_num++, "\n";
+}
+
+eval {
+
+	print "creating some test files\n";
+	$test_blob = '';
+	srand();
+	for ($i = 0; $i < 10000; $i++) {
+		$test_blob .= pack 'S', rand 0xffff;
+	}
+
+	open F, '>xx' or croak "couldn't create: $!";
+	print F $test_blob;
+
+	open F, '>xxcopy' or croak "couldn't create: $!";
+	print F $test_blob;
+
+	open F, '>xxshort' or croak "couldn't create: $!";
+	print F substr $test_blob, 0, 19999;
+
+	(substr $test_blob, 7654, 1) =~ tr/\0-\377/\01-\377\0/;
+	open F, '>xx1byte' or croak "couldn't create: $!";
+	print F $test_blob;
+
+	(substr $test_blob, -1, 1) =~ tr/\0-\377/\01-\377\0/;
+	open F, '>xx2byte' or croak "couldn't create: $!";
+	print F $test_blob;
+	close F;
+
+	if (File::Compare::cmp('xx', 'xx') == 0) {
+		print "ok ", $test_num++, "\n";
+	} else {
+		print "NOT ok (same file) ", $test_num++, "\n";
+	}
+
+	if (compare('xx', 'xxcopy') == 0) {
+		print "ok ", $test_num++, "\n";
+	} else {
+		print "NOT ok (copy of file) ", $test_num++, "\n";
+	}
+
+	if (compare('xx', 'xxshort') > 0) {
+		print "ok ", $test_num++, "\n";
+	} else {
+		print "NOT ok (truncated copy of file) ", $test_num++, "\n";
+	}
+
+	if (compare('xxshort', 'xx') > 0) {
+		print "ok ", $test_num++, "\n";
+	} else {
+		print "NOT ok (truncated copy of file) ", $test_num++, "\n";
+	}
+
+	if (compare('xx', 'xxfrobizz') < 0) {
+		print "ok ", $test_num++, "\n";
+	} else {
+		print "NOT ok (file doesn'xx exist)  ", $test_num++, "\n";
+	}
+
+	if (compare('xxfrobizz', 'xx') < 0) {
+		print "ok ", $test_num++, "\n";
+	} else {
+		print "NOT ok (file doesn'xx exist)  ", $test_num++, "\n";
+	}
+
+	if (compare('xx', 'xx1byte') > 0) {
+		print "ok ", $test_num++, "\n";
+	} else {
+		print "NOT ok (1 byte difference) ", $test_num++, "\n";
+	}
+
+	if (compare('xx1byte', 'xx') > 0) {
+		print "ok ", $test_num++, "\n";
+	} else {
+		print "NOT ok (1 byte difference) ", $test_num++, "\n";
+	}
+
+	if (compare('xx1byte', 'xx2byte') > 0) {
+		print "ok ", $test_num++, "\n";
+	} else {
+		print "NOT ok (1 byte at end) ", $test_num++, "\n";
+	}
+
+	if (compare('xx2byte', 'xx1byte') > 0) {
+		print "ok ", $test_num++, "\n";
+	} else {
+		print "NOT ok (1 byte at end) ", $test_num++, "\n";
+	}
+                   
+        open(STDIN,'xx') or croak "couldn't open xx as STDIN: $!";
+
+        seek(STDIN,0,0) || croak "couldn't seek STDIN: $!";
+	if (compare('xx', *STDIN) == 0) {
+		print "ok ", $test_num++, "\n";
+	} else {
+		print "NOT ok (glob to) ", $test_num++, "\n";
+	}
+
+        seek(STDIN,0,0) || croak "couldn't seek STDIN: $!";
+	if (compare(*STDIN, 'xx') == 0) {
+		print "ok ", $test_num++, "\n";
+	} else {
+		print "NOT ok (glob from) ", $test_num++, "\n";
+	}
+
+        seek(STDIN,0,0) || croak "couldn't seek STDIN: $!";
+	if (compare('xx', \*STDIN) == 0) {
+		print "ok ", $test_num++, "\n";
+	} else {
+		print "NOT ok (ref glob to) ", $test_num++, "\n";
+	}
+
+        seek(STDIN,0,0) || croak "couldn't seek STDIN: $!";
+	if (compare(\*STDIN, 'xx') == 0) {
+		print "ok ", $test_num++, "\n";
+	} else {
+		print "NOT ok (ref glob from) ", $test_num++, "\n";
+	}
+
+        $fh = IO::File->new("cat xx |") or die "Cannot open pipe:$!";
+	if (compare($fh, 'xx') == 0) {
+		print "ok ", $test_num++, "\n";
+	} else {
+		print "NOT ok (pipe from) ", $test_num++, "\n";
+	}
+        $fh->close;
+
+        $fh = IO::File->new("cat xx2byte |") or die "Cannot open pipe:$!";
+	if (compare('xx1byte', $fh) > 0) {
+		print "ok ", $test_num++, "\n";
+	} else {
+		print "NOT ok (pipe to) ", $test_num++, "\n";
+	}
+        $fh->close;
+
+};
+
+if ($@) {
+	print "... something went wrong during the tests.\n";
+}
+
+print "tidying up ...\n";
+foreach (glob 'xx*')
+ {
+  unlink($_) || warn "Cannot delete $_:$!";
+ }
+
+print "... all done\n";
+