File Coverage

blib/lib/Data/Header/Fields.pm

Criterion	Covered	Total	%
statement	228	234	97.4
branch	81	100	81.0
condition	16	32	50.0
subroutine	43	44	97.7
pod	0	15	0.0
total	368	425	86.5

package Data::Header::Fields;

use warnings;
use strict;

use IO::Any;
use Carp 'croak';
use String::Escape ();
use List::MoreUtils 'uniq', 'all';

use overload
	'""' => \&as_string,
	'cmp' => \&cmp,
;

our $VERSION = '0.05';

sub new {
	my $class = shift;
	return bless {
		tight_folding => 0,
		key_cmp       => sub { $_[0] cmp $_[1] },
		@_
	}, $class;
}

sub _lines {
	my $self = shift;

	$self->{_lines} = shift
		if (@_);

	$self->{_lines} = []
		if (not $self->{_lines});

	return $self->{_lines};
}

sub key_cmp {
	my $self   = shift;
	$self->{'key_cmp'} = shift
		if @_;

	return $self->{'key_cmp'};
}

sub tight_folding {
	my $self = shift;

	$self->{tight_folding} = shift
		if (@_);

	return 0
		if not ref $self;

	return $self->{tight_folding};
}

sub decode {
	my $self = shift;
	my $any  = shift;

	my @lines = $self->_read_lines($any);

	my $line_ending = (
		($lines[0] || '') =~ m/\r\n \Z/xms
		? "\r\n"
		: "\n"
	);
	$self->line_ending($line_ending);

	@lines = (
		map {
			Data::Header::Fields::Line->new(
				'line'          => $_,
				'parent'        => $self,
			);
		} @lines
	);

	if (ref $self) {
		$self->_lines(\@lines);
		return $self;
	}

	return \@lines;
}

sub _read_lines {
	my $self = shift;
	my $any  = shift;

	my $fh = IO::Any->read($any);

	# put folded lines to an array http://tools.ietf.org/html/rfc2822#section-2.2.3
	my @lines;
	while (my $line = <$fh>) {
		# folded line
		if (($line =~ m/^\s/xms)) {
			# ignore if the first line starts with white space
			next if not @lines;

			$lines[-1] .= $line;
			next;
		}
		push @lines, $line;
	}

	close $fh;

	return @lines;
}

*as_string = *encode;
sub encode {
	my $self  = shift;
	my $lines = shift || (ref $self ? $self->_lines : undef);

	# no additional arguments
	if (@_ == 0) {
		my $text = '';
		$self->encode($lines, \$text);
		return $text;
	}

	my $any = shift;

	my $fh = IO::Any->write($any);
	foreach my $line (@{$lines}) {
		print $fh $line->as_string;
	}

	close $fh;

	return $self;
}

sub get_fields {
	my $self       = shift;
	my $field_name = shift or croak 'field_name argument is mandatory';

	my $key_cmp = $self->key_cmp;
	return (
		grep {
			$key_cmp->($field_name, $_->key) == 0
		} @{$self->_lines}
	);
}

sub get_field {
	my $self       = shift;
	my $field_name = shift or croak 'field_name argument is mandatory';
	my @extra_args = @_;

	my @fields = $self->get_fields($field_name, @extra_args);
	croak 'more then one header field with name "'.$field_name.'"'
		if @fields > 1;

	return $fields[0];
}

sub get_value {
	my $self = shift;
	my $key  = shift or croak 'key argument is mandatory';
	my @extra_args = @_;

	my $field = $self->get_field($key, @extra_args);
	return undef if not defined $field;
	return $field->value;
}

sub update_values {
	my $self  = shift;
	my $key   = shift or croak 'key argument is mandatory';
	my $value = shift;

	my $key_cmp = $self->key_cmp;
	my @lines = (
		map {
			($key_cmp->($_->key, $key) == 0 ? $_->value($value) : ());
			$_;
		} @{$self->_lines}
	);

	return $self;
}

sub rm_fields {
	my $self          = shift;
	my (@field_names) = (@_) or croak 'field_names argument is mandatory';

	my $key_cmp = $self->key_cmp;
	my @lines = (
		grep {
			my $key = $_->key;
			all { $key_cmp->($key, $_) != 0 } @field_names;
		} @{$self->_lines}
	);

	$self->_lines(\@lines);

	return $self;
}

sub set_value {
	my $self  = shift;
	my $key   = shift or croak 'key argument is mandatory';
	my $value = shift;

	my @fields = $self->get_fields($key);
	if (@fields == 1) {
		$self->update_values($key, $value);
	}
	elsif (@fields == 0) {
		push @{$self->_lines}, Data::Header::Fields::Line->new(
			'key' => $key,
			'value' => $value,
			'parent' => $self,
		);
	}
	else {
		croak 'more then one header field with name "'.$key.'"';
	}


	return $self;
}

sub cmp {
	my $a = shift;
	my $b = shift;

	$a = $a->encode if ref $a and $a->can('encode');
	$b = $b->encode if ref $b and $b->can('encode');

	return $a cmp $b;
}

sub keys {
	my $self  = shift;
	my $lines = shift || (ref $self ? $self->_lines : []);

	return
		uniq
		map {
			$_->key
		} @{$lines}
	;
}

sub line_ending {
	my $self = shift;

	return "\n"
		if not ref $self;

	if (@_) {
		$self->{line_ending} = shift;
	}
	$self->{line_ending} = "\n"
		if (not $self->{line_ending});

	return $self->{line_ending};
}

sub push_line {
	my $self = shift;
	my $line = shift;

	my $lines = $self->_lines;
	push(@$lines, $line);

	return $self;
}

1;

package Data::Header::Fields::Value;

use Scalar::Util 'weaken', 'isweak';

use overload
	'""' => \&as_string,
	'cmp' => \&cmp,
;

sub new {
	my $class = shift;
	my $value = shift;

	if (@_ == 0) {
		if (not ref $value) {
			$value = { 'value' => $value };
		}
	}
	else {
		$value = { $value, @_ };
	}

	my $self = bless { 'parent' => $class->_default_parent, %{$value} }, $class;

	weaken($self->{'parent'})
		if (ref($self->{'parent'}) && !isweak($self->{'parent'}));

	return $self;
}

sub as_string {
	my $self   = shift;

	# remove folding
	my $line = $self->{value};
	if ($self->parent->parent->tight_folding) {
		$line =~ s/\n\s//xmsg;
	}
	else {
		$line =~ s/\n(\s)/$1/xmsg;
	}
	$line =~ s/\r?\n$//;
	$line = String::Escape::unprintable($line);

	return $line;
}

sub cmp {
	my $a = shift;
	my $b = shift;

	$a = $a->as_string if ref $a and $a->can('as_string');
	$b = $b->as_string if ref $b and $b->can('as_string');

	return $a cmp $b;
}

sub _default_parent {
	return 'Data::Header::Fields::Line';
}

sub parent {
	my $self   = shift;
	$self->{'parent'} = shift
		if @_;

	return (ref $self->{'parent'} ? $self->{'parent'} : $self->_default_parent);
}

sub value {
	my $self = shift;

	if (@_) {
		$self->{'value'} = shift;
		$self->parent->line_changed;
	}

	return $self->{'value'};
}
1;

package Data::Header::Fields::Line;

use Scalar::Util 'blessed', 'weaken', 'isweak';

use overload
	'""' => \&as_string,
	'cmp' => \&cmp,
;

sub new {
	my $class = shift;
	my $line  = shift;
	my @args  = @_;

	if (@args > 0) {
		$line = { $line, @args };
	}

	if (not ref $line) {
		$line = { 'line' => $line };
	}

	$line = { 'parent' => $class->_default_parent, %{$line} };

	if (exists $line->{'line'}) {
		# reblessing the line object
		if (blessed $line->{'line'}) {
			my $self = delete $line->{'line'};
			foreach my $key (keys %{$line}) {
				$self->{$key} = $line->{$key};
			}
			return bless $self, $class;
		}
		else {
			my $line_string   = delete $line->{'line'};
			$line->{'original_line'} = $line_string;
			my ($key, $value) = split(/:/, $line_string, 2);
			$line->{'key'}    = $key;
			$line->{'value'}  = Data::Header::Fields::Value->new(
				'value'         => $value,
				'parent'        => $line,
			);
		}
	}

	weaken($line->{'parent'})
		if (ref($line->{'parent'}) && !isweak($line->{'parent'}));

	return bless $line, $class;
}

sub key {
	my $self   = shift;
	$self->{'key'} = shift
		if @_;

	return $self->{'key'};
}
sub value {
	my $self   = shift;
	$self->line_changed->{'value'} = shift
		if @_;

	return $self->{'value'};
}

sub line_changed {
	my $self = shift;
	delete $self->{'original_line'}
		if ref $self;
	return $self;
}

sub as_string {
	my $self = shift;

	if (exists $self->{'original_line'}) {
		my $original_line = $self->{'original_line'};

		# make sure the line has line_ending, even the original one could be created without using ->new()
		$original_line .= $self->parent->line_ending
			if $original_line !~ m/ \n \Z /xms;

		return $original_line;
	}

	my ($key, $value) = ($self->key, $self->value);
	$value = String::Escape::printable($value);

	my $line = join(':', $key, $value);

	$line .= $self->parent->line_ending
		if $line !~ m/\n$/xms;

	return $line;
}

sub cmp {
	my $a = shift;
	my $b = shift;

	$a = $a->as_string if ref $a and $a->can('as_string');
	$b = $b->as_string if ref $b and $b->can('as_string');

	return $a cmp $b;
}

sub _default_parent {
	return 'Data::Header::Fields';
}

sub parent {
	my $self   = shift;
	$self->{'parent'} = shift
		if @_;

	return (ref $self ? $self->{'parent'} : $self->_default_parent);
}


1;


__END__