# copyright (C) 1997-2006 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.10 2006/01/28 19:16:59 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;
            }
        }

    }

}
