view release on metacpan or  search on metacpan

lib/Config/Model/Tk/AnyViewer.pm  view on Meta::CPAN

}

my @top_frame_args = qw/-relief raised -borderwidth 4/;
my @low_frame_args = qw/-relief sunken -borderwidth 1/;
my $padx           = 20;

sub add_info_button {
    my $cw = shift;
    my $frame = shift || $cw;

    my $elt_name = $cw->cme_object->element_name;
    my @items = $cw->cme_object->get_info;

    my $title = "Info on " . $cw->{config_class_name};
    $title .= ':' . $elt_name if $elt_name;

    my $dialog = $cw->Dialog(
        -title => $title,
        -text  => join( "\n", $title, @items ),
    );
    my $button = $frame->Button(
        -text    => "info ...",
        -command => sub { $dialog->Show; } );
    return $button;    # to be packed by caller
}

# returns the help widget (Label or ROText) which must be packed by caller
sub add_help {
    my $cw                = shift;
    my $help_label        = shift;
    my $help              = shift || '';
    my $force_text_widget = shift || '';    # pod or text

    my $help_frame = $cw->Frame();

    return $help_frame unless $force_text_widget or $help;

    $help_frame->Label( -text => $help_label, )->pack( -anchor => 'w' );

    my $widget;
    chomp $help;

    if ( $force_text_widget or $help =~ /\n/ or length($help) > 50 ) {
        $widget = $help_frame->PodText( -height => 6, -scrollbars => 'oe' );
        $widget->base_font_size(12);
        $widget->pack(@fbe1);
        $cw->update_help( $widget, $help );
    }
    elsif ( $help =~ /\w/ ) {
        $widget = $help_frame->Label(
            -text    => $help,
            -justify => 'left',
            -anchor  => 'w',
            -padx    => $padx,
        )->pack( -fill => 'x' );
    }

    return wantarray ? ( $help_frame, $widget ) : $help_frame;
}

sub update_help {
    my ( $cw, $w, $help ) = @_;

    # work around RT https://rt.cpan.org/Ticket/Display.html?id=67306
    my $t = $cw->toplevel->cget('-title');
    $w->text("\n\n=pod\n\n\n=encoding utf8\n\n$help\n\n=cut\n\n");
    $w->toplevel->title($t);
}

sub add_summary {
    my ( $cw, $elt_obj ) = @_;

    my $p    = $elt_obj->parent;
    my $name = $elt_obj->element_name;
    return $cw->add_help( Summary => $p->get_help( summary => $name ) );
}

sub add_description {
    my ( $cw, $elt_obj ) = @_;

    my $p    = $elt_obj->parent;
    my $name = $elt_obj->element_name;
    return $cw->add_help( Description => $p->get_help( description => $name ) );
}

sub add_warning {
    my ( $cw, $elt_obj, $usage ) = @_;

    my $frame       = $cw->Frame;       # packed by caller
    my $inner_frame = $frame->Frame;    # packed by update_warning

    my $label_button_frame = $inner_frame->Frame->pack(@fxe1);
    $label_button_frame->Label( -text => 'Issues', )
        ->pack( -anchor => 'w', -side => 'left', -fill => 'x' );

    if ( $usage eq 'edit' ) {
        my $nb_fixes = $elt_obj->has_fixes || 0;

        my $fix_widget = $label_button_frame->Button(
            -text  => "Apply $nb_fixes fixes",
            -state => $nb_fixes ? 'normal' : 'disabled'
        );
        $fix_widget->pack( -anchor => 'e', -side => 'right' );
        $cw->Advertise( fix_widget => $fix_widget );
    }

    my $warn_widget = $inner_frame->Scrolled(
        'ROText',
        -scrollbars => 'ow',
        -wrap       => 'word',
        -relief     => 'ridge',
        -height     => 4,
    );

    my $err = $elt_obj->error_msg || '';
    $warn_widget->pack(@fbe1)->insert( 'end', $err, 'error' );
    $warn_widget->tagConfigure(qw/error -lmargin1 2 -lmargin2 2 -rmargin 2 -background red/);

    my $msg = $elt_obj->warning_msg || '';
    $msg .= "with " . $elt_obj->has_fixes . " fixes" if $msg;
    $warn_widget->pack(@fbe1)->insert( 'end', $msg, 'warning' );
    $warn_widget->tagConfigure(qw/warning -lmargin1 2 -lmargin2 2 -rmargin 2 -background orange/);

    $logger->debug( "creating warning widget"
            . ( $err ? " with errors"   : '' )
            . ( $msg ? " with warnings" : '' ) );

    $cw->Advertise( warn_widget => $warn_widget );
    $cw->Advertise( warn_frame  => $inner_frame );

    $cw->update_warning($elt_obj);

    return $frame;
}

sub update_warning {
    my ( $cw, $elt_obj ) = @_;

    my $wf = $cw->Subwidget('warn_frame');
    my $ww = $cw->Subwidget('warn_widget');
    my $fw = $cw->Subwidget('fix_widget');

    $ww->delete( '0.0', 'end' );

    $elt_obj->check;
    my $err = $elt_obj->error_msg || '';
    $ww->insert( 'end', $err, 'error' ) if $err;

    my $msg = $elt_obj->warning_msg || '';
    if ( ref($msg) eq 'HASH' ) {
        $msg = join( '', map { join( "\n\t", @{ $msg->{$_} } ) } sort keys %$msg );
    }
    $ww->insert( 'end', $msg, 'warning' ) if $msg;

    $logger->debug( "updating warning widget"
            . ( $err ? " with errors"   : '' )
            . ( $msg ? " with warnings" : '' ) );

    if ( $msg or $err ) {
        $wf->pack(@fbe1);

        if ( $msg and defined $fw ) {
            my $nb_fixes = $elt_obj->has_fixes;
            $fw->configure(
                -text    => "Apply $nb_fixes fixes",
                -command => sub {
                    $elt_obj->apply_fixes;
                    $cw->reset_value;
                    $cw->update_warning($elt_obj);
                    $cw->{store_cb}->();
                },
                -state => $nb_fixes ? 'normal' : 'disabled'
            );
        }
    }
    else {
        $wf->packForget;
    }
}

# returns a widget that must be packed
sub add_annotation {
    my ( $cw, $obj ) = @_;

    return $cw->add_help( 'Note', $obj->annotation );
}

sub add_editor_button {
    my ( $cw, $path ) = @_;

    my $sub = sub {
        $cw->parent->parent->parent->parent->create_element_widget( edit => $path );
    };
    return $cw->Button( -text => 'Edit ...', -command => $sub );
}