#!/usr/bin/perl
#

package S2;

use strict;
use vars qw($pout $pout_s %Domains $CurrentDomain);  # public interface:  sub refs to print and print safely

$pout = sub { print @_; };
$pout_s = sub { print @_; };

## array indexes into $_ctx (which shows up in compiled S2 code)
use constant VTABLE => 0;
use constant STATICS => 1;
use constant PROPS => 2;
use constant SCRATCH => 3;  # embedder-defined use
use constant LAYERLIST => 4;  # arrayref of layerids which made the context

%Domains = ();
$CurrentDomain = 'unset';

sub set_domain
{
    my $name = shift;
    $Domains{ $name } ||= {
        layer               => undef, # time()
        layercomp           => undef, # compiled time (when loaded from database)
        layerinfo           => undef, # key -> value
        layerset            => undef, # key -> value
        layerprop           => undef, # prop -> { type/key => "string"/val }
        layerprops          => undef, # arrayref of hashrefs
        layerprophide       => undef, # prop -> 1
        layerfunc           => undef, # funcnum -> sub{}
        layerclass          => undef, # classname -> hashref
        layerglobal         => undef, # signature -> hashref
        layerpropgroups     => undef, # [ group_ident* ]
        layerpropgroupname  => undef, # group_ident -> text_name
        layerpropgroupprops => undef, # group_ident -> [ prop_ident* ]
        funcnum             => undef, # funcID -> funcnum
        funcnummax          => 0, # maxnum in use already by funcnum, above.
    };

    $CurrentDomain = $name;
}

sub get_layer_all
{
    my $lid = shift;
    my $domain = $Domains{$CurrentDomain};

    return undef unless $domain->{layer}{$lid};
    return {
        layer          => $domain->{layer}{$lid},
        info           => $domain->{layerinfo}{$lid},
        set            => $domain->{layerset}{$lid},
        prop           => $domain->{layerprop}{$lid},
        class          => $domain->{layerclass}{$lid},
        global         => $domain->{layerglobal}{$lid},
        propgroupname  => $domain->{layerpropgroupname}{$lid},
        propgroups     => $domain->{layerpropgroups}{$lid},
        propgroupprops => $domain->{layerpropgroupprops}{$lid},
    };
}

# compatibility functions
sub pout   { $pout->(@_);   }
sub pout_s { $pout_s->(@_); }

sub get_property_value
{
    my ($ctx, $k) = @_;
    return $ctx->[PROPS]->{$k};
}

sub get_lang_code
{
    return get_property_value($_[0], 'lang_current');
}

sub make_context
{
    my (@lids) = @_;
    if (ref $lids[0] eq "ARRAY") { @lids = @{$lids[0]}; } # 1st arg can be array ref
    my $ctx = [];
    undef $@;

    my $domain = $Domains{$CurrentDomain};

    ## load all the layers & make the vtable
    foreach my $lid (0, @lids)
    {
        ## build the vtable
        foreach my $fn (keys %{$domain->{layerfunc}{$lid}}) {
            $ctx->[VTABLE]->{$fn} = $domain->{layerfunc}{$lid}->{$fn};
        }

        ## ignore further stuff for layer IDs of 0
        next unless $lid;

        ## FIXME: load the layer if not loaded, using registered
        ## loader sub.

        ## setup the property values
        foreach my $p (keys %{$domain->{layerset}{$lid}}) {
            my $v = $domain->{layerset}{$lid}->{$p};

            # this was the old format, but only used for Color constructors,
            # so we can change it to the new format:
            $v = S2::Builtin::Color__Color($v->[0])
                if (ref $v eq "ARRAY" && scalar(@$v) == 2 &&
                    ref $v->[1] eq "CODE");

            $ctx->[PROPS]->{$p} = $v;
        }
    }

    $ctx->[LAYERLIST] = [ @lids ];
    return $ctx;
}

# returns an arrayref of layerids loaded in this context
sub get_layers {
    my $ctx = shift;
    return @{ $ctx->[LAYERLIST] };
}

sub get_style_modtime
{
    my $ctx = shift;

    my $high = 0;
    foreach (@{$ctx->[LAYERLIST]}) {
        $high = $Domains{$CurrentDomain}{layercomp}{$_}
            if $Domains{$CurrentDomain}{layercomp}{$_} > $high;
    }
    return $high;
}

sub register_class
{
    my ($lid, $classname, $info) = @_;
    $Domains{$CurrentDomain}{layerclass}{$lid}{$classname} = $info;
}

sub register_layer
{
    my ($lid) = @_;
    unregister_layer($lid) if $Domains{$CurrentDomain}{layer}{$lid};
    $Domains{$CurrentDomain}{layer}{$lid} = time();
}

sub unregister_layer
{
    my ($lid) = @_;
    my $domain = $Domains{$CurrentDomain};

    delete $domain->{layer}{$lid};
    delete $domain->{layercomp}{$lid};
    delete $domain->{layerinfo}{$lid};
    delete $domain->{layerset}{$lid};
    delete $domain->{layerprop}{$lid};
    delete $domain->{layerprops}{$lid};
    delete $domain->{layerprophide}{$lid};
    delete $domain->{layerfunc}{$lid};
    delete $domain->{layerclass}{$lid};
    delete $domain->{layerglobal}{$lid};
    delete $domain->{layerpropgroups}{$lid};
    delete $domain->{layerpropgroupprops}{$lid};
    delete $domain->{layerpropgroupname}{$lid};
}

sub load_layer
{
    my ($lid, $comp, $comptime) = @_;

    eval $comp;
    if ($@) {
        my $err = $@;
        unregister_layer($lid);
        die "Layer \#$lid: $err";
    }
    $Domains{$CurrentDomain}{layercomp}{$lid} = $comptime;
    return 1;
}

sub load_layers_from_db
{
    my ($db, @layers) = @_;
    my $maxtime = 0;
    my @to_load;
    my $domain = $Domains{$CurrentDomain};

    foreach my $lid (@layers) {
        $lid += 0;
        if (exists $domain->{layer}{$lid}) {
            $maxtime = $domain->{layercomp}{$lid} if $domain->{layercomp}{$lid} > $maxtime;
            push @to_load, "(s2lid=$lid AND comptime>$domain->{layercomp}{$lid})";
        } else {
            push @to_load, "s2lid=$lid";
        }
    }
    return $maxtime unless @to_load;
    my $where = join(' OR ', @to_load);
    my $sth = $db->prepare("SELECT s2lid, compdata, comptime FROM s2compiled WHERE $where");
    $sth->execute;
    while (my ($id, $comp, $comptime) = $sth->fetchrow_array) {
        eval $comp;
        if ($@) {
            my $err = $@;
            unregister_layer($id);
            die "Layer \#$id: $err";
        }
        $domain->{layercomp}{$id} = $comptime;
        $maxtime = $comptime if $comptime > $maxtime;
    }
    return $maxtime;
}

# returns the modtime of a loaded layer; if a second parameter is specified,
# that is the maximum age in seconds to consider the layer loaded for.  if a
# layer is older than that time, it is automatically unloaded and undef is
# returned to the caller.
sub layer_loaded
{
    my ($id, $maxage) = @_;
    my $modtime = $Domains{$CurrentDomain}{layercomp}{$id};
    return $modtime unless $maxage && $modtime;

    # layer must be defined and loaded and we must have a max age at this point
    my $age = time() - $Domains{$CurrentDomain}{layer}{$id};
    return $modtime if $age <= $maxage;

    # layer is invalid; unload it and say it's not loaded
    unregister_layer($id);
    return undef;
}

sub set_layer_info
{
    my ($lid, $key, $val) = @_;
    $Domains{$CurrentDomain}{layerinfo}{$lid}->{$key} = $val;
}

sub get_layer_info
{
    my ($lid, $key) = @_;
    return undef unless $Domains{$CurrentDomain}{layerinfo}{$lid};
    return $key
        ? $Domains{$CurrentDomain}{layerinfo}{$lid}->{$key}
        : %{$Domains{$CurrentDomain}{layerinfo}{$lid}};
}

sub register_property
{
    my ($lid, $propname, $props) = @_;
    $props->{'name'} = $propname;
    $Domains{$CurrentDomain}{layerprop}{$lid}->{$propname} = $props;
    push @{$Domains{$CurrentDomain}{layerprops}{$lid}}, $props;
}

sub register_property_use
{
    my ($lid, $propname) = @_;
    push @{$Domains{$CurrentDomain}{layerprops}{$lid}}, $propname;
}

sub register_property_hide
{
    my ($lid, $propname) = @_;
    $Domains{$CurrentDomain}{layerprophide}{$lid}->{$propname} = 1;
}

sub register_propgroup_name
{
    my ($lid, $gname, $name) = @_;
    $Domains{$CurrentDomain}{layerpropgroupname}{$lid}->{$gname} = $name;
}

sub register_propgroup_props
{
    my ($lid, $gname, $list) = @_;
    $Domains{$CurrentDomain}{layerpropgroupprops}{$lid}->{$gname} = $list;
    push @{$Domains{$CurrentDomain}{layerpropgroups}{$lid}}, $gname;
}

sub is_property_hidden
{
    my ($lids, $propname) = @_;
    foreach (@$lids) {
        return 1 if $Domains{$CurrentDomain}{layerprophide}{$_}->{$propname};
    }
    return 0;
}

sub get_property
{
    my ($lid, $propname) = @_;
    return $Domains{$CurrentDomain}{layerprop}{$lid}->{$propname};
}

sub get_properties
{
    my ($lid) = @_;
    return () unless $Domains{$CurrentDomain}{layerprops}{$lid};
    return @{$Domains{$CurrentDomain}{layerprops}{$lid}};
}

sub get_property_groups
{
    my $lid = shift;
    return @{$Domains{$CurrentDomain}{layerpropgroups}{$lid} || []};
}

sub get_property_group_props
{
    my ($lid, $group) = @_;
    return () unless $Domains{$CurrentDomain}{layerpropgroupprops}{$lid};
    return @{$Domains{$CurrentDomain}{layerpropgroupprops}{$lid}->{$group} || []};
}

sub get_property_group_name
{
    my ($lid, $group) = @_;
    return unless $Domains{$CurrentDomain}{layerpropgroupname}{$lid};
    return $Domains{$CurrentDomain}{layerpropgroupname}{$lid}->{$group};
}

sub register_set
{
    my ($lid, $propname, $val) = @_;
    $Domains{$CurrentDomain}{layerset}{$lid}->{$propname} = $val;
}

sub get_set
{
    my ($lid, $propname) = @_;
    my $v = $Domains{$CurrentDomain}{layerset}{$lid}->{$propname};
    return undef unless defined $v;
    return $v;
}

# the whole point here is just to get the docstring.
# attrs is a comma-delimited list of attributes
sub register_global_function
{
    my ($lid, $func, $rtype, $docstring, $attrs) = @_;

    # need to make the signature:  foo(int a, int b) -> foo(int,int)
    return unless
        $func =~ /^(.+?\()(.*)\)$/;
    my ($signature, @args) = ($1, split(/\s*\,\s*/, $2));
    foreach (@args) { s/\s+\w+$//; } # strip names
    $signature .= join(",", @args) . ")";
    $Domains{$CurrentDomain}{layerglobal}{$lid}->{$signature} = {
        'returntype' => $rtype,
        'docstring' => $docstring,
        'args' => $func,
        'attrs' => $attrs,
    };
}

sub register_function
{
    my ($lid, $names, $code) = @_;

    # run the code to get the sub back with its closure data filled.
    my $closure = $code->();

    # now, remember that closure.
    foreach my $fi (@$names) {
        my $num = get_func_num($fi);
        $Domains{$CurrentDomain}{layerfunc}{$lid}->{$num} = $closure;
    }
}

sub set_output
{
    $pout = shift;
}

sub set_output_safe
{
    $pout_s = shift;
}

sub function_exists
{
    my ($ctx, $func) = @_;
    my $fnum = get_func_num($func);
    my $code = $ctx->[VTABLE]->{$fnum};
    return 1 if ref $code eq "CODE";
    return 0;
}

sub run_code
{
    my ($ctx, $entry, @args) = @_;
    run_function($ctx, $entry, @args);
    return 1;
}

sub run_function
{
    my ($ctx, $entry, @args) = @_;
    my $fnum = get_func_num($entry);
    my $code = $ctx->[VTABLE]->{$fnum};
    unless (ref $code eq "CODE") {
        die "S2::run_code: Undefined function $entry ($fnum $code)\n";
    }
    my $val;
    eval {
        local $SIG{__DIE__} = undef;
        local $SIG{ALRM} = sub { die "Style code didn't finish running in a timely fashion.  ".
                                     "Possible causes: <ul><li>Infinite loop in style or layer</li>\n".
                                     "<li>Database busy</li></ul>\n" };
        alarm 4;
        $val = $code->($ctx, @args);
        alarm 0;
    };
    if ($@) {
        die "Died in S2::run_code running $entry: $@\n";
    }
    return $val;
}

sub get_func_num
{
    my $name = shift;
    my $domain = $Domains{$CurrentDomain};

    return $domain->{funcnum}{$name}
        if exists $domain->{funcnum}{$name};
    return $domain->{funcnum}{$name} = ++$domain->{funcnummax};
}

sub get_object_func_num
{
    my ($type, $inst, $func, $s2lid, $s2line, $is_super) = @_;
    if (ref $inst ne "HASH" || $inst->{'_isnull'}) {
        die "Method called on null $type object at layer \#$s2lid, line $s2line.\n";
    }
    $type = $inst->{'_type'} unless $is_super;
    my $fn = get_func_num("${type}::$func");
    #Apache->request->log_error("get_object_func_num(${type}::$func) = $fn");
    return $fn;
}

# Called by NodeForeachStmt
sub get_characters
{
    my $string = shift;
    use utf8;
    return split(//,$string);
}

sub check_defined {
    my $obj = shift;
    return ref $obj eq "HASH" && ! $obj->{'_isnull'};
}

sub check_elements {
    my $obj = shift;
    if (ref $obj eq "ARRAY") {
        return @$obj ? 1 : 0;
    } elsif (ref $obj eq "HASH") {
        return %$obj ? 1 : 0;
    }
    return 0;
}

sub interpolate_object {
    my ($ctx, $cname, $obj, $method) = @_;
    return "" unless ref $obj eq "HASH" && ! $obj->{'_isnull'};
    my $res = eval {
        # wrap in an eval in case get_object_func_num returns something invalid...
        return $ctx->[VTABLE]->{get_object_func_num($cname,$obj,$method)}->($ctx, $obj);
    };
    return $res unless $@;

    # if we get here, we know something went wrong
    my $type = $obj->{_type} || $cname || "undef";
    return "$type::$method call failed.";
}

sub notags {
    my $a = shift;
    $a =~ s/</&lt;/g;
    $a =~ s/>/&gt;/g;
    return $a;
}

package S2::Builtin;

# generic S2 has no built-in functionality

1;