Tk-ObjScanner-2.012/0000755004725500017500000000000010702662106012572 5ustar domidomiTk-ObjScanner-2.012/t/0000755004725500017500000000000010702662106013035 5ustar domidomiTk-ObjScanner-2.012/t/rudi.t0000644004725500017500000000647707756662024014221 0ustar domidomi# -*- cperl -*- use warnings FATAL => qw(all); ### ### variant of test.pl for Tk:ObjScanner, with additional test cases ### by R Farkas rudif@lecroy.com 27 Jun 1999 ### # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..4\n"; } END {print "not ok 1\n" unless $loaded;} use Tk ; use ExtUtils::testlib ; use Tk::ObjScanner ; $loaded = 1; my $idx = 1; print "ok ",$idx++,"\n"; my $trace = shift || 0 ; ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): use strict ; package toto ; use FileHandle; use Benchmark; use Math::BigInt; sub new { my $type = shift; # add recursive data only if interactive test my $tkstuff = $trace ? shift : "may be another time ..." ; my $scl = 'my scalar var'; my $self = { 'scalar: key1' => 'value1', 'ref array:' => [qw/a b sdf/, {'v1' => '1', 'v2' => 2},'dfg'], 'ref hash: key2' => { 'sub key1' => 'sv1', 'sub key2' => 'sv2' }, 'ref hash: piped|key' => {a => 1 , b => 2}, 'scalar: long' => 'very long line'.'.' x 80 , 'scalar: is undef' => undef, 'scalar: some text' => "some \n dummy\n Text\n", 'ref blessed hash: tk widget' => $tkstuff, 'ref const' => \12345, 'ref scalar' => \$scl, 'ref ref tk widget' => \$tkstuff, # ref to ref (assumes $tkstuff is a ref) 'ref code' => sub { my $x = shift; sin($x) + cos(2*$x) }, 'ref blessed glob' => new FileHandle, 'ref blessed array' => new Benchmark, 'ref blessed scalar' => new Math::BigInt '123 456 789 123 456 789', } ; bless $self,$type; } package main; my $toto ; my $mw = MainWindow-> new ; $mw->geometry('+10+10'); my $w_menu = $mw->Frame(-relief => 'raised', -borderwidth => 2); $w_menu->pack(-fill => 'x'); my $f = $w_menu->Menubutton(-text => 'File', -underline => 0) -> pack(-side => 'left' ); $f->command(-label => 'Quit', -command => sub{$mw->destroy;} ); print "creating dummy object \n" if $trace ; my $dummy = new toto ($mw); print "ok ",$idx++,"\n"; print "Creating obj scanner\n" if $trace ; my $s = $mw -> ObjScanner ( 'caller' => $dummy, title => 'test scanner' ); $s -> pack(-expand => 1, -fill => 'both') ; print "ok ",$idx++,"\n"; $mw->idletasks; sub scan { my $topName = shift ; $s->yview($topName) ; $mw->after(200); # sleep 300ms foreach my $c ($s->infoChildren($topName)) { $s->displaySubItem($c); scan($c); } $mw->idletasks; } if ($trace) { MainLoop ; # Tk's } else { scan('root'); } print "ok ",$idx++,"\n"; Tk-ObjScanner-2.012/t/options.t0000644004725500017500000001100507756661762014740 0ustar domidomi# -*- cperl -*- ### ### test of Tk:ObjScanner options ### by Rudi Farkas rudif@lecroy.com 27 May 2999 ### # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..4\n"; } END {print "not ok 1\n" unless $loaded;} use warnings FATAL => qw(all); use Tk ; use ExtUtils::testlib ; use Tk::ObjScanner ; $loaded = 1; use strict ; my $idx = 1; print "ok ",$idx++,"\n"; my $trace = shift || 0 ; ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): package myHash; use Tie::Hash ; use vars qw/@ISA/; sub TIEHASH { my $type = shift; my $self={ 'tied_attr1' => 'hidden data1', 'tied_attr2' => 'hidden data2' } ; bless $self,$type; my %args = @_ ; return $self ; } sub STORE { my ($self,$index,$value) = @_ ; return $self->{data}{$index} = $value ; } sub FETCH { my ($self,$index) = @_ ; return $self->{data}{$index} ; } sub DELETE { my $self = shift; my $idx = shift ; delete $self->{data}{$idx}; } sub CLEAR { my $self = shift; $self->{data} = {} ; } sub EXISTS { my $self = shift; my $idx = shift ; return exists $self->{data}{$idx}; } sub FIRSTKEY { my $self = shift; my $a = keys %{$self->{data}}; # reset each() iterator each %{$self->{data}} } sub NEXTKEY { my $self = shift; return each %{ $self->{data} } ; } package Toto ; my %h ; tie %h, 'myHash', 'dummy key' => 'dummy value' or die ; $h{'user_data1'} = 'non hidden data' ; use FileHandle; use Benchmark; use Math::BigInt; sub new { my $type = shift ; # add recursive data only if interactive test my $tkstuff = $trace ? shift : "may be another time ..." ; my $scl = 'my scalar var'; my $self = { 'scalar: key1' => 'value1', 'ref array:' => [qw/a b sdf/, {'v1' => '1', 'v2' => 2},'dfg'], 'ref hash: key2' => { 'sub key1' => 'sv1', 'sub key2' => 'sv2' }, 'ref hash: piped|key' => {a => 1 , b => 2}, 'scalar: long' => 'very long line'.'.' x 80 , 'scalar: is undef' => undef, 'scalar: some text' => "some \n dummy\n Text\n", 'ref blessed hash: tk widget' => $tkstuff, 'ref const' => \12345, 'ref scalar' => \$scl, 'ref ref tk widget' => \$tkstuff, # ref to ref (assumes $tkstuff is a ref) 'ref code' => sub { my $x = shift; sin($x) + cos(2*$x) }, 'ref blessed glob' => new FileHandle, 'ref blessed array' => new Benchmark, 'ref blessed scalar' => new Math::BigInt('123 456 789 123 456 789'), 'tied hash' => \%h , } ; bless $self,$type; } package main; my $toto ; my $mw = MainWindow-> new ; $mw->geometry('+10+10'); my $w_menu = $mw->Frame(-relief => 'raised', -borderwidth => 2); $w_menu->pack(-fill => 'x'); my $f = $w_menu->Menubutton(-text => 'File', -underline => 0) -> pack(-side => 'left' ); $f->command(-label => 'Quit', -command => sub{$mw->destroy;} ); print "creating dummy object \n" if $trace ; my $dummy = new Toto ($mw); print "ok ",$idx++,"\n"; print "Creating obj scanner\n" if $trace ; my $s = $mw -> ObjScanner ( caller => $dummy, title => 'test scanner options', background => 'white', selectbackground => 'beige', show_menu => 1, foldImage => $mw->Photo(-file => Tk->findINC('folder.xpm')), openImage => $mw->Photo(-file => Tk->findINC('openfolder.xpm')), itemImage => $mw->Photo(-file => Tk->findINC('textfile.xpm')) ); $s -> pack(-expand => 1, -fill => 'both') ; print "ok ",$idx++,"\n"; $mw->idletasks; sub scan { my $topName = shift ; $s->yview($topName) ; $mw->after(200); # sleep 300ms foreach my $c ($s->infoChildren($topName)) { $s->displaySubItem($c,1); scan($c); } $mw->idletasks; } if ($trace) { MainLoop ; # Tk's } else { scan('root'); } print "ok ",$idx++,"\n"; Tk-ObjScanner-2.012/t/basic.t0000644004725500017500000000754407761676444014342 0ustar domidomi# -*- cperl -*- use warnings FATAL => qw(all); # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..4\n"; } END {print "not ok 1\n" unless $loaded;} use Tk ; use ExtUtils::testlib ; use Tk::ObjScanner ; $loaded = 1; use strict ; my $idx = 1; print "ok ",$idx++,"\n"; my $trace = shift || 0 ; ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): package myHash; use Tie::Hash ; use vars qw/@ISA/; @ISA=qw/Tie::StdHash/ ; sub TIEHASH { my $class = shift; my %args = @_ ; return bless { %args, dummy => 'foo' } , $class ; } sub STORE { my ($self, $idx, $value) = @_ ; $self->{$idx}=$value; return $value; } package MyScalar; use Tie::Scalar ; use vars qw/@ISA/; @ISA=qw/Tie::StdHash/ ; sub TIESCALAR { my $class = shift; my %args = @_ ; return bless { %args, dummy => 'foo default value' } , $class ; } sub STORE { my ($self, $value) = @_ ; $self->{data} = $value; return $value; } sub FETCH { my ($self) = @_ ; # print "\t\t",'@.....@.....@..... MeScalar read',"\n"; return $self->{data} || $self->{dummy} ; } package Toto ; use Scalar::Util qw(weaken) ; sub new { my $type = shift ; my %h ; tie (%h, 'myHash', 'dummy key' => 'dummy value') or die ; $h{data1}='value1'; # add recursive data only if interactive test my $tkstuff = $trace ? shift : "may be another time ..." ; my $scalar = 'dummy scalar ref value'; open (FILE,"t/basic.t") || die "can't open myself !\n"; my %a_hash = (for => 'weak ref') ; my $glob = \*FILE ; # ??? my $self = { 'key1' => 'value1', 'array' => [qw/a b sdf/, {'v1' => '1', 'v2' => 2},'dfg'], 'key2' => { 'sub key1' => 'sv1', 'sub key2' => 'sv2' }, 'some_code' => sub {print "some_code\n";}, 'piped|key' => {a => 1 , b => 2}, 'scalar_ref_ref' => \\$scalar, 'filehandle' => $glob, 'empty string' => '', 'non_empty string' => ' ', 'long' => 'very long line'.'.' x 80 , 'is undef' => undef, 'some text' => "some \n dummy\n Text\n", 'tied hash' => \%h , 'not weak' => \%a_hash, 'weak' => \%a_hash , 'tk widget' => $tkstuff }; tie ($self->{tied_scalar}, 'MyScalar', 'dummy key' => 'dummy value') or die ; weaken($self->{weak}) ; $self->{tied_scalar} = 'some scalar huh?'; bless $self,$type; } package main; my $toto ; my $mw = MainWindow-> new ; $mw->geometry('+10+10'); my $w_menu = $mw->Frame(-relief => 'raised', -borderwidth => 2); $w_menu->pack(-fill => 'x'); my $f = $w_menu->Menubutton(-text => 'File', -underline => 0) -> pack(-side => 'left' ); $f->command(-label => 'Quit', -command => sub{$mw->destroy;} ); print "creating dummy object \n" if $trace ; my $dummy = new Toto ($mw); print "ok ",$idx++,"\n"; print "Creating obj scanner\n" if $trace ; my $s = $mw -> ObjScanner ('-caller' => $dummy, -columns => 4, -header => 1 ); $s->headerCreate(1,-text =>'coucou') ; $s -> pack(-expand => 1, -fill => 'both') ; print "ok ",$idx++,"\n"; $mw->idletasks; sub scan { my $topName = shift ; $s->yview($topName) ; $mw->after(200); # sleep 300ms foreach my $c ($s->infoChildren($topName)) { $s->displaySubItem($c); scan($c); } $mw->idletasks; } if ($trace) { MainLoop ; # Tk's } else { scan('root'); } print "ok ",$idx++,"\n"; Tk-ObjScanner-2.012/t/pseudo_hash.t0000644004725500017500000000405110674240165015531 0ustar domidomi# -*- cperl -*- # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..", $] >= 5.009 ? '1' : '4' ,"\n"; } END {print "not ok 1\n" unless $loaded;} use Tk ; use ExtUtils::testlib ; use Tk::ObjScanner ; use warnings ; $loaded = 1; my $idx = 1; print "ok ",$idx++,"\n"; my $trace = shift || 0 ; ######################### End of black magic. exit if $] >= 5.009 ; # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): # define a class using pseudo hashes package Bla; use fields qw(a b c); sub new { my $class = shift; no strict 'refs'; my $self = bless [\%{"$class\::FIELDS"}], $class; $self; } sub new2 { my $class = shift; bless {}, $class; } package main; use strict ; print "ok ",$idx++,"\n"; my $top=tkinit; $top->geometry('+10+10'); my $x = [{}, 1, 2, 3]; # not a pseudo hash my $y = [{a => 3}, 3, 4, 2, 3, 4]; # not a pseudo hash my $y3 = [{a => 1, c => 3}, 3, 4]; # not a pseudo hash # check not correct my $y2 = [{a => 1, b => 2}, 3, 4]; # a possible pseudo hash my $z = [{a => "bcd"}, 3, 4, 2, 3, 4]; # also not a pseudo hash my $o = new Bla; # a pseudo hash $o->{a} = "a"; $o->{b} = ["b", "d", $y2, $x, $y, $y3, $z]; my $b2 = $o->{c} = new Bla; $b2->{a} = "a2"; $b2->{b} = "b23"; my $s = $top->ObjScanner(caller => $o , -view_pseudo => 1); $s->pack; print "ok ",$idx++,"\n"; $top->idletasks; sub scan { my $topName = shift ; $s->yview($topName) ; $top->after(200); # sleep 300ms foreach my $c ($s->infoChildren($topName)) { $s->displaySubItem($c); scan($c); } $top->idletasks; } if ($trace) { MainLoop ; # Tk's } else { scan('root'); } print "ok ",$idx++,"\n"; Tk-ObjScanner-2.012/t/scanner.t0000644004725500017500000000043607756662055014700 0ustar domidomi# -*- cperl -*- use warnings FATAL => qw(all); use ExtUtils::testlib; use Test::More tests => 1 ; use Tk ; use Tk::ObjScanner ; my $trace = shift || 0 ; my $data = { foo => 'bar', bar => 'baz' } ; my $animate = $trace ? 0 : 1 ; Tk::ObjScanner::scan_object($data,$animate) ; ok(1) ; Tk-ObjScanner-2.012/META.yml0000644004725500017500000000075710702662106014054 0ustar domidomi# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Tk-ObjScanner version: 2.012 version_from: ObjScanner.pm installdirs: site requires: Scalar::Util: 1.01 Tk: 0 Tk::Adjuster: 0 Tk::HList: 0 Tk::ROText: 0 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.30_01 Tk-ObjScanner-2.012/ObjScanner.pm0000644004725500017500000005663010702662044015167 0ustar domidomi# $Id: ObjScanner.pm,v 2.12 2007-10-09 11:21:08 domi Exp $ package Tk::ObjScanner; require 5.006; use strict; use warnings ; use Scalar::Util qw(weaken isweak); # 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; our @ISA = qw(Tk::Derived Tk::Frame); *isa = \&UNIVERSAL::isa; our $VERSION = sprintf "%d.%03d", q$Revision: 2.12 $ =~ /(\d+)\.(\d+)/; 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 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 ; my $display_show_tied_button = defined $args->{'-show_tied'} || defined $args->{show_tied} ? 0 : 1 ; $cw->{show_tied} = defined $args->{'-show_tied'} ? delete $args->{'-show_tied'} : defined $args->{show_tied} ? delete $args->{show_tied} : 1 ; my $scanned_data = delete $args->{'caller'} || delete $args->{'-caller'}; $cw->{chief} = \$scanned_data ; my $destroyable = defined $args->{'-destroyable'} ? delete $args->{'-destroyable'} : defined $args->{'destroyable'} ? delete $args->{'destroyable'} : 1 ; my $display_view_pseudo_button = defined $args->{'-view_pseudo'} || defined $args->{view_pseudo} ? 0 : 1; my $view_pseudo = delete $args->{'-view_pseudo'} || delete $args->{'view_pseudo'} || 0; # override option for feature not supported by Perl 5.09 and later if ($] >= 5.009) { $view_pseudo = 0 ; } croak "Missing caller argument in ObjScanner\n" unless defined $cw->{chief}; my $title = delete $args->{title} || delete $args->{-title} || ref($cw->{chief}).' scanner'; my $background = delete $args->{'background'} || delete $args->{'-background'} ; my $selectbackground = delete $args->{'selectbackground'} || delete $args->{'-selectbackground'} ; $cw->{itemImg} = delete $args->{'itemImage'} || delete $args->{'-itemImage'} || $cw->Photo(-file => Tk->findINC('textfile.xpm')); $cw->{foldImg} = delete $args->{'foldImage'} || delete $args->{'-foldImage'} || $cw->Photo(-file => Tk->findINC('folder.xpm')); $cw->{openImg} = delete $args->{'openImage'} || delete $args->{'-openImage'} || $cw->Photo(-file => Tk->findINC('openfolder.xpm')); my $menuframe; my $menu ; if ($destroyable or $cw->{show_menu}) { $menuframe = $cw -> Frame (-relief => 'raised', -borderwidth => 1)-> pack(-pady => 2, -fill => 'x' ) ; $menu = $cw->{menu} = $menuframe -> Menubutton (-text => $title.' menu') -> pack ( -fill => 'x' , -side => 'left'); $menu -> command (-label => 'reload', -command => sub{$cw->updateListBox; }); } my %hlist_args ; map {$hlist_args{$_} = delete $args->{$_} if defined $args->{$_};} qw/-columns -header/; my $hlist= $cw -> Scrolled ( qw\HList -selectmode single -indent 35 -separator | -itemtype imagetext -wideselection 0 \, %hlist_args )-> pack ( qw/-fill both -expand 1 /) ; # See Mastering Perl/Tk page 364 for details $hlist->bind('' => sub { my $y = $Tk::event->y ; my $name = $Tk::widget->nearest($y) ; $cw->displaySubItem($name,0) ; } ); $hlist->bind('' => sub { my $y = $Tk::event->y ; my $name = $Tk::widget->nearest($y) ; $cw->displaySubItem($name,1) ; } ) if $cw->{show_tied}; $cw->Advertise(hlist => $hlist); #my $adj1 = $cw->Adjuster()->packAfter($hlist); my $popup = $cw->{popup} = $cw -> Toplevel ; $popup -> withdraw ; $cw->{dumpLabel} = $popup -> Label(-text => 'not yet ...') ; $cw->{dumpLabel} ->pack(-fill => 'x') ; $cw->{dumpWindow} = $popup -> Scrolled('ROText', -height => 10) ; $cw->{dumpWindow} -> pack( -fill => 'both', -expand => 1) ; $popup->Button(-text => 'OK', -command => sub{$popup ->withdraw();}) -> pack ; # add a destroy commend to the menu $menu -> command (-label => 'destroy', -command => sub{$cw->destroy; }) if defined $cw->{menu} && $destroyable ; $cw->ConfigSpecs ( -scrollbars=> ['DESCENDANTS', undef, undef, 'osoe'], -background => ['DESCENDANTS', 'background', 'Background', $background], -selectbackground => [$hlist, 'selectBackground', 'SelectBackground', $selectbackground], -width => [$hlist, undef, undef, 80], -height => [$hlist, undef, undef, 25], -oldcursor => [$hlist, undef, undef, undef], DEFAULT => [$hlist] ) ; $cw->Delegates(DEFAULT => $hlist ) ; $cw->SUPER::Populate($args) ; $cw->{viewpseudohash} = $view_pseudo; if (defined $menuframe) { $menuframe -> Checkbutton ( -text => 'view pseudo-hashes', -variable => \$cw->{viewpseudohash}, -onvalue => 1, -offvalue => 0, -command => sub{$cw->updateListBox;} ) -> pack(-side => 'right') if $display_view_pseudo_button ; $menuframe -> Checkbutton ( -text => 'show tied info', -variable => \$cw->{show_tied}, -onvalue => 1, -offvalue => 0, -command => sub{$cw->updateListBox;} ) -> pack(-side => 'right') if $display_show_tied_button; } $cw->updateListBox; return $cw ; } # function to find whether a reference is a pseudo hash # return the nb of elements of the pseudo hash sub isPseudoHash { my $cw = shift ; my $item = shift; return 0 unless (defined $item && $cw->{viewpseudohash} && isa($item,'ARRAY') && scalar @$item && ref($item->[0]) =~ /^(HASH|pseudohash)$/); my @indexes = values %{ $item->[0] } ; my $nb_of_elt = scalar keys %{ $item->[0] } ; # check that all indexes are numbers and within the range return 0 if scalar grep( /\D/ || $_ < 1 || $_ > $nb_of_elt, @indexes ); # check that not more array items than in the range are defined return 0 unless $nb_of_elt >= scalar @$item - 1; return $nb_of_elt ; } sub updateListBox { my $cw = shift ; my $h = $cw->Subwidget('hlist'); my $root = 'root'; #print "root adding $root \n"; if ($h->infoExists($root)) { #print "deleting root children\n"; $h->deleteOffsprings($root); # set new text of root $h->entryconfigure($root,-text => $cw->element($cw->{chief})); } else { $h->add ( $root, -data => { tied_display => 0, item_ref => $cw->{chief} } ); $h->itemCreate ( $root, 0, -image => $cw->{foldImg}, -text => $cw->element($cw->{chief}) ); } $cw->displaySubItem($root,0); } sub displaySubItem { my $cw = shift ; my $name = shift ; my $do_tie = shift || 0 ; $do_tie = 0 unless $cw->{show_tied} ; my $h = $cw->Subwidget('hlist'); $h->selectionClear() ; $h->selectionSet($name) ; ### my $hash = $h->info('data', $name); my $tied_display = $hash->{tied_display} ; my $ref = $hash->{item_ref} ; #print "pressed ",$Tk::event->b,',', # $Tk::event->x,' ',$y," for $Tk::widget\n"; # test for tied_display objects my $tied_object ; if (isa($$ref,'ARRAY')) {$tied_object = tied @$$ref ;} elsif (isa($$ref, 'HASH')) {$tied_object = tied %$$ref ;} elsif (isa($$ref, 'REF')) {$tied_object = tied $$$ref ;} else {$tied_object = tied $$ref ;} my $is_tied = $do_tie && defined $tied_object ? 1 : 0 ; my $delete = $is_tied ^ $tied_display ; #print "Button clicked for $name (do_tie $do_tie, item $$ref, ", # "tied object $tied_object)\n"; if ($delete) { $hash->{tied_display} = $is_tied; $h->deleteOffsprings($name) ; } $cw->toggle_display($name) ; # return if the children are already represented in the hlist return if scalar($h->infoChildren($name)) ; my $ref_to_display = $is_tied ? \$tied_object : $ref ; $cw->_swapCursor('watch'); $cw->displayObject($name,$ref_to_display) ; $cw->_swapCursor(); $cw->_redisplayImage($name); } sub toggle_display { my $cw = shift ; my $name = shift ; my $h = $cw->Subwidget('hlist'); foreach my $child ( $h->infoChildren($name) ) { if ($h->info('hidden',$child)) {$h->show('entry',$child);} else {$h->hide('entry',$child);} } $cw->_redisplayImage($name); } sub displayObject { my $cw = shift ; my $name = shift ; my $ref = shift ; my $h = $cw->Subwidget('hlist'); my $isPseudoHash = $cw->isPseudoHash($$ref); if (isa($$ref,'ARRAY') and not $isPseudoHash) { foreach my $i (0 .. $#$$ref) { #print "adding array item $i: $_,",ref($_),"\n"; my $img = ref $$ref->[$i] ? $cw->{foldImg} : $cw->{itemImg} ; my $npath = $h->addchild ( $name, -data => { tied_display => 0, index => $i , item_ref => \$$ref->[$i] } ); $h->itemCreate($npath, 0, -image => $img, -text => $cw->describe_element($ref,$i) ); } } elsif (isa($$ref,'REF') or isa($$ref,'SCALAR')) { my $npath = $h->addchild($name, -data => { tied_display => 0, item_ref => $$ref}); $h->itemCreate($npath, 0, -image => isa($$ref,'REF') ? $cw->{foldImg} : $cw->{itemImg}, -text => $cw->describe_element($ref) ); } elsif (isa($$ref,'CODE')) { require B::Deparse; my $deparse = B::Deparse->new("-p", "-sC"); my $body = $deparse->coderef2text($$ref); $cw->popup_text("B::Deparse code dump",$body) ; } elsif (isa($$ref,'GLOB')) { if (isa($$ref, 'UNIVERSAL')) { my ($what) = ($$ref =~ /\b([A-Z]+)\b/); $cw->popup_text('Error', "Sorry, can't display a $what based $$ref object"); } else { $cw->popup_text('Error', "Sorry, can't display ".$$ref." reference"); } } elsif (isa($$ref, 'HASH') or $isPseudoHash) { # hash or object foreach my $k (sort keys %$$ref) { #print "adding hash key $name|$k ", ref($$ref->{$k}),"\n"; my $img = ref($$ref->{$k}) ? $cw->{foldImg} : $cw->{itemImg} ; my $npath = $h->addchild($name, -data => { tied_display => 0, index => $k, item_ref => \$$ref->{$k}}); $h->itemCreate($npath, 0, -text => $cw->describe_element($ref,$k), -image => $img); } } elsif (defined $$ref) { #print "adding scalar $name , $$ref is a scalar\n"; $cw->popup_text('scalar dump',$$ref) if $$ref =~ /\n/; } } sub describe_element { my ($cw,$ref,$index) = @_ ; my $isPseudoHash = $cw->isPseudoHash($$ref); if (isa($$ref,'ARRAY') and not $isPseudoHash) { return "[$index]-> ".$cw->element(\$$ref->[$index] ) ; } elsif (isa($$ref,'REF') or isa($$ref,'SCALAR')) { return $cw->element($$ref) ; } elsif (isa($$ref, 'HASH') or $isPseudoHash) { return ("{$index}-> ".$cw->element(\$$ref->{$index})) ; } else { die "describe_element: unexpected type $$ref, index $index"; } } sub popup_text { my ($cw,$title,$text) = @_ ; $cw->{popup} -> title ($title) ; $cw->{dumpLabel} -> configure (-text => $title ); $cw->{dumpWindow}->delete('1.0','end'); $cw->{dumpWindow}-> insert ('end', $text); $cw->{popup} -> deiconify ; $cw->{popup} -> raise ; } sub analyse_element { my $cw = shift ; my $ref = shift; my %info = ( description => '' ); confess "ref error" unless ref($ref) ; my $pseudo = $info{pseudo_hash} = $cw->isPseudoHash($$ref) ; $info{element_ref} = $ref ; my $str_ref = ref($$ref) ; $info{tied} = $str_ref eq 'HASH' ? tied %$$ref : $str_ref eq 'ARRAY' ? tied @$$ref : $str_ref eq 'SCALAR' ? tied $$$ref : $str_ref eq 'REF' ? tied $$$ref : $str_ref ? undef : tied $$ref ; if (not defined $$ref) { $info{description} = 'undefined' ; } elsif ($str_ref and isa($$ref,'UNIVERSAL')) { $info{class} = $str_ref ; $info{base} = $pseudo ? 'PSEUDO-HASH' : isa($$ref,'SCALAR') ? 'SCALAR' : ($$ref =~ /=([A-Z]+)\(/) ? $1 : "some magic with $$ref" ; # desperate measure $info{description} = "$str_ref OBJECT based on $info{base}"; } elsif ($pseudo) { $info{description} = 'PSEUDO-HASH'; } elsif ($str_ref) { # a ref but not an object $info{description} = $str_ref ; } elsif ($$ref =~ /\n/) { # multi-line string $info{description} = 'double click here to display value'; } else { # plain scalar $info{value} = $$ref; } if (defined $$ref) { $info{nb} = $pseudo ? $pseudo : isa($$ref,'ARRAY') ? scalar (@$$ref) : isa($$ref,'HASH') ? scalar keys(%$$ref) : undef ; } if ($str_ref and isweak($$ref)) { $info{description} .= ' (weak ref)'; } return \%info ; } sub element { my $cw = shift ; my $ref = shift; my $info = $cw->analyse_element($ref); my $what = $info->{description} || "'$info->{value}'" ; my $nb = $info -> {nb} ; my $tied = $info -> {tied} ; $what .= " ($nb)" if defined $nb; $what .= " (tied with ".ref($tied).")" if defined $tied and $cw->{show_tied}; return $what ; } sub _swapCursor { my ($cw, $cursor) = @_; my $parent = $cw->parent; if (defined($cursor)) { $cw->{oldcursor} = $parent->cget('-cursor'); # save $parent->configure(-cursor => $cursor); # replace } else { $parent->configure(-cursor => $cw->{oldcursor}); # restore } $parent->update; # does not seem to be absolutely necessary } sub _redisplayImage { my ($cw, $name) = @_; my $h = $cw->Subwidget('hlist'); my @children = $h->infoChildren($name); return if @children == 0; my $image = $h->info('hidden',$children[0]) ? $cw->{foldImg} : $cw->{openImg}; $h->entryconfigure($name, '-image' => $image); } 1; __END__ =head1 NAME Tk::ObjScanner - Tk data scanner =head1 SYNOPSIS # regular use use Tk::ObjScanner; my $scanner = $mw->ObjScanner( -caller => $object, -title=>"windows") -> pack ; my $mw -> ObjScanner ( -caller => $object, -title => 'demo setting the scanner options', -background => 'white', -selectbackground => 'beige', -foldImage => $mw->Photo(-file => Tk->findINC('folder.xpm')), -openImage => $mw->Photo(-file => Tk->findINC('openfolder.xpm')), -itemImage => $mw->Photo(-file => Tk->findINC('textfile.xpm')), ) -> pack(-expand => 1, -fill => 'both') ; # non-intrusive scan style # user code to produce data Tk::ObjScanner::scan_object($mydata) ; # resume user code =head1 DESCRIPTION The scanner provides a GUI to scan the attributes of an object. It can also be used to scan the elements of a hash or an array. This widget can be used as a regular widget in a Tk application or can be used as an autonomous popup widget that will display the content of a data structure. The latter is like a call to a graphical L. The scanner can be used in an autonomous way with the C function. The scanner is a composite widget made of a menubar and L. This widget acts as a scanner to the object (or hash ref) passed with the 'caller' parameter. The scanner will retrieve all keys of the hash/object and insert them in the HList. When the user double clicks on a key, the corresponding value will be added in the HList. If the value is a multi-line scalar, the scalar will be displayed in a popup text window. Code ref will be deparsed and shown also in the pop-up window. Tied scalar, hash or array internal can also be scanned by clicking on the I button to open them. Weak references are recognized (See L for details) =head1 Autonomous widget =head2 scan_object( data ) This function is not exported and must be called this way: Tk::ObjScanner::scan_object($data); This function will load Tk and pop up a scanner widget. When the user destroy the widget (with C destroy> menu), the user code is resumed. =head1 Constructor parameters =over 4 =item C The ref of the object or hash or array to scan (mandatory). (you can also use 'C<-caller>') =item C<-title> The title of the menu created by the scanner (optional) =item C<-background> The background color for subwidgets (optional) =item C<-selectbackground> The select background color for HList (optional) =item C<-itemImage> The image for a scalar item (optional, default 'file.xbm') =item C<-foldImage> The image for a composite item (array or hash) when closed (optional, default 'folder.xbm') =item C<-openImage> The image for a composite item (array or hash) when open (optional, default 'openfolder.xbm') =item C<-show_menu> ObjScanner can feature a menu with 'reload' button, 'show tied info', 'view pseudo-hash' check box. (optional default 0). =item C<-destroyable> If set, a menu entry will allow the user to destroy the scanner widget. (optional, default 1) . You may want to set this parameter to 0 if the destroy can be managed by a higher level object. This parameter is ignored if show_menu is unset. =item C<-view_pseudo> If set, will interpret pseudo hashes as hash (default 0). This option is disabled for Perl 5.09 and later. =item C<-show_tied> If set, will indicate if a variable is a tied variable. You can see the internal data of the tied variable by double clicking on the middle button. (default 1) =back =head1 WIDGET-SPECIFIC METHODS =head2 updateListBox Update the keys of the listbox. This method may be handy if the scanned object wants to update the listbox of the scanner when the scanned object gets new attributes. =head1 CAVEATS The name of the widget is misleading as any data (not only object) may be scanned. This widget is in fact a DataScanner. ObjScanner may fail if an object involves a lot of internal perl magic. In this case, I'd be glad to hear about and I'll try to fix the problem. ObjScanner does not detect recursive data structures. It will just keep on displaying the tree until the user gets tired of clicking on the HList items. There's no sure way to detect if a reference is a pseudo-hash or not. When a reference is believed to be a pseudo-hash, ObjScanner will display the content of the reference like a hash. If the reference is should not be displayed like a pseudo-hash, you can turn off the pseudo-hash view with the check button on the top right of the widget. Aynway, pseudo-hashes are deprecated from perl 5.8.0. Hence they are also deprecated in ObjScanner. The icon used for tied scalar changes from scalar icon to folder icon when opening the object hidden behind the tied scalar (using the middle button). I sure could use a better icon for tied items. (hint hint) =head1 THANKS To Rudi Farkas for all the improvements provided to ObjScanner. To Slaven Rezic for: =over =item * The propotype code of the pseudo-hash viewer. =item * The idea to use B::Deparse to view code ref. =back =head1 AUTHOR Dominique Dumont, dominique.dumont@hp.com Copyright (c) 1997-2004,2007 Dominique Dumont. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L, L =cut Tk-ObjScanner-2.012/MANIFEST0000644004725500017500000000031610101703125013711 0ustar domidomiChangeLog ObjScanner.pm MANIFEST README Makefile.PL demo/objscan.pl t/basic.t t/rudi.t t/options.t t/pseudo_hash.t t/scanner.t META.yml Module meta-data (added by MakeMaker) Tk-ObjScanner-2.012/ChangeLog0000644004725500017500000001300210702662017014341 0ustar domidomi2007-10-09 Dominique Dumont v2.012 * ObjScanner.pm: Added require 5.006 * Makefile.PL: Added require 5.006 to avoid automatic test failures from tester.cpan.org 2007-09-20 Dominique Dumont v2.011 * ObjScanner.pm (Populate): pseudo hashes are disabled for perl >= 5.009 2004-07-30 domi v2.010 * ObjScanner.pm: Showing tied info can be disabled by option or menu (exclusive or) Removed unnecessary 'ROOT:' word from top level label 2004-07-28 domi v2.009 * ObjScanner.pm v2.8: Applied patch from MAREKR at cpan.org (See https://rt.cpan.org/Ticket/Display.html?id=5197) to better handle pseudo hashes (even though pseudo hashes are still obsolete) 2004-07-27 domi v2.008 * ObjScanner.pm : Applied Slaven Rezic's patch which fixes image associated to array elements. (See https://rt.cpan.org/Ticket/Display.html?id=6831) 2003-11-28 Dominique Dumont * t/basic.t (new): works with Tk804.025 2003-11-19 Dominique Dumont * ObjScanner.pm v2.6: all configuration options can be called with a hyphen (i.e '-title' instead of 'title') (scan_object): call pack with hyphenated option (otherwise it breaks on Solaris with Tk800.025) 2003-11-14 Dominique Dumont * ObjScanner.pm: v2.5: replaced obsolete WeakRef module by Scalar::Util Note that pseudo-hashes are deprecated. 2003-03-21 Dominique Dumont * ObjScanner.pm v 2.4 (analyse_element): - recognize weak references 2003-02-28 Dominique Dumont v2.3 * ObjScanner.pm (scan_object): - added autonomous scan popup widget 2003-01-31 Dominique Dumont * ObjScanner.pm v2.1 : External changes: - added view_pseudo parameter - can view intern of tied scalar, hash or array by using middle-button - text window is removed from scanner and is now displayed in popup window. - can deparse code ref and display the deparsed code in popup window Internal changes: - changed internal data model. This will break classes derived from ObjScanner - internal methods are re-organized for easier sub-classing 2001-01-17 Dominique Dumont v1.022 * ObjScanner.pm (isPseudoHash): small bug fix * Makefile.PL: added Tk in PREREQ_PM 2001-01-12 Dominique Dumont v1.021 * Makefile.PL: fixed Makefile.PL * ObjScanner.pm: - added pseudo hash viewer 2000-06-07 Dominique Dumont v1.019 * ObjScanner.pm: 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. 5: add 'open folder' image and display it when item has displayed children 2000-04-17 Dominique Dumont v1.018 * ObjScanner.pm: - fixed a bug related to root display - added a patch provided by Rudi Farkas to display a watch cursor when displaying a sub-object 1999-07-06 Dominique Dumont v1.017 * ObjScanner.pm (element): bug fix on string display * Thanks to Rudi Farkas for contributing test cases with Math::BigInt and Filehandle 1999-05-31 Dominique Dumont v1.016 * ObjScanner.pm: - Better support of complex (perl wise) objects - added 'destroyable' parameters - updated 'CAVEATS' doc 1999-04-29 Dominique Dumont v1.014 * ObjScanner.pm (element): Support REF and SCALAR, and does not choke on GLOB ,CODE. 1999-04-21 Dominique Dumont v1.013 * ObjScanner.pm : Complete re-write. It now uses HList instead of data dumper. 1999-01-20 Dominique Dumont v1.11 * ObjScanner.pm: removed dependance on Tk::Multi, better doc, don't wrap lines in Text widget. v0.5: 1998-08-18 Dominique Dumont * ObjScanner.pm: simplified and adapted for new Multi::Text 1998-06-25 Dominique Dumont * 0.4 cleanup remaining traces in test.pl Tue Mar 17 15:09:42 1998 Dominique Dumont * 0.3 : Accepts '-stuff' parameters (instead of 'stuff') Thu Feb 12 18:07:00 1998 Dominique Dumont * 0.2 : Patch made by Achim Bohnet (Thanks) o removed AutoLoadeer because don't use AutoLoader for 3 little function defs. Every 'use AutoLoader' does search auto/mod/ule/autoload.ix in at INC. I think that this is much more expensive than having perl compile the 3 subs (Tom C. mentioned that perl can compile ~10000 lines/sec). o use Data::Dumper only when needed: startup gain with replace of 'use Data::Dumper' and use 'require Data::Dumper in sub listScan. o 2 little POD fixes o Makefile.PL: Tk::Multi does not exist. Changed to check for Tk::Multi::Text Fri Feb 6 18:15:06 1998 Dominique Dumont * 0.1 Beta version. Better AutoLoader usage. Fix minor problem to smooth inheriting Tk::ObjScanner 0.02 Mon 1.12.1997 - bug fix - better README 0.01 Wed Jul 23 17:02:08 1997 - original version; created by h2xs 1.18 Tk-ObjScanner-2.012/demo/0000755004725500017500000000000010702662106013516 5ustar domidomiTk-ObjScanner-2.012/demo/objscan.pl0000444004725500017500000000441707226340523015501 0ustar domidomi# ObjScanner - data and object scanner use Tk ; use Tk::ObjScanner ; use vars qw/$TOP/; my $data = { 'scalar: key1' => 'value1', 'ref array:' => [qw/a b sdf/, {'v1' => '1', 'v2' => 2},'dfg'], 'ref hash: key2' => { 'sub key1' => 'sv1', 'sub key2' => 'sv2' }, 'ref hash: piped|key' => {a => 1 , b => 2}, 'pseudo hash' => [{a => 1, b => 2}, 3, 4], 'scalar: long' => 'very long line'.'.' x 80 , 'scalar: is undef' => undef, 'scalar: some text' => "some \n dummy\n Text\n", 'ref blessed hash: tk widget' => $MW, 'ref const' => \12345, 'ref scalar' => \$scl, 'ref ref tk widget' => \$MW, # ref to ref 'ref code' => sub { my $x = shift; sin($x) + cos(2*$x) } } ; sub objscan { my($demo) = @_; $TOP = $MW->WidgetDemo ( -name => $demo, -text => 'ObjScanner - data and object scanner.', -geometry_manager => 'grid', -title => 'Data or Object Scanner', -iconname => 'ObjScannerDemo' ) ; $TOP->ObjScanner ( caller => $data, title => 'demo scanner', destroyable => 0 ) ->grid ; $TOP->Label(-text => 'Click "See Code".')->grid; } __END__ } my $toto ; my $mw = MainWindow-> new ; $mw->geometry('+10+10'); my $w_menu = $mw->Frame(-relief => 'raised', -borderwidth => 2); $w_menu->pack(-fill => 'x'); my $f = $w_menu->Menubutton(-text => 'File', -underline => 0) -> pack(side => 'left' ); $f->command(-label => 'Quit', -command => sub{$mw->destroy;} ); print "creating dummy object \n" if $trace ; my $dummy = new toto ($mw); print "ok ",$idx++,"\n"; print "Creating obj scanner\n" if $trace ; my $s = $mw -> ObjScanner ( ); $s -> pack(expand => 1, fill => 'both') ; print "ok ",$idx++,"\n"; $mw->idletasks; sub scan { my $topName = shift ; $s->yview($topName) ; $mw->after(200); # sleep 300ms foreach my $c ($s->infoChildren($topName)) { my $item = $s->info('data', $c); $s->displaySubItem($c,$item); scan($c); } $mw->idletasks; } if ($trace) { MainLoop ; # Tk's } else { scan('root'); } print "ok ",$idx++,"\n"; Tk-ObjScanner-2.012/README0000644004725500017500000000406710674242065013467 0ustar domidomiTk::ObjScanner provides a GUI to scan any perl data including the attributes of an object. The scanner is a composite widget made of a HList. This widget acts as a scanner to the object (or hash ref) passed with the 'caller' parameter. The scanner will retrieve all keys of the hash/object and insert them in the HList. When the user double clicks on a key, the corresponding value will be added in the HList. If the user use the middle button to open a tied item, the internals of the tied object will be displayed. If the value is a scalar, the scalar will be displayed in a popup text window. If the value is a code ref, the deparsed code will be displayed in a popup text window. This widget can be used as a regular widget in a Tk application or can be used as an autonomous popup widget that will display the content of a data structure. The latter is like a call to a graphical Data::Dumper. The scanner recognizes: - tied hashes arrays or scalars - weak reference (See weaken function of Scalar::Util for details) Pseudo-hashes are deprecated. This module was tested with perl5.8.2 and Tk 804.025 (beta). But should work with older versions of perl (> 5.6.1) or Tk. See the embedded documentation in the module for more details. Note that test program (in the 't' directory) can be run interactively this way : perl t/xxx.t 1 Comments and suggestions are always welcome. Many thanks to Achim Bohnet for all the tests, patches (and reports) he made. Many improvements were made thanks to his efforts. Thanks to Rudi Farkas for the 'watch' patch. Thanks to Slavec Rezic for the pseudo-hash prototype. Legal mumbo jumbo: Copyright (c) 1997-2004,2007 Dominique Dumont. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - Dominique Dumont dominique_dumont@hp.com --------------------------------------------------------------------- INSTALLATION gunzip -c .tar.gz | tar xvf - cd perl Makefile.PL make test make install Tk-ObjScanner-2.012/Makefile.PL0000644004725500017500000000131010702661551014542 0ustar domidomiuse ExtUtils::MakeMaker; require 5.006 ; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile ( 'NAME' => 'Tk::ObjScanner', 'VERSION_FROM' => 'ObjScanner.pm', 'dist' => {COMPRESS=>'gzip -9f', SUFFIX => 'gz'}, PM => { 'ObjScanner.pm' => '$(INST_LIB)/Tk/ObjScanner.pm', 'demo/objscan.pl' => '$(INST_LIB)/Tk/demos/widtrib/objscan.pl' }, ABSTRACT => 'A scanner to view an object\'s attribute', AUTHOR => 'Dominique Dumont (ddumont@cpan.org)', 'PREREQ_PM' => { 'Tk' => 0, 'Tk::Adjuster' => 0, 'Tk::HList' => 0, 'Tk::ROText' => 0, 'Scalar::Util' => 1.01 } );