view release on metacpan or  search on metacpan

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

package # hide from PAUSE
App::DBBrowser::Table;
use warnings;
use strict;
use 5.016;

use Cwd                   qw( realpath );
use Encode                qw( encode decode );
use File::Spec::Functions qw( catfile );

#use String::Unescape  qw( unescape );             # required
#use Text::CSV_XS      qw();                       # required

use Term::Choose         qw();
use Term::Choose::Screen qw( hide_cursor clear_screen );
use Term::Form::ReadLine qw();
use Term::TablePrint     qw();

use App::DBBrowser::Auxil;
use App::DBBrowser::Options;
use App::DBBrowser::Options::ReadWrite;

use App::DBBrowser::Table::Substatement;
#use App::DBBrowser::Table::InsertUpdateDelete;     # required


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


sub browse_the_table {
    my ( $sf, $sql, $return_stmt_prompt ) = @_;
    my $tc = Term::Choose->new( $sf->{i}{tc_default} );
    my $ax = App::DBBrowser::Auxil->new( $sf->{i}, $sf->{o}, $sf->{d} );
    my $sb = App::DBBrowser::Table::Substatement->new( $sf->{i}, $sf->{o}, $sf->{d} );
    $sf->{d}{stmt_types} = [ 'Select' ];
    my $changed = {};
    my $hidden = 'Customize:';
    my ( $print_table, $select, $distinct, $where, $group_by, $having, $order_by, $limit, $offset, $export ) =
       ( 'Print TABLE',
         '- SELECT',
         '- DISTINCT',
         '- WHERE',
         '- GROUP BY',
         '- HAVING',
         '- ORDER BY',
         '- LIMIT',
         '- OFFSET',
         '  Export',
    );
    my @choices = ( $print_table, $select, $distinct, $where, $group_by, $having, $order_by, $limit, $offset, $export );
    my @pre = ( $hidden, undef );
    my $back = $sf->{i}{back};
    my ( $return_statement, $hidden_print ) = ( $sf->{i}{_confirm}, $return_stmt_prompt );
    if ( $return_stmt_prompt ) {
        $choices[0] = $return_statement;
        @pre = ( $hidden_print, undef );
        $back = $sf->{i}{_back};
    }
    my $footer = $sf->{d}{table_origin} eq 'ordinary' ? $sf->{d}{table_key} : ucfirst $sf->{d}{table_origin};
    $sf->{d}{table_footer} = "     '$footer'     ";
    my $old_idx = 1;

    CUSTOMIZE: while ( 1 ) {
        my $menu = [ @pre, @choices ];

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

    if ( $#{$sf->{d}{table_print_history}} > 50 ) {
        $#{$sf->{d}{table_print_history}} = 50;
    }
    my $sth = $sf->{d}{dbh}->prepare( $statement );
    $sth->execute();
    my $col_names = $sth->{NAME}; # not quoted
    my $col_types = $sth->{TYPE};
    my $all_arrayref = $sth->fetchall_arrayref;
    unshift @$all_arrayref, $col_names;
    if ( $sf->{i}{driver} eq 'DB2' && length $sf->{o}{G}{db2_encoding} ) {
        print 'Decoding: ...' . "\r"  if $sf->{o}{table}{progress_bar};
        my $encoding = Encode::find_encoding( $sf->{o}{G}{db2_encoding} );
        if ( ! ref $encoding ) {
            die qq(encoding "$sf->{o}{G}{db2_encoding}" not found);
        }
        my $is_text = [ map { /^(?:1|12|2005|-15)\z/ ? 1 : 0 } @$col_types ];

        for my $row ( @$all_arrayref ) {
            for my $i ( 0 .. $#$row ) {
                if ( $is_text->[$i] ) {
                    $row->[$i] = $encoding->decode( $row->[$i] )
                }
            }
        }
    }
    elsif ( $sf->{i}{driver} eq 'DuckDB' ) {
        my $duckdb_encoding = 'UTF-8';
        my $encoding = Encode::find_encoding( $duckdb_encoding );
        if ( ! ref $encoding ) {
            die qq(encoding "$duckdb_encoding" not found);
        }
        for my $row ( @$all_arrayref ) {
            for my $i ( 0 .. $#$row ) {
                if ( $col_types->[$i] == 12 ) {
                    $row->[$i] = $encoding->decode( $row->[$i] );
                    #Encode::_utf8_on( $row->[$i] );
                }
            }
        }
    }
    return $all_arrayref;
}


sub __export {
    my ( $sf, $sql ) = @_;
    my $file_fs = $sf->__get_filename_fs( $sql );
    if ( ! length $file_fs ) {
        return;
    }
    print 'Working ...' . "\r" if $sf->{o}{table}{progress_bar};
    my $all_arrayref = $sf->select_statement_results( $sql );
    my $open_mode;
    if ( length $sf->{o}{export}{file_encoding} ) {
        $open_mode = '>:encoding(' . $sf->{o}{export}{file_encoding} . ')';
    }
    else {
        $open_mode = '>';
    }
    open my $fh, $open_mode, $file_fs or die "$file_fs: $!";
    require String::Unescape;
    my $options = {
        map { $_ => String::Unescape::unescape( $sf->{o}{csv_out}{$_} ) }
        grep { length $sf->{o}{csv_out}{$_} } # keep the default value if the option is set to ''
        keys %{$sf->{o}{csv_out}}
    };
    if ( ! length $options->{eol} ) {
        $options->{eol} = $/; # for `eol` use `$/` as the default value
    }
    require Text::CSV_XS;
    my $csv = Text::CSV_XS->new( $options ) or die Text::CSV_XS->error_diag();
    $csv->print( $fh, $_ ) for @$all_arrayref;
    close $fh;
    return 1;
}


sub __get_filename_fs {
    my ( $sf, $sql ) = @_;
    my $tc = Term::Choose->new( $sf->{i}{tc_default} );
    my $tr = Term::Form::ReadLine->new( $sf->{i}{tr_default} );
    my $ax = App::DBBrowser::Auxil->new( $sf->{i}, $sf->{o}, $sf->{d} );
    my $file_name;
    if ( $sf->{o}{export}{default_filename} ) {
        $file_name = $sf->{d}{table_key};
    }
    my $count = 0;

    FILE_NAME: while ( 1 ) {
        if ( ++$count > 2 ) {
            $file_name = '';
        }
        my $info = $ax->get_sql_info( $sql );
        # Readline
        $file_name = $tr->readline(
            'File name: ',
            { info => $info, default => $file_name, hide_cursor => 2, history => [] }
        );
        $ax->print_sql_info( $info );
        if ( ! length $file_name ) {
            return;
        }

        FULL_FILE_NAME: while ( 1 ) {
            my $file_name_plus = $file_name;
            if ( $sf->{o}{export}{add_extension} && $file_name !~ /\.csv\z/i ) {
                $file_name_plus .= '.csv';
            }
            my $export_dir = $sf->{o}{export}{export_dir};
            my $dir_fs = realpath( encode( 'locale_fs', $export_dir ) ) or die "$export_dir: $!";
            my $file_fs = catfile $dir_fs, encode( 'locale_fs', $file_name_plus );
            my ( $new_name, $overwrite ) = ( '- New name', '- Overwrite' );
            my $chosen;
            if ( -e $file_fs ) {
                my $menu;
                my $prompt;
                if ( -d $file_fs ) {
                    $prompt = 'A directory with name "' . $file_name_plus . '" already exists.';
                    $menu = [ undef, $new_name ];
                }
                else {
                    $prompt =  'A file with name "' . $file_name_plus . '" already exists.';
                    $menu = [ undef, $new_name, $overwrite ];