This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add File::Compare
[perl5.git] / 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