The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package ObjectDB::Util;

use strict;
use warnings;

use base 'Exporter';

our $VERSION   = '3.10';
our @EXPORT_OK = qw(load_class execute merge merge_rows filter_columns);

require Carp;
use Hash::Merge ();
use ObjectDB::Exception;

sub load_class {
    my ($class) = @_;

    Carp::croak('class name is required') unless $class;

    Carp::croak("Invalid class name '$class'")
      unless $class =~ m/^[[:lower:]\d:]+$/smxi;

    my $path = $class;
    $path =~ s{::}{/}smxg;
    $path .= '.pm';

    return 1 if exists $INC{$path} && defined $INC{$path};

    {
        no strict 'refs';

        for (keys %{"$class\::"}) {
            return 1 if defined &{$_};
        }
    }

    eval {
        require $path;

        1;
    } or do {
        my $e = $@;

        delete $INC{$path};

        {
            no strict 'refs';
            %{"$class\::"} = ();
        }

        Carp::croak($e);
    };
}

sub execute {
    my ($dbh, $stmt, %context) = @_;

    my $sql  = $stmt->to_sql;
    my @bind = $stmt->to_bind;

    my ($rv, $sth);
    eval {
        $sth = $dbh->prepare($sql);
        $rv  = $sth->execute(@bind);

        1;
    } or do {
        my $e = $@;

        ObjectDB::Exception->throw($e, %context, sql => $stmt);
    };

    return wantarray ? ($rv, $sth) : $rv;
}

my $merge;

sub merge {
    $merge ||= do {
        my $merge = Hash::Merge->new();
        $merge->set_behavior('STORAGE_PRECEDENT');
        $merge->set_clone_behavior(1);
        $merge;
    };
    $merge->merge(@_);
}

sub merge_rows {
    my $rows = shift;

    my $merged = [];

    my %order;
  NEXT_MERGE: while (@$rows) {
        my $row = shift @$rows;

        my $row_sign = '';
        foreach my $key (sort keys %$row) {
            my $value = $row->{$key};
            $value = \'join' if ref $value eq 'HASH' || ref $value eq 'ARRAY';

            $value = \undef unless defined $value;
            $row_sign .= "$key=$value";
        }

        if (!exists $order{$row_sign}) {
            $order{$row_sign} = $row;

            push @$merged, $row;
            next NEXT_MERGE;
        }

        my $prev = $order{$row_sign};

        foreach my $key (keys %$row) {
            next
              unless ref $prev->{$key} eq 'HASH'
              || ref $prev->{$key} eq 'ARRAY';

            my $prev_row =
              ref $prev->{$key} eq 'ARRAY'
              ? $prev->{$key}->[-1]
              : $prev->{$key};

            my $merged = merge_rows([$prev_row, $row->{$key}]);
            if (@$merged > 1) {
                my $prev_rows =
                  ref $prev->{$key} eq 'ARRAY'
                  ? $prev->{$key}
                  : [$prev->{$key}];
                pop @$prev_rows;
                $prev->{$key} = [@$prev_rows, @$merged];
            }
        }
    }

    return $merged;
}

sub filter_columns {
    my ($meta_columns, $params) = @_;

    my $columns = $params->{columns} || $meta_columns;
    $columns = [$columns] unless ref $columns eq 'ARRAY';

    push @$columns, @{$params->{'+columns'}} if $params->{'+columns'};
    if ($params->{'-columns'}) {
        my $minus_columns = {map { $_ => 1 } @{$params->{'-columns'}}};
        $columns =
          [grep { !exists $minus_columns->{ref($_) ? $_->{'-col'} : $_} }
              @$columns];
    }

    return $columns;
}

1;