aboutsummaryrefslogtreecommitdiff
path: root/Perl
diff options
context:
space:
mode:
Diffstat (limited to 'Perl')
-rw-r--r--Perl/Zinc/TraceUtils.pm134
-rw-r--r--Perl/t/traceutils.t90
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");