view release on metacpan or  search on metacpan

lib/Acrux/DBI/Dump.pm  view on Meta::CPAN

=head1 SEE ALSO

L<Acrux::DBI>, L<Mojo::mysql>, L<Mojo::Pg>

=head1 AUTHOR

Serż Minus (Sergey Lepenkov) L<https://www.serzik.com> E<lt>abalama@cpan.orgE<gt>

=head1 COPYRIGHT

Copyright (C) 1998-2026 D&D Corporation

=head1 LICENSE

This program is distributed under the terms of the Artistic License Version 2.0

See the C<LICENSE> file or L<https://opensource.org/license/artistic-2-0> for details

=cut

use Mojo::Base -base;

use Mojo::Loader qw/data_section/;
use Mojo::File qw/path/;

use constant {
    DELIMITER   => ';',
    TAG_DEFAULT => 'main',
};

has name => 'schema';
has 'dbi';
has 'pool' => sub {{}};

sub from_string {
    my $self = shift;
    my $s = shift;
    return $self unless defined $s;
    my $pool = $self->{pool} = {};
    my $tag = TAG_DEFAULT;
    my $delimiter = DELIMITER;
    my $is_new = 1;
    my $buf = '';

    # String processing
    while (length($s)) {
        my $chunk;

        # get fragments (chunks) from string
        if ($s =~ /^$delimiter/x) { # any delimiter char(s)
            $is_new = 1;
            $chunk = $delimiter;
        } elsif ($s =~ /^delimiter\s+(\S+)\s*(?:\n|\z)/ip) { # set new delimiter
            $is_new = 1;
            $chunk = ${^MATCH};
            $delimiter = $1;
        } elsif ($s =~ /^(\s+)/s or $s =~ /^(\w+)/) { # whitespaces or general name
            $chunk = $1;
        } elsif ($s =~ /^--.*(?:\n|\z)/p                            # double-dash comment
                or $s =~ /^\#.*(?:\n|\z)/p                          # hash comment
                or $s =~ /^\/\*(?:[^\*]|\*[^\/])*(?:\*\/|\*\z|\z)/p # C-style comment
                or $s =~ /^'(?:[^'\\]*|\\(?:.|\n)|'')*(?:'|\z)/p    # single-quoted literal text
                or $s =~ /^"(?:[^"\\]*|\\(?:.|\n)|"")*(?:"|\z)/p    # double-quoted literal text
                or $s =~ /^`(?:[^`]*|``)*(?:`|\z)/p ) {             # schema-quoted literal text
            $chunk = ${^MATCH};
        } else {
            $chunk = substr($s, 0, 1);
        }
        #say STDERR ">$chunk<";

        # cut string by chunk length
        substr($s, 0, length($chunk), '');

        # marker
        if ($chunk =~ /^--\s+[#]+\s*(\w+)/i) {
            my $_tag = $1 // TAG_DEFAULT;
            push @{$pool->{$tag} //= []}, $buf if length($tag) and $buf !~ /^\s*$/s;
            $tag = $_tag;
            $is_new = 0;
            $buf = '';
            $delimiter = DELIMITER; # flush delimiter to default
        }

        # make new block
        if ($is_new) {
            push @{$pool->{$tag} //= []}, $buf if length($tag) and $buf !~ /^\s*$/s;
            $is_new = 0;
            $buf = '';
        } else { # Or add cur chunk to section
            $buf .= $chunk;
        }
    }

    # add buf line to block
    push @{$pool->{$tag} //= []}, $buf if length($tag) and $buf !~ /^\s*$/s;

    return $self;
}
sub from_data {
    my $self = shift;
    my $class = shift;
    my $name = shift;
    return $self->from_string(data_section($class //= caller, $name // $self->name));
}
sub from_file {
    my $self = shift;
    my $file = shift;
    return $self->from_string(path($file)->slurp('UTF-8'));
}
sub poke {
    my $self = shift;
    my $tag = shift || TAG_DEFAULT;
    my $sqls = $self->pool->{$tag} || [];
    my $dbi = $self->dbi;
    return $self unless $dbi and $dbi->ping;

    # Import statements
    foreach my $sql (@$sqls) {
        #print STDERR $sql, "\n";
        $dbi->query($sql) or last;
    }