File Coverage

blib/lib/File/MergeSort.pm

Criterion	Covered	Total	%
statement	103	106	97.1
branch	29	38	76.3
condition	16	24	66.6
subroutine	13	13	100.0
pod	3	3	100.0
total	164	184	89.1

package File::MergeSort;

use 5.006;     # 5.6.0
use strict;
use warnings;

use Carp;
use IO::File;

our $VERSION = '1.23';

my $have_io_zlib;

BEGIN {
    eval { require IO::Zlib; };
    unless ( $@ ) {
        require IO::Zlib;
        $have_io_zlib++;
    }
}

### PRIVATE METHODS

sub _open_file {
    my $self = shift;
    my $file = shift || croak 'No filename specified';

    my $fh;

    if ( $file =~ /[.](z|gz)$/ ) { # Files matching .z or .gz
        if ( $have_io_zlib ) {
            $fh = IO::Zlib->new( $file, 'rb' ) or croak "Failed to open file $file: $!";
        } else {
            croak 'IO::Zlib not available, cannot handle compressed files. Stopping';
        }
    } else {
        $fh = IO::File->new( $file, '<' ) or croak "Failed to open file $file: $!";
    }

    return $fh;
}

# Yes, I'm really closing filehandles, just trying to be consistent
# with the _open_file counterpart.
sub _close_file {
    my $self = shift;
    my $fh   = shift;

    $fh->close() or croak "Problems closing filehandle: $!";

    return 1;
}

sub _get_line {
    my $self = shift;
    my $fh   = shift || croak 'No filehandle supplied';

    my $line;

    if ( $self->{'skip_empty'} ) {
	do {
	    $line = <$fh>;
	} until ( ! defined $line || $line !~ /^$/ );
    } else {
	$line = <$fh>;
    }
    return $line;
}

# Given a line of input and a code reference that extracts a value
# from the line, return an index value that can be used to compare the
# lines.
sub _get_index {
    my $self = shift;
    my $line = shift || croak 'No line supplied';

    my $code_ref = $self->{'index'};
    my $index    = $code_ref->( $line );

    if ( $index ) {
        return $index;
    } else {
        croak 'Unable to return an index. Stopping';
    }
}

### PUBLIC METHODS

sub new {
    my $class     = shift;
    my $files_ref = shift;      # ref to array of files.
    my $index_ref = shift;      # ref to sub that will extract index value from line
    my $opts_ref  = shift;      # ref to hash of options, optional.

    unless ( ref $files_ref eq 'ARRAY' && @{ $files_ref } ) {
	croak 'Array reference of input files required';
    }

    unless ( ref $index_ref eq 'CODE' ) {
	croak 'Code reference required for merge key extraction';
    }

    if ( $opts_ref && ref $opts_ref ne 'HASH' ) {
	croak 'Options should be supplied as a hash reference';
    }

    my $self = { index       => $index_ref,
                 stack       => [],
		 skip_empty => $opts_ref->{'skip_empty_lines'} ? 1 : 0,
               };

    bless $self, $class;

    my @files;
    my $i = 0;
    foreach my $file ( @{ $files_ref } ) {
        my $fh  = $self->_open_file( $file );
        my $l   = $self->_get_line( $fh );
        my $idx = $self->_get_index( $l );

        my $f = { 'fh'    => $fh,
                  'line'  => $l,
                  'index' => $idx,
                  'pref'  => $i++, # preference: take the records from the files in the order specified.
                };

        push @files, $f;
    }

    # Now that the first records are complete for each file, sort them
    # by merge key then file order.  Create a sorted array of hashrefs
    # based on the index values of each file.
    $self->{'stack'} = [ sort {    $a->{'index'} cmp $b->{'index'}
                                || $a->{'pref'}  <=> $b->{'pref'}
                              } @files ];

    return $self;
}

sub next_line {
    my $self = shift;

    my $pick = shift @{ $self->{'stack'} };
    return unless $pick;

    my $line = $pick->{'line'};

    # Re-populate invalidated data in the shifted structure, before
    # reinserting into stack.
    my $nextline = $self->_get_line( $pick->{'fh'} );

    if ( $nextline ) {
        $pick->{'line'}  = $nextline;
        $pick->{'index'} = $self->_get_index( $nextline );
    } else {
        # File exhausted, close and return last line, no need to
        # proceed onto juggling stack.
        $self->_close_file( $pick->{'fh'} );
        return $line;
    }

    # Re-organise the 'stack' structure to insert the newly fetched
    # data into the correct position for the next call. Since it
    # begins as a sorted array, and we only need to insert one element
    # in the appropriate position in the array, we can abandon the
    # loop as soon as we hit the right spot.
    # There may be room for optimisation here. Algorithms and/or tips
    # welcome.

    # Scan the array for the point where:

    # * The index of the element to insert is the less than than the
    # element in the array

    # ...or...

    # * The index of the element to insert is the same as that in the
    # array, but the preference of the element to insert is lower -
    # this is so that data is consistently fed in from the source
    # files in the order specified in the constuctor.

    # Previous behaviour can be had with last if $_->{'index'} ge $pick->{'index'};
    my $i = 0;

    foreach ( @{ $self->{'stack'} } ) {
        if (      $_->{'index'} gt $pick->{'index'}
             || ( $_->{'index'} eq $pick->{'index'} && $pick->{'pref'} <= $_->{'pref'} )
           ) {
            last;
        }
        $i++;
    }

    # And stuff the fresh data in the appropriate place.
    splice @{ $self->{'stack'} }, $i, 0, $pick;

    return $line;
}

# Dump the contents of the file to either STDOUT (default).
sub dump {
    my $self = shift;
    my $file = shift; # optional

    my $lines = 0;

    if ( $file ) {
        open my $fh, '>',  $file or croak "Unable to create output file $file: $!";

        while ( my $line = $self->next_line() ) {
            print $fh $line;
	    $lines++;
        }

        close $fh or croak "Problems closing output file $file: $!";
    } else {
        while ( my $line = $self->next_line() ) {
            print $line;
	    $lines++;
        }
    }

    return $lines;
}

1;

__END__