File Coverage

blib/lib/File/Marker.pm

Criterion	Covered	Total	%
statement	71	79	89.8
branch	16	20	80.0
condition			n/a
subroutine	15	16	93.7
pod	7	7	100.0
total	109	122	89.3

use 5.006;
use strict;
use warnings;

package File::Marker;
# ABSTRACT: Set and jump between named position markers on a filehandle
our $VERSION = '0.14'; # VERSION

our @ISA = qw( IO::File );

use Carp;
use IO::File;
use Scalar::Util 1.09 qw( refaddr weaken );

#--------------------------------------------------------------------------#
# Inside-out data storage
#--------------------------------------------------------------------------#

my %MARKS = ();

# Track objects for thread-safety

my %REGISTRY = ();

#--------------------------------------------------------------------------#
# new()
#--------------------------------------------------------------------------#

sub new {
    my $class = shift;
    my $self  = IO::File->new();
    bless $self, $class;
    weaken( $REGISTRY{ refaddr $self } = $self );
    $self->open(@_) if @_;
    return $self;
}

#--------------------------------------------------------------------------#
# open()
#--------------------------------------------------------------------------#

sub open {
    my $self = shift;
    $MARKS{ refaddr $self } = {};
    $self->SUPER::open(@_);
    $MARKS{ refaddr $self }{'LAST'} = $self->getpos;
    return 1;
}

#--------------------------------------------------------------------------#
# set_marker()
#--------------------------------------------------------------------------#

sub set_marker {
    my ( $self, $mark ) = @_;

    croak "Can't set marker on closed filehandle"
      if !$self->opened;

    croak "Can't set special marker 'LAST'"
      if $mark eq 'LAST';

    my $position = $self->getpos;

    croak "Couldn't set marker '$mark': couldn't locate position in file"
      if !defined $position;

    $MARKS{ refaddr $self }{$mark} = $self->getpos;

    return 1;
}

#--------------------------------------------------------------------------#
# goto_marker()
#--------------------------------------------------------------------------#

sub goto_marker {
    my ( $self, $mark ) = @_;

    croak "Can't goto marker on closed filehandle"
      if !$self->opened;

    croak "Unknown file marker '$mark'"
      if !exists $MARKS{ refaddr $self}{$mark};

    my $old_position = $self->getpos; # save for LAST

    my $rc = $self->setpos( $MARKS{ refaddr $self }{$mark} );

    croak "Couldn't goto marker '$mark': could not seek to location in file"
      if !defined $rc;

    $MARKS{ refaddr $self }{'LAST'} = $old_position;

    return 1;
}

#--------------------------------------------------------------------------#
# markers()
#--------------------------------------------------------------------------#

sub markers {
    my $self = shift;
    return keys %{ $MARKS{ refaddr $self } };
}

#--------------------------------------------------------------------------#
# save_markers()
#--------------------------------------------------------------------------#

sub save_markers {
    my ( $self, $filename ) = @_;
    my $outfile = IO::File->new( $filename, "w" )
      or croak "Couldn't open $filename for writing";
    my $markers = $MARKS{ refaddr $self };
    for my $mark ( keys %$markers ) {
        next if $mark eq 'LAST';
        print $outfile "$mark\n";
        print $outfile unpack( "H*", $markers->{$mark} ), "\n";
    }
    close $outfile;
}

#--------------------------------------------------------------------------#
# load_markers()
#--------------------------------------------------------------------------#

sub load_markers {
    my ( $self, $filename ) = @_;
    my $infile = IO::File->new( $filename, "r" )
      or croak "Couldn't open $filename for reading";
    my $markers = $MARKS{ refaddr $self };
    my $mark;
    while ( defined( $mark = <$infile> ) ) {
        chomp $mark;
        my $position = <$infile>;
        chomp $position;
        $position = pack( "H*", $position );
        $markers->{$mark} = $position;
    }
    close $infile;
}

#--------------------------------------------------------------------------#
# DESTROY()
#--------------------------------------------------------------------------#

sub DESTROY {
    my $self = shift;
    delete $MARKS{ refaddr $self };
    delete $REGISTRY{ refaddr $self };

    $self->SUPER::DESTROY;
}

#--------------------------------------------------------------------------#
# CLONE()
#--------------------------------------------------------------------------#

sub CLONE {
    for my $old_id ( keys %REGISTRY ) {

        # look under old_id to find the new, cloned reference
        my $object = $REGISTRY{$old_id};
        my $new_id = refaddr $object;

        # relocate data
        $MARKS{$new_id} = $MARKS{$old_id};
        delete $MARKS{$old_id};

        # update the weak reference to the new, cloned object
        weaken( $REGISTRY{$new_id} = $object );
        delete $REGISTRY{$old_id};
    }

    return;
}

#--------------------------------------------------------------------------#
# _object_count() -- used in test scripts to see if memory is leaking
#--------------------------------------------------------------------------#

sub _object_count {
    return scalar keys %REGISTRY;
}

1;

__END__