view release on metacpan or  search on metacpan

lib/Tk/ObjEditor.pm  view on Meta::CPAN

#
# This file is part of Tk-ObjEditor
#
# This software is copyright (c) 2014 by Dominique Dumont.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
package Tk::ObjEditor;
$Tk::ObjEditor::VERSION = '2.010';
use Carp;
use Tk::Derived;
use Tk::Frame;
use Tk::ObjScanner 2.010;
use Tk::Dialog;
use Tk::DialogBox;
use warnings;
use strict;
use 5.10.1;
use Scalar::Util 1.01 qw(reftype);

use vars qw/$VERSION @ISA/;

use Storable qw(dclone);

use base qw(Tk::Derived Tk::ObjScanner);

Tk::Widget->Construct('ObjEditor');

sub _isa {
    return (reftype($_[0]) // '') eq $_[1] ;
}

sub edit_object {
    require Tk;
    import Tk;
    my $object = shift;

    my $mw = MainWindow->new;
    $mw->geometry('+10+10');
    my $s = $mw->ObjEditor(
        '-caller' => $object,
        -direct   => 1,
        -title    => 'object editor'
    );

    $s->pack( -expand => 1, -fill => 'both' );
    $s->OnDestroy( sub { $mw->destroy; } );

    &MainLoop;    # Tk's
}

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

    my $data = delete $args->{'caller'} || delete $args->{'-caller'};
    $cw->{direct} =
        delete $args->{'direct'} || delete $args->{'-direct'} || 0;

    $cw->{user_data} = $data;

    my $edited_data = $cw->{direct} ? $data : dclone($data);

    $args->{'-caller'}    = $edited_data;    # to pass to ObjScanner
    $args->{'-show_tied'} = 0;               # do not show tied data internal

    $args->{title} = ref($data) . ' editor'
        unless ( defined $args->{title} || defined $args->{-title} );

    $cw->SUPER::InitObject($args);

    $cw->Subwidget('hlist')->bind( '<B3-ButtonRelease>', sub { $cw->modify_menu() } );

    $cw->{actions} = [];

    return $cw;
}

sub modify_menu {
    my $cw   = shift;
    my $item = shift;    # reserved for tests

    unless ( defined $item ) {

        # pointery and rooty are common widget method and must called on
        # the right widget to give accurate results