From: Nick Ing-Simmons Date: Mon, 16 Dec 1996 18:44:59 +0000 (+0000) Subject: Add File::Compare X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4c14bdd2b1c68540381264459ca6c17a76a72042;p=p5sagit%2Fp5-mst-13.2.git Add File::Compare Subject: Re: Does File::Copy work as expected? Nick Ing Simmons 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> --- diff --git a/lib/File/Compare.pm b/lib/File/Compare.pm new file mode 100644 index 0000000..12d97e7 --- /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 0000000..209ee47 --- /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"; +