File Coverage

blib/lib/OPM/Maker/Command/sopm.pm

Criterion	Covered	Total	%
statement	351	376	93.3
branch	116	170	68.2
condition	23	41	56.1
subroutine	32	36	88.8
pod	6	6	100.0
total	528	629	83.9

package OPM::Maker::Command::sopm;
$OPM::Maker::Command::sopm::VERSION = '1.2.0';
use v5.10;

use strict;
use warnings;

# ABSTRACT: Build .sopm file based on metadata

use Carp;
use File::Find::Rule;
use File::Basename;
use File::Spec;
use IO::File;
use JSON;
use List::Util qw(first max);
use Path::Class ();
use XML::LibXML;
use XML::LibXML::PrettyPrint;

use OPM::Maker -command;
use OPM::Maker::Utils::OTRS3;
use OPM::Maker::Utils::OTRS4;

sub abstract {
    return "build sopm file based on metadata";
}

sub usage_desc {
    return "opmbuild sopm [--config ] [--cvs] ";
}

sub opt_spec {
    return (
        [ 'config=s', 'JSON file that provides all the metadata' ],
        [ 'cvs'     , 'Add CVS tag to .sopm' ],
    );
}

sub validate_args {
    my ($self, $opt, $args) = @_;

    if ( !$opt->{config} ) {
        my @json_files = File::Find::Rule->file->name( '*.json' )->in( $args->[0] || '.' );

        @json_files > 1 ?
            $self->usage_error( 'found more than one json file, please specify the config file to use' ) :
            do{ $opt->{config} = $json_files[0] };
    }

    if ( !$opt->{config} ) {
        $self->usage_error( 'Please specify the config file to use' );
    }

    my $config = Path::Class::File->new( $opt->{config} );
    my $json = JSON->new->relaxed;
    my $json_text = $config->slurp;
    $self->usage_error( 'config file has to be in JSON format: ' . $@ ) if ! eval{ $json->decode( $json_text ); 1; };
}

sub execute {
    my ($self, $opt, $args) = @_;

    if ( !$opt->{config} ) {
        print $self->usage->text;
        return;
    }

    my $config    = Path::Class::File->new( $opt->{config} );
    my $json_text = $config->slurp;
    my $object    = JSON->new->relaxed;
    my $json      = $object->decode( $json_text );
    my $name      = $json->{name};

    chdir $args->[0] if $args->[0];

    # check needed info
    for my $needed (qw(name version framework)) {
        if ( !$json->{$needed} ) {
            carp "Need $needed in config file";
            exit 1;
        }
    }

    my @xml_parts;
    my %major_versions;

    {
        for my $framework ( @{ $json->{framework} } ) {
            my $version = $framework;
            my $min     = '';
            my $max     = '';

            if ( 'HASH' eq ref $framework ) {
                $version = $framework->{version};
                $min     = $framework->{min};
                $max     = $framework->{max};
            }

            push @xml_parts, sprintf "    %s",
                ( $min ? qq~ Minimum="$min"~ : '' ),
                ( $max ? qq~ Maximum="$max"~ : '' ),
                $version;

            my $major_version = (split /\./, $version)[0];
            $major_versions{$major_version}++;
        }

        if ( 2 <= keys %major_versions ) {
            carp "Two major versions declared in framework settings. Those might be incompatible.\n";
        }
    }

    my %utils_versions = (
        OTRS => {
            '3' => 'OTRS3',
            '4' => 'OTRS4',
            '5' => 'OTRS4',
            '6' => 'OTRS4',
            '7' => 'OTRS4',
        },
        KIX => {
            '5' => 'OTRS4',
        },
        OTOBO => {
            '10' => 'OTRS4',
        },
    );

    my ($max) = max keys %major_versions;

    my $product = uc ( $json->{product} // 'OTRS' );
    if ( $product eq 'KIX' ) {
        $max = 5;
    }

    my $mod   = $utils_versions{$product}->{$max} || $utils_versions{OTRS}->{4};
    my $utils = 'OPM::Maker::Utils::' . $mod;

    if ( $json->{requires} ) {
        {
            for my $name ( sort keys %{ $json->{requires}->{package} } ) {
                push @xml_parts, sprintf '    %s', $json->{requires}->{package}->{$name}, $name;
            }
        }

        {
            for my $name ( sort keys %{ $json->{requires}->{module} } ) {
                push @xml_parts, sprintf '    %s', $json->{requires}->{module}->{$name}, $name;
            }
        }
    }

    push @xml_parts, sprintf "    %s", $json->{vendor}->{name} || '';
    push @xml_parts, sprintf "    %s", $json->{vendor}->{url} || '';

    if ( $json->{description} ) {
        for my $lang ( sort keys %{ $json->{description} } ) {
            push @xml_parts, sprintf '    %s', $lang, $json->{description}->{$lang};
        }
    }

    if ( $json->{license} ) {
        push @xml_parts, sprintf '    %s', $json->{license};
    }

    # create filelist
    {
        my @files = File::Find::Rule->file->in( '.' );

        # remove "hidden" files from list; and do not list .sopm
        @files = grep{
            ( substr( $_, 0, 1 ) ne '.' ) &&
            $_ !~ m{[\\/]\.} &&
            $_ ne $json->{name} . '.sopm'
        }sort @files;

        if ( $json->{exclude_files} and 'ARRAY' eq ref $json->{exclude_files} ) {
            # ignore ignore file ;-)
            my $ignore_name = '.opmbuild_filetest_ignore';
            push @{ $json->{exclude_files} }, $ignore_name if !grep{ $_ eq $ignore_name } @{ $json->{exclude_files} };

            for my $index ( reverse 0 .. $#files ) {
                my $file     = $files[$index];
                my $excluded = first {
                    eval{ $file =~ /$_\z/ };
                }@{ $json->{exclude_files} };

                splice @files, $index, 1 if $excluded;
            }

            # create ignore file
            my $fh = IO::File->new( $ignore_name, 'w' ) or die $!;
            my $ignore_files = join "\n", @{ $json->{exclude_files} };
            $fh->print( $ignore_files );
            $fh->close;
        }

        $utils->filecheck( \@files );

        push @xml_parts,
            sprintf "    \n%s\n    ",
                join "\n", map{ my $permission = $_ =~ /^bin/ ? 755 : 644; qq~        ~ }@files;
    }

    if ( $json->{changes_file} && -f $config->dir . "/" . $json->{changes_file} ) {
        my $changes_file = Path::Class::File->new( $config->dir, $json->{changes_file} );
        my $lines        = $changes_file->slurp( iomode => '<:encoding(UTF-8)' );

        my @entries = grep{ ( $_ // '' ) ne '' }split m{
            (?:\s+)?
            (                         # headline with version and date
                ^
                \d+\.\d+ (?:\.\d+)?   # version
                \s+ - \s+
                \d{4}-\d{2}-\d{2} \s  # date
                \d{2}:\d{2}:\d{2}     # time
            )
            \s+
        }xms, $lines;

        while ( @entries ) {
            my ($header, $desc) = ( shift(@entries), shift(@entries) );

            my ($version, $date) = split /\s+-\s+/, $header // '';

            $desc =~ s{\s+\z}{};

            push @xml_parts, sprintf qq~    ~, $version, $date, $desc;
        }
    }

    # changelog
    {
        CHANGE:
        for my $change ( @{ $json->{changes} || [] } ) {
            my $version = '';
            my $date    = '';
            my $info    = '';

            if ( !ref $change ) {
                $info = $change;
            }
            elsif ( 'HASH' eq ref $change ) {
                $info    = $change->{message};
                $version = sprintf( ' Version="%s"', $change->{version} ) if $change->{version};
                $date    = sprintf( ' Date="%s"', $change->{date} )       if $change->{date};
            }

            next CHANGE if !length $info;

            push @xml_parts, sprintf "    %s", $version, $date, $info;
        }
    }

    my %actions = (
        Install   => 'post',
        Uninstall => 'pre',
        Upgrade   => 'post',
    );

    my %action_code = (
        TableCreate      => \&_TableCreate,
        Insert           => \&_Insert,
        TableDrop        => \&_TableDrop,
        ColumnAdd        => \&_ColumnAdd,
        ColumnDrop       => \&_ColumnDrop,
        ColumnChange     => \&_ColumnChange,
        ForeignKeyCreate => \&_ForeignKeyCreate,
        ForeignKeyDrop   => \&_ForeignKeyDrop,
        UniqueDrop       => \&_UniqueDrop,
        UniqueCreate     => \&_UniqueCreate,
    );

    my %tables_to_delete;
    my %own_tables;
    my @columns_to_delete;
    my %db_actions;

    my $table_counter = 0;
    my $column_counter;

    ACTION:
    for my $action ( @{ $json->{database} || [] } ) {
        my $tmp_version = $action->{version};
        my @versions    = ref $tmp_version ? @{$tmp_version} : ($tmp_version);

        VERSION:
        for my $version ( @versions ) {
            my $action_type = $version ? 'Upgrade' : 'Install';
            my $op          = $action->{type};

            if ( $action->{uninstall} ) {
                $action_type = 'Uninstall';
            }

            next VERSION if !$action_code{$op};

            my $phase = $action->{phase} || $actions{ $action_type };

            if ( $op eq 'TableCreate' ) {
                my $table = $action->{name};
                $tables_to_delete{$table} = $table_counter++;
                $own_tables{$table}       = 1;
            }
            elsif ( $op eq 'TableDrop' ) {
                my $table = $action->{name};
                delete $tables_to_delete{$table};
            }

            if ( $op eq 'ColumnAdd' ) {
                my $table = $action->{name};
                if ( !$own_tables{$table} ) {
                    unshift @columns_to_delete, +{
                        name    => $table,
                        columns => [ map { $_->{name} } @{ $action->{columns} || [] } ],
                    };
                }
            }

            $action->{version} = $version;
            push @{ $db_actions{$action_type}->{$phase} }, $action_code{$op}->($action);
        }
    }

    for my $columns_delete ( @columns_to_delete ) {
        push @{ $db_actions{Uninstall}->{pre} }, _ColumnDrop($columns_delete);
    }

    if ( %tables_to_delete ) {
        for my $table ( sort { $tables_to_delete{$b} <=> $tables_to_delete{$a} }keys %tables_to_delete ) {
            push @{ $db_actions{Uninstall}->{pre} }, _TableDrop({ name => $table });
        }
    }

    for my $action_type ( qw/Install Upgrade Uninstall/ ) {
        for my $phase ( qw/pre post/ ) {

            next if !$db_actions{$action_type}->{$phase};

            push @xml_parts,
                sprintf qq~
%s
    ~, join "\n", @{ $db_actions{$action_type}->{$phase} };
        }
    }

    CODE:
    for my $code ( @{ $json->{code} || [] } ) {
        if ( !ref $code ) {
            $code = {
                type    => $code,
                version => 0,
                phase   => ( $code eq 'Uninstall' ? 'pre' : 'post' ),
            };
        }

        $code->{type} = 'Code' . $code->{type};

        if ( $code->{inline} ) {
            push @xml_parts, _InlineCode( $code );
            next CODE;
        }

        push @xml_parts, $utils->packagesetup(
            $code->{type},
            $code->{version},
            $code->{function} || $code->{type},
            $code->{phase},
            $code->{package},
        );
    }

    for my $intro ( @{ $json->{intro} || [] } ) {
        push @xml_parts, _IntroTemplate( $intro );
    }

    my $cvs = "";
    if ( $opt->{cvs} ) {
        $cvs = sprintf qq~\n    \$Id: %s.sopm,v 1.1.1.1 2011/04/15 07:49:58 rb Exp \$~, $name;
    }

    my %product_start_tags = (
        OTRS  => 'otrs_package',
        KIX   => 'otrs_package',
        OTOBO => 'otobo_package',
    );

    my $start_tag = $product_start_tags{$product};

    my $xml = sprintf q~
<%s version="1.0">
    %s
    %s
    %s
%s

~,
    $start_tag,
    __PACKAGE__->VERSION(),
    $cvs,
    $name,
    $json->{version},
    join( "\n", @xml_parts ),
    $start_tag;

    my $fh = IO::File->new( $name . '.sopm', 'w' ) or die $!;
    $fh->print( $xml );
    $fh->close;
}

sub _InlineCode {
    my ($code) = @_;

    my @parts = split /::/, $code->{inline};

    my $method  = pop @parts;
    $parts[-1] .= '.pm';
    my $file    = Path::Class::File->new( @parts );

    my $content = $file->slurp( iomode => '<:encoding(utf-8)' );

    my ($method_body) = $content =~ m{
        ^sub \s+ \Q$method\E \s* \{ \s+
            (.*?)
        ^\}\s+
    }xms;

    my $version = $code->{version} ?
        ' Version="' . $code->{version} . '"' :
        '';

    my $xml = sprintf q~    <%s Type="%s"%s>
        %s
    ]]>~, $code->{type}, $code->{phase} // 'post', $version, $method_body, $code->{type};

    return $xml;
}

sub _IntroTemplate {
    my ($intro) = @_;

    my $version = $intro->{version} ? ' Version="' . $intro->{version} . '"' : '';
    my $type    = $intro->{type};
    my $text    = ref $intro->{text} ? join( "\n", @{ $intro->{text} } ) : $intro->{text};
    my $phase   = $intro->{time} || "post";
    my $lang    = $intro->{lang} ? ' Lang="' . $intro->{lang} . '"' : '';
    my $title   = $intro->{title} ? ' Title="' . $intro->{title} . '"' : '';

    return qq~
            $text
    ]]>~;
}

sub _Insert {
    my ($action) = @_;


    my $table   = $action->{name};
    my $version = $action->{version};

    my $version_string = $version ? ' Version="' . $version . '"' : '';

    my $string = '        \n";

    COLUMN:
    for my $column ( @{ $action->{columns} || [] } ) {
        my $value = ref $column->{value} ? join( "\n", @{ $column->{value} } ) : $column->{value};
        $value //= '';

        $string .= sprintf '            %s' . "\n",
            $column->{name},
            ( $column->{type} ?
                (' Type="' . $column->{type} . '"', '' ) :
                ("", $value)
            );
    }

    $string .= '        ';

    return $string;
}

sub _TableDrop {
    my ($action) = @_;

    my $table = $action->{name};

    return '        ';
}

sub _TableCreate {
    my ($action) = @_;

    my $table   = $action->{name};
    my $version = $action->{version};

    my $version_string = $version ? ' Version="' . $version . '"' : '';

    my $string = '        \n";

    COLUMN:
    for my $column ( @{ $action->{columns} || [] } ) {
        my $type = _TypeCheck( $column->{type}, 'TableCreate' );
        $string .= sprintf '            ' . "\n",
            $column->{name},
            $column->{required},
            $type,
            ( $column->{size} ? ' Size="' . $column->{size} . '"' : "" ),
            ( $column->{auto_increment} ? ' AutoIncrement="true"' : "" ),
            ( $column->{primary_key} ? ' PrimaryKey="true"' : "" ),
    }

    UNIQUE:
    for my $unique ( @{ $action->{unique} || [] } ) {
        my $table = $unique->{name};
        $string .= '            {columns} || ["unique$table"] } ) ) . '">' . "\n";

        for my $column ( @{ $unique->{columns} || [] } ) {
            $string .= '                ' . "\n";
        }

        $string .= '            ' . "\n";
    }

    KEY:
    for my $key ( @{ $action->{keys} || [] } ) {
        my $table = $key->{name};
        $string .= '            ' . "\n";

        for my $reference ( @{ $key->{references} || [] } ) {
            my $local   = $reference->{local};
            my $foreign = $reference->{foreign};
            $string .= '                ' . "\n";
        }

        $string .= '            ' . "\n";
    }

    $string .= '        ';

    return $string;
}

sub _ColumnAdd {
    my ($action) = @_;

    my $table   = $action->{name};
    my $version = $action->{version};

    my $version_string = $version ? ' Version="' . $version . '"' : '';

    my $string = '        \n";

    COLUMN:
    for my $column ( @{ $action->{columns} || [] } ) {
        my $type = _TypeCheck( $column->{type}, 'ColumnAdd' );
        $string .= sprintf '            ' . "\n",
            $column->{name},
            $column->{required},
            $type,
            ( $column->{size} ? ' Size="' . $column->{size} . '"' : "" ),
            ( $column->{auto_increment} ? ' AutoIncrement="true"' : "" ),
            ( $column->{primary_key} ? ' PrimaryKey="true"' : "" ),
    }

    $string .= '        ';

    return $string;
}

sub _ColumnDrop {
    my ($action) = @_;

    my $table   = $action->{name};
    my $version = $action->{version};

    my $version_string = $version ? ' Version="' . $version . '"' : '';

    my $string = '        \n";

    COLUMN:
    for my $column ( @{ $action->{columns} || [] } ) {
        $string .= sprintf qq~            \n~, $column;
    }

    $string .= '        ';

    return $string;
}

sub _ForeignKeyCreate {
    my ($action) = @_;

    my $table   = $action->{name};
    my $version = $action->{version};

    my $version_string = $version ? ' Version="' . $version . '"' : '';

    my $string = '        \n";

    COLUMN:
    for my $reference ( @{ $action->{references} || [] } ) {
        $string .= sprintf '

            ' . "\n",
            $reference->{name},
            $reference->{local},
            $reference->{foreign};
    }

    $string .= '        ';

    return $string;
}

sub _ForeignKeyDrop {
    my ($action) = @_;

    my $table   = $action->{name};
    my $version = $action->{version};

    my $version_string = $version ? ' Version="' . $version . '"' : '';

    my $string = '        \n";

    COLUMN:
    for my $reference ( @{ $action->{references} || [] } ) {
        $string .= sprintf '

            ' . "\n",
            $reference->{name},
            $reference->{local},
            $reference->{foreign};
    }

    $string .= '        ';

    return $string;
}

sub _UniqueCreate {
    my ($action) = @_;

    my $table   = $action->{name};
    my $version = $action->{version};

    my $version_string = $version ? ' Version="' . $version . '"' : '';

    my $string = '        \n";
    $string   .= sprintf qq~            \n~, $action->{unique_name};

    COLUMN:
    for my $column ( @{ $action->{columns} || [] } ) {
        $string .= sprintf qq~                \n~,
            $column;
    }

    $string .= qq~            \n~;
    $string .= '        ';

    return $string;
}

sub _UniqueDrop {
    my ($action) = @_;

    my $table   = $action->{name};
    my $version = $action->{version};

    my $version_string = $version ? ' Version="' . $version . '"' : '';

    my $string = '        \n";

    $string .= sprintf qq~            \n~,
        $action->{unique_name};

    $string .= '        ';

    return $string;
}

sub _ColumnChange {
    my ($action) = @_;

    my $table   = $action->{name};
    my $version = $action->{version};

    my $version_string = $version ? ' Version="' . $version . '"' : '';

    my $string = '        \n";

    COLUMN:
    for my $column ( @{ $action->{columns} || [] } ) {
        my $type = _TypeCheck( $column->{type}, 'ColumnChange' );
        $string .= sprintf '            ' . "\n",
            $column->{new_name},
            $column->{old_name},
            $column->{required},
            $type,
            ( $column->{size} ? ' Size="' . $column->{size} . '"' : "" ),
            ( $column->{auto_increment} ? ' AutoIncrement="true"' : "" ),
            ( $column->{primary_key} ? ' PrimaryKey="true"' : "" ),
    }

    $string .= '        ';

    return $string;
}

sub _TypeCheck {
    my ($type, $action) = @_;

    my %types = (
        DATE     => 1,
        SMALLINT => 1,
        BIGINT   => 1,
        INTEGER  => 1,
        DECIMAL  => 1,
        VARCHAR  => 1,
        LONGBLOB => 1,
    );

    if ( !$types{$type} ) {
        croak "$type is not allowed in $action. Allowed types: ", join ', ', sort keys %types;
    }

    return $type;
}

sub VERSION {
    return $OPM::Maker::Command::sopm::VERSION || '1.0.0';
}

1;

__END__