| 17 | | "use strict; |
| 18 | | |
| 19 | | "package pugs; |
| 20 | | |
| 21 | | "our $AUTOLOAD; |
| 22 | | "sub AUTOLOAD { pugs::guts::invoke($AUTOLOAD, @_) } |
| 23 | | "sub DESTROY {} |
| 24 | | |
| 25 | | "package pugs::guts; |
| 26 | | "our @ISA=('pugs'); |
| 27 | | "sub Block { my ($class, $val) = @_; |
| 28 | | " sub { pugs::guts::invoke($val, undef, @_) } } |
| 29 | | |
| 30 | | "sub Array { my ($class, $val) = @_; |
| 31 | | " my $array; tie @$array, 'pugs::array', $val; |
| 32 | | " warn 'returning '.$array;" |
| 33 | | " return $array; } |
| 34 | | |
| 35 | | "our $AUTOLOAD; |
| 36 | | "sub AUTOLOAD { my $type = $AUTOLOAD; $type =~ s/.*:://; |
| 37 | | " return if $type =~ m/^[A-Z]*$/; die 'unhandled supported type: '.$type } |
| 38 | | "warn 'compiled .'.__PACKAGE__;" |
| 39 | | |
| 40 | | "package pugs::array; |
| 41 | | "sub TIEARRAY { |
| 42 | | " my ($class, $val) = @_; |
| 43 | | " bless \\$val, $class; } |
| 44 | | |
| 45 | | "sub STORE { |
| 46 | | " my ($self, $index, $elem) = @_; |
| 47 | | " warn 'store! '.$elem;" |
| 48 | | " pugs::guts::eval_apply('{ $^x[$^y] = $^z }', $$self, $index, $elem) } |
| 49 | | |
| 50 | | "sub FETCHSIZE { |
| 51 | | " my ($self) = @_; |
| 52 | | " my $ret = pugs::guts::invoke('elems', $$self); |
| 53 | | " warn 'FETCHSIZE: '.$ret; $ret; }" |
| 54 | | |
| 55 | | "sub FETCH { |
| 56 | | " my ($self, $index) = @_; |
| 57 | | " pugs::guts::eval_apply('{ $^x[$^y] }', $$self, $index) } |
| 58 | | "warn 'compiled';" |
| 59 | | "1; |
| | 21 | "use strict;\n\n" |
| | 22 | |
| | 23 | "package pugs;\n\n" |
| | 24 | |
| | 25 | "our $AUTOLOAD;\n" |
| | 26 | "sub AUTOLOAD { pugs::guts::invoke($AUTOLOAD, @_) } \n" |
| | 27 | "sub DESTROY {}\n\n" |
| | 28 | |
| | 29 | "package pugs::guts;\n" |
| | 30 | "our @ISA=('pugs');\n" |
| | 31 | "sub Block { my ($class, $val) = @_;\n" |
| | 32 | " sub { pugs::guts::invoke($val, undef, @_) } }\n" |
| | 33 | |
| | 34 | "sub Array { my ($class, $val) = @_;\n" |
| | 35 | " my $array; tie @$array, 'pugs::array', $val;\n" |
| | 36 | oRZ" warn 'returning '.$array;\n" |
| | 37 | " return $array; }\n\n" |
| | 38 | |
| | 39 | "our $AUTOLOAD;\n" |
| | 40 | "sub AUTOLOAD { my $type = $AUTOLOAD; $type =~ s/.*:://;\n" |
| | 41 | " return if $type =~ m/^[A-Z]*$/; die 'unhandled supported type: '.$type } \n" |
| | 42 | oRZ"warn 'compiled .'.__PACKAGE__;\n\n" |
| | 43 | |
| | 44 | "package pugs::array;\n" |
| | 45 | "sub TIEARRAY {\n" |
| | 46 | " my ($class, $val) = @_;\n" |
| | 47 | " bless \\$val, $class; }\n\n" |
| | 48 | |
| | 49 | "sub STORE {\n" |
| | 50 | " my ($self, $index, $elem) = @_;\n" |
| | 51 | oRZ" warn 'store! '.$elem;\n" |
| | 52 | " pugs::guts::eval_apply('{ $^x[$^y] = $^z }', $$self, $index, $elem) }\n\n" |
| | 53 | |
| | 54 | "sub FETCHSIZE {\n" |
| | 55 | " my ($self) = @_;\n" |
| | 56 | " my $ret = pugs::guts::invoke('elems', $$self); \n" |
| | 57 | oRZ" warn 'FETCHSIZE: '.$ret; $ret; }\n\n" |
| | 58 | |
| | 59 | "sub FETCH {\n" |
| | 60 | " my ($self, $index) = @_;\n" |
| | 61 | " pugs::guts::eval_apply('{ $^x[$^y] }', $$self, $index) }\n" |
| | 62 | oRZ"warn 'compiled';\n" |
| | 63 | "1;\n"; |
