File Coverage

blib/lib/OTRS/OPM/Validate.pm

Criterion	Covered	Total	%
statement	114	179	63.6
branch	9	18	50.0
condition	7	8	87.5
subroutine	7	7	100.0
pod	1	1	100.0
total	138	213	64.7

package OTRS::OPM::Validate;
$OTRS::OPM::Validate::VERSION = '0.04';
# ABSTRACT: Validate .opm files

use v5.20;

use strict;
use warnings;

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) = @_;

    $content =~ s{

    }{}xmsg;

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

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

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

    my %s;

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

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

        $s{$name} //= 0;

        my $context = '';
#        my $pos     = pos();
#        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 ( $s{$name} > $max ) {
            die sprintf 'Too many "%s" elements. Max %s element(s) allowed.%s', $name, $max, $context;
        }
        elsif ( $s{$name} < $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*
           )

           (?
               (?:.*?(?{$s{CVS}++; $check->('CVS')})) |
               (?:.*?(?{++$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) |
               (?&PREREQ) |
               (?&FILELIST) |
               (?&DATABASE) |
               (?&CHANGELOG)
           )

           (?
               .*?
           )

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

           (?
               .*?
           )

           (?
               (?: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, 1); $check->('ChangeLog.Version', 1, 1); })
           )

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

           (?
               Install|Upgrade|Reinstall|Uninstall) (?{delete @s{map{'Intro.'. $_}qw/Type Lang Title Translatable Version Format/};})
                   ( \s+ (?&INTRO_ATTR))+>.*?
                (?{$check->('Intro.Type', 1, 1);})
           )

           (?
               (?: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=".*?"(?{++$s{'Intro.Version'}; $check->('Intro.Version',$+{intro_type} eq 'Upgrade' ? 1 : 0)}))
           )

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

           (?
               (?: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.Version'};})
                 (\s+ (?&VERSION))?>.*?
                (?{$check->('Prereq.Version', 1);})
           )

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

           (?

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

           (?
               (?:TargetVersion=".*?"(?{++$s{'Merge.Version'}; $check->('Merge.Version', 1)})) |
               (?:Name=".*?"(?{++$s{'Merge.Name'};}))
           )


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

           (?

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

           (?
               (?:Location=".*?"(?{++$s{'File.Location'};})) |
               (?:Encode=".*?"(?{++$s{'File.Encode'};})) |
               (?:Permission=".*?"(?{++$s{'File.Permission'};}))
           )

           (?
               Install|Upgrade|Reinstall|Uninstall) (?{delete @s{map{'Database.'. $_}qw/Type Version/};})
                   ( \s+ (?&DATABASE_ATTR)){0,3}>
                   (\s* (?&DATABASE_TAGS) )+ \s*

           )

           (?
               (?:Type="(?i:Post|Pre)"(?{++$s{'Database.Type'}; $check->('Database.Type',1)})) |
               (?:Version=".*?"(?{++$s{'Database.Version'}; $check->('Database.Version',$+{database_type} eq 'Upgrade' ? 1 : 0)}))
           )

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

           (?

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

           )

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

           (?

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

           )

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

           (?

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

           (?
               (?:Name=".*?"(?{++$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',$+{database_type} eq 'Upgrade' ? 1 : 0)}))
           )

           (?

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

           (?

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

           (?
               (?:Name=".*?"(?{++$s{'Column.Name'}; $check->('Column.Name',1,1)})) |
               (?:AutoIncrement="(?:true|false)"(?{++$s{'Column.AutoIncrement'}; $check->('Column.AutoIncrement',1)})) |
               (?:Required="(?:true|false)"(?{++$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+"(?{++$s{'Column.Size'}; $check->('Column.Size',1)})) |
               (?:Default=".*?"(?{++$s{'Column.Default'}; $check->('Column.Default',1)}))
           )

           (?

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

           (?
               (?: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)"(?{++$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+"(?{++$s{'Column.Size'}; $check->('Column.Size',1)})) |
               (?:Default=".*?"(?{++$s{'Column.Default'}; $check->('Column.Default',1)}))
           )

           (?

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

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

           (?

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

           )

           (?
               (?: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))+>
                   .*?

           )

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

           (?

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

           )

           (?

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

           (?

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

           (?

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

           (?

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

           )

           (?

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

           (?

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

           (?
               |>\s*)
           )

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

           (?

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

           )

           (?

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

           (?
               |>\s*)
           )

           (?
               (?:ForeignTable=".*?"(?{++$s{'ForeignTable'}; $check->('ForeignTable',1,1)}))
           )

           (?

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

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

    return $check, $grammar;
}

1;

__END__