File Coverage

blib/lib/WWW/AUR/PKGBUILD.pm

Criterion	Covered	Total	%
statement	127	137	92.7
branch	30	40	75.0
condition	6	7	85.7
subroutine	19	19	100.0
pod	2	3	66.6
total	184	206	89.3

package WWW::AUR::PKGBUILD;

use warnings 'FATAL' => 'all';
use strict;

use Fcntl qw(SEEK_SET);
use Carp  qw();

my @ARRAY_FIELDS = qw{ license source noextract
                       md5sums sha1sums sha256sums sha384sums sha512sums
                       groups arch backup depends makedepends conflicts
                       provides replaces options };
# We cannot auto-split optdepends because spaces are allowed.

sub new
{
    my $class = shift;
    my $self  = bless {}, $class;

    if ( @_ ) { $self->read( @_ ); }
    return $self;
}

#---HELPER FUNCTION---
sub _unquote_bash
{
    my ($bashtext, $start, $expander) = @_;
    my $elem;

    $expander ||= sub { shift };
    $start    ||= 0;
    ( pos $bashtext ) = $start;

    # Extract the values of a bash array...
    if ( $bashtext =~ / \G [(] ([^)]*) [)] /gcx ) {
        my $arrtext = $1;
        my @result;

        ARRAY_LOOP:
        while ( 1 ) {
            my ($elem, $elem_end) = _unquote_bash( $arrtext,
                                                   pos $arrtext,
                                                   $expander );
            push @result, $elem if $elem;

            # There should only be spaces leftover.
            ( pos $arrtext ) = $elem_end;
            last ARRAY_LOOP if ( $elem_end >= length $arrtext ||
                                 $arrtext !~ /\G\s+/g );
        }

        # Arrays are special, we do not recurse after we find one.
        return \@result, pos $bashtext;
    }

    # The rest is for string "parsing"...

    # Single quoted strings cannot escape the quote (')...
    if ( $bashtext =~ /\G'([^']*)'/gc ) {
        $elem = $1;
    }
    # Double quoted strings can...
    elsif ( $bashtext =~ /\G"/gc ) {
        my $beg = pos $bashtext;
        # Skip past escaped double-quotes and non-double-quote chars.
        while ( $bashtext =~ / \G (?: \\" | [^"] ) /gcx ) { ; }

        $elem = substr $bashtext, $beg, ( pos $bashtext ) - $beg;
        $elem = $expander->( $elem );
        ++( pos $bashtext ); # skip the closing "
    }
    # Otherwise regular words are treated as one element...
    elsif ( $bashtext =~ /\G([^ \n\t'"]+)/gc ) {
        $elem = $expander->( $1 );
    }
    # If none of the above matches, then we stop recursion.
    else { return q{}, $start; }

    # We recurse in order to concatenate adjacent strings.
    my ( $next_elem, $next_end ) = _unquote_bash( $bashtext,
                                                  pos $bashtext,
                                                  $expander );
    return ( $elem . $next_elem, $next_end );
}

# Perform the simplest parameter expansion possible.
sub _expand_bash
{
    my ($bashstr, $fields_ref) = @_;

    my $expand_field = sub {
        my $name = shift;
        return $fields_ref->{ $name } if defined $fields_ref->{ $name };
        return qq{\$$name};
        # TODO: error reporting?
    };

    $bashstr =~ s{ \$ ([\w_]+) }
                 { $expand_field->( $1 ) }gex;

    # TODO: check for special expansion modifiers
    $bashstr =~ s( \$ \{ ([^}]+) \} )
                 ( $expand_field->( $1 ) )gex;

    return $bashstr;
}

#---HELPER FUNCTION---
sub _depstr_to_hash
{
    my ($depstr) = @_;
    my ($pkg, $cmp, $ver) = $depstr =~ / \A ([^=<>]+)
                                         (?: ([=<>]=?)
                                             (.*) )? \z/xms;

    Carp::confess "Failed to parse depend string: $_" unless $pkg;

    return +{ 'pkg' => $pkg, 'cmp' => $cmp,
              'ver' => $ver, 'str' => $depstr };
}

sub _provides_to_hash
{
    my ($provstr) = @_;
    my ($pkg, $ver) = $provstr =~ / \A ([^=]+)
                                    (?: = (.*))?
                                  /xms;
    Carp::confess "Failed to parse provides string: $_" unless $pkg;
    return +{ 'pkg' => $pkg, 'ver' => $ver, 'str' => $provstr };
}

#---HELPER FUNCTION---
sub _pkgbuild_fields
{
    my ($pbtext) = @_;

    my %pbfields;
    my $expander = sub {
        _expand_bash( shift, \%pbfields )
    };

    while ( $pbtext =~ / \G .*? \n? ^ ([\w_]+) = /gxms ) {
        my $name = $1;
        my ( $value, $endpos ) = _unquote_bash( $pbtext,
                                                pos $pbtext,
                                                $expander );
        $pbfields{ $name } = $value;
        ( pos $pbtext ) = $endpos;
    }

    # Split arrays at whitespace for poorly made PKGBUILDs...
    # also ensures each field has an arrayref.
    ARRAY_LOOP:
    for my $arrkey ( @ARRAY_FIELDS ) {
        unless ( $pbfields{ $arrkey } ) {
            $pbfields{ $arrkey } = [];
            next ARRAY_LOOP;
        }

        my $val_ref = $pbfields{ $arrkey };

        # Force the value into being an array...
        $val_ref    = [ $val_ref ] unless ref $val_ref;

        # Try to filter out common problems people have with defining arrays.
        # 1) trailing \'s
        # 2) commented array items (generally a complete line is commented)
        # 3) depends=('foo=1 bar<2 baz>=3')  (a string separated by spaces)
        # 4) depends=('turbojpegipp >=1.11') (only in the turbovnc-bin pkg)
        # (These should be done by the parser, eventually)
        $val_ref    = [ grep { $_ ne q{\\} } # *1
                        map  { split }       # *3
                        map  { s{ \A (\w+) \s+
                                  ([<>=]{1,2}\d+) }{$1$2}x; $_ } # *4
                        map  { s/\A\s+//; s/\s+\z//; $_ }        # trim ws
                        grep { length } map { s/\#.*//; $_ }     # *2
                        @$val_ref ];

        $pbfields{ $arrkey } = $val_ref;
    }

    # optdepends are special, we should only split on newlines
    if ( $pbfields{'optdepends'} ) {
        my $optdeps = $pbfields{'optdepends'};
        $optdeps = [ $optdeps ] unless ref $optdeps;

        # Remember stupid \'s at the end of lines
        $optdeps = [ grep { length } map { s/\#.*//; $_ }
                     grep { $_ ne q{\\} }
                     map { s/\A\s+//; s/\s+\z//; $_ }
                     @$optdeps ];
        $pbfields{'optdepends'} = $optdeps;
    }
    else {
        $pbfields{'optdepends'} = [];
    }

    # Convert all depends into hash references...
    VERSPEC_LOOP:
    for my $depkey ( qw/ makedepends depends conflicts / ) {
        my @deps = @{ $pbfields{ $depkey } };
        next VERSPEC_LOOP unless @deps;

        eval {
            $pbfields{ $depkey } = [ map { _depstr_to_hash($_) } @deps ];
        };
        if ( $@ ) {
            die qq{Error with "$depkey" field:\n$@};
        }
    }

    # Provides has no comparison operator and may have no version...
    if ( $pbfields{'provides'} ) {
        $pbfields{'provides'} =
            [ map { _provides_to_hash($_) } @{$pbfields{'provides'}} ];
    }

    return %pbfields;
}

#---HELPER FUNCTION---
sub _slurp
{
    my ($fh) = @_;

    # Make sure we start reading from the beginning of the file...
    seek $fh, SEEK_SET, 0 or die "seek: $!";

    local $/;
    return <$fh>;
}

sub read
{
    my $self = shift;
    $self->{'text'} = ( ref $_[0] eq 'GLOB' ? _slurp( shift ) : shift );

    my %pbfields = _pkgbuild_fields( $self->{'text'} );
    $self->{'fields'} = \%pbfields;
    return %pbfields;
}

sub fields
{
    my ($self) = @_;
    return %{ $self->{'fields'} }
}

sub _def_field_acc
{
    my ($name) = @_;

    no strict 'refs';
    *{ $name } = sub {
        my ($self) = @_;
        my $val = $self->{'fields'}{$name};

        return q{} unless defined $val;
        return $val;
    }
}

_def_field_acc( $_ ) for qw{ pkgname pkgver pkgdesc pkgrel url
                             license install changelog source
                             noextract md5sums sha1sums sha256sums
                             sha384sums sha512sums groups arch
                             backup depends makedepends optdepends
                             conflicts provides replaces options };

1;

__END__