File Coverage

blib/lib/Parse/Deb/Control.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package Parse::Deb::Control;

=head1 NAME

Parse::Deb::Control - parse and manipulate F in a controlable way

=head1 SYNOPSIS

Print out all "Package:" values lines

    use Parse::Deb::Control;

    my $parser = Parse::Deb::Control->new($control_txt);
    my $parser = Parse::Deb::Control->new(['path', 'to', 'debian', 'control']);
    my $parser = Parse::Deb::Control->new($fh);

    foreach my $para ($parser->get_paras('Package')) {
        print $para->{'Package'}, "\n";
    }

or

    foreach my $entry ($parser->get_keys('Package')) {
        print ${$entry->{'value'}}, "\n";
    }

Modify "Maintainer:"

    my $mantainer = 'someone@new';

    my $parser = Parse::Deb::Control->new($control_txt);
    foreach my $para ($parser->get_paras(qw{ Maintainer })) {
        $para->{'Maintainer'} =~ s/^ (\s*) (\S.*) $/ $maintainer\n/xms;
    }

or

    my $parser = Parse::Deb::Control->new($control_txt);
    foreach my $src_pkg ($parser->get_keys(qw{ Maintainer })) {
        ${$src_pkg->{'value'}} =~ s/^ (\s*) (\S.*) $/ $maintainer\n/xms;
    }

and

    print $parser->control;

=head1 DESCRIPTION

This modules helps to automate changes in F file. It
tries hard to preserve the original structure so that diff on input and
output can be made and it will be clear what was changed. There are 2 checks.
First when original F file processed it is generated
back and compared to the original. The program dies if those two doesn't
match. After making changes and creating new file. The result is parsed
again and the same check is applied to make sure the file will be still
parseable.

See also L for alternative.

=cut

use warnings;
use strict;

our $VERSION = '0.04';

use base 'Class::Accessor::Fast';

use Storable 'dclone';
use List::MoreUtils 'any';
use IO::Any;
use Carp;

=head1 PROPERTIES

    _control_src
    structure

=cut

__PACKAGE__->mk_accessors(qw{
    _control_src
    structure
});

=head1 METHODS

=head2 new()

Object constructor. Accepts anythign L->read() does to get
F from.

=cut

sub new {
    my $class = shift;
    my $what  = shift || '';
    my $self  = $class->SUPER::new({});

    $self->_control_src(IO::Any->read($what));

    return $self;
}

=head2 content()

Returns content of the F. The return value is an array
ref holding hashes representing control file paragraphs.

=cut

sub content {
    my $self = shift;
    my $content = $self->{'content'};

    return $content
        if defined $content;

    my @structure   = ();
    my @content     = ();
    my $last_value  = undef;
    my $last_para   = undef;
    my $control_txt = '';

    my $line_number = 0;
    my $control_src = $self->_control_src;
    while (my $line = <$control_src>) {
        $line_number++;
        $control_txt .= $line;

        # if the line is empty it's the end of control paragraph
        if ($line =~ /^\s*$/) {
            $last_value = undef;
            push @structure, $line;
            if (defined $last_para) {
                push @content, $last_para;
                $last_para = undef;
            }
            next;
        }

        # line starting with white space
        if ($line =~ /^\s/) {
            die 'not previous value to append "'.$line.'" to (line '.$line_number.')'
                if not defined $last_value;
            ${$last_value} .= $line;
            next;
        }

        # line starting with # are comments
        if ($line =~ /^#/) {
            push @structure, $line;
            next;
        }

        # other should be key/value lines
        if ($line =~ /^([^:]+):(.*$)/xms) {
            my ($key, $value) = ($1, $2);
            push @structure, $key;
            $last_para->{$key} = $value;
            $last_value = \($last_para->{$key});
            next;
        }

        croak 'unrecognized format "'.$line.'" (line '.$line_number.')';
    }
    push @content, $last_para
        if defined $last_para;

    $self->{'content'} = \@content;
    $self->structure(\@structure);

    # for debugging
    # use File::Slurp 'write_file';
    # write_file('xxx1', $control_txt);
    # write_file('xxx2', $self->control);

    croak 'control reconstruction failed, send your "control" file attached to bug report :-)'
        if $control_txt ne $self->_control;

    return \@content;
}


=head2 control

Returns text representation of a F constructed from
C<<$self->content>> and C<<$self->structure>>.

=cut

sub control {
    my $self = shift;

    my $control_txt = $self->_control;

    # run through parser again to test if future parsing will be successful
    eval {
        my $parser = Parse::Deb::Control->new($control_txt)->content;
    };
    if ($@) {
        die 'generating and parsing back failed ("'.$@.'"), this is probably a bug. attach your control file and manipulations you did to the bug report :)'
    }

    return $control_txt;
}

sub _control {
    my $self = shift;

    my $control_txt = '';
    my @content     = @{$self->content};
    return $control_txt
        if not @content;

    my %cur_para    = %{shift @content};

    # loop through the control file structure
    foreach my $structure_key (@{$self->structure}) {
        # just add comment lines
        if ($structure_key =~ /^#/) {
            $control_txt .= $structure_key;
            next;
        }

        if ($structure_key =~ /^\s*$/) {
            # loop throug new keys and add them
            foreach my $key (sort keys %cur_para) {
                $control_txt .= $key.':'.(delete $cur_para{$key});
            }

            # add the space
            $control_txt .= $structure_key;

            %cur_para = ();
            next;
        }

        # get next paragraph if empty
        %cur_para = %{shift @content}
            if not %cur_para;

        my $value = delete $cur_para{$structure_key};
        $control_txt .= $structure_key.':'.$value
            if $value;
    }
    # loop throug new keys and add them
    foreach my $key (sort keys %cur_para) {
        $control_txt .= $key.':'.(delete $cur_para{$key});
    }

    return $control_txt;
}

=head2 get_keys

Parameters are the requested keys from F. Returns array
of key/values of matching keys. Ex.

    {
        'key'   => 'Package',
        'value' => \"perl",
        'para'  => { ... one item from $self->content array ... },
    }

Note that value is a pointer to scalar value so that it can be easyly
modified if needed.

=cut

sub get_keys {
    my $self   = shift;
    my @wanted = @_;

    my @content = @{$self->content};

    my @wanted_keys;
    foreach my $para (@content) {
        foreach my $key (keys %{$para}) {
            if (any { $_ eq $key } @wanted) {
                push @wanted_keys, {
                    'key'   => $key,
                    'value' => \$para->{$key},
                    'para'  => $para,
                };
            }
        }
    }

    return @wanted_keys;
}

=head2 get_paras

Returns a paragraphs that has key(s) passed as argument.

=cut

sub get_paras {
    my $self = shift;
    my @wanted = @_;

    my @keys = $self->get_keys(@wanted);
    return
        map { $_->{'para'} }
        @keys
    ;
}

1;


__END__