view release on metacpan or  search on metacpan

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

# the same terms as the Perl 5 programming language system itself.
#
package Tk::ObjScanner;
$Tk::ObjScanner::VERSION = '2.018';
require 5.006;

use strict;
use warnings;
use Scalar::Util 1.01 qw(weaken isweak reftype);

# Version 1.1805 - patches proposed by Rudi Farkas rudif@lecroy.com
# 1: Use Adjuster so that the user can adjust the relative heights of the
# HList window and the dump window.
# 2: Provide 5 options for setting colors and images
# 3: Impose the same scrollbar style ('osoe') to HList and ROText.
# 4: Set -wideselection 0 for HList.
# The patches consist of code changes in sub Populate().

# Version 1.1803 - patch proposed by Rudi Farkas rudif@lecroy.com
# Purpose #1: fix the problem with call $scanner->configure();
#   dies with error
# unknown option "oldcursor" at C:/Perl/site/lib/Tk/Derived.pm line 223.
# The patch consists of
# - a modified ConfigSpecs line
#                     oldcursor => [$hlist, undef, undef, undef],
# Purpose #2: add 'open folder' image and display it when item has displayed children
# The patch consists of
# - a line in sub Populate
#    $cw->{openImg} = $cw->Photo(-file => Tk->findINC('open_folder.xbm'));
# - method _redisplayImage()
# - 2 calls to _redisplayImage inside displaySubItem()

# Patch proposed by Rudi Farkas rudif@lecroy.com
# Purpose: while executing displaySubItem() which may take a long time
# if getting data from disk, another package or another machine,
# the default arrow cursor is replaced by a 'watch' cursor.
# The patch consists of
# - ConfigSpecs item : oldcursor => undef
# - method _swapCursor()
# - 3 calls to _swapCursor inside displaySubItem(), at entry and at 2 exits

# Implementation note:
#
# The scanner deals with a tree representation of the user data. The
# scanner used to keep a copy of the data in its data tree that is
# embedded in the HList widget. Unfortunately this scheme fails when
# dealing with tied scalar: the copy stored within the HList is a copy
# of the value of the scalar. The tied object itself is lost.

# So to be able to use ObjScanner with tied scalar, one big change was
# necessary: The HList data must not hold a copy of the data, but just
# reference to the data. Hence it will hold a scalar ref, a ref to a
# hash ref or a ref to an array ref. Hence the item attribute of the
# itemcget data part of Hlist is changed to item_ref.

# Furthermore to avoid memory leak if the user modifies its data
# structure, the ref kept must be weakened (See Scalar::Util man page)

use Carp;
use warnings;
use Tk::Derived;
use Tk::Frame;
use Data::Dumper;

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

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

sub scan_object {
    require Tk;
    import Tk;
    my $object = shift;
    my $animate = shift || 0;    # used by tests

    my $mw = MainWindow->new;
    $mw->geometry('+10+10');
    my $s = $mw->ObjScanner(
        '-caller'    => $object,
        -destroyable => 1,
        -title       => 'object scan'
    );

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

    if ($animate) {
        $s->_scan('root');
    }
    else {
        &MainLoop;    # Tk's
    }
}

# used by test
sub _scan {
    my $cw      = shift;
    my $topName = shift;
    $cw->yview($topName);
    $cw->after(200);    # sleep 200ms

    foreach my $c ( $cw->infoChildren($topName) ) {
        $cw->displaySubItem($c);
        $cw->_scan($c);
    }
    $cw->idletasks;
}

sub _isa {
    #return UNIVERSAL::isa(@_);
    return (reftype($_[0]) || '') eq $_[1] ;
}

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

    require Tk::Menubutton;
    require Tk::HList;
    require Tk::ROText;
    require Tk::Adjuster;

    $cw->{show_menu} =
          defined $args->{'show_menu'}  ? delete $args->{'show_menu'}
        : defined $args->{'-show_menu'} ? delete $args->{'-show_menu'}
        :                                 0;