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;