[FWP] fun with closures

[Uri Guttman <uri@sysarch.com>]

i wrote this a short while ago and think it is kinda cool. damian liked
it so i thought i would inflict it upon you all. it is an AUTOLOAD that
builds 3 types of closures based on the method names. all the allowed
methods are driven by lists. have the appropriate amount of fun.

uri

	my @_attrs = qw( type data in_portal ) ;
	my @_addr_types = qw( to from reply ) ;
	my @_addr_parts = qw( cell obj target ) ;

	my $type_regex = '(' . join( '|', @_addr_types ) . ')' ;
	my $part_regex = '(' . join( '|', @_addr_parts ) . ')' ;

	push @_attrs, @_addr_types,
		      map { my $type = $_ ;
			    map "${type}_$_", @_addr_parts } @_addr_types ;

	my %_is_attr = map { ( $_, [] ) } @_attrs ;

	sub _get_attrs {
		keys %_is_attr ;
	}


sub AUTOLOAD
{
	no strict 'refs';

	my ( $self ) = @_ ;

#print "AUTO: $AUTOLOAD $_[0] - [$_[1]]\n" ;

	if ( $AUTOLOAD =~ /.*::${type_regex}_$part_regex$/o &&
	     $_is_attr{ "${1}_$2" } ) {
		my $type = $1;
		my $part = $2;

		*{$AUTOLOAD} = sub {

			$_[0]->{$type}{$part} = $_[1] if @_ > 1 ;
			return $_[0]->{$type}{$part} ;
		} ;

		goto &$AUTOLOAD ;
	}

	if ( $AUTOLOAD =~ /.*::${type_regex}$/o &&
	     $_is_attr{ $1 } ) {
		my $type = $1;

		*{$AUTOLOAD} = sub {

			if ( @_ > 1 ) {

				my %args ;

				%args = ( ref $_[1] eq 'HASH' ) ?
					 %{$_[1]} : @_ ;

				$_[0]->{$type} = { map exists $args{$_} ?
						( $_, $args{$_} ) : (),
						    @_addr_parts } ;
			}

			return wantarray ? %{$_[0]->{$type}} : $_[0]->{$type} ;
		} ;

		goto &$AUTOLOAD ;
	}

	if ( $AUTOLOAD =~ /.*::(\w+)/ && $_is_attr{ $1 } ) {
		my $attr_name = $1;
		*{$AUTOLOAD} = sub {

			$_[0]->{$attr_name} = $_[1] if @_ > 1 ;
			return $_[0]->{$attr_name}
		} ;

		goto &$AUTOLOAD ;
	}
	
	# Must have been a mistake then

	croak "No such method: $AUTOLOAD";
}

 


-- 
Uri Guttman  ---------  uri@sysarch.com  ----------  http://www.sysarch.com
SYStems ARCHitecture, Software Engineering, Perl, Internet, UNIX Consulting
The Perl Books Page  -----------  http://www.sysarch.com/cgi-bin/perl_books
The Best Search Engine on the Net  ----------  http://www.northernlight.com

==== Want to unsubscribe from Fun With Perl?  Well, if you insist...
==== Send email to <fwp-request@technofile.org> with message _body_
====   unsubscribe