Config-Model-TkUI

 view release on metacpan or  search on metacpan

lib/Config/Model/TkUI.pm  view on Meta::CPAN

package Config::Model::TkUI 1.379;

use 5.10.1;
use strict;
use warnings;
use Carp;

use base qw/Tk::Toplevel/;
use vars qw/$icon_path $error_img $warn_img/;
use subs qw/menu_struct/;
use Scalar::Util qw/weaken/;
use Log::Log4perl 1.11;
use Path::Tiny;
use YAML::PP;
use File::HomeDir;

use Pod::POM;
use Pod::POM::View::Text;

use Tk::DoubleClick;

lib/Config/Model/TkUI.pm  view on Meta::CPAN

    );

    # create 'show only custom values'
    $cw->{auto_save_mode} = 0;
    $option_menu->checkbutton(
        -label => 'Auto save',
        -variable => \$cw->{auto_save_mode},
    );

    my $weak_cw = $cw;
    weaken($weak_cw);
    $cw->{instance}->on_change_cb( sub {
        $weak_cw->save if $weak_cw->{auto_save_mode};;
    });

    # create frame for location entry
    my $loc_frame =
        $cw->Frame( -relief => 'sunken', -borderwidth => 1 )->pack( -pady => 0, -fill => 'x' );
    $loc_frame->Label( -text => 'location :' )->pack( -side => 'left' );
    $loc_frame->Label( -textvariable => \$cw->{location} )->pack( -side => 'left' );

lib/Config/Model/TkUI.pm  view on Meta::CPAN

    my $node_loc = $node->location;

    my $prevpath = '';
    foreach my $elt (@element_list) {
        my $newpath  = "$path." . to_path($elt);
        my $scan_sub = sub {
            $scanner->scan_element( [ $newpath, $cw,  $opening, $actions, $force_display_path ], $node, $elt );
        };
        my @data = ( $scan_sub, $node->fetch_element($elt) );

        # It's necessary to store a weakened reference of a tree
        # object as these ones tend to disappear when warped out. In
        # this case, the object must be destroyed. This does not
        # happen if a non-weakened reference is kept in Tk Tree.
        weaken( $data[1] );

        my $elt_type = $node->element_type($elt);
        my $eltmode  = $elt_mode{$elt_type};
        if ( $tkt->infoExists($newpath) ) {
            $eltmode = $tkt->getmode($newpath);    # will reuse mode below
        }
        else {
            my @opt = $prevpath ? ( -after => $prevpath ) : ( -at => 0 );
            $logger->trace("disp_obj_elt add $newpath mode $eltmode type $elt_type");
            $tkt->add( $newpath, -data => \@data, @opt );

lib/Config/Model/TkUI.pm  view on Meta::CPAN

                # wrong order, delete the entry
                $tkt->delete( entry => $newpath );
            }
        }

        if ( not $tkt->infoExists($newpath) ) {
            my @opt = $prevpath ? ( -after => $prevpath ) : ( -at => 0 );
            $logger->trace(
                "disp_hash add $newpath mode $eltmode cargo_type $elt_type" . " elt $sub_elt" );
            my @data = ( $scan_sub, $sub_elt );
            weaken( $data[1] );
            $tkt->add( $newpath, -data => \@data, @opt );
            $tkt->itemCreate( $newpath, 0, -text => $node->shorten_idx($idx) );
            $tkt->setmode( $newpath => $eltmode );
        }

        # update the node gist
        my $gist = $elt_type =~ /node/ ? $elt->fetch_with_id($idx)->fetch_gist : '';
        $tkt->itemCreate( $newpath, 2, -text => $gist );

        my $elt_loc = $sub_elt->location;

lib/Config/Model/TkUI.pm  view on Meta::CPAN

    if ( $tree->info( exists => $tree_path ) ) {
        $tree->selectionClear();    # clear all
        $tree->selectionSet($tree_path);
        my $data_ref = $tree->infoData($tree_path);
        unless ( defined $data_ref->[1] ) {
            $cw->reload;
            return;
        }
        $obj = $data_ref->[1];
        weaken($obj);
    }

    my $loc  = $obj->location;
    my $type = $obj->get_type;
    $logger->trace("item $loc to $mode (type $type)");

    my $e_frame = $cw->Subwidget('ed_frame');

    # cleanup existing widget contained in this frame
    delete $cw->{editor};
    map { $_->destroy if Tk::Exists($_) } $e_frame->children;

    my $widget = $widget_table{$mode}{$type}
        || die "Cannot find $mode widget for type $type";
    my $weak_cw = $cw;
    weaken($weak_cw);
    my @store = $mode eq 'edit' ? ( -store_cb => sub { $weak_cw->reload(@_) } ) : ();
    $cw->{current_mode} = $mode;

    my $tk_font = $cw->cget('-font');
    $cw->{editor} = $e_frame->$widget(
        -item => $obj,
        -path => $tree_path,
        -font => $tk_font,
        @store,
    );

t/config-model-ui.t  view on Meta::CPAN

# -*- cperl -*-

use ExtUtils::testlib;
use Test::More ;
use Test::Log::Log4perl;
use Test::Memory::Cycle;
use Tk;
use Scalar::Util qw/weaken/;

use Config::Model::TkUI;
use Config::Model 2.137;
use Config::Model::Tester::Setup qw/init_test setup_test_dir/;

use strict;
use warnings;

use lib 't/lib';


sub test_all {
    my ($mw, $delay,$test_ref) = @_ ;
    my $test = shift @$test_ref ;
    $test->() ;
    weaken($mw);
    $mw->after($delay, sub { test_all($mw, $delay,$test_ref) } ) if @$test_ref;
}

my ($model, $trace, $args) = init_test('show');

note("You can play with the widget if you run this test with '--show' option");

my $wr_root = setup_test_dir;
my $cmu ;

t/config-model-ui.t  view on Meta::CPAN

SKIP: {

    my $mw = eval {MainWindow-> new ; };

    # cannot create Tk window
    skip "Cannot create Tk window",1 unless $mw;

    $mw->withdraw ;

    $cmu = $mw->ConfigModelUI (-instance => $inst ) ;
    weaken($cmu);

    my $delay = 200 ;

    my $tktree= $cmu->Subwidget('tree') ;
    my $mgr   = $cmu->Subwidget('multi_mgr') ;
    my $widget ; # ugly global variable. Use with care
    my $idx = 1 ;

    my @test = (
	 sub { $cmu->reload ; ok(1,"forced test: reload") } ,