view release on metacpan or  search on metacpan

lib/File/Marker.pm  view on Meta::CPAN

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;

lib/File/Marker.pm  view on Meta::CPAN

    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__

=pod

=encoding UTF-8

=head1 NAME

File::Marker - Set and jump between named position markers on a filehandle

=head1 VERSION

version 0.14

=head1 SYNOPSIS

 use File::Marker;

 my $fh = File::Marker->new( 'datafile.txt' );

 my $line1 = <$fh>;           # read a line
 $fh->set_marker( 'line2' );  # mark the current position
 my @rest = <$fh>;            # slurp the remainder
 $fh->goto_marker( 'line2' ); # jump back to the marked position
 my $line2 = <$fh>;           # read another line

=head1 DESCRIPTION

File::Marker allows users to set named markers for the current position in
a filehandle and then later jump back to a marked position.  A
File::Marker object is a subclass of L<IO::File>, providing full filehandle
object functionality.

File::Marker automatically sets a special, reserved marker, 'LAST', when it
jumps to a marker, allowing an easy return to a former position.

This module was written as a demonstration of the inside-out object technique
for the NY Perl Seminar group.  It is intended for teaching purposes and has 
not been tested in production code. 

=head1 USAGE

=head2 new