1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
|
# copyright (C) 1997-2005 Jean-Luc Fontaine (mailto:jfontain@free.fr)
# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu
# $Id: modperl.tcl,v 1.9 2005/01/02 00:45:07 jfontain Exp $
namespace eval module::perl {
variable utilities {
sub array_string { # return string usable by Tcl array set command, from Perl data array
my @data = @_;
my $string = '';
for my $row (0 .. $#data) {
for my $column (0 .. $#{$data[$row]}) {
my $value = qq($data[$row][$column]);
$value =~ s/"/\\"/g; # embedded quotes allowed in value but must be escaped
$string .= " $row,$column \"$value\"";
}
}
return $string;
}
sub hash_string { # return string usable by Tcl array set command, from Perl data hash
my %data = @_;
my $string = '';
while (my ($key, $value) = each %data) {
if ($key =~ /^(pollTimes|indices|indexColumns)$/) { # Perl arrays transformed into Tcl lists
$string .= " $key {@{$value}}";
} elsif ($key eq 'columns') {
for my $column (0 .. $#{$value}) {
while (my ($key, $value) = each %{$$value[$column]}) {
$value =~ s/"/\\"/g; # embedded quotes allowed in message but must be escaped
$string .= " $column,$key \"$value\"";
}
}
} elsif ($key eq 'views') {
$string .= ' views {';
for my $view (0 .. $#{$value}) {
$string .= ' {';
while (my ($key, $value) = each %{$$value[$view]}) {
$string .= " $key";
if ($key eq 'swap') { # simple boolean
$string .= " $value";
} elsif ($key eq 'sort') { # sort hash
my ($key, $value) = %$value; # keep first entry only
$string .= " {$key $value}";
} else { # indices array
$string .= " {@{$value}}";
}
}
$string .= '}';
}
$string .= '}';
} elsif ($key eq 'sort') { # sort hash
$string .= " $key {";
my ($key, $value) = %$value; # keep first entry only
$string .= "$key $value";
$string .= '}';
} elsif ($key eq 'switches') { # Perl hash transformed into Tcl array compatible list
$string .= " $key {";
while (my ($key, $value) = each %$value) {
$string .= " $key $value";
}
$string .= '}';
} else {
$value =~ s/"/\\"/g; # embedded quotes allowed in value but must be escaped
$string .= " $key \"$value\"";
}
}
return $string;
}
{
package moodss::Updated;
sub TIESCALAR {
my $class = shift;
my $command = shift;
return bless {value => undef, command => $command}, $class;
}
sub FETCH {
my $self = shift;
return $self->{value};
}
sub STORE {
my $self = shift;
my $value = shift;
$self->{value} = $value;
$Tcl::parent->eval($self->{command});
return $value;
}
}
}
}
|
