lib/File/Compare.pm

   1 package File::Compare;
   2
   3 require Exporter;
   4 use Carp;
   5 use UNIVERSAL qw(isa);
   6
   7 @ISA=qw(Exporter);
   8 @EXPORT=qw(compare);
   9 @EXPORT_OK=qw(compare cmp);
  10
  11 $File::Compare::VERSION = '1.0';
  12 $File::Compare::Too_Big = 1024 * 1024 * 2;
  13
  14
  15 use strict;
  16 use vars qw($\ *FROM *TO);
  17
  18 sub VERSION {
  19     # Version of File::Compare
  20     return $File::Compare::VERSION;
  21 }
  22
  23 sub compare {
  24     croak("Usage: compare( file1, file2 [, buffersize]) ")
  25       unless(@_ == 2 || @_ == 3);
  26
  27     my $from = shift;
  28     my $to = shift;
  29     my $closefrom=0;
  30     my $closeto=0;
  31     my ($size, $status, $fr, $tr, $fbuf, $tbuf);
  32     local(*FROM, *TO);
  33     local($\) = '';
  34
  35     croak("from undefined") unless (defined $from);
  36     croak("to undefined") unless (defined $to);
  37
  38     if (ref($from) && (isa($from,'GLOB') || isa($from,'IO::Handle'))) {
  39         *FROM = *$from;
  40     } elsif (ref(\$from) eq 'GLOB') {
  41         *FROM = $from;
  42     } else {
  43         open(FROM,"<$from") or goto fail_open1;
  44         binmode FROM;
  45         $closefrom = 1;
  46     }
  47
  48     if (ref($to) && (isa($to,'GLOB') || isa($to,'IO::Handle'))) {
  49         *TO = *$to;
  50     } elsif (ref(\$to) eq 'GLOB') {
  51         *TO = $to;
  52     } else {
  53         open(TO,"<$to") or goto fail_open2;
  54         binmode TO;
  55         $closeto = 1;
  56     }
  57
  58     if (@_) {
  59         $size = shift(@_) + 0;
  60         croak("Bad buffer size for compare: $size\n") unless ($size > 0);
  61     } else {
  62         $size = -s FROM;
  63         $size = 1024 if ($size < 512);
  64         $size = $File::Compare::Too_Big if ($size > $File::Compare::Too_Big);
  65     }
  66
  67     $fbuf = '';
  68     $tbuf = '';
  69     while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) {
  70         unless (defined($tr = read(TO,$tbuf,$fr)) and $tbuf eq $fbuf) {
  71             goto fail_inner;
  72         }
  73     }
  74     goto fail_inner if (defined($tr = read(TO,$tbuf,$size)) && $tr > 0);
  75
  76     close(TO) || goto fail_open2 if $closeto;
  77     close(FROM) || goto fail_open1 if $closefrom;
  78
  79     return 0;
  80
  81   # All of these contortions try to preserve error messages...
  82   fail_inner:
  83     close(TO) || goto fail_open2 if $closeto;
  84     close(FROM) || goto fail_open1 if $closefrom;
  85
  86     return 1;
  87
  88   fail_open2:
  89     if ($closefrom) {
  90         $status = $!;
  91         $! = 0;
  92         close FROM;
  93         $! = $status unless $!;
  94     }
  95   fail_open1:
  96     return -1;
  97 }
  98
  99 *cmp = \&compare;
 100