scripts/tk-comm

#!/usr/bin/env perl

use strict;
use warnings FATAL => 'all';

use Tk;
use IO::File;
use List::Compare;
require Tk::ROText;

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( -side => 'left' ) ;
$button_frame->Button( -text => "Quit",        -command => sub { $mw->destroy } )->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()
        or return;
    show_results( 'File A only', $lc->get_unique_ref );
}

sub file_B_only {
    my $lc = compare_files()
        or return;
    show_results( 'File B only', $lc->get_complement_ref );
}

sub both_files {
    my $lc = compare_files()
        or return;
    show_results( 'Both files', $lc->get_intersection_ref );
}

sub show_results {
    my ( $title, $results ) = @_;

    my $results_window = $mw->Toplevel( -title => $title );
    my $text = $results_window->Scrolled( 'ROText', -wrap => 'none', -scrollbars => 'osoe' )->pack;
    $text->insert( 'end', join "\n", @{$results} );

    $results_window->Button(
        -text    => 'Close',
        -command => sub { $results_window->destroy }
    )->pack( -side => 'right' );
    
    $results_window->Button(
        -text    => 'Save',
        -command => sub { save_results( $results_window, $results ) && $results_window->destroy }
    )->pack( -side => 'right' );
}

sub save_results {
    my ( $rw, $results ) = @_;

    my $filename = $rw->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;

    $rw->messageBox( -title => 'Saved', -message => "Results saved to $filename", -type => 'ok' );

    return 1;
}

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' );
}

__END__

=head1 NAME

tk-comm

=head1 DESCRIPTION

B<tk-comm> is a graphical version of the standard Unix L<comm(1)>
command. Unlike L<comm(1)>, it does not require files to be sorted,
and it handles Unix, Windows, and Mac line endings transparently.

=head1 SEE ALSO

L<comm(1)>, L<List::Compare>

=head1 AUTHOR

Ray Miller E<lt>ray@1729.org.ukE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (c) 2012 Ray Miller.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.