libconfig-model-tkui-perl 1.344-1 / usr / share / perl5 / Config / Model / Tk / LeafEditor.pm

#
# This file is part of Config-Model-TkUI
#
# This software is Copyright (c) 2014 by Dominique Dumont.
#
# This is free software, licensed under:
#
#   The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Tk::LeafEditor;
$Config::Model::Tk::LeafEditor::VERSION = '1.344';
use strict;
use warnings;
use Carp;
use Log::Log4perl;
use Config::Model::Tk::NoteEditor;
use Path::Tiny;
use Tk::Balloon;

use base qw/Config::Model::Tk::LeafViewer/;

Construct Tk::Widget 'ConfigModelLeafEditor';

my @fbe1 = qw/-fill both -expand 1/;
my @fxe1 = qw/-fill x    -expand 1/;
my @fx   = qw/-fill x  /;

my $logger = Log::Log4perl::get_logger("Tk::LeafEditor");

sub ClassInit {
    my ( $cw, $args ) = @_;

    # ClassInit is often used to define bindings and/or other
    # resources shared by all instances, e.g., images.

    # cw->Advertise(name=>$widget);
}

sub Populate {
    my ( $cw, $args ) = @_;
    my $leaf = $cw->{leaf} = delete $args->{-item}
        || die "LeafEditor: no -item, got ", keys %$args;
    delete $args->{-path};
    $cw->{store_cb} = delete $args->{-store_cb} || die __PACKAGE__, "no -store_cb";

    my $inst = $leaf->instance;
    my $vt   = $leaf->value_type;
    $logger->info("Creating leaf editor for value_type $vt");
    $cw->{value} = $leaf->fetch( check => 'no' );
    $logger->info( "Creating leaf editor with error " . $leaf->error_msg );

    $cw->add_header( Edit => $leaf )->pack(@fx);

    my $vref = \$cw->{value};

    my @pack_args = @fx;
    @pack_args = @fbe1
        if $vt eq 'string'
        or $vt eq 'enum'
        or $vt eq 'reference';

    my $ed_frame = $cw->Frame(qw/-relief raised -borderwidth 2/)->pack(@pack_args);
    $ed_frame->Label( -text => 'Value' )->pack();

    my $balloon = $cw->Balloon( -state => 'balloon' );

    if ( $vt eq 'string' ) {
        $cw->{e_widget} = $ed_frame->Scrolled(
            'Text',
            -height     => 5,
            -scrollbars => 'ow',
        )->pack(@fbe1);
        $cw->{e_widget}->tagConfigure(qw/value -lmargin1 2 -lmargin2 2 -rmargin 2/);
        $cw->reset_value;
        my $bframe = $cw->add_buttons($ed_frame);
        $bframe->Button(
            -text    => 'Cleanup',
            -command => sub { $cw->cleanup },
        )->pack( -side => 'left' );
        my $ext_ed_b = $bframe->Button(
            -text    => 'Ext editor',
            -command => sub { $cw->exec_external_editor },
            -state   => defined $ENV{EDITOR} ? 'normal' : 'disabled',
        )->pack( -side => 'left' );
        $balloon->attach( $ext_ed_b,
            -msg => "Run external editor (if EDITOR environment variable is set" );
    }
    elsif ( $vt eq 'boolean' ) {
        $ed_frame->Checkbutton(
            -text     => $leaf->element_name,
            -variable => $vref,
            -command  => sub { $cw->try },
        )->pack();
        $cw->add_buttons($ed_frame);
    }
    elsif ( $vt eq 'uniline' or $vt eq 'integer' ) {
        $ed_frame->Entry( -textvariable => $vref )->pack(@fx);
        $cw->add_buttons($ed_frame);
    }
    elsif ( $vt eq 'enum' or $vt eq 'reference' ) {
        my $lb = $ed_frame->Scrolled(
            'Listbox',
            -height     => 5,
            -scrollbars => 'osow',

            #-listvariable => $vref,
            #-selectmode => 'single',
        )->pack(@fbe1);
        my @choice = $leaf->get_choice;
        $lb->insert( 'end', $leaf->get_choice );
        my $idx = 0;
        if ( defined $$vref ) {
            map { $lb->selectionSet($idx) if $_ eq $$vref; $idx++ } @choice;
        }
        $lb->bind( '<Button-1>', sub { $cw->try( $lb->get( $lb->curselection() ) ) } );
        $cw->add_buttons($ed_frame);

    }

    $cw->ConfigModelNoteEditor( -object => $leaf )->pack;
    $cw->add_warning( $leaf, 'edit' )->pack(@fx);
    $cw->add_info_button()->pack( @fx, qw/-anchor n/ );
    $cw->add_summary($leaf)->pack(@fx);
    $cw->add_description($leaf)->pack(@fx);
    my ( $help_frame, $help_widget ) = $cw->add_help( 'help on value' => '', 1 );
    $help_frame->pack(@fx);

    $cw->Advertise( value_help_widget => $help_widget );
    $cw->Advertise( value_help_frame  => $help_frame );

    $cw->set_value_help;

    $cw->ConfigSpecs(

        #-fill   => [ qw/SELF fill Fill both/],
        #-expand => [ qw/SELF expand Expand 1/],
        -relief      => [qw/SELF relief Relief groove/],
        -borderwidth => [qw/SELF borderwidth Borderwidth 2/],
        DEFAULT      => [qw/SELF/],
    );

    # don't call directly SUPER::Populate as it's LeafViewer's populate
    $cw->Tk::Frame::Populate($args);
}

sub cleanup {
    my ($cw) = @_;
    my $text_widget = $cw->{e_widget} || return;
    my $selected    = $text_widget->getSelected;
    my $text        = $selected || $text_widget->Contents;
    $text =~ s/^\s+//gm;
    $text =~ s/\s+$//gm;
    $text =~ s/\s+/ /g;

    if ($selected) {
        $text_widget->Insert($text);
    }
    else {
        $text_widget->Contents($text);
    }
}

sub add_buttons {
    my ( $cw, $frame ) = @_;
    my $bframe = $frame->Frame->pack();

    my $balloon = $cw->Balloon( -state => 'balloon' );

    my $reset_b = $bframe->Button(
        -text    => 'Reset',
        -command => sub { $cw->reset_value; },
    )->pack( -side => 'left' );
    $balloon->attach( $reset_b, -msg => "reset entry value from tree value" );

    my $del_label = defined $cw->{leaf}->fetch_standard ? 'Back to default' : 'Delete';
    $bframe->Button(
        -text    => $del_label,
        -command => sub { $cw->delete },
    )->pack( -side => 'left' );
    my $store_b = $bframe->Button(
        -text    => 'Store',
        -command => sub { $cw->store },
    )->pack( -side => 'right' );

    $balloon->attach( $store_b, -msg => "store entry value in config tree" );

    return $bframe;
}

sub try {
    my $cw = shift;
    my $v  = shift;

    if ( defined $v ) {
        $cw->{value} = $v;
    }
    else {
        my $e_w = $cw->{e_widget};

        # tk widget use a reference
        $v =
            defined $e_w
            ? $e_w->get( '1.0', 'end' )
            : $cw->{value};
    }

    $v = '' unless defined $v;
    chomp $v;

    $logger->debug("try: value $v");
    require Tk::Dialog;

    my @errors = $cw->{leaf}->check( value => $v, quiet => 1 );

    if (@errors) {
        $cw->Dialog(
            -title => 'Value error',
            -text  => join( "\n", @errors ),
        )->Show;
        $cw->reset_value;
        return;
    }
    else {
        $cw->set_value_help($v);
        return $v;
    }
}

sub delete {
    my $cw = shift;

    eval { $cw->{leaf}->store(undef); };

    if ($@) {
        $cw->Dialog(
            -title => 'Delete error',
            -text  => $@->as_string,
        )->Show;
    }
    else {
        # trigger redraw of Tk Tree
        $cw->reset_value;
        $cw->update_warning( $cw->{leaf} );
        $cw->parent->parent->parent->parent->reload();
    }
}

# can be used without parameters to store value from widget into config tree
sub store {
    my $cw = shift;
    my $v  = $cw->try(@_);
    return unless defined $v;

    print "Storing '$v'\n";

    eval { $cw->{leaf}->store($v); };

    if ($@) {
        $cw->Dialog(
            -title => 'Value error',
            -text  => $@->as_string,
        )->Show;
    }
    else {
        # trigger redraw of Tk Tree
        $cw->{store_cb}->();
        $cw->update_warning( $cw->{leaf} );
    }
}

sub set_value_help {
    my $cw         = shift;
    my $v          = $cw->{value};
    my $value_help = defined $v ? $cw->{leaf}->get_help($v) : '';

    my $w = $cw->Subwidget('value_help_widget');
    my $f = $cw->Subwidget('value_help_frame');

    if ($value_help) {

        #$w->delete( '0.0', 'end' );
        #$w->insert( 'end', $value_help ) ;
        $cw->update_help( $w, $value_help );
        $f->pack(@fbe1);
    }
    else {
        $f->packForget;
    }
}

sub reset_value {
    my $cw = shift;
    $cw->{value} = $cw->{leaf}->fetch( check => 'no' );
    if ( defined $cw->{e_widget} ) {
        $cw->{e_widget}->delete( '1.0', 'end' );
        $cw->{e_widget}->insert( 'end', $cw->{value}, 'value' );
    }
    $cw->set_value_help if defined $cw->{value_help_widget};
}

sub exec_external_editor {
    my $cw = shift;

    my $pt = Path::Tiny->tempfile();
    die "Can't create Path::Tiny:$!" unless defined $pt;
    $pt->spew_utf8( $cw->{e_widget}->get( '1.0', 'end' ) );

    # See mastering Perl/Tk p382
    my $h = $cw->{ed_handle} = IO::Handle->new;
    die "IO::Handle->new failed." unless defined $h;

    my $ed = $ENV{EDITOR} . ' ' . $pt->canonpath;
    $cw->{ed_pid} = open $h, $ed . ' 2>&1 |';

    if ( not defined $cw->{ed_pid} ) {
        $cw->Dialog(
            -title => 'External editor error',
            -text  => "'$ed' : $!",
        )->Show;
        return;
    }
    $h->autoflush(1);
    $cw->fileevent( $h, 'readable' => [ \&_read_stdout, $cw ] );

    # prevent navigation in the tree (and destruction of this widget
    # while the external editor is active). See mastering Perl/Tk p302
    $cw->grab;

    $cw->waitVariable( \$cw->{ed_done} );

    $cw->grabRelease;

    my $new_v = $pt->slurp_utf8();
    print "exec_external_editor done with '$new_v'\n";
    $cw->store($new_v);
    $cw->reset_value;
}

# also from Mastering Perl/Tk
sub _read_stdout {

    # Called when input is available for the output window.  Also checks
    # to see if the user has clicked Cancel.
    print "_read_stdout called\n";
    my ($cw) = @_;

    my $h = $cw->{ed_handle};
    die "External editor handle is udefined!\n" unless defined $h;
    my $stat;

    if ( $stat = sysread $h, $_, 4096 ) {
        print;
    }
    elsif ( $stat == 0 ) {
        print "edition done\n";
        $h->close;
        $cw->{ed_done} = 1;
    }
    else {
        die "External editor sysread error: $!";
    }
}    # end _read_stdout

sub reload {
    my $cw = shift;
    $cw->reset_value;
    $cw->update_warning( $cw->{leaf} );
}
1;