File Coverage

blib/lib/Iterator/IO.pm

Criterion	Covered	Total	%
statement	140	143	97.9
branch	62	76	81.5
condition	33	42	78.5
subroutine	16	16	100.0
pod	4	4	100.0
total	255	281	90.7

=for gpg
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1

=head1 NAME

Iterator::IO - Filesystem and stream iterators.

=head1 VERSION

This documentation describes version 0.02 of Iterator::IO.pm, August 23, 2005.

=cut

use strict;
use warnings;
package Iterator::IO;
our $VERSION = '0.02';

use base 'Exporter';
use vars qw/@EXPORT @EXPORT_OK %EXPORT_TAGS/;

@EXPORT      = qw(idir_listing idir_walk ifile ifile_reverse);
@EXPORT_OK   = @EXPORT;

use Iterator;

# Function name: idir_listing
# Synopsis:      $iter = idir_listing ($path)
# Description:   Returns the full file names in the specified directory.
# Created:       07/28/2005 by EJR
# Parameters:    $path - Directory.  If omitted, uses current dir.
# Returns:       Iterator
# Exceptions:    Iterator::X::Am_Now_Exhausted
sub idir_listing
{
    require IO::Dir;
    require Cwd;

    my $path = shift || Cwd::getcwd();
    $path =~ s|/ \z||x;   # remove any trailing slash
    my $d = new IO::Dir $path;
    Iterator::X::IO_Error (message => qq{Cannot read "$path": $!},
                           error => $!)
        unless $d;

    return Iterator->new (sub
    {
        # Get next file, skipping . and ..
        my $next;
        while (1)
        {
            $next = $d->read;

            if (! defined $next)
            {
                undef $d;   # allow garbage collection
                Iterator::is_done();
            }

            last  if $next ne '.'  &&  $next ne '..';
        }

        # Return the filename
        return "$path/$next";
    });
}


# Function name: idir_walk
# Synopsis:      $iter = idir_walk ($path)
# Description:   Returns the directory tree below a given dir.
# Created:       07/28/2005 by EJR
# Parameters:    $path - Directory.  If omitted, uses current dir.
# Returns:       Iterator
# Exceptions:    Iterator::X::Am_Now_Exhausted
sub idir_walk
{
    my @dir_queue;
    my $path = shift;
    my $files = idir_listing($path);

    return Iterator->new (sub
    {
        # If no more files in current directory,
        # get next directory off the queue
        while ($files->is_exhausted)
        {
            # Nothing else on the queue?  Then we're done.
            if (@dir_queue == 0)
            {
                undef $files;    # allow garbage collection
                Iterator::is_done();
            }

            # Create an iterator to return the files in that directory
            $files = idir_listing(shift @dir_queue);
        }

        # Get next file in current directory
        my $next = $files->value;

        # If this is a directory (and not a symlink), remember it for later recursion
        if (-d $next  &&  !-l $next)
        {
            unshift @dir_queue, $next;
        }

        return $next;
    });
}

# Function name: ifile
# Synopsis:      $iter = ifile ($filename, {options});
# Description:   Returns the lines of a file, one at a time.
# Created:       07/28/2005 by EJR
# Parameters:    $filename - File name to open.
#                \%options - hashref of options
# Returns:       Iterator
# Exceptions:    Iterator::X::Parameter_Error
#                Iterator::X::IO_Error
#                Iterator::X::Am_Now_Exhausted
sub ifile
{
    require IO::File;

    my $filename  = shift;

    # Options
    my ($autochomp, $sep_defined, $separator);
    $autochomp = 1;    # default

    ################################################################
    # Backwards-compatibility block.
    # THIS WILL GO AWAY!
    #
    # This parses the old 'chomp' and 'nochomp' and 'sep' arguments.
    if (@_)
    {
        if ($_[0] eq 'chomp'  ||  $_[0] eq 'nochomp'  ||  !defined($_[0]))
        {
            my $chomp_opt = shift;
            if (defined $chomp_opt)
            {
                Iterator::X::Parameter_Error->throw(q{Invalid "chomp" argument to ifile})
                    if ($chomp_opt ne 'chomp'  &&  $chomp_opt ne 'nochomp');

                $autochomp = $chomp_opt eq 'chomp';
            }

            # Separator argument
            if (@_)
            {
                $sep_defined = 1;
                $separator   = shift;
            }
        }
    }
    ################################################################

    if (@_)
    {
        Iterator::X::Parameter_Error->throw
            (q{Second argument to ifile must be a hashref})
            if ref $_[0] ne 'HASH';

        Option: while (my ($opt,$val) = each %{$_[0]})
        {
            my $lcopt = lc $opt;   # because we're friendly.

            if ($lcopt eq 'chomp')
            {
                $autochomp = $val;
                next Option;
            }
            if ($lcopt eq 'rs'  ||  $lcopt eq '$/'  ||  $lcopt eq 'input_record_separator')
            {
                $separator   = $val;
                $sep_defined = 1;
                next Option;
            }
            Iterator::X::OptionError->throw
                (message => qq{Unknown option: "$opt" in call to ifile},
                 name    => $opt);
        }
    }

    # Open the file handle.
    my $fh = new IO::File ($filename);
    Iterator::X::IO_Error (message => qq{Cannot read "$filename": $!},
                           error => $!)
        unless $fh;

    return Iterator->new (sub
    {
        my $line;

        # Get next line (delimited by $separator if such is defined);
        {
            local $/ = $sep_defined? $separator : $/;
            $line = $fh->getline();
            chomp $line  if defined $line  &&  $autochomp;
        }

        # Done?
        if (!defined $line)
        {
            $fh->close;
            undef $fh;
            Iterator::is_done();
        }

        # Return the line
        return $line;
    });
}

# Function name: ifile_reverse
# Synopsis:      $iter = ifile_reverse ($filename, {options})
# Description:   Returns the lines of a file, in reverse order
# Created:       07/28/2005 by EJR
# Parameters:    $filename - File name to open.
#                \%options - options: chomp => bool, $/ => string
# Returns:       Iterator
# Exceptions:    Iterator::X::Parameter_Error
#                Iterator::X::IO_Error
#                Iterator::X::Am_Now_Exhausted
sub ifile_reverse
{
    require IO::File;

    my $filename  = shift;

    # Options
    my ($autochomp, $sep_defined, $separator);
    $autochomp = 1;    # default

    ################################################################
    # Backwards-compatibility block.
    # THIS WILL GO AWAY!
    #
    # This parses the old 'chomp' and 'nochomp' and 'sep' arguments.
    if (@_)
    {
        if ($_[0] eq 'chomp'  ||  $_[0] eq 'nochomp'  ||  !defined($_[0]))
        {
            my $chomp_opt = shift;
            if (defined $chomp_opt)
            {
                Iterator::X::Parameter_Error->throw(q{Invalid "chomp" argument to ifile})
                    if ($chomp_opt ne 'chomp'  &&  $chomp_opt ne 'nochomp');

                $autochomp = $chomp_opt eq 'chomp';
            }

            # Separator argument
            if (@_)
            {
                $sep_defined = 1;
                $separator   = shift;
            }
        }
    }
    ################################################################

    if (@_)
    {
        Iterator::X::Parameter_Error->throw
            (q{Second argument to ifile_reverse must be a hashref})
            if ref $_[0] ne 'HASH';

        Option: while (my ($opt,$val) = each %{$_[0]})
        {
            my $lcopt = lc $opt;   # because we're friendly.

            if ($lcopt eq 'chomp')
            {
                $autochomp = $val;
                next Option;
            }
            if ($lcopt eq 'rs'  ||  $lcopt eq '$/'  ||  $lcopt eq 'input_record_separator')
            {
                $separator   = $val;
                $sep_defined = 1;
                next Option;
            }
            Iterator::X::OptionError->throw
                (message => qq{Unknown option: "$opt" in call to ifile},
                 name    => $opt);
        }
    }

    # Must read chunks of the end of the file into memory
    my $block_size   = 8192;   # somewhat arbitrary

    my $fh = IO::File->new ($filename)
        or Iterator::X::IO_Error (message => qq{Cannot read "$filename": $!},
                                  error => $!);

    # Buffer variables
    my $leftover;
    my @lines;

    # Are we at the start of the file?
    my $at_start = sub {$fh->tell == 0};

    my $break = sub
    {
        my $block = shift;
        $block .= $leftover if defined $leftover;

        # Split up the block
        my $sep = $sep_defined? $separator : $/;
        @lines = reverse split /(?<=\Q$sep\E)/, $block;
        $leftover = pop @lines;
    };

    my $prev_block = sub
    {
        my $pos = $fh->tell;
        my $bytes = 1 + ($pos-1) % $block_size;
        my $buf;

        my $seek_ok = seek $fh, -$bytes, 1;
        Iterator::X::IO_Error->throw
                (message => qq{Seek error on $filename: $!},
                 os_error => $!)
            unless $seek_ok;

        my $num_read = read $fh, $buf, $bytes;
        Iterator::X::IO_Error->throw
                (message => qq{Read error on $filename: $!},
                 os_error => $!)
            if ! defined $num_read;

        seek $fh, -$bytes, 1;
        Iterator::X::IO_Error->throw
                (message => qq{Seek error on $filename: $!},
                 os_error => $!)
            unless $seek_ok;

        return $buf;
    };

    seek $fh, 0, 2;    # end of file
    $break->( $prev_block->() );

    return Iterator->new (sub
    {
        if (@lines == 0)
        {
            if ($at_start->())
            {
                @lines = $leftover;
                undef $leftover;
            }
            else
            {
                $break->( $prev_block->() );
            }
        }

        # Return the line (chomped if so requested)
        my $line = shift @lines;

        # Exhausted?
        Iterator::is_done()
            if ! defined $line;

        my $sep = $sep_defined? $separator : $/;
        $line =~ s/\Q$sep\E$//  if $autochomp;
        return $line;
    });
}


1;
__END__