view release on metacpan or  search on metacpan

lib/BoutrosLab/TSVStream/IO/Role/Base/Fixed.pm  view on Meta::CPAN

=head1 NAME

    BoutrosLab::TSVStream:IO::Role::Base::Fixed

=head1 SYNOPSIS

This is a collection of base attributes and methods used internally
by TSVStream reader and writer role modules.  It provides the
common parameters used to define reader and writer methods that
can be imported into a target class.

=cut

package BoutrosLab::TSVStream::IO::Role::Base::Fixed;

# safe Perl
use warnings;
use strict;
use Carp;
use feature 'say';

use Moose::Role;
use namespace::autoclean;
use Try::Tiny;

# Base role for all reader/writer variants
#
# The BUILDARGS wrapper checks wheter a handle was proveded
# and, if not, opens the file provided and sets the handle
# to that newly opened fd.
#
# The class that consumes this role can add two extra entries
# to the arg list:
#     - _open_mode - the mode to be used for an open (usually
#                    one of '<', '>', '>>')
#     - _valid_arg - a hash of arg names to be validated, any
#                    arg key provided which does not match a
#                    key in this hash will cause an error
#                    (the _valid_arg and _open_mode args will not
#                    cause an error - they do not need to be
#                    listed in the _valid_arg hash since they
#                    are provided internally and removed before
#                    validation).

has handle => ( is => 'ro', required => 1, isa => 'FileHandle' );

has file => ( is => 'ro', lazy => 1, isa => 'Str', default => '[Unnamed stream]' );

has class => ( is => 'ro', required => 1, isa => 'Str' );

has [ qw(comment pre_comment pre_header) ] => ( is => 'ro', isa => 'Bool', default => 0 );

has comment_pattern => (
	is      => 'ro',
	isa     => 'RegexpRef',
	default => sub { qr/(?:^\s*#)|(?:^\s*$)/ }
	);

sub _null_header_fix {
	return $_[0];
	}

has header_fix => (
	is      => 'ro',
	isa     => 'CodeRef',
	default => sub { \&_null_header_fix }
	);

around BUILDARGS => sub {
	my $orig  = shift;
	my $class = shift;
	my $arg = ref($_[0]) ? $_[0] : { @_ };

	my $open_mode = delete $arg->{_open_mode} || '<';
	if (my $valid_arg = delete $arg->{_valid_arg}) {
		my @unknowns = grep { !$valid_arg->{$_} } keys %$arg;
		if (@unknowns) {
			my $s = 1 == scalar(@unknowns) ? '' : 's';
			confess "Unknown option$s ("
				. join( ',', @unknowns )
				. "), valid options are ("
				. join( ',', keys %$valid_arg )
				. ")\n";