diff options
Diffstat (limited to 'Perl')
| -rw-r--r-- | Perl/Zinc/TraceUtils.pm | 134 | ||||
| -rw-r--r-- | Perl/t/traceutils.t | 90 |
2 files changed, 181 insertions, 43 deletions
diff --git a/Perl/Zinc/TraceUtils.pm b/Perl/Zinc/TraceUtils.pm index 55714f9..5a9536f 100644 --- a/Perl/Zinc/TraceUtils.pm +++ b/Perl/Zinc/TraceUtils.pm @@ -8,84 +8,132 @@ use strict; use Tk::Font; use Tk::Photo; use vars qw(@EXPORT); -@EXPORT = qw(printItem printArray printList); +@EXPORT = qw(printItem printArray printList Item Array List); -### to print something sub printItem { + print &Item (@_); +} + +sub printArray { + print &Array (@_); +} + +sub printList { + print &List (@_); +} + +sub Item { my ($value) = @_; my $ref = ref($value); # print "VALUE=$value REF=$ref\n"; if ($ref eq 'ARRAY') { - printArray ( @{$value} ); - } - elsif ($ref eq 'CODE') { - print "{CODE}"; - } - elsif ($ref eq 'Tk::Photo') { + return Array ( @{$value} ); + } elsif ($ref eq 'CODE') { + return "{CODE}"; + } elsif ($ref eq 'Tk::Photo') { # print " **** $value ***** "; - print "Tk::Photo(\"". scalar $value->cget('-file') . "\")"; - } - elsif ($ref eq 'Tk::Font') { - print "'$value'"; + return "Tk::Photo(\"". scalar $value->cget('-file') . "\")"; + } elsif ($ref eq 'Tk::Font') { + return "'$value'"; + } elsif ($ref eq '') { # scalar + print "value: $value\n"; + if (defined $value) { + print "defined value: $value\n"; + { no strict; + if ($value eq eval ($value)) { + return $value; + } else { + return "'$value'"; + } + use strict; + } + } else { + return "_undef"; + } + } else { # some class instance + return $value; } - elsif ($ref eq '') { # scalar + +} # end Item + +### to print something +sub Item { + my ($value) = @_; + my $ref = ref($value); +# print "VALUE=$value REF=$ref\n"; + if ($ref eq 'ARRAY') { + return Array ( @{$value} ); + } elsif ($ref eq 'CODE') { + return "{CODE}"; + } elsif ($ref eq 'Tk::Photo') { +# print " **** $value ***** "; + return "Tk::Photo(\"". scalar $value->cget('-file') . "\")"; + } elsif ($ref eq 'Tk::Font') { + return "'$value'"; + } elsif ($ref eq '') { # scalar if (defined $value) { - if ($value eq '') { - print "''"; - } elsif ($value =~ /\s/ + if ($value =~ /^-?\d+(\.\d*(e[+-]?\d+)?)?$/ or # -1. or 1.0 + $value =~ /^-[a-zA-Z]([\w])*$/ # -option1 or -option-1 + ) { + return $value; + } elsif ($value eq '' + or $value =~ /\s/ or $value =~ /^[a-zA-Z]/ - or $value =~ /^[\W]$/ ) { - print "'$value'"; - } else { - print $value; + or $value =~ /^[\W]/ + ) { + return "'$value'"; + } else { + return $value; } + } else { + return "_undef"; } - else { - print "undef"; - } - } - else { # some class instance + } else { # some class instance return $value; } -} # end printitem +} # end Item ### to print a list of something -sub printArray { +sub Array { my (@values) = @_; if (! scalar @values) { - print "[]"; + return "[]"; } else { # the list is not empty - my @res; - print "["; + my $res = "["; while (@values) { my $value = shift @values; - &printItem ($value); - print ", " if (@values); + $res .= &Item ($value); + $res .= ", " if (@values); } - print "]" ; + return $res. "]" ; } -} # end printArray +} # end Array -sub printList { - print "("; +sub List { + my $res = "("; while (@_) { my $v = shift @_; - printItem $v; - if ($v =~ /^-\w+/) { - print " => "; - } elsif (@_) { - print ", "; + $res .= Item ($v); + if (@_ > 0) { + ## still some elements + if ($v =~ /^-\d+$/) { + $res .= ", "; + } elsif ($v =~ /^-\w+$/) { + $res .= " => "; + } else { + $res .= ", "; + } } } - print ")"; + return $res. ")"; -} # end printList +} # end List 1; diff --git a/Perl/t/traceutils.t b/Perl/t/traceutils.t new file mode 100644 index 0000000..ad18813 --- /dev/null +++ b/Perl/t/traceutils.t @@ -0,0 +1,90 @@ +#!/usr/bin/perl -w + +# +# $Id: traceutils.t,v 1.1 2003-11-07 15:36:49 mertz Exp $ +# Author: Christophe Mertz +# + +# testing Tk::Zinc::TraceUtils utilities + +use Tk::Zinc::TraceUtils; +use strict; + +BEGIN { + if (!eval q{ +# use Test::More qw(no_plan); + use Test::More tests => 14; + 1; + }) { + print "# tests only work properly with installed Test::More module\n"; + print "1..1\n"; + print "ok 1\n"; + exit; + } + if (!eval q{ + use Tk::Zinc::TraceUtils; + 1; + }) { + print "unable to load Tk::ZincTraceUtils"; + print "1..1\n"; + print "ok 1\n"; + exit; + } +} + + + +#### creating different images, bitmaps and pixmaps... + +my $arg; + +$arg = "1"; +is (&Item ($arg), $arg, "testing " . $arg); + +SKIP: { + my $mw; + skip "not able to create a MainWindow", 3 if !eval q{$mw = MainWindow->new()} ; + require Tk::Font; + my $font = $mw->fontCreate("testfont", -family => "Helvetica"); + + like ($font, qr/^testfont/, "font creation"); + is (&Item ($font), "'testfont'", "testing " . "testfont"); # not so sure about this result! + print "$font : ", ref($font), "\n"; + is (&List (-font => $font), "(-font => 'testfont')", ); +} + +$arg = "()"; +is (&List (eval $arg), $arg, "empty list: ". $arg); + +$arg = "(-option_without_value)"; +is (&List (eval $arg), $arg, $arg); + +$arg = "(1, 2, 3, 4)"; +is (&List (eval $arg), $arg, $arg); + +$arg = "(-1, -2, -3, -4)"; +is (&List (eval $arg), $arg, $arg); + +$arg = "(1.2, -2, .01, -1.2e+22, 1.02e+34)"; + +is (&List (eval $arg), ($arg =~ s/\.01/0.01/ , $arg ), $arg); + +$arg = "('-1aa' => -2, '-a b', -1.2)"; +is (&List (eval $arg), $arg, $arg); + +$arg = "(-option => -2, -option2 => -1.2, -option3)"; +is (&List (eval $arg), $arg, $arg); + +$arg = "('icon', 1, -priority => 210, -visible => 1)"; +is (&List (eval $arg), $arg, $arg); + +$arg = "('text', 1, -font => '-adobe-helvetica-bold-r-normal-*-120-*-*-*-*-*-*')"; +is (&List (eval $arg), $arg, $arg); + + +$arg = "-option, -2, -option2, -1.2, -option3"; +is (&Array (eval "(".$arg.")"), "[".$arg."]", "[".$arg."]"); + + + +diag("############## Tk::Zinc::TraceUtils test"); |