File Coverage

blib/lib/OPM/Validate.pm

Criterion	Covered	Total	%
statement	131	182	71.9
branch	15	24	62.5
condition	13	15	86.6
subroutine	7	7	100.0
pod	1	1	100.0
total	167	229	72.9

package OPM::Validate;

# ABSTRACT: Validate .opm files

use v5.20;

use strict;
use warnings;

our $VERSION = '1.13'; # VERSION

my %boundaries = (
    # tag             min max
    CVS          => [ 0,   1],
    Name         => [ 1,   1],
    URL          => [ 1,   1],
    Vendor       => [ 1,   1],
    Version      => [ 1,   1],
    BuildDate    => [ 0,   1],
    BuildHost    => [ 0,   1],
);

sub validate {
    my ($class, $content, $is_sopm) = @_;

    $content =~ s{

    }{}xmsg;

    my ($check,$grammar) = _grammar( $content, $is_sopm );
    my $match = $content =~ $grammar;
    die 'Invalid .opm file' if !$match;

    for my $key ( keys %boundaries ) {
        $check->( $key );
    }
}

sub _grammar {
    my ($content, $is_sopm) = @_;

    $is_sopm //= 0;

    my %s;
    my %pos;

    my $check = sub {
        my ($name, $max, $min) = @_;

        $max //= (exists $boundaries{$name} ? $boundaries{$name}->[-1] : 100_000);
        $min //= (exists $boundaries{$name} ? $boundaries{$name}->[0] : 0);

        my ($first,$second) = split /\./, $name;

        my $check = $s{$name} // 0;
        if ( $second && ref $s{$first} ) {
            $check = $s{$first}->{$second} // 0;
        }

        my $context = '';
        my $pos     = $pos{$name};
        if ( $pos ) {
            my $start_length = 30;
            my $start        = $pos - $start_length;
            if ( $start < 0 ) {
                $start_length = $pos;
                $start        = 0;
            }

            my $end_length = 30;
            if ( $pos + $end_length > length $content ) {
                $end_length = ( length $content ) - $pos;
            }

            $context = sprintf "\n%s <-- --> %s",
                ( substr $content, $start, $start_length ),
                ( substr $content, $pos, $end_length );
        }

        if ( $check > $max ) {
            die sprintf 'Too many "%s" elements. Max %s element(s) allowed.%s', $name, $max, $context;
        }
        elsif ( $check < $min ) {
            die sprintf 'Too few "%s" elements. Min %s element(s) required.%s', $name, $min, $context;
        }
    };

    my $grammar = qr{
       \A(?&PACKAGE)\z

       (?(DEFINE)
           (?
               \s* <\?xml \s* version="1.0" \s* encoding="[^"]+?" \s* \?> \s+
               \s* <(?otrs|otobo)_package \s+ version="[12].[0-9]+">
               (?:\s*(?&PACKAGE_TAGS))+
               \s*  \s*
           )

           (?
               (?:.*?(?{$pos{CVS} = pos(); $s{CVS}++; $check->('CVS')})) |
               (?:.*?(?{$pos{Name} = pos(); ++$s{Name}; $check->('Name')})) |
               (?:.*?(?{++$s{Version}; $check->('Version')})) |
               (?:.*?(?{++$s{Vendor}; $check->('Vendor')})) |
               (?:.*?(?{++$s{URL}; $check->('URL')})) |
               (?:.*?(?{++$s{License}; $check->('License')})) |
               (?:.*?(?{$s{BuildDate}++; $check->('BuildDate')})) |
               (?:.*?(?{$s{BuildHost}++; $check->('BuildHost')})) |
               (?:.*?) |
               (?:.*?) |
               (?:.*?) |
               (?&FRAMEWORK) |
               (?&DESCRIPTION) |
               (?&INTRO) |
               (?&CODE) |
               (?&PACKAGEMERGE) |
               (?&FILELIST) |
               (?&PREREQ) |
               (?&DATABASE) |
               (?&CHANGELOG)
           )

           (?
             <(?[A-Za-z0-9]+)[^>]*>.*?(?{ print $+{custom},"\n" })
           )

           (?
               .*?
               (*COMMIT)
           )

           (?
               (?:Maximum="[0-9\.]+"(?{++$s{'Framework.Max'}; $check->('Framework.Max',1)})) |
               (?:Minimum="[0-9\.]+"(?{++$s{'Framework.Min'}; $check->('Framework.Min',1)}))
           )

           (?
               .*?
               (*COMMIT)
           )

           (?
               (?:Lang="(?[a-zA-Z]+)"(?{++$s{'Description.Lang'}; $check->('Description.Lang',1)})) |
               (?:Format="[a-zA-Z]+"(?{++$s{'Description.Format'}; $check->('Description.Format',1)})) |
               (?:Translatable="[01]"(?{++$s{'Description.Translatable'}; $check->('Description.Translatable',1)}))
           )

           (?

                   ( \s+ (?&CHANGELOG_ATTR))*>.*?
                (?{$check->('ChangeLog.Date', 1, 0); $check->('ChangeLog.Version', 1, 0); })
               (*COMMIT)
           )

           (?
               (?:Date="[^"]+"(?{++$s{'ChangeLog.Date'}; $check->('ChangeLog.Date',1,1)})) |
               (?:Version="[0-9\.]+"(?{++$s{'ChangeLog.Version'}; $check->('ChangeLog.Version',1,1)}))
           )

           (?
               Install|Upgrade|Reinstall|Uninstall)(?{delete $s{Intro};})
                     (?:(?Pre|Post|)(?{++$s{Intro}->{Type} if $+{intro_pre_post}}))?
                   ( \s+ (?&INTRO_ATTR))+>.*?
                (?{$check->('Intro.Type', 1, 1);})
               (*COMMIT)
           )

           (?
               (?:Type="(?i:Post|Pre)"(?{++$s{Intro}->{Type}; $check->('Intro.Type',1,1)})) |
               (?:Title="[^"]*"(?{++$s{Intro}->{Title}; $check->('Intro.Title',1)})) |
               (?:Format="[^"]*"(?{++$s{Intro}->{Format}; $check->('Intro.Format',1)})) |
               (?:Lang="[A-Za-z]+"(?{++$s{Intro}->{Lang}; $check->('Intro.Lang',1)})) |
               (?:Translatable="[01]"(?{++$s{Intro}->{Translatable}; $check->('Intro.Translatable',1)})) |
               (?:Version="[0-9\.]+"(?{++$s{Intro}->{Version}; $check->('Intro.Version',$+{intro_type} eq 'Upgrade' ? 1 : 0)}))
           )

           (?
               Install|Upgrade|Reinstall|Uninstall) (?{delete $s{Code};})
                   ( \s+ (?&CODE_ATTR))*>.*?
                (?{$check->('Code.Type', 1);})
               (*COMMIT)
           )

           (?
               (?:Type="(?i:Post|Pre)"(?{++$s{Code}->{Type}; $check->('Code.Type',1,1)})) |
               (?:Version="[^"]+"(?{++$s{Code}->{Version}; $check->('Code.Version',$+{code_type} eq 'Upgrade' ? 1 : 0)}))
           )

           (?
               <(?Module|Package)Required (?{delete $s{Prereq};})
                 (\s+ (?&VERSION))?>.+?
                (?{$check->('Prereq.Version', 1); delete $s{Prereq}})
               (*COMMIT)
           )

           (?
               (?:Version="[^"]+"(?{++$s{Prereq}->{Version}; $check->('Prereq.Version', 1)}))
           )

           (?

                 (\s+ (?&PACKAGEMERGEATTR))+>.*?
                (?{$check->('Merge.Name', 1, 1);})
               (*COMMIT)
           )

           (?
               (?:TargetVersion="[0-9\.]+"(?{++$s{'Merge.Version'}; $check->('Merge.Version', 1)})) |
               (?:Name="[^"]+"(?{++$s{'Merge.Name'};}))
           )


           (?
               (\s*(?(?{$is_sopm})(?&FILESOPM)|(?&FILEOPM)))+\s*
               (*COMMIT)
           )

           (?

                   ( \s+ (?&FILE_ATTR))+ \s* />(?{$check->('File.' . $_ , 1, 1) for qw/Location Permission/;})
               (*COMMIT)
           )

           (?

                   ( \s+ (?&FILE_ATTR))+ \s* > \s* [A-Za-z0-9\+/\s]+ (*COMMIT) ={0,3} \s*?
                (?{$check->('File.' . $_ , 1, 1) for qw/Location Permission Encode/;})
               (*COMMIT)
           )

           (?
               (?:Location="[^"]+"(?{++$s{File}->{Location};})) |
               (?:Encode="[^"]+"(?{++$s{File}->{Encode};})) |
               (?:Permission="[0-7]+"(?{++$s{File}->{Permission};}))
           )

           (?
               Install|Upgrade|Reinstall|Uninstall) (?{delete $s{Database}})
                   ( \s+ (?&DATABASE_ATTR)){0,3}>
                   (\s* (?&DATABASE_TAGS) )* \s*

               (*COMMIT)
           )

           (?
               (?:Type="(?i:Post|Pre)"(?{++$s{Database}->{Type}; $check->('Database.Type',1)})) |
               (?:Version="[^"]+"(?{++$s{Database}->{Version}; $check->('Database.Version',1)}))
           )

           (?
               (?&TABLE_CREATE) |
               (?&TABLE_DROP) |
               (?&TABLE_ALTER) |
               (?&INSERT)
           )

           (?

                   (?: \s+ (?&TABLE_ATTR))+ \s*>
                   (?: \s* (?&TABLE_CREATE_TAGS) )+ \s*

               (*COMMIT)
           )

           (?
               (?&COLUMN) |
               (?&FOREIGN_KEY) |
               (?&INDEX) |
               (?&UNIQUE)
           )

           (?

                   ( \s+ (?&TABLE_ALTER_ATTR))+>
                   (\s* (?&TABLE_ALTER_TAGS) )*? \s*

               (*COMMIT)
           )

           (?
               (?&TABLE_ATTR) |
               (?: \s* NameNew="[^"]*?") |
               (?: \s* NameOld="[^"]*?")
           )

           (?
               (?&COLUMN_ADD) |
               (?&COLUMN_DROP) |
               (?&COLUMN_CHANGE) |
               (?&FOREIGN_KEY_CREATE) |
               (?&FOREIGN_KEY_DROP) |
               (?&INDEX_CREATE) |
               (?&INDEX_DROP) |
               (?&UNIQUE_CREATE) |
               (?&UNIQUE_DROP)
           )

           (?

                   ( \s+ (?&TABLE_ATTR))+ \s* (?:/>|>\s*)
               (*COMMIT)
           )

           (?
               (?:Name="([^"]+)"(?{$pos{'Table.Name'} = pos(); ++$s{Table}->{Name}; $check->('Table.Name',1,1)})) |
               (?:Type="(?i:Post|Pre)"(?{++$s{Table}->{Type}; $check->('Table.Type',1)})) |
               (?:Version="[^"]+"(?{++$s{Table}->{Version}; $check->('Table.Version', 1)}))
           )

           (?

                   ( \s+ (?&COLUMN_ATTR))+ \s* (?:/>|>\s*)
               (*COMMIT)
           )

           (?

                   ( \s+ (?&COLUMN_ATTR))+ \s* (?:/>|>\s*)
               (*COMMIT)
           )

           (?
               (?:Name="[^"]+"(?{++$s{Column}->{Name}; $check->('Column.Name',1,1);})) |
               (?:AutoIncrement="(?i:true|false)"(?{++$s{Column}->{AutoIncrement}; $check->('Column.AutoIncrement',1)})) |
               (?:Required="(?i:true|false|0|1)"(?{++$s{Column}->{Required}; $check->('Column.Required',1)})) |
               (?:PrimaryKey="(?i:true|false)"(?{++$s{Column}->{PrimaryKey}; $check->('Column.PrimaryKey',1)})) |
               (?:\bType="[A-Za-z]+"(?{++$s{Column}->{Type}; $check->('Column.Type',1)})) |
               (?:Size="\d+(?:,\d+)?"(?{++$s{Column}->{Size}; $check->('Column.Size',1)})) |
               (?:Default="[^"]+"(?{++$s{Column}->{Default}; $check->('Column.Default',1)}))
           )

           (?

                   (?: \s+ (?&COLUMN_CHANGE_ATTR))+ \s* (?:/>|>\s*)
               (*COMMIT)
           )

           (?
               (?:NameOld="[^"]*?"(?{++$s{Column}->{NameOld}; $check->('Column.NameOld',1)})) |
               (?:NameNew="[^"]*?"(?{++$s{Column}->{NameNew}; $check->('Column.NameNew',1)})) |
               (?:AutoIncrement="(?:true|false)"(?{++$s{Column}->{AutoIncrement}; $check->('Column.AutoIncrement',1)})) |
               (?:Required="(?:true|false|0|1)"(?{++$s{Column}->{Required}; $check->('Column.Required',1)})) |
               (?:PrimaryKey="(?:true|false)"(?{++$s{Column}->{PrimaryKey}; $check->('Column.PrimaryKey',1)})) |
               (?:Type=".*?"(?{++$s{Column}->{Type}; $check->('Column.Type',1)})) |
               (?:Size="\d+(?:,\d+)?"(?{++$s{Column}->{Size}; $check->('Column.Size',1)})) |
               (?:Default=".*?"(?{++$s{Column}->{Default}; $check->('Column.Default',1)}))
           )

           (?

                   ( \s+ (?&COLUMN_DROP_ATTR))+ \s* (?:/>|>\s*)
               (*COMMIT)
           )

           (?
               (?:Name="[^"]+?"(?{++$s{Column}->{Name}; $check->('Column.Name',1,1)}))
           )

           (?

                   ( \s+ (?&INSERT_ATTR))+>
                   (\s+ (?&INSERT_DATA) )+ \s*

               (*COMMIT)
           )

           (?
               (?:Table=".*?"(?{++$s{'Insert.Table'}; $check->('Insert.Table',1,1)})) |
               (?:Type=".*?"(?{++$s{'Insert.Type'}; $check->('Insert.Type',1)})) |
               (?:Version=".*?"(?{++$s{'Insert.Version'}; $check->('Insert.Version',1)}))
           )

           (?

                   ( \s+ (?&INSERT_DATA_ATTR))+>
                   .*?

               (*COMMIT)
           )

           (?
               (?:Key=".*?"(?{++$s{'Data.Key'}; $check->('Data.Key',1,1)})) |
               (?:Translatable="[01]"(?{++$s{'Data.Translatable'}; $check->('Data.Translatable',1)})) |
               (?:Type=".*?"(?{++$s{'Data.Type'}; $check->('Data.Type',1)}))
           )

           (?

                   (\s+ (?&INDEX_COLUMN) )+ \s*

               (?{ delete $s{'Generic.Name'}; })
               (*COMMIT)
           )

           (?

                   ( \s* (?&NAME_ATTR))? \s* (?:/>|>
                   (\s+ (?&INDEX_COLUMN) )* \s*
               )
               (?{ delete $s{'Generic.Name'}; })
               (*COMMIT)
           )

           (?

                   ( \s* (?&NAME_OR_SIZE_ATTR))* \s* (?:/>|>\s*)
               (?{ delete $s{'Generic.Name'}; })
               (*COMMIT)
           )

           (?
               (?&NAME_ATTR) |
               (?:Size="[^"]*")
           )

           (?

                   ( \s* (?&NAME_ATTR))? \s* (?:/>|>\s*)
               (?{ delete $s{'Generic.Name'}; })
               (*COMMIT)
           )

           (?

                   (\s+ (?&UNIQUE_COLUMN) )+ \s*

               (*COMMIT)
           )

           (?

                   ( \s+ (?&NAME_ATTR))? \s* (?:/>|>\s*)
               (?{ delete $s{'Generic.Name'}; })
               (*COMMIT)
           )

           (?

                   ( \s+ (?&NAME_ATTR))? \s* (?:/>|>\s*)
               (?{ delete $s{'Generic.Name'}; })
               (*COMMIT)
           )

           (?
               |>\s*)
               (*COMMIT)
           )

           (?
               (?:Name="[^"]+"(?{++$s{'Generic.Name'}; $check->('Generic.Name',1,1)}))
           )

           (?

                   (\s+ (?&REFERENCE) )+ \s*

               (*COMMIT)
           )

           (?

                   (?: \s+ (?:(?&NAME_ATTR)|(?&FOREIGN_TABLE)))? \s* (?:/>|>\s*
                   (\s+ (?&REFERENCE) )* \s*
               )
               (*COMMIT)
           )

           (?
               |>\s*(?:(?&REFERENCE)\s*)*)
               (*COMMIT)
           )

           (?
               (?:ForeignTable="[^"]+"(?{++$s{'ForeignTable'}; $check->('ForeignTable',1,1)}))
           )

           (?

                   ( \s+ (?&REFERENCE_ATTR) )+ \s*
               (?:\s*/>|>\s*)
               (*COMMIT)
           )

           (?
               (?:Local="[^"]+"(?{++$s{'Reference.Local'}; $check->('Reference.Local',1,1)})) |
               (?:Foreign="[^"]+"(?{++$s{'Reference.Foreign'}; $check->('Reference.Foreign',1,1)}))
           )
       )
    }xms;

    return $check, $grammar;
}

1;

__END__