ngcp-schema/bin/ngcp-dump-schema

#!/usr/bin/perl

use Sipwise::Base;
use DBIx::Class::Schema::Loader qw(make_schema_at);
use File::Path qw(make_path);
use Getopt::Long qw(GetOptions);
use Quantum::Superpositions qw(any);
use Pod::Usage qw(pod2usage);

my $result_class_code = <<'END';
sub TO_JSON {
    my ($self) = @_;
    return {
        map { blessed($_) && $_->isa('DateTime') ? $_->datetime : $_ } %{ $self->next::method }
    };
}
END

my %opt = (
    dump_directory => 'lib',
);

# XXX: Remove after mr10.5.
sub old_option {
    my ($name, $value) = @_;
    my $newname = $name =~ tr/_/-/r;
    $opt{$name} = $value;
    warn "$0: option --$name is deprecated; use --$newname instead\n";
}

GetOptions(\%opt,
    'dump_directory:s' => \&old_option,
    'dump-directory:s' => \$opt{dump_directory},
    'overwrite_modifications' => \&old_option,
    'overwrite-modifications' => \$opt{overwrite_modifications},
    'version=s',
    'help|?',
    'man',
) or die 'could not process command-line options';

pod2usage(-exitval => 1) if $opt{help};
pod2usage(-exitval => 0, -verbose => 2) if $opt{man};
pod2usage unless $opt{version};

make_path $opt{dump_directory};

for my $db (qw(accounting billing carrier kamailio ngcp provisioning sipstats)) {
    make_schema_at(
        "NGCP::Schema::$db",
        {
            overwrite_modifications => $opt{overwrite_modifications},
            col_collision_map => 'column_%s',
            dump_directory => $opt{dump_directory},
            filter_generated_code => sub {
                my ($type, $class, $text) = @_;
                my (@source, @pod);
                my $in_pod = 0;
                for my $line (split /(?<=\n)/, $text) {
                    next if $line eq any(
                        "use utf8;\n",
                        "use strict;\n",
                        "use warnings;\n",
                        "use Moose;\n",
                        "use MooseX::NonMoose;\n",
                        "use MooseX::MarkAsMethods autoclean => 1;\n",
                    );
                    if ($line =~ /^=head/) {
                        $in_pod = 1;
                    }
                    if ($line =~ /^=cut/) {
                        $in_pod = 0;
                        next;
                    }
                    if ($in_pod) {
                        push @pod, $line;
                    } else {
                        push @source, $line;
                    }
                }
                my $package = shift @source;
                @source = (
                    $package,
                    "use Sipwise::Base;\n",
                    ($package =~ /::Result::/ ? "use MooseX::NonMoose;\nuse Scalar::Util qw(blessed);\n" : ()),
                    "our \$VERSION = '$opt{version}';\n",
                    @source,
                    ($package =~ /::Result::/ ? $result_class_code : ()),
                );
                @pod = ("=encoding UTF-8\n\n", @pod, "=cut\n") if @pod;
                return join '', @source, @pod;
            },
            moniker_map => sub { $_[0] },
            col_accessor_map => sub {
                my ($column) = @_;
                return __PACKAGE__->can($column) ? "column_$column" : $column;
            },
            components => [qw(InflateColumn::DateTime Helper::Row::ToJSON)],
            quiet => 1,
            use_moose => 1,
        },
        [
            "dbi:mysql:dbname=$db", 'root'
        ],
    );
}

__END__

=encoding UTF-8

=head1 NAME

ncgp-dump-schema - recreate schema files from live database definition

=head1 SYNOPSIS

B<ncgp-dump-schema> B<--version>=I<VERSION> [I<option>...]

=head1 DESCRIPTION

This program takes care of recreating schema files from live database
definitions.

=head1 OPTIONS

=head2 B<--dump-directory>[=I<DIRECTORY>]

Directory name for the output, default is F<lib>.

=head2 B<--overwrite-modifications>

(boolean) See L<DBIx::Class::Schema::Loader::Base/overwrite_modifications>,
default is false. Use with care, since this is a potentially destructive
operation, only apply to a working copy in a known safe fall-back state.

=head2 B<--version>=I<VERSION>

(required) Version for the dumped classes. Increase the version when
incompatible changes are done, e.g. adding a table. See L<Perl::Version> for
the notion and L<Sipwise::CodingStandards/"versions"> for guidance.

=head2 B<-?>, B<--help>

Print a brief help message and exits.

=head2 B<--man>

Prints the manual page and exits.

=head1 AUTHOR

Sipwise Development Team C<< <support@sipwise.com> >>

=head1 LICENSE

This software is Copyright © 2017 by Sipwise GmbH, Austria.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this package.  If not, see <https://www.gnu.org/licenses/>.