package ToyDefineArrayMethods;

# This is another _toy_ helper class.  It creates methods for
# array-like classes, based on a description of the desired design.
# It is a simplified/mangled/gutted version of a real class, currently
# _pre-alpha_ (ie, it is crufty and broken and known to be so).  The
# toy was created solely for a webpage
# http://www.vendian.org/mncharity/dir3/inline/ , illustrating the use
# of Perl Objects with C API's.  Since ease of creating array classes
# was part of the argument, it seemed worth including an instance of a
# code-generator, even it this immature state.  Please don't expect it
# to even pretend to work in any other context.

# This class is basically a call stack - a client declared sequence of
# methods call each other, with the object serving as a rich auxiliary
# argument, and accumulator of return values.

# Copyright (c) 2002 Mitchell N Charity.  All rights reserved.  This
# program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.

use Carp;
use strict;

sub import {
    my $class = shift;
    my $callerpkg = caller(0);
    my $self = $class->new(package => $callerpkg , @_);
    $self->eval();
    $self;
}

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    $self->_configure(@_);
    $self;
}

sub eval {
    my($self) = @_;
    my $code = $self->code_for_eval();
    eval($code);
    confess ("->eval() FAILED! :\n$@\n"
             .("-"x 60)."\n$code\n".("-"x 60)."\n") if $@;
}

sub code_for_import { shift->{IMPORT} }
sub code_for_eval {
    my($self) = @_;
    my $pkg  = ($self->{PACKAGE} ?
                "package $self->{PACKAGE};\nuse strict;\n" : '');
    my $code = $self->code_for_import() || '';
    return $pkg.$code;
}

#-----------
sub _configure {
    my $self = shift;
    $self->{CONFIG} = [@_];
    $self->{DECL} = [$self->_configuration_simplify(@_)];
    $self->{CALL} = [@{$self->{DECL}}];
    $self->call_next();
    $self;
}
sub _configuration_simplify {
    my $self = shift;
    my @ret;
    while(my $key = shift @_) {
        push(@ret,$key,{}), next
            if !@_ || (!ref($_[0]) && ($_[0] !~ /[ \$\;\(]/o
                                       && $key ne 'package'));
        push(@ret,$key,{ arg => shift(@_) }), next if !ref($_[0]);
        push(@ret,$key,shift(@_));
    }
    @ret;
}
sub call_next {
    my $self = shift;
    my $todo = $self->{CALL};
    while(my $key = shift @{$todo}) {
        my $args  = shift @{$todo};
        if(ref $key) {
            $key->(%{$args});
        } else {
            my $method = "do_" . $key;
            $self->$method(%{$args});
        }
    }
}

#----------------------------
sub do_package {
    my($self,%args) = @_;
    $self->{PACKAGE} = $args{'arg'} || $args{'name'};
}


sub do_new_array {
    my $self = shift;
    $self->{IMPORT} .=
        'sub new_array { my @a; tie @a,shift,@_; return \@a; }'."\n";
}


sub do_TIEARRAY {
    my($self,%args) = @_;
    $self->call_next();
    my $code = <<'EOC';
sub TIEARRAY {
    my $class = shift;
    return $_[1] if @_ && !ref($_[0]) && $_[0] eq 'tie_to_object';
    $class->new(@_);
}
sub EXTEND {
    my($self,$newsize) = @_;
    ...;
    return;
}
sub CLEAR {
    my($self) = @_;
    ...;
    return;
}
sub FETCHSIZE {
    my($self) = @_;
    ...;
    return $size;
}
sub STORESIZE {
    my($self,$newsize) = @_;
    ...;
    return;
}
sub FETCH {
    my($self,$index) = @_;
    my $value;
    ...;
    return $value;
}
sub STORE {
    my($self,$index,$value) = @_;
    ...;
    return;
}
sub EXISTS {
    my($self,$index) = @_;
    my $exists;
    ...;
    return $exists;
}
sub DELETE {
    my($self,$index) = @_;
    my $value;
    ...;
    return $value;
}
sub POP {
    my($self) = @_;
    my $value;
    ...;
    return $value;
}
sub SHIFT {
    my($self) = @_;
    my $value;
    ...;
    return $value;
}
sub PUSH {
    my($self,@values) = @_;
    ...;
    return;
}
sub UNSHIFT {
    my($self,@values) = @_;
    ...;
    return;
}
sub SPLICE {
    my $self = shift;
    my $index = @_ ? shift : 0;
    my $length = @_ ? shift : undef;
    my @values = @_;
    my @old_values;
    ...;
    return wantarray ? @old_values : pop @old_values;
}
EOC
    $self->do_edge_methods_use_SPLICE(default_only => 1);
    $self->do_SPLICE(default_only => 1);
    do {
        my $src = ""; my $replacement = "";
        foreach my $line (split(/\n/,$code)) {
            $line =~ s/^\s+\.\.\.;/$replacement/;
            $src .= $line."\n";
            if($line =~ /^sub\s+(\w+)/o) {
                my $bod = ($self->{GEN}{TIEARRAY}{$1}
                           || "# do nothing"."\n    ");
                $self->kludge_add_vars_maybe(\$bod);
                $replacement = "    ".$bod;
                $replacement =~ s/\n {4}$//;
            }
        }
        $code = $src;
    };
    $self->{GEN}{TIEARRAY}{TieArray} = $code;
    $self->{IMPORT} .= $code;
}

sub kludge_add_vars_maybe {
    my($self,$rcode) = @_;
    my $code = $$rcode;
    if($code =~ /^((.*?)\$size\b.*)/m) {
        my($its_first_line,$before) = ($1,$2);
        if($its_first_line =~ /=.*\$size\b/o
           || $before =~ /\b(if|while|unless)\s*\(/o) {
            my $sz;
            if($code =~ /\$self->[A-Z]+/o) {
                $sz = 'my $size = $self->FETCHSIZE();'."\n    ";
            } else {
                $sz = 'my $size;'."\n    ".$self->{GEN}{TIEARRAY}{FETCHSIZE};
            }
            $code = $sz . $code;
        } elsif($its_first_line =~ /^\s*\$size\s*=/o) {
            $code = "my \$size;"."\n    ".$code;
        }

    }
    if($code =~ /^((.*?)\$array\b.*)/m) {
        my($its_first_line,$before) = ($1,$2);
        if($its_first_line =~ /=.*\$array\b/o
           || $before !~ /\b(my|local)\b/o)
        {
            my $a = 'my $array = '.$self->{GEN}{TIEARRAY}{array_code}.';';
            $code = $a ."\n    ". $code;
        }
    }
    $$rcode = $code;
}


sub do_get_toy_api_ImageCMacros {
    my($self,%args) = @_;
    $self->call_next();
    my %names = %{$self->{GEN}{TIEARRAYC}{NAMES}};
    my $code = <<'EOC';
/* 
  toy_api_ImageCMacros
*/
#define DECL(obj)    ^DECL^(obj)
#define INIT(obj)    ^INIT^(obj)
#define SET_R(x,y,r) ^STORE3D^((x),(y),0,(r))
#define SET_G(x,y,g) ^STORE3D^((x),(y),1,(g))
#define SET_B(x,y,b) ^STORE3D^((x),(y),2,(b))
#define GET_R(x,y)   ^FETCH3D^((x),(y),0)
#define GET_G(x,y)   ^FETCH3D^((x),(y),1)
#define GET_B(x,y)   ^FETCH3D^((x),(y),2)
#define HEIGHT()     ^FETCHSIZE3D^(0)
#define WIDTH()      ^FETCHSIZE3D^(1)
#define DEPTH()      ^FETCHSIZE3D^(2)
#define SET_RGB(x,y, r,g,b) (SET_R((x),(y),(r)),SET_G((x),(y),(g)),SET_B((x),(y),(b)))
EOC
    $code =~ s/\^(\w+)\^/$names{$1}/g;
    $code = $self->{GEN}{TIEARRAYC}{TieArrayC} . $code."\n";
    my $perlcode = <<"END_OF_METHOD";
sub get_toy_api_ImageCMacros {
    return <<'END_OF_C';
$code
END_OF_C
}
END_OF_METHOD
    $self->{IMPORT} .= $perlcode;
}


sub do_array {
    my($self,%args) = @_;
    my $ar = $args{'arg'} || die "bug";
    $self->{GEN}{TIEARRAY}{array_code} = $ar;
}


sub do_size_is_fixed {
}

sub do_toy_folded {
    my($self,%args) = @_;
    my $id = defined($args{'id'}) ? $args{'id'} : 'folded_';
    my $shape = $args{'shape'} || croak('folded requires a "shape" argument');
    die "toy only folds to 3D" if @{$shape} != 3;

    $self->call_next();

    my $getsizes = "    {   SV ** psv;  IV iv;";
    for(my $i=0; $i < @{$shape}; $i++) {
	my $sz = $shape->[$i];
	$sz =~ /^\$self->{[\"\']?(\w+)[\"\']?}$/o or die "toy broke";
	my $key = "\"$1\"";
	$getsizes .= "
                psv = hv_fetch(\$\$_selfhv, $key, strlen($key), 0);
                if(psv == NULL) goto \$\$_error;
                \$\$_dims[$i] = SvIV(*psv);";
    }
    $getsizes .= "\n        goto \$\$_no_error;
            \$\$_error: croak(\"toy broken (folding shape)\");
            \$\$_no_error: ;\n    }";
    $getsizes =~ s/\n/\\\n/g;

    my %names = %{$self->{GEN}{TIEARRAYC}{NAMES}};
    my $code = <<'EOC';
static inline void
$$_initialize (SV* self, HV** pselfhv) {
    SV* self_sv;
    if(!SvOK(self) || !SvROK(self)) goto error;
    self_sv = SvRV(self);
    if(SvTYPE(self_sv) != SVt_PVHV) goto error;
    *pselfhv = self_sv;
    return;
  error:
    croak("toy broken2");
}
#define DECL(obj)             HV* $$_selfhv; int $$_dims[3];\
  ^DECL^(obj)
#define INIT(obj)             $$_initialize((obj),&$$_selfhv);\
*GETSIZES* \
  ^INIT^(obj)
#define FETCH3D(i0,i1,i2)     ^FETCH^(~_UNWRAP~((i0),(i1),(i2)))
#define STORE3D(i0,i1,i2,val) ^STORE^(~_UNWRAP~((i0),(i1),(i2)),(val))
#define FETCHSIZE3D(dim)      ($$_dims[(dim)]+0)
#define _UNWRAP(i0,i1,i2)     ((((i0)*($$_dims[1]*$$_dims[2]))+((i1)*$$_dims[2])+(i2))*1)
EOC
    $code =~ s/\*GETSIZES\*/$getsizes/;
    while($code =~ /^\#define\s+(\w+)/mg) {
        my $meth = $1;  next if $meth =~ /^_/;
        $self->{GEN}{TIEARRAYC}{NAMES}{$meth} = "${id}${meth}";
    }
    $code =~ s/\^(\w+)\^/$names{$1}/g;
    $code =~ s/\~(\w+)\~/${id}${1}/g;
    $code =~ s/\b_(\w+?)_\b/${id}_${1}/g;
    $code =~ s/\$\$/$id/g;
    $code =~ s/^(\#define\s+)(\w+)/${1}${id}${2}/mg;
    $self->{GEN}{TIEARRAYC}{TieArrayC} .= "/*\n  $id\n*/\n".$code."\n";
}


sub do_SPLICE {
    my($self,%args) = @_;
    my $dont_my = $args{'dont_declare_result_variables'} || 0;
    my $suffix  = $args{'suffix'} || '';
    my $default = $args{'default_only'} || 0;
    my %code =
        (SPLICE_method    => '$index += $size if ($index < 0);
        $length = $size - $index if !defined $length;
        $length += $size - $index if $length < 0;
        for (my $i = 0; $i < $length; $i++) {
                push(@old_values, $self->FETCH($index + $i));
        }
        $index = $size if $index > $size;
        $length -= $index + $length - $size if $index + $length > $size;
        if (@values > $length) {
                # Move items up to make room
                my $d = @values - $length;
                my $e = $index+$length;
                $self->EXTEND($size + $d);
                for (my $i=$size-1; $i >= $e; $i--) {
                        $self->STORE($i+$d, $self->FETCH($i));
                }
        }
        elsif (@values < $length) {
                # Move items down to close the gap
                my $d = $length - @values;
                my $e = $index+$length;
                for (my $i=$index+$length; $i < $size; $i++) {
                        $self->STORE($i-$d, $self->FETCH($i));
                }
                $self->STORESIZE($size-$d);
        }
        for (my $i=0; $i < @values; $i++) {
                $self->STORE($index+$i, $values[$i]);
        }
        # return wantarray ? @old_values : pop @old_values;',
         );
    foreach my $key (keys %code) {
        my($name,$mode) = $key =~ /^(.+?)_([^_]+)$/o; die "bug" if !$name;
        next if $default && $self->{GEN}{TIEARRAY}{$name};
        my $code = $code{$key};
        $code =~ s/([\@\$])((?!self)\w+)/$1$2$suffix/g;
        $code =~ s/^\s*my(?:\s+|\()(?!_)//mg if $dont_my;
        $code =~ s/\^(\w+)\^/\# begin $1\n    $self->{GEN}{TIEARRAY}{$1}\# end $1\n    /g;
        $self->{GEN}{TIEARRAY}{$name} = $code."\n    ";
    }
}

sub do_edge_methods_use_SPLICE {
    my($self,%args) = @_;
    my %dontdo  = map{($_,1)} @{$args{'dont_do'} || []};
    my $inline  = $args{'inline'} || 0;
    my $id = defined($args{'id'}) ? $args{'id'} : '';
    my %code_opts =
        (SHIFT_method     => '($value) = $self->SPLICE(0,1);',
         SHIFT_inline     => 'do {
                my($index,$length,@values) = (0,1);
                ^SPLICE^
                $value = @old_values[0];
        };',
         UNSHIFT_method   => '$self->SPLICE(0,0,@values);',
         UNSHIFT_inline   => 'do {
                my($index,$length) = (0,0);
                ^SPLICE^
                $value = $old_values[0];
        };',
         POP_method       => 'if($size >= 1) {
                $value = $self->FETCH($size -1);
                $self->STORESIZE($size -1);
        };',
         POP_inline       => 'my $_vtmp;
        if($size >= 1) {
                my $index   = $size -1;
                ^FETCH^
                $_vtmp = $value;
                my $newsize = $size -1;
                ^STORESIZE^
        };
        my $value = $_vtmp;',
         PUSH_method      => 'my $_i = $size;
        $self->EXTEND($size + @values);
        foreach my $value (@values) {
                $self->STORE($_i++,$value);
        }',
         PUSH_inline      => 'my $_i = $size;
        do {
                my $newsize = $size + @values;
                ^EXTEND^
        };
        foreach my $value (@values) {
                my $index = $_i++;
                ^STORE^
        }'
         );
    my @opts;
    if($inline == 0) { @opts = grep(/_method/,keys %code_opts); }
    if($inline == 1) { @opts = grep(/_inline/,keys %code_opts); }
    if($inline == 2) { @opts = (grep(/_method/,keys %code_opts),
                           'PUSH_inline'); }
    if($inline == 3) { @opts = (grep(/_method/,keys %code_opts),
                           'PUSH_inline','POP_inline'); }
    if(!@opts)       { croak "invalid \"inline => $inline\""; }

    my %code = map{ /^([^_]+)/; ($1,$code_opts{$_}) } @opts;
    foreach (values %code) { s/([\@\$])(\w+)\b/$1$2$id/g; }
    foreach my $key (keys %code) {
        my $name = $key;
        next if $dontdo{$name};
        my $code = $code{$key};
        my $f = sub { ("\# begin $_[0]\n    ".
                       ($self->{GEN}{TIEARRAY}{$_[0]}||"").
                       "\# end of $_[0]\n    ") };
        $code =~ s/\^(\w+)\^/&$f($1)/ge;
        $self->{GEN}{TIEARRAY}{$name} = $code."\n    ";
    }
}


sub do_packed_substr {
    my($self,%args) = @_;
    my $id = defined($args{'id'}) ? $args{'id'} : '_packstr';
    my %up = %{$self->{GEN}{TIEARRAY}{VARS}||{}};

    unshift(@{$self->{CALL}},sub { $self->do_array(arg => $args{'strref'}); },{})
        if $args{'strref'};
    unshift(@{$self->{CALL}},sub { $self->do_packed_substr_C(%args); },{});
    $self->call_next();

    my $template = $args{'template'} || '"C"';
    my $offset   = $args{'offset'} || "0";
    my $nbytes   = ($args{'element_bytesize'}
                    || do { my $T = $template; $T =~ s/^[\"\']//; $T =~ s/[\"\']$//;
                            my $test = pack($T,(1..100));
                            length($test); });
    my $value_is_array = $args{'elements_are_arrays'} || 0;
    my %code = 
        (
         EXTEND => '# do nothing',
         FETCH => 'my $_idx_ = (<OFFSET> + ($index * <NBYTES>));
        $value = ( $_idx_ >= length($$array)
                                    ? undef
                                    : <[> unpack(<TEMPLATE>,substr($$array, $_idx_ ,<NBYTES>)) <]>);',
         STORE => 'if($index > $size) {
                my $sz = $index;
                $$array .= "\0" x ((($sz * <NBYTES>) + <OFFSET>) - length($$array));
        }
        substr($$array,<OFFSET> + ($index * <NBYTES>),<NBYTES>) = pack(<TEMPLATE>,<@{>$value<}>);',
         FETCHSIZE => '$size = int((length($$array) - <OFFSET>) / <NBYTES>);',
         STORESIZE => 'my $_newlen_ = ($newsize * <NBYTES>) + <OFFSET>;
        my $_delta_  = $_newlen_ - length($$array);
        $$array .= "\0" x $_delta_;
        substr($$array,$_newlen_) = "";',
         CLEAR => 'my $_off_ = <OFFSET>;
        $$array .= "\0" x $_off_ if length($$array) < $_off_;
        substr($$array,$_off_) = "";',
         EXISTS => '$exists = ($index >= -$size) && ($index < $size);',
         DELETE => 'confess(ref($self)." doesn\'t support DELETE");'
         );
    my $f = sub { my($var)=@_; return (($var =~ /^(\w+?)_$/o)
                                       ? $1.$id : $var.($up{$var} || "") ); };
    foreach (values %code) { s/([\@\$])(\w+)\b/$1.&$f($2)/eg; }
    foreach my $key (keys %code) {
        local $_ = $code{$key};
        s/<TEMPLATE>/$template/g; s/<OFFSET>/$offset/g; s/<NBYTES>/$nbytes/g;
        s/<(\@?[\[\]\{\}])>/$value_is_array ? $1 : ""/ge;
        $self->{GEN}{TIEARRAY}{$key} = $_ ."\n    ";
    }
}

sub do_packed_substr_C { #aligned
    my($self,%args) = @_;
    my $id = defined($args{'id'}) ? $args{'id'} : 'packstr_';
    my $offset   = $args{'offset'} || "0";

    $self->call_next();

    my $STR_KEY = ( ($self->{GEN}{TIEARRAY}{'array_code'}
		     =~ /^\$self->{[\"\']?(\w+)[\"\']?}$/o)
		    ? $1 : die "toy broke on array" );
    my $OFFSET = "/* no offset */";
    if($offset ne "0") {
	if($offset =~ /^\d+$/) {
	    $OFFSET = "offset = $offset;";
	} elsif($offset =~ /^\$self->{[\"\']?(\w+)[\"\']?}$/o) {
	    my $key = "\"$1\"";
	    $OFFSET = "psv = hv_fetch(self_hv, $key, strlen($key), 0);
        if(psv == NULL) goto error;
        offset = SvIV(*psv);";
	} else { die "toy broke on offset"; }
    }
    my $code = <<'EOC';
static inline void
$$_initialize (SV* self, int* psize, char** pptr) {
    SV* self_sv; HV* self_hv; SV** psv; SV* str_ref; SV* string;
    int offset = 0;
    if(!SvOK(self) || !SvROK(self)) goto error;
    self_sv = SvRV(self);
    if(SvTYPE(self_sv) != SVt_PVHV) goto error;
    self_hv = self_sv;
    psv = hv_fetch(self_hv, *STR_KEY*, strlen(*STR_KEY*), 0);
    if(psv == NULL) goto error;
    str_ref = *psv;
    if(!SvROK(str_ref)) goto error;
    string = SvRV(str_ref);
    if(!SvPOK(string))  goto error;

    *OFFSET*

    *pptr  = SvPV(string, (*psize));
    *pptr += offset;
    return;
  error:
    croak("?CONTEXT?: packed_substr's INIT(obj) had difficulty with the given object.");
}
#define DECL(obj)          int $$_size; char* $$_ptr;
#define INIT(obj)          $$_initialize((obj),&$$_size,&$$_ptr);
#define _PTR               $$_ptr
#define _SIZE              $$_size
#define EXTEND(sz)         /* do nothing */
#define FETCH(idx)         _PTR_[(idx)]
#define STORE(idx,val)     _PTR_[(idx)] = (val)
#define FETCHSIZE()        _SIZE_
#define STORESIZE(sz)      croak("toy doesn't STORESIZE")
#define CLEAR()            ~STORESIZE~(0)
#define EXISTS(idx)        ((idx) >= (_SIZE_ -1) && (idx) < _SIZE_)
#define DELETE(idx)        croak("?PACKAGE? doesn't support DELETE")
EOC
    $code =~ s/\*STR_KEY\*/\"$STR_KEY\"/g;
    $code =~ s/\*OFFSET\*/$OFFSET/g;
    while($code =~ /^\#define\s+(\w+)/mg) {
        my $meth = $1;  next if $meth =~ /^_/;
        $self->{GEN}{TIEARRAYC}{NAMES}{$meth} = "${id}${meth}";
    }
    $code =~ s/\~(\w+)\~/${id}${1}/g;
    $code =~ s/\b_(\w+?)_\b/${id}_${1}/g;
    $code =~ s/\$\$/$id/g;
    $code =~ s/^(\#define\s+)(\w+)/${1}${id}${2}/mg;
    $self->{GEN}{TIEARRAYC}{TieArrayC} .= "/*\n  $id \n*/\n".$code."\n";
}

sub do_TieArray_on_ArrayRef {
    my($self,%args) = @_;
    my %up = %{$self->{GEN}{TIEARRAY}{VARS}||{}};
    my %code =
        (
         EXTEND  => '# do nothing',
         CLEAR   => '@{$array} = ();',
         DELETE  => '$value = delete $array->[$index];',
         EXISTS  => '$exists = exists $array->[$index];',
         FETCHSIZE => '$size = scalar @{$array};',
         STORESIZE => '$#{$array} = $newsize - 1;',
         FETCH   => '$value = $array->[$index];',
         STORE   => '$array->[$index] = $value;',
         SPLICE  => '$length = (@{$array} - $index) if !defined $length;
        @old_values = splice(@{$array},$index,$length,@values);',
         POP     => '$value = pop @{$array};',
         SHIFT   => '$value = shift @{$array};',
         PUSH    => 'push(@{$array},@values);',
         UNSHIFT => 'unshift(@{$array},@values);'
         );
    foreach my $key (keys %code) {
        my $code = $code{$key};
        $code =~ s/([\@\$])(\w+)/"$1$2".($up{$2}||"")/eg;
        $self->{GEN}{TIEARRAY}{$key} = $code."\n    ";
    }
}


1;