view release on metacpan or  search on metacpan

lib/App/DBBrowser/Auxil.pm  view on Meta::CPAN

package # hide from PAUSE
App::DBBrowser::Auxil;

use warnings;
use strict;
use 5.016;

use Encode       qw( decode );
use Scalar::Util qw( looks_like_number );
#use Storable     qw();  # required


use DBI::Const::GetInfoType;
use JSON::MaybeXS            qw( decode_json );
use List::MoreUtils          qw( none );

use Term::Choose            qw();
use Term::Choose::Constants qw( EXTRA_W );
use Term::Choose::LineFold  qw( line_fold );
use Term::Choose::Screen    qw( clear_screen );
use Term::Choose::Util      qw( insert_sep get_term_width get_term_height unicode_sprintf );
use Term::Form::ReadLine    qw();


sub new {
    my ( $class, $info, $options, $d ) = @_;
    bless {
        i => $info,
        o => $options,
        d => $d
    }, $class;
}


sub reset_sql {
    my ( $sf, $sql ) = @_;
    # preserve base data: table name, column names and data types:
    my $backup = {
        table => $sql->{table} // '',
        columns => $sql->{columns} // [],
        data_types => $sql->{data_types} // {},
    };
    # reset:
    delete @{$sql}{ keys %$sql }; # not "$sql = {}" so $sql is still pointing to the outer $sql
    # initialize:
    my @string = qw( distinct_stmt set_stmt where_stmt having_stmt order_by_stmt limit_stmt offset_stmt );
    my @array  = qw( group_by_cols selected_cols set_args order_by_cols
                     ct_column_definitions ct_table_constraints ct_table_options
                     insert_col_names insert_args );
    my @hash   = qw( alias );
    @{$sql}{@string} = ( '' ) x  @string;
    @{$sql}{@array}  = map{ [] } @array;
    @{$sql}{@hash}   = map{ {} } @hash;
    for my $y ( keys %$backup ) {
        $sql->{$y} = $backup->{$y};
    }
}


sub __stmt_fold {
    my ( $sf, $term_w, $used_for, $stmt, $indent ) = @_;
    if ( $used_for eq 'print' ) {
        my $in = ' ' x $sf->{o}{G}{base_indent};
        my %tabs = ( init_tab => $in x $indent, subseq_tab => $in x ( $indent + 1 ) );
        return line_fold( $stmt, { width => $term_w, %tabs, join => 0 } );
    }
    else {
        return $stmt;
    }

lib/App/DBBrowser/Auxil.pm  view on Meta::CPAN

    }
    else {
        @idx = ( 2 );
    }
    if ( $sf->{o}{G}{quote_tables} ) {
        return $sf->qualified_identifier( $sf->__quote_identifiers( @{$table_info}[ @idx ] ) );
    }
    else {
        return $sf->qualified_identifier( @{$table_info}[@idx] );
    }
}


sub quote_table {
    my ( $sf, $table ) = @_;
    if ( $sf->{o}{G}{quote_tables} ) {
        ( $table ) = $sf->__quote_identifiers( $table );
    }
    return $table;
}


sub quote_column {
    my ( $sf, $column ) = @_;
    if ( $sf->{o}{G}{quote_columns} ) {
        ( $column ) = $sf->__quote_identifiers( $column );
    }
    return $column;
}


sub quote_cols {
    my ( $sf, $cols ) = @_;
    if ( $sf->{o}{G}{quote_columns} ) {
        $cols = [ $sf->__quote_identifiers( @$cols ) ];
    }
    return $cols;
}


sub quote_alias { ##
    my ( $sf, $alias ) = @_;
    #if ( $sf->{o}{G}{quote_aliases} ) {
    if ( $sf->{o}{G}{quote_columns} ) {
        ( $alias ) = $sf->__quote_identifiers( $alias );
    }
    return $alias;
}


sub unquote_identifier {
    my ( $sf, $identifier ) = @_;
    my $qc = quotemeta( $sf->{d}{identifier_quote_char} );
    $identifier =~ s/$qc(?=(?:$qc$qc)*(?:[^$qc]|\z))//g;
    return $identifier;
}


sub quote_if_not_numeric {
    my ( $sf, $value ) = @_;
    if ( looks_like_number $value ) {
        return $value;
    }
    else {
        return $sf->{d}{dbh}->quote( $value );
    }
}


sub unquote_constant {
    my ( $sf, $constant ) = @_;
    return if ! defined $constant;
    if ( $constant =~ /^'(.*)'\z/ ) {
        $constant = $1;
        if ( $sf->{i}{dbms} =~ /^(?:mysql|MariaDB)\z/ ) {
            $constant =~ s/\\(.)/$1/g;
        }
        else {
            $constant =~ s/''/'/g;
            #$constant =~ s/'(?=(?:'')*(?:[^']|\z))//g;
        }
    }
    return $constant;
}


sub regex_quoted_literal {
    my ( $sf ) = @_;
    if ( $sf->{i}{dbms} =~ /^(?:mysql|MariaDB)\z/ ) {
        return qr/(?<!')'(?:[^\\']|\\'|\\\\)*'(?!')/;
    }
    else {
        return qr/(?<!')'(?:[^']|'')*'(?!')/;
    }
}


sub regex_quoted_identifier {
    my ( $sf ) = @_;
    my $iqc = $sf->{d}{identifier_quote_char};
    return "$iqc(?:[^$iqc]|$iqc$iqc)+$iqc";
}


sub normalize_space_in_stmt {
    my ( $sf, $stmt ) = @_;
    my $quoted_literal = $sf->regex_quoted_literal();
    my $iqc = $sf->{d}{identifier_quote_char};
    my $quoted_identifier = $sf->regex_quoted_identifier();
    my $split_rx = qr/ ( $quoted_identifier | $quoted_literal ) /x;
    $stmt =~ s/^\s+|\s+\z//g;
    $stmt = join '', map {
        if ( ! /^[$iqc']/ ) { s/\s+/ /g; s|\(\s|(|; s|\s\)|)| };
        $_
    } split $split_rx, $stmt;
    return $stmt;
}


sub major_server_version {
    my ( $sf ) = @_;