File Coverage

blib/lib/MySQL/Sandbox.pm

Criterion	Covered	Total	%
statement	44	375	11.7
branch	9	202	4.4
condition	1	66	1.5
subroutine	10	37	27.0
pod	0	27	0.0
total	64	707	9.0

package MySQL::Sandbox;
use strict;
use warnings;
use Carp;
use English qw( -no_match_vars );
use Socket;
use File::Find;
use Data::Dumper;

use base qw( Exporter);
our @ISA= qw(Exporter);
our @EXPORT_OK= qw( is_port_open
                    runs_as_root
                    mylogin_cnf_exists
                    exists_in_path
                    is_a_sandbox
                    find_safe_port_and_directory
                    first_unused_port
                    get_sandbox_params
                    is_sandbox_running
                    get_sb_info
                    get_ports
                    get_ranges
                    use_env
                    sbinstr
                    get_json_from_dirs
                    get_option_file_contents
                    validate_json_object
                    fix_server_uuid
                    greater_version
                    split_version
                    ) ;

our $VERSION=q{3.2.15};
our $DEBUG;

BEGIN {
    $DEBUG = $ENV{'SBDEBUG'} || $ENV{'SBVERBOSE'} || 0;
    if (! $ENV{'USER'})
    {
        my $user = qx/whoami/;
        chomp $user;
        $ENV{'USER'} = $user;
    }
    for my $var (qw( HOME USER PWD ))
    {
        unless ($ENV{$var}) {
        die "The variable \$$var is undefined - aborting\n";
        }
    }
    if ($ENV{HOME} =~ /\s/)
    {
        die "# The variable \$HOME contains spaces. Please fix this problem before continuing\n(HOME='$ENV{HOME}')\n";
    }
    unless ( $ENV{SANDBOX_HOME} ) {
        $ENV{SANDBOX_HOME} = "$ENV{HOME}/sandboxes";
    }

    unless ($ENV{TMPDIR})
    {
        $ENV{TMPDIR} = '/tmp';
    }
    unless ( -d $ENV{TMPDIR})
    {
        die "could not find $ENV{TMPDIR}\n";
    }

    if ( -d "$ENV{HOME}/sandboxes" ) {
        $ENV{SANDBOX_HOME} = $ENV{SANDBOX_HOME} || "$ENV{HOME}/sandboxes";
    }

    unless ( $ENV{SANDBOX_BINARY} ) {
        if ( -d "$ENV{HOME}/opt/mysql") {
            $ENV{SANDBOX_BINARY} = "$ENV{HOME}/opt/mysql";
        }
        else
        {
            $ENV{SANDBOX_BINARY} = '';
        }
    }
}

my @supported_versions = qw( 3.23 4.0 4.1 5.0 5.1 5.2 5.3 5.4
    5.5 5.6 5.7 6.0 8.0 10.0 10.1 10.2 10.3 );

our $sandbox_options_file    = "my.sandbox.cnf";
# our $sandbox_current_options = "current_options.conf";

our %default_base_port = (
    replication => 11000,
    circular    => 14000,
    multiple    =>  7000,
    custom      =>  5000,
);

our %default_users = (
    db_user                => 'msandbox',
    remote_access          => '127.%',
    db_password            => 'msandbox',
    ro_user                => 'msandbox_ro',
    rw_user                => 'msandbox_rw',
    repl_user              => 'rsandbox',
    repl_password          => 'rsandbox',
);

our $SBINSTR_SH_TEXT =<<'SBINSTR_SH_TEXT';
if [ -f "$SBINSTR" ]
then
    echo "[`basename $0`] - `date "+%Y-%m-%d %H:%M:%S"` - $@" >> $SBINSTR
fi
SBINSTR_SH_TEXT



sub new {
    my ($class) = @_;
    my $self = bless {
        parse_options => undef,
        options => undef,
    }, $class;
    # my $version = get_version( $install_dir);
    # $self->{version} = $VERSION;
    return $self;
}

sub parse_options {
    my ($self, $opt ) = @_;
    # print "<", ref($opt) , ">\n";
    unless (ref($opt) eq 'HASH') {
        confess "parse_options must be a hash reference\n";
    }
    if ($opt) {
        $self->{parse_options} = $opt;
    }
    my %options = map { $_ ,  $opt->{$_}{'value'}}  keys %{$opt};
    $self->{options} = \%options;

    return $self->{options};
}

sub find_safe_port_and_directory {
    my ($wanted_port, $wanted_dir, $upper_directory) = @_;
    my $chosen_port = $wanted_port;
    my ($ports, undef) = get_sb_info( $ENV{SANDBOX_HOME}, undef);
    # print Dumper($ports);
    while ( is_port_open($chosen_port) or exists $ports->{$chosen_port}) {
        $chosen_port++;
        $chosen_port = first_unused_port($chosen_port);
        # print "checking -> $chosen_port\n";
    }
    my $suffix = 'a';
    my $chosen_dir = $wanted_dir;
    while ( -d "$upper_directory/$chosen_dir" ) {
        # print "checking -> $chosen_dir\n";
        $chosen_dir = $wanted_dir . '_' . $suffix;
        $suffix++;
    }
    return ($chosen_port, $chosen_dir);
}

sub get_help {
    my ($self, $msg) = @_;
    if ($msg) {
        warn "[***] $msg\n\n";
    }

    my $HELP_MSG = q{};
    for my $op (
                sort { $self->{parse_options}->{$a}{so} <=> $self->{parse_options}->{$b}{so} }
                grep { $self->{parse_options}->{$_}{parse}}  keys %{ $self->{parse_options} } ) {
        my $param =  $self->{parse_options}->{$op}{parse};
        my $param_str = q{    };
        my ($short, $long ) = $param =~ / (?: (\w) \| )? (\S+) /x;
        if ($short) {
            $param_str .= q{-} . $short . q{ };
        }
        $long =~ s/ = s \@? / = name/x;
        $long =~ s/ = i / = number/x;
        $param_str .= q{--} . $long;
        my $lparam = 40 - length($param_str);
        if ($lparam < 0)
        {
            $lparam = 0;
        }
        $param_str .= (q{ } x $lparam );
        my $text_items = $self->{parse_options}->{$op}{help};
        for my $titem (@{$text_items}) {
            $HELP_MSG .= $param_str . $titem . "\n";
            $param_str = q{ } x 40;
        }
        if (@{$text_items} > 1) {
            $HELP_MSG .= "\n";
        }
        # $HELP_MSG .= "\n";
   }

   my $VAR_HELP =
    "\nVARIABLES affecting this program: \n"
        . "\t\$SBDEBUG : DEBUG LEVEL ("
            . ($ENV{SBDEBUG} || 0) . ")\n"
        . "\t\$SBVERBOSE : DEBUG LEVEL (same as \$SBDEBUG) ("
            . ($ENV{SBVERBOSE} || 0)  . ")\n"

        . "\t\$SANDBOX_HOME : root of all sandbox installations ("
            . use_env($ENV{SANDBOX_HOME}) . ")\n"

        . "\t\$SANDBOX_BINARY : where to search for binaries ("
            . use_env($ENV{SANDBOX_BINARY}) . ")\n"
   ;

    if ( $PROGRAM_NAME =~ /replication|multiple/ ) {
        $VAR_HELP .=
            "\t\$NODE_OPTIONS : options to pass to all node installations ("
            . ($ENV{NODE_OPTIONS} || '') . ")\n"
    }

    if ( $PROGRAM_NAME =~ /replication/ ) {
        $VAR_HELP .=
            "\t\$MASTER_OPTIONS : options to pass to the master installation ("
            . ($ENV{MASTER_OPTIONS} || '') . ")\n"

           . "\t\$SLAVE_OPTIONS : options to pass to all slave installations ("
            . ($ENV{SLAVE_OPTIONS} || '' ) . ")\n"
    }
   my $target = '';
   if ( grep {$PROGRAM_NAME =~ /$_/ }
          qw( make_sandbox make_replication_sandbox
              make_multiple_sandbox make_multiple_sandbox ) )
   {
        $target = '{tarball|dir|version}';
        $HELP_MSG =
              "tarball = the full path to a MySQL binary tarball\n"
            . "dir     = the path to an expanded MySQL binary tarball\n"
            . "version = the simple version number of the expanded tarball\n"
            . "          if it is under \$SANDBOX_BINARY and renamed as the\n "
            . "          version number.\n\n"
            . $HELP_MSG;
   }

   print $self->credits(),
          "syntax: $PROGRAM_NAME [options] $target \n",
          $HELP_MSG,
          $VAR_HELP;
          # This example is only relevant for a single sandbox, but it is
          # wrong for a multiple sandbox.
          #,
          #"\nExample:\n",
          #"     $PROGRAM_NAME --my_file=large --sandbox_directory=my_sandbox\n\n";

    exit(1);
}

sub credits {
    my ($self) = @_;
    my $CREDITS =
          qq(    The MySQL Sandbox,  version $VERSION\n)
        . qq(    (C) 2006-2017 Giuseppe Maxia\n);
    return $CREDITS;
}

sub split_version
{
    my ($v) = @_;
    #if ($v =~ /(?\d+)\.(?\d+)\.(?\d+)/ )
    if ($v =~ /(\d+)\.(\d+)\.(\d+)/ )
    {
        #return ($+{major}, $+{minor}, $+{rev})
        return ($1, $2, $3)

    }
    else
    {
        die "# Split version: could not get components from <$v>\n";
    }
}

sub greater_version
{
    my ($v1, $v2) = @_;

    my ($v1_major, $v1_minor, $v1_rev) = split_version($v1);
    my ($v2_major, $v2_minor, $v2_rev) = split_version($v2);
    if ( $v1_major > $v2_major)
    {
        return 1;
    }
    elsif ( ($v1_major == $v2_major) &&  ($v1_minor > $v2_minor))
    {
        return 1;
    }
    elsif ( ($v1_major == $v2_major) && ($v1_minor == $v2_minor) && ($v1_rev > $v2_rev) )
    {
        return 1;
    }
    return 0
}


sub fix_server_uuid
{
    my ($server_id, $version, $port, $sandbox_directory) = @_;
    if ($version =~ /(\d+)\.(\d+)/)
    {
        my ($major, $minor ) = ($1, $2);
        unless ( ($major == 8) or ( ($major == 5) && ($minor >=6)) )
        {
            return;
        }
    }
    my $current_dir = $ENV{PWD};
    my $increase_id = 0;
    $sandbox_directory =~ s{/$}{};
    my $operation_dir= "$sandbox_directory/data";
    if ( ! -d $operation_dir)
    {
        die "<$operation_dir> not found\n";
    }
    chdir $operation_dir;
    print "# operation_dir is $operation_dir\n" if $DEBUG;
    if ( ($operation_dir =~ m{/node\d/data$})  && (-d "../../master"))
    {
        $increase_id =1;
    }
    #               12345678 1234 1234 1234 123456789012
    # my $new_uuid='00000000-0000-0000-0000-000000000000';
    my $group1 = sprintf('%08d', $port);

    my $group2= sprintf('%04d-%04d-%04d-%012d', 0,0,0,0);
    if ($server_id < 10)
    {
        $group2 =~ s/\d/$server_id/g;
    }
    elsif (($server_id >= 100) && ($server_id < 109))
    {
        $server_id -= 100;
        $server_id += 1 if $increase_id;    # 101 => 2
        $group2 =~ s/\d/$server_id/g;
    }
    else
    {
        my $second_id = $server_id;
        if ($second_id > 9999)
        {
            $second_id = 9999;
        }
        $group2 = sprintf( '%04d-%04d-%04d-%012d', $second_id, $second_id, $second_id, $server_id );
    }
    my $new_uuid= "$group1-$group2";
    open my $FH, '>', 'auto.cnf'
        or die "Error updating 'auto.cnf' ($!)\n";
    print $FH "[auto]\n";
    print $FH "server-uuid=$new_uuid\n";
    close $FH;
    chdir $current_dir;
    print "New UUID=$new_uuid\n" if $DEBUG;
}

sub validate_json_object {
    my ($json_filename, $json_text) = @_;

    my $JSON_module = undef;
    for my $module ( 'JSON', 'JSON::PP', 'JSON::XS')
    {
        eval "use $module;";
        if (! $@)
        {
            print "# Using $module\n" if $DEBUG;
            $JSON_module=$module;
           last;
        }
    }
    unless ($JSON_module)
    {
        print "# JSON modules not installed - skipped evaluation\n" if $DEBUG;
        return -1;
    }

    unless ($json_text)
    {
        $json_text = slurp($json_filename);
    }
    my $json = $JSON_module->new->allow_nonref;

    my $perl_value;
    eval {
        $perl_value = $json->decode( $json_text );
    };
    if ($@)
    {
        print "error decoding json object\n" if $DEBUG;
        return ;
    }
    return 1;
}

sub slurp {
    my ($filename, $skip_blanks, $skip_comments ) = @_;
    open my $FH , q{<}, $filename
        or die "file '$filename' not found\n";
    my @text_array = ();
    my $text='';
    while (my $line = <$FH>)
    {
        if ($skip_blanks)
        {
            next if $line =~ /^\s*$/;
        }
        if ($skip_comments)
        {
            next if $line =~ /^\s*#/;
        }
        if (wantarray)
        {
            push @text_array, $line;
        }
        else
        {
            $text .= $line;
        }
    }
    close $FH;
    if (wantarray)
    {
        return @text_array;
    }
    else
    {
        return $text;
    }
}

sub get_json_from_dirs {
    my ($directories, $json_file) = @_;
    my $collective_json = '';
    my $indent = '    ';
    for my $dir (@$directories)
    {
        my $filename = "$dir/$json_file";
        if ($collective_json)
        {
            $collective_json .= ",\n"
        }
        else
        {
            $collective_json = "{\n";
        }
        $collective_json .= qq("$dir":  \n);
        if ( -f $filename)
        {
            # get the contents
            my @json_lines = slurp($filename, 'skip_blanks');
            for my $jl (@json_lines)
            {
                $collective_json .= $indent . $jl;
            }
        }
        else
        {
            if ($DEBUG)
            {
                warn "# No connection.json found in $dir\n";
                my ($package, $filename, $line) = caller;
                warn "# called from $package - $filename - $line \n";
            }
            $collective_json .= "{}";
        }
    }
    $collective_json .= "}";
    my $is_valid_json = validate_json_object(undef, $collective_json);
    if ($is_valid_json && ($is_valid_json == -1))
    {
        if ($DEBUG)
        {
            warn "# Could not validate JSON object\n";
        }
    }
    elsif ( ! $is_valid_json)
    {
        warn "Invalid JSON object in $ENV{PWD} from [@$directories] \n";
        $collective_json = qq({ "comment": "WARNING: invalid JSON object", "original" : )
            . $collective_json
            . "\n}";
    }
    return $collective_json;
}

#sub get_version {
#    my ($install_dir) = @_;
#    open my $VER , q{<}, "$install_dir/VERSION"
#    #open my $VER , q{<}, "VERSION"
#        or die "file 'VERSION' not found\n";
#    my $version = <$VER>;
#    chomp $version;
#    close $VER;
#    return $version;
#}

sub write_to {
    my ($self, $fname, $mode, $contents) = @_;
    open my $FILE, $mode, $fname
        or die "can't open file $fname\n";
    print $FILE $contents, "\n";
    if (($mode eq '>') && ( $contents =~ m/\#!\/bin\/sh/ ) ) {
        print $FILE $SBINSTR_SH_TEXT;
    }
    close $FILE;
}

sub supported_versions {
    return \@supported_versions;
}

sub is_port_open {
    my ($port) = @_;
    die "No port" unless $port;
    my ($host, $iaddr, $paddr, $proto);

    $host  =  '127.0.0.1';
    $iaddr   = inet_aton($host)
        or die "no host: $host";
    $paddr   = sockaddr_in($port, $iaddr);

    $proto   = getprotobyname('tcp');
    socket(SOCK, PF_INET, SOCK_STREAM, $proto)
        or die "error creating test socket for port $port: $!";
    if (connect(SOCK, $paddr)) {
        close (SOCK)
            or die "error closing test socket: $!";
        return 1;
    }
    return 0;
}

sub first_unused_port {
    my ($port) = @_;
    while (is_port_open($port)) {
        $port++;
        if ($port > 0xFFF0) {
            die "no ports available\n";
        }
    }
    return $port;
}

##
# SBtool
#
sub get_sandbox_params {
    my ($dir, $skip_strict) = @_;
    confess "directory name required\n" unless $dir;
    confess "directory $dir doesn't exist\n" unless -d $dir;
    unless (is_a_sandbox($dir)) {
        confess "directory <$dir> must be a sandbox\n" unless $skip_strict;
    }
    my %params = (
        opt  => undef,
        conf => undef
    );
    if ( -f "$dir/$sandbox_options_file" ) {
        $params{opt} = get_option_file_contents("$dir/$sandbox_options_file");
    }
    else {
        # warn "options file $dir not found\n";
        return;
    }
#    if ( -f "$dir/$sandbox_current_options" ) {
#        $params{conf} =
#          get_option_file_contents("$dir/$sandbox_current_options");
#    }
#    else {
#        # warn "current conf file not found\n";
#        return;
#    }
    return \%params;
}

sub get_option_file_contents {
    my ($file) = @_;
    confess "file name required\n" unless $file;
    confess "file $file doesn't exist\n" unless -f $file;
    my %options;
    open my $RFILE, q{<}, $file
      or confess "can't open file $file\n";
    while ( my $line = <$RFILE> ) {
        next if $line =~ /^\s*$/;
        next if $line =~ /^\s*#/;
        next if $line =~ /^\s*\[/;
        chomp $line;
        my ( $key, $val ) = split /\s*=\s*/, $line;
        $key =~ s/-/_/g;
        $options{$key} = $val;
    }
    close $RFILE;
    # print Dumper(\%options) ; exit;
    return \%options;
}

sub get_sb_info {
    my ($search_path, $options) = @_;
    my %ports         = ();
    my %all_info      = ();
    my $seen_dir      = '';

    find(
        {
            no_chdir => 1,
            follow  => 1,
            wanted   => sub {
                if ( $seen_dir eq $File::Find::dir ) {
                    return;
                }
                my $params;
                if ( $params = get_sandbox_params($File::Find::dir, 1) ) {
                    $seen_dir = $File::Find::dir;
                    my $port = $params->{opt}{port};
                    if (   -f $params->{opt}{pid_file}
                        && -e $params->{opt}{socket} )
                    {
                        $ports{$port} = 1;
                        $all_info{$port} = $params if $options->{all_info};
                    }
                    else {
                        unless ( $options->{only_used} ) {
                            $ports{$port} = 0;
                            $all_info{$port} = $params if $options->{all_info};
                        }
                    }
                }
              }
        },
        $search_path || $options->{search_path}
    );
    return ( \%ports, \%all_info );
}

sub is_a_sandbox {
    my ($dir) = @_;
    unless ($dir) {
        confess "directory missing\n";
    }
    $dir =~ s{/$}{};
    my %sandbox_files = map {s{.*/}{}; $_, 1 } glob("$dir/*");
    my @required = (qw(data start stop send_kill clear use restart),
         # $sandbox_current_options,
         $sandbox_options_file );
    for my $req (@required) {
        unless (exists $sandbox_files{$req}) {
            return;
        }
    }
    return 1;
}

sub is_sandbox_running {
    my ($sandbox) = @_;
    unless ( -d $sandbox ) {
        confess "Can't see if it's running. <$sandbox> is not a sandbox\n";
    }
    my $sboptions = get_sandbox_params($sandbox);
    unless ($sboptions->{opt}
            && $sboptions->{opt}{'pid_file'}
            && $sboptions->{opt}{'socket'}) {
        # print Dumper($sboptions);
        confess "<$sandbox> is not a single sandbox\n";
    }
    if (   ( -f $sboptions->{opt}{'pid_file'} )
        && ( -e $sboptions->{opt}{'socket'}) ) {
        return (1, $sboptions);
    }
    else {
        return (0, $sboptions);
    }
}

sub get_ranges {
    my ($options, $silent ) = @_;
    my ( $ports, $all_info ) = get_sb_info(undef, $options);
    my $minimum_port = $options->{min_range};
    my $maximum_port = $options->{max_range};
    my $range_size   = $options->{range_size};
    if ( $minimum_port >= $maximum_port ) {
        croak "minimum range must be lower than the maximum range\n";
    }
    if ( ( $minimum_port + $range_size ) > $maximum_port ) {
        croak "range too wide for given boundaries\n";
    }
    my $range_found = 0;
  range_search:
    while ( !$range_found ) {
        if ( $minimum_port >= $maximum_port ) {
            croak "can't find a range of $range_size "
              . "free ports between "
              . "$options->{min_range} and $options->{max_range}\n";
        }
        for my $i ( $minimum_port .. $minimum_port + $range_size ) {
            if ( exists $ports->{$i} or ( $i >= $maximum_port ) ) {
                $minimum_port = $i + 1;
                next range_search;
            }
        }
        $range_found = 1;
    }
    unless ($silent) {
        printf "%5d - %5d\n", $minimum_port , $minimum_port + $range_size;
    }
    return $minimum_port;
}

sub get_ports {
    my ($options) = @_;
    my ( $ports, $all_info ) = get_sb_info(undef, $options);

    if ( $options->{format} eq 'perl' ) {
        print Data::Dumper->Dump( [$ports], ['ports'] );
        print Data::Dumper->Dump( [$all_info], ['all_info'] )
          if $options->{all_info};
    }
    elsif ( $options->{format} eq 'text' ) {
        for my $port ( sort { $a <=> $b } keys %$ports ) {
            printf "%5d %2d\n", $port, $ports->{$port};
        }
    }
    else {
        croak "unrecognized format -> $options->{format}\n";
    }
    return ( $ports, $all_info );
}

sub exists_in_path {
    my ($cmd) = @_;
    my @path_directories = split /:/, $ENV{PATH}; ## no critic
    for my $dir (@path_directories) {
        if ( -x "$dir/$cmd") {
            return "$dir/$cmd";
        }
    }
    return ;
}

sub runs_as_root {
    if ( ($REAL_USER_ID == 0) or ($EFFECTIVE_USER_ID == 0)) {
        unless ($ENV{SANDBOX_AS_ROOT}) {
            die   "MySQL Sandbox should not run as root\n"
                . "\n"
                . "If you know what you are doing and want to\n "
                . "run as root nonetheless, please set the environment\n"
                . "variable 'SANDBOX_AS_ROOT' to a nonzero value\n";
        }
    }
}

sub mylogin_cnf_exists {
    my $mylogin_cnf = "$ENV{HOME}/.mylogin.cnf";
    if ( -r $mylogin_cnf) {
        unless ($ENV{IGNORE_MYLOGIN_CNF}) {
            die   "MySQL Sandbox does not work with \$HOME/.mylogin.cnf,\n"
                . "which is a file created by mysql_config_editor.\n"
                . "Either remove the file or make it not readable by the current user.\n"
                . "If you know what you are doing, you can skip this check by\n"
                . "setting the variable IGNORE_MYLOGIN_CNF to a nonzero value.\n"
                . "Be aware that having \$HOME/.mylogin.cnf can disrupt MySQL-Sandbox.\n"
                . "Use it at your own risk.\n"
        }
    }
}

#
# Replaces a path portion with an environment variable name
# if a match is found
#
sub use_env{
    my ($path) = @_;
    my @vars = (
            'HOME',
            'SANDBOX_HOME',
    );
    return '' unless $path;
    for my $var (@vars) {
        if ($path =~ /^$ENV{$var}/) {
            $path =~ s/$ENV{$var}/\$$var/;
            return $path;
        }
    }
    return $path;
}

sub sbinstr {
    my ($msg) = @_;
    unless ($ENV{SBINSTR}) {
        return;
    }
    my $pname = $PROGRAM_NAME;
    unless ($DEBUG) {
        $pname =~ s{.*/}{};
    }
    open my $FH, '>>', $ENV{SBINSTR}
        or die "can't write to $ENV{SBINSTR} ($!)\n";
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
    $mon++;
    $year +=1900;
    print $FH "[$pname] - ",
        sprintf('%4d-%02d%02d %02d:%02d:%02d',
                $year, $mon, $mday, $hour, $min, $sec),
        " - $msg \n";
    close $FH;
}

1;
__END__