The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package # hide from PAUSE
App::DBBrowser::DB::Debug;

use warnings;
use strict;
use 5.008003;
no warnings 'utf8';

#our $VERSION = '';

use Encode                qw( encode decode );
use File::Find            qw( find );
use File::Spec::Functions qw( catdir );
use Scalar::Util          qw( looks_like_number );

use DBI             qw();
use Encode::Locale  qw();
use List::MoreUtils qw( none );

use App::DBBrowser::Auxil;

$SIG{__WARN__} = sub { die @_ };

sub new {
    my ( $class, $opt ) = @_;
    $opt->{db_driver} = 'SQLite';
    $opt->{driver_prefix} = 'sqlite';
    $opt->{plugin_api_version} = 1.4;
    bless $opt, $class;
}


my @info_check = sort( qw(
    _back
    _confirm
    _continue
    _quit
    _reset
    app_dir
    avail_aggregate
    avail_operators
    back
    back_short
    clear_screen
    conf_file_fmt
    config_generic
    csv_opt
    db_cache_file
    db_driver
    db_plugin
    driver_prefix
    home_dir
    input_files
    line_fold
    lock
    lyt_1
    lyt_3
    lyt_stmt_h
    lyt_stmt_v
    lyt_stop
    ok
    quit
    scalar_func_h
    scalar_func_keys
    sqlite_search
    stmt_init_tab

    backup_max_rows
    login_error
    write_config
) );

my $opt_check = {
    G => [ qw(
        db_plugins
        lock_stmt
        menu_sql_memory
        menus_config_memory
        menus_db_memory
        metadata
        operators
        parentheses_h
        parentheses_w
        thsd_sep
    ) ],
    insert => [ qw(
        allow_loose_escapes
        allow_loose_quotes
        allow_whitespace
        auto_diag
        binary
        blank_is_undef
        empty_is_undef
        escape_char
        file_encoding
        input_modes
        i_f_s
        i_r_s
        max_files
        parse_mode
        quote_char
        sep_char
    ) ],
        table => [ qw(
        binary_filter
        binary_string
        keep_header
        max_rows
        min_col_width
        mouse
        progress_bar
        tab_width
        table_expand
        undef
    ) ],
};


my $db_opt_check = {
    Debug => [ qw(
        binary_filter
        directories_sqlite
        field
        host
        port
        user
        sqlite_see_if_its_a_number
        sqlite_unicode
    ) ],
};


#        login_mode_field
#        login_mode_host
#        login_mode_pass
#        login_mode_port
#        login_mode_user



sub debug {
    my ( $self, $dbh, $info, $opt, $db_opt ) = @_;
    $dbh->disconnect();
    my $dir = catdir $self->{home_dir}, 'lib/CPAN/App-DBBrowser/';
    my $info_regex;
    my $opt_regex;
    my $db_opt_regex;
    File::Find::find( {
        wanted => sub {
            my $file = $_;
            return if $file !~ /\.p[lm]\z/;
            return if $file =~ /Debug\.pm/;
            open my $fh, '<', $file or die "$file: $!";
            while ( my $line = <$fh> ) {
                map { $info_regex->{$_}++ }          $line =~ /self->\{info\}\{([^}{\$]+)\}/g;
                map { $opt_regex->{G}{$_}++ }        $line =~ /self->\{opt\}\{G\}\{([^}{\$]+)\}/g;
                map { $opt_regex->{insert}{$_}++ }   $line =~ /self->\{opt\}\{insert\}\{([^}{\$]+)\}/g;
                map { $opt_regex->{table}{$_}++ }    $line =~ /self->\{opt\}\{table\}\{([^}{\$]+)\}/g;
                map { $db_opt_regex->{Debug}{$_}++ } $line =~ /self->\{db_opt\}\{Debug\}\{([^}{\$]+)\}/g;
            }
            close $fh;
        },
        no_chdir => 1
    }, $dir );


    # info keys
    for my $key ( keys %$info ) {
        if ( none { $key eq $_ } @info_check ) {
            print $key, "\n";
        }
    }
    for my $key_r ( keys %$info_regex ) {
        if ( none { $key_r eq $_ } @info_check ) {
            print $key_r, "\n";
        }
    }
    my $total_info;
    for my $key ( keys %$info, keys %$info_regex ) {
        $total_info->{$key}++;
    }
    my @info_total = sort keys %$total_info;
    if ( "@info_check" ne "@info_total" ) {
        printf "info keys: %d - %d\n", scalar @info_total, scalar @info_check;
        print "info      : @info_total\n";
        print "info_check: @info_check\n";

    }


    # opt sections
    my @section_check = sort keys %$opt_check;
    my @section = sort keys %$opt;
    if ( "@section" ne "@section_check" ) {
        print "opt      : @section\n";
        print "opt_check: @section_check\n";
    }


    # opt sections keys
    for my $sect ( @section ) {
        my @option_check = sort @{$opt_check->{$sect}};

        my @option = sort keys %{$opt->{$sect}};
        if ( "@option" ne "@option_check" ) {
            print "$sect:\n";
            print "orig : @option\n";
            print "check: @option_check\n\n";
        }

        for my $key_r ( keys %{$opt_regex->{$sect}} ) {
            if ( none { $key_r eq $_ } @option_check ) {
                print "$sect: $key_r\n";
            }
        }
    }


    # db_opt Debug
    my $sect = 'Debug';
    my @debug_check = @{$db_opt_check->{$sect}};

    my $not_ok = 0;
    my @debug = sort keys %{$db_opt->{$sect}};
    for my $key ( @debug ) {
        if ( none { $key eq $_ } @debug_check ) {
            print $key, "\n";
            $not_ok = 1;
            last;
        }
    }
    if ( $not_ok ) {
        print "debug      : @debug\n";
        print "debug_check: @debug_check\n";
    }

    $not_ok = 0;
    my @debug_regex = sort keys %{$db_opt_regex->{$sect}};
    for my $key_r ( @debug_regex ) {
        if ( none { $key_r eq $_ } @debug_check ) {
            print $key_r, "\n";
            $not_ok = 1;
            last;
        }
    }
    if ( $not_ok ) {
        print "debug_regex: @debug_regex\n";
        print "debug_check: @debug_check\n";
    }


    die "End Debug.";
    return 1;

}



sub plugin_api_version {
    my ( $self ) = @_;
    return $self->{plugin_api_version};
}


sub db_driver {
    my ( $self ) = @_;
    return $self->{db_driver};
}


sub driver_prefix {
    my ( $self ) = @_;
    return $self->{driver_prefix};
}


sub read_argument {
    my ( $self ) = @_;
    return [
        { name => 'field', prompt => "Field",    keep_secret => 0 },
        { name => 'host',  prompt => "Host",     keep_secret => 0 },
        { name => 'port',  prompt => "Port",     keep_secret => 0 },
        { name => 'user',  prompt => "User",     keep_secret => 0 },
        { name => 'pass',  prompt => "Password", keep_secret => 1 },
    ];
}


sub choose_arguments {
    my ( $self ) = @_;
    return [
        { name => 'sqlite_unicode',             default_index => 1, avail_values => [ 0, 1 ] },
        { name => 'sqlite_see_if_its_a_number', default_index => 1, avail_values => [ 0, 1 ] },
    ];
}


sub get_db_handle {
    my ( $self, $db, $connect_parameter ) = @_;
    my $dsn = "dbi:$self->{db_driver}:dbname=$db";
    my $dbh = DBI->connect( $dsn, '', '', {
        PrintError => 0,
        RaiseError => 1,
        AutoCommit => 1,
        ShowErrorStatement => 1,
        %{$connect_parameter->{chosen_arg}},
    } ) or die DBI->errstr;
    $dbh->sqlite_create_function( 'regexp', 3, sub {
            my ( $regex, $string, $case_sensitive ) = @_;
            $string = '' if ! defined $string;
            return $string =~ m/$regex/sm if $case_sensitive;
            return $string =~ m/$regex/ism;
        }
    );
    $dbh->sqlite_create_function( 'truncate', 2, sub {
            my ( $number, $places ) = @_;
            return if ! defined $number;
            return $number if ! looks_like_number( $number );
            return sprintf "%.*f", $places, int( $number * 10 ** $places ) / 10 ** $places;
        }
    );
    $dbh->sqlite_create_function( 'bit_length', 1, sub {
            use bytes;
            return length $_[0];
        }
    );
    $dbh->sqlite_create_function( 'char_length', 1, sub {
            return length $_[0];
        }
    );
    return $dbh;
}


sub available_databases {
    my ( $self, $connect_parameter ) = @_;
    return \@ARGV if @ARGV;
    my $dirs = $connect_parameter->{dir_sqlite};
    my $cache_key = $self->{db_plugin} . '_' . join ' ', @$dirs;
    my $auxil = App::DBBrowser::Auxil->new();
    my $db_cache = $auxil->read_json( $self->{db_cache_file} );
    if ( $self->{sqlite_search} ) {
        delete $db_cache->{$cache_key};
    }
    my $databases = [];
    if ( ! defined $db_cache->{$cache_key} ) {
        print 'Searching...' . "\n";
        for my $dir ( @$dirs ) {
            File::Find::find( {
                wanted => sub {
                    my $file = $_;
                    return if ! -f $file;
                    return if ! -s $file; #
                    return if ! -r $file; #
                    #print "$file\n";
                    if ( ! eval {
                        open my $fh, '<:raw', $file or die "$file: $!";
                        defined( read $fh, my $string, 13 ) or die "$file: $!";
                        close $fh;
                        push @$databases, decode( 'locale_fs', $file ) if $string eq 'SQLite format';
                        1 }
                    ) {
                        utf8::decode( $@ );
                        print $@;
                    }
                },
                no_chdir => 1,
            },
            encode( 'locale_fs', $dir ) );
        }
        print 'Ended searching' . "\n";
        $db_cache->{$cache_key} = $databases;
        $auxil->write_json( $self->{db_cache_file}, $db_cache );
    }
    else {
        $databases = $db_cache->{$cache_key};
    }
    return $databases;
}


sub get_schema_names {
    my ( $self, $dbh, $db ) = @_;
    return [ 'main' ];
}


sub get_table_names {
    my ( $self, $dbh, $schema ) = @_;
    my $regexp_system_tbl = '^sqlite_';
    my $stmt = "SELECT name FROM sqlite_master WHERE type = 'table'";
    if ( ! $self->{add_metadata} ) {
        $stmt .= " AND name NOT REGEXP ?";
    }
    $stmt .= " ORDER BY name";
    my $tables = $dbh->selectcol_arrayref( $stmt, {}, $self->{add_metadata} ? () : ( $regexp_system_tbl ) );
    if ( $self->{add_metadata} ) {
        my $user_tbl   = [];
        my $system_tbl = [];
        for my $table ( @{$tables} ) {
            if ( $table =~ /(?:$regexp_system_tbl)/ ) {
                push @$system_tbl, $table;
            }
            else {
                push @$user_tbl, $table;
            }
        }
        push @$system_tbl, 'sqlite_master';
        return $user_tbl, $system_tbl;
    }
    else {
        return $tables;
    }
}


sub column_names_and_types {
    my ( $self, $dbh, $db, $schema, $tables ) = @_;
    my ( $col_names, $col_types );
    for my $table ( @$tables ) {
        my $sth = $dbh->prepare( "SELECT * FROM " . $dbh->quote_identifier( undef, undef, $table ) );
        $col_names->{$table} = $sth->{NAME};
        $col_types->{$table} = $sth->{TYPE};
    }
    return $col_names, $col_types;
}


sub primary_and_foreign_keys {
    my ( $self, $dbh, $db, $schema, $tables ) = @_;
    my $pk_cols = {};
    my $fks     = {};
    for my $table ( @$tables ) {
        for my $c ( @{$dbh->selectall_arrayref( "pragma foreign_key_list( $table )" )} ) {
            $fks->{$table}{$c->[0]}{foreign_key_col}  [$c->[1]] = $c->[3];
            $fks->{$table}{$c->[0]}{reference_key_col}[$c->[1]] = $c->[4];
            $fks->{$table}{$c->[0]}{reference_table} = $c->[2];
        }
        $pk_cols->{$table} = [ $dbh->primary_key( undef, $schema, $table ) ];
    }
    return $pk_cols, $fks;
}


sub sql_regexp {
    my ( $self, $quote_col, $do_not_match_regexp, $case_sensitive ) = @_;
    if ( $do_not_match_regexp ) {
        return sprintf ' NOT REGEXP(?,%s,%d)', $quote_col, $case_sensitive;
    }
    else {
        return sprintf ' REGEXP(?,%s,%d)', $quote_col, $case_sensitive;
    }
}


sub concatenate {
    my ( $self, $arg ) = @_;
    return join( ' || ', @$arg );
}



# scalar functions

sub epoch_to_datetime {
    my ( $self, $col, $interval ) = @_;
    return "DATETIME($col/$interval,'unixepoch','localtime')";
}

sub epoch_to_date {
    my ( $self, $col, $interval ) = @_;
    return "DATE($col/$interval,'unixepoch','localtime')";
}

sub truncate {
    my ( $self, $col, $precision ) = @_;
    return "TRUNCATE($col,$precision)";
}

sub bit_length {
    my ( $self, $col ) = @_;
    return "BIT_LENGTH($col)";
}

sub char_length {
    my ( $self, $col ) = @_;
    return "CHAR_LENGTH($col)";
}




1;


__END__