Initial check-in of Perl/Tk implementation of comm(1)

tk-comm

@@ -0,0 +1,131 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings FATAL => 'all';
+
+use Tk;
+use IO::File;
+use List::Compare;
+
+my ( $filename_A, $filename_B ) = ( '', '' );
+
+my $mw = MainWindow->new;
+$mw->title( 'Compare Files' );
+
+add_choose_file_frame( 'File A', \$filename_A );
+add_choose_file_frame( 'File B', \$filename_B );
+
+my $button_frame = $mw->Frame->pack;
+$button_frame->Button( -text => "File A only", -command => \&file_A_only )->pack( -side => 'left' );
+$button_frame->Button( -text => "File B only", -command => \&file_B_only )->pack( -side => 'left' );
+$button_frame->Button( -text => "Both files",  -command => \&both_files)->pack;
+
+MainLoop;
+
+sub add_choose_file_frame {
+    my ( $label, $var_ref ) = @_;
+
+    my $frame = $mw->Frame->pack( -side => 'top', -fill => 'x' );
+    $frame->Label( -text => $label )->pack( -side => 'left' );
+    $frame->Entry( -width => 30, -textvariable => $var_ref )->pack( -side => 'left' );
+    $frame->Button( -text => 'Browse', -command => choose_file( $var_ref ) )->pack;
+}
+
+sub choose_file {
+    my $var_ref = shift;
+
+    my @types = (
+        ['All Files',                 '*',             ],
+        ['Text Files',                ['.txt', '.text']],
+    );
+    
+    return sub {
+        ${$var_ref} = $mw->getOpenFile( -filetypes => \@types );
+   };
+}
+
+sub file_A_only {
+    my $lc = compare_files();
+    save_results( $lc->get_unique_ref );
+}
+
+sub file_B_only {
+    my $lc = compare_files();
+    save_results( $lc->get_complement_ref );
+}
+
+sub both_files {
+    my $lc = compare_files();
+    save_results( $lc->get_intersection_ref );
+}
+
+sub save_results {
+    my $results = shift;
+    
+    my $filename = $mw->getSaveFile();
+    unless ( defined $filename and length $filename ) {
+        popup_error( "You must specify a file for the results to be saved" );
+        return;
+    }
+
+    my $fh = IO::File->new( $filename, O_RDWR|O_CREAT|O_TRUNC, 0644 );
+    unless ( $fh ) {
+        popup_error( "Failed to open $filename for writing: $!" );
+        return;
+    }
+
+    for my $r ( @{$results} ) {
+        $fh->print( "$r\n" );
+    }
+
+    $fh->close;
+}
+
+sub compare_files {
+    my ( $A, $B ) = read_files()
+        or return;
+
+    return List::Compare->new( $A, $B );
+}
+
+sub read_files {
+
+    unless ( defined $filename_A and length $filename_A ) {
+        popup_error( "File A must be specified" );
+        return;
+    }
+
+    unless ( defined $filename_B and length $filename_B ) {
+        popup_error( "File B must be specified" );
+        return;
+    }
+    
+    my $content_A = slurp_lines( $filename_A )
+        or return;
+
+    my $content_B = slurp_lines( $filename_B )
+        or return;
+
+    return ( $content_A, $content_B );
+}
+
+sub slurp_lines {
+    my $filename = shift;
+
+    my $fh = IO::File->new( $filename, O_RDONLY );
+    unless ( $fh ) {
+        popup_error( "Failed to open $filename: $!" );
+        return;
+    }
+
+    local $/ = undef;
+
+    my $content = <$fh>;
+
+    [ split qr/\r\n|\r|\n/, $content ];
+}
+
+sub popup_error {
+    my $error = shift;
+    $mw->messageBox( -title => 'Error', -message => $error, -type => 'ok' );
+}